Merge pull request #170 from ashalkhakov/endpoints

Endpoints output

15 files changed, 311 insertions, 8 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 09cd9c7f..d7416616 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2550,8 +2550,10 @@ fun p_decl env (dAll as (d, loc) : decl) =
 		(case Settings.getOutputJsFile () of
 		    NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"
 		  | SOME s => s)
-            val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
-                                                    file = name}
+            val js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
+                                          file = name}
+            val () = app_js := js
+            val () = Endpoints.setJavaScript js
         in
             box [string "static char jslib[] = \"",
                  string (Prim.toCString s),
diff --git a/src/compiler.sig b/src/compiler.sig
index 09c913f8..6ed2f9a6 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -35,6 +35,7 @@ signature COMPILER = sig
          sources : string list,
          exe : string,
          sql : string option,
+         endpoints : string option,
          debug : bool,
          profile : bool,
          timeout : int,
@@ -116,6 +117,7 @@ signature COMPILER = sig
     val css : (Core.file, Css.report) phase
     val monoize : (Core.file, Mono.file) phase
     val mono_opt : (Mono.file, Mono.file) phase
+    val endpoints : (Mono.file, Mono.file) phase
     val untangle : (Mono.file, Mono.file) phase
     val mono_reduce : (Mono.file, Mono.file) phase
     val mono_shake : (Mono.file, Mono.file) phase
@@ -171,6 +173,7 @@ signature COMPILER = sig
     val toEffectize : (string, Core.file) transform
     val toCss : (string, Css.report) transform
     val toMonoize : (string, Mono.file) transform
+    val toEndpoints : (string, Mono.file) transform
     val toMono_opt1 : (string, Mono.file) transform
     val toUntangle : (string, Mono.file) transform
     val toMono_reduce : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 868dd628..7099effc 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -39,6 +39,7 @@ type job = {
      sources : string list,
      exe : string,
      sql : string option,
+     endpoints : string option,
      debug : bool,
      profile : bool,
      timeout : int,
@@ -275,7 +276,7 @@ val parseUr = {
               handle LrParser.ParseError => [],
      print = SourcePrint.p_file}
 
-fun p_job ({prefix, database, exe, sql, sources, debug, profile,
+fun p_job ({prefix, database, exe, sql, endpoints, sources, debug, profile,
             timeout, ffi, link, headers, scripts,
             clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) =
     let
@@ -304,6 +305,10 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile,
                  NONE => string "No SQL file."
                | SOME sql => string ("SQL fle: " ^ sql),
              newline,
+             case endpoints of
+                 NONE => string "No endpoints file."
+               | SOME ep => string ("Endpoints fle: " ^ ep),
+             newline,
              string "Timeout: ",
              string (Int.toString timeout),
              newline,
@@ -443,6 +448,7 @@ fun parseUrp' accLibs fname =
                         sources = [fname],
                         exe = fname ^ ".exe",
                         sql = NONE,
+                        endpoints = NONE,
                         debug = Settings.getDebug (),
                         profile = false,
                         timeout = 120,
@@ -581,6 +587,7 @@ fun parseUrp' accLibs fname =
                      val database = ref (Settings.getDbstring ())
                      val exe = ref (Settings.getExe ())
                      val sql = ref (Settings.getSql ())
+                     val endpoints = ref (Settings.getEndpoints ())
                      val debug = ref (Settings.getDebug ())
                      val profile = ref false
                      val timeout = ref NONE
@@ -622,6 +629,7 @@ fun parseUrp' accLibs fname =
                                  exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
                                                                                  ext = SOME "exe"}),
                                  sql = !sql,
+                                 endpoints = !endpoints,
                                  debug = !debug,
                                  profile = !profile,
                                  timeout = Option.getOpt (!timeout, 60),
@@ -684,6 +692,7 @@ fun parseUrp' accLibs fname =
                                  database = mergeO (fn (old, _) => old) (#database old, #database new),
                                  exe = #exe old,
                                  sql = #sql old,
+                                 endpoints = #endpoints old,
                                  debug = #debug old orelse #debug new,
                                  profile = #profile old orelse #profile new,
                                  timeout = #timeout old,
@@ -1429,7 +1438,14 @@ val mono_opt = {
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize
+val endpoints = {
+    func = Endpoints.collect,
+    print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toEndpoints = transform endpoints "endpoints" o toMonoize
+
+val toMono_opt1 = transform mono_opt "mono_opt1" o toEndpoints
 
 val untangle = {
     func = Untangle.untangle,
@@ -1719,6 +1735,18 @@ fun compile job =
                              TextIO.closeOut outf
                          end;
 
+                     case #endpoints job of
+                         NONE => ()
+                       | SOME endpoints =>
+                         let
+                             val report = Endpoints.summarize ()
+                             val outf = TextIO.openOut endpoints
+                             val s = TextIOPP.openOut {dst = outf, wid = 80}
+                         in
+                             Print.fprint s (Endpoints.p_report report);
+                             TextIO.closeOut outf
+                         end;
+
                      compileC {cname = cname, oname = oname, ename = ename, libs = libs,
                                profile = #profile job, debug = #debug job, linker = #linker job, link = #link job}
 
diff --git a/src/demo.sml b/src/demo.sml
index eaec38bb..ef57e65b 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -98,6 +98,10 @@ fun make' {prefix, dirname, guided} =
                             NONE => OS.Path.joinDirFile {dir = dirname,
                                                          file = "demo.sql"}
                           | SOME s => s),
+            endpoints = SOME (case Settings.getEndpoints () of
+                                  NONE => OS.Path.joinDirFile {dir = dirname,
+                                                               file = "demo-endpoints.json"}
+                               | SOME e => e),
             debug = Settings.getDebug (),
             timeout = Int.max (#timeout combined, #timeout urp),
             profile = false,
diff --git a/src/endpoints.sig b/src/endpoints.sig
new file mode 100644
index 00000000..89e72add
--- /dev/null
+++ b/src/endpoints.sig
@@ -0,0 +1,44 @@
+(* Copyright (c) 2019, Artyom Shalkhakov
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature ENDPOINTS = sig
+
+    datatype method = GET | POST
+    val methodToString : method -> string
+
+    type endpoint = {Method : method, Url : string, ContentType : string option, LastModified : Time.time option}
+    val p_endpoint : endpoint Print.printer
+
+    type report = {Endpoints : endpoint list}
+    val p_report : report Print.printer
+
+    val reset : unit -> unit
+    val collect : Mono.file -> Mono.file
+    val setJavaScript : string -> unit
+    val summarize : unit -> report
+
+end
diff --git a/src/endpoints.sml b/src/endpoints.sml
new file mode 100644
index 00000000..5699f319
--- /dev/null
+++ b/src/endpoints.sml
@@ -0,0 +1,117 @@
+(* Copyright (c) 2019 Artyom Shalkhakov
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Endpoints :> ENDPOINTS = struct
+
+open Print.PD
+open Print
+
+open Mono
+
+datatype method = GET | POST
+
+fun methodToString GET = "GET"
+  | methodToString POST = "POST"
+
+type endpoint = {Method : method, Url : string, ContentType : string option, LastModified : Time.time option}
+type report = {Endpoints : endpoint list}
+
+fun p_endpoint {Method = m, Url = u, ContentType = oct, LastModified = olm} =
+    let
+        val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT"
+    in
+        box [string "{",
+             string "\"method\": \"", string (methodToString m), string "\", ",
+             string "\"url\": \"", string u, string "\", ",
+             string "\"content-type\": ", (case oct of SOME ct => box [string "\"", string ct, string"\""]
+                                                     | NONE => string "null"),
+             string "}"]
+    end
+
+fun p_report {Endpoints = el} =
+    box [string "{\"endpoints\":",
+         space,
+         string "[",
+         p_list_sep (box [string ",", newline]) p_endpoint el,
+         string "]}"]
+
+val endpoints = ref ([] : endpoint list)
+val jsFile = ref (NONE : string option)
+
+fun setJavaScript x = jsFile := SOME x
+
+fun reset () = (endpoints := []; jsFile := NONE)
+
+fun collect file =
+    let
+        fun exportKindToMethod (Link _) = GET
+          | exportKindToMethod (Action _) = POST
+          | exportKindToMethod (Rpc _) = POST
+          | exportKindToMethod (Extern _) = POST
+
+        fun decl ((d, _), st as endpoints) =
+            let
+            in
+                case d of
+                    DExport (ek, id, i, tl, rt, f) =>
+                    {Method = exportKindToMethod ek, Url = id, LastModified = NONE, ContentType = NONE} :: st
+                 | _ => st
+            end
+
+        val () = reset ()
+
+        val (decls, _) = file
+        val ep = foldl decl [] decls
+
+        fun binfile ({Uri = u, ContentType = ct, LastModified = lm, Bytes = _ }, st) =
+            {Method = GET, Url = u, LastModified = SOME lm, ContentType = ct} :: st
+
+        val ep = foldl binfile ep (Settings.listFiles ())
+
+        fun jsfile ({Filename = f, Content = _}, st) =
+            {Method = GET, Url = f, LastModified = NONE, ContentType = SOME "text/javascript"} :: st
+
+        val ep = foldl jsfile ep (Settings.listJsFiles ())
+    in
+        endpoints := ep;
+        file
+    end
+
+fun summarize () =
+    let
+        val ep = !endpoints
+        val js = !jsFile
+        val ep =
+            case js of
+                NONE => ep
+             |  SOME js =>
+                {Method = GET, Url = js, LastModified = NONE, ContentType = SOME "text/javascript"} :: ep
+    in
+        {Endpoints = ep}
+    end
+
+end
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 99005df5..bfa40265 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -49,7 +49,7 @@ fun parse_flags flag_info args =
             | "--h" => "-help"
             | "--help" => "-help"
             | _ => arg
-                
+
         fun loop [] : string list = []
           | loop (arg :: args) =
             let
@@ -167,7 +167,7 @@ fun oneRun args =
               ("print-cinclude", ZERO printCInclude,
                     SOME "print directory of C headers and exit"),
               ("ccompiler", ONE ("<program>", Settings.setCCompiler),
-                    SOME "set the C compiler to <program>"), 
+                    SOME "set the C compiler to <program>"),
               ("demo", ONE ("<prefix>", fn prefix =>
                                 demo := SOME (prefix, false)),
                     NONE),
@@ -217,6 +217,8 @@ fun oneRun args =
                     SOME "serve JavaScript as <file>"),
               ("sql", ONE ("<file>", Settings.setSql o SOME),
                     SOME "output sql script as <file>"),
+              ("endpoints", ONE ("<file>", Settings.setEndpoints o SOME),
+                    SOME "output exposed URL endpoints in JSON as <file>"),
               ("static", call_true Settings.setStaticLinking,
                     SOME "enable static linking"),
               ("stop", ONE ("<phase>", Compiler.setStop),
@@ -288,7 +290,7 @@ fun oneRun args =
             else
                 OS.Process.failure
           | (_, _, true) => (Tutorial.make job;
-                             OS.Process.success)
+                                OS.Process.success)
           | _ =>
             if !tc then
                 (Compiler.check Compiler.toElaborate job;
diff --git a/src/settings.sig b/src/settings.sig
index a6a9c5fc..97d56b45 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -240,6 +240,9 @@ signature SETTINGS = sig
     val setSql : string option -> unit
     val getSql : unit -> string option
 
+    val setEndpoints : string option -> unit
+    val getEndpoints : unit -> string option
+
     val setCoreInline : int -> unit
     val getCoreInline : unit -> int
 
diff --git a/src/settings.sml b/src/settings.sml
index 0fea73e8..abb26f72 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -704,6 +704,10 @@ val sql = ref (NONE : string option)
 fun setSql so = sql := so
 fun getSql () = !sql
 
+val endpoints = ref (NONE : string option)
+fun setEndpoints so = endpoints := so
+fun getEndpoints () = !endpoints
+
 val coreInline = ref 5
 fun setCoreInline n = coreInline := n
 fun getCoreInline () = !coreInline
@@ -730,7 +734,7 @@ fun getSigFile () = !sigFile
 
 val fileCache = ref (NONE : string option)
 fun setFileCache v =
-    (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true 
+    (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true
                                                                         | SOME _ => false) then
          ErrorMsg.error "The selected database engine is incompatible with file caching."
      else
@@ -1008,6 +1012,7 @@ fun reset () =
      dbstring := NONE;
      exe := NONE;
      sql := NONE;
+     endpoints := NONE;
      coreInline := 5;
      monoInline := 5;
      staticLinking := false;
diff --git a/src/sources b/src/sources
index 5c0b2a84..851cdc16 100644
--- a/src/sources
+++ b/src/sources
@@ -165,6 +165,9 @@ $(SRC)/css.sml
 
 $(SRC)/mono.sml
 
+$(SRC)/endpoints.sig
+$(SRC)/endpoints.sml
+
 $(SRC)/mono_util.sig
 $(SRC)/mono_util.sml
 
diff --git a/tests/endpoints.py b/tests/endpoints.py
new file mode 100755
index 00000000..8dc5abef
--- /dev/null
+++ b/tests/endpoints.py
@@ -0,0 +1,30 @@
+#!/usr/bin/python3
+
+import sys
+import json
+import time
+import subprocess
+import urllib.request
+import urllib.parse
+import os
+
+def main():
+    prefix = 'http://localhost:8080/'
+
+    with open('/tmp/endpoints.json') as json_data:
+        data = json.load(json_data)
+        endpoints = data['endpoints']
+        for ep in endpoints:
+            path = ep['url']
+            src = urllib.parse.urljoin(prefix, path)
+            if ep['method'] == 'GET':
+                contents = urllib.request.urlopen(src).read()
+                # it's okay that we can retrieve it, enough for us right now
+            else:
+                # TODO: add support for parameters?
+                post_fields = {'Nam': 'X', 'Msg': 'message', 'Sameday': 'on'}     # Set POST fields here
+                request = urllib.request.Request(src, urllib.parse.urlencode(post_fields).encode())
+                contents = urllib.request.urlopen(request).read().decode()
+
+if __name__ == '__main__':
+    main()
diff --git a/tests/endpoints.sh b/tests/endpoints.sh
new file mode 100755
index 00000000..1d3289a5
--- /dev/null
+++ b/tests/endpoints.sh
@@ -0,0 +1,15 @@
+#!/bin/bash
+
+TEST=endpoints
+TESTPID=/tmp/$TEST.pid
+TESTENDPOINTS=/tmp/$TEST.json
+TESTSRV=./$TEST.exe
+
+rm -f $TESTENDPOINTS $TESTPID $TESTSRV
+../bin/urweb -debug -boot -noEmacs -endpoints $TESTENDPOINTS  "$TEST" || exit 1
+
+$TESTSRV -q -a 127.0.0.1 &
+echo $! >> $TESTPID
+sleep 1
+python3 $TEST.py
+kill `cat $TESTPID`
diff --git a/tests/endpoints.ur b/tests/endpoints.ur
new file mode 100644
index 00000000..ddb91faa
--- /dev/null
+++ b/tests/endpoints.ur
@@ -0,0 +1,40 @@
+fun formbased (): transaction page =
+    return <xml>
+      <body>
+        <form>
+          <label>Your name: <textbox{#Nam}/></label>
+          <label>Your message: <textarea{#Msg}/></label>
+          <label>Delivered on the same day <checkbox{#Sameday}/></label>
+          <submit value="Send" action={formbased_handler}/>
+        </form>
+      </body>
+    </xml>
+
+and formbased_handler (r : {Nam : string, Msg : string, Sameday : bool}) : transaction page =
+    return <xml>
+      <body>
+        <p>Oh hello {[r.Nam]}! Great to see you here again!</p>
+        <p>Your message was:</p>
+        <p>{[r.Msg]}</p>
+        <p>Sameday delivery was:</p>
+        <p>{[if r.Sameday then "set" else "unset"]}</p>
+      </body>
+    </xml>
+
+fun say_hi_to (s : string) : transaction page =
+return <xml>
+  <body>
+    <p>It's {[s]} birthday!</p>
+  </body>
+</xml>
+
+fun optimized_out (): transaction page =
+    return <xml>this one is optimized away since it's not referenced in the declarations</xml>
+
+fun main (): transaction page =
+    return <xml>
+      <body>
+        <p>hello</p>
+        <p>Say hi to <a link={say_hi_to "JC"}>JC</a></p>
+      </body>
+</xml>
diff --git a/tests/endpoints.urp b/tests/endpoints.urp
new file mode 100644
index 00000000..faf855bd
--- /dev/null
+++ b/tests/endpoints.urp
@@ -0,0 +1,4 @@
+rewrite url Endpoints/main index.html
+rewrite url Endpoints/formbased greet.html
+
+endpoints
diff --git a/tests/endpoints.urs b/tests/endpoints.urs
new file mode 100644
index 00000000..fba42a2b
--- /dev/null
+++ b/tests/endpoints.urs
@@ -0,0 +1,3 @@
+val main : unit -> transaction page
+val say_hi_to : string -> transaction page
+val formbased : unit -> transaction page