Make Scriptcheck catch more script/message-passing uses, and move the phase earlier in compilation

1 files changed, 28 insertions, 103 deletions

diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 6c6c5588..e5db476a 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -27,7 +27,7 @@
 
 structure ScriptCheck :> SCRIPT_CHECK = struct
 
-open Cjr
+open Mono
 
 structure SS = BinarySetFn(struct
                            type ord_key = string
@@ -35,98 +35,31 @@ structure SS = BinarySetFn(struct
                            end)
 structure IS = IntBinarySet
 
-val pullBasis = SS.addList (SS.empty,
-                            ["new_client_source",
-                             "get_client_source",
-                             "set_client_source"])
-
 val pushBasis = SS.addList (SS.empty,
                             ["new_channel",
                              "self"])
 
-val events = ["abort",
-              "blur",
-              "change",
-              "click",
-              "dblclick",
-              "error",
-              "focus",
-              "keydown",
-              "keypress",
-              "keyup",
-              "load",
-              "mousedown",
-              "mousemove",
-              "mouseout",
-              "mouseover",
-              "mouseup",
-              "reset",
-              "resize",
-              "select",
-              "submit",
-              "unload"]
-                
-val scriptWords = "<script"
-                   :: map (fn s => " on" ^ s ^ "='") events
-
-val pushWords = ["rv("]
-
 fun classify (ds, ps) =
     let
         val proto = Settings.currentProtocol ()
 
         fun inString {needle, haystack} = String.isSubstring needle haystack
 
-        fun hasClient {basis, words, onload} csids =
-            let
-                fun hasClient e =
-                    case #1 e of
-                        EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
-                      | EPrim _ => false
-                      | ERel _ => false
-                      | ENamed n => IS.member (csids, n)
-                      | ECon (_, _, NONE) => false
-                      | ECon (_, _, SOME e) => hasClient e
-                      | ENone _ => false
-                      | ESome (_, e) => hasClient e
-                      | EFfi ("Basis", x) => SS.member (basis, x)
-                      | EFfi _ => false
-                      | EFfiApp ("Basis", "maybe_onload",
-                                 [((EFfiApp ("Basis", "strcat", all as [_, ((EPrim (Prim.String s), _), _)]), _), _)]) =>
-                        List.exists (hasClient o #1) all
-                        orelse (onload andalso size s > 0)
-                      | EFfiApp ("Basis", x, es) => SS.member (basis, x)
-                                                    orelse List.exists (hasClient o #1) es
-                      | EFfiApp (_, _, es) => List.exists (hasClient o #1) es
-                      | EApp (e, es) => hasClient e orelse List.exists hasClient es
-                      | EUnop (_, e) => hasClient e
-                      | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
-                      | ERecord (_, xes) => List.exists (hasClient o #2) xes
-                      | EField (e, _) => hasClient e
-                      | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
-                      | EError (e, _) => hasClient e
-                      | EReturnBlob {blob = e1, mimeType = e2, ...} => hasClient e1 orelse hasClient e2
-                      | ERedirect (e, _) => hasClient e
-                      | EWrite e => hasClient e
-                      | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
-                      | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
-                      | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
-                                                              orelse hasClient initial
-                      | EDml {dml, ...} => hasClient dml
-                      | ENextval {seq, ...} => hasClient seq
-                      | ESetval {seq, count, ...} => hasClient seq orelse hasClient count
-                      | EUnurlify (e, _, _) => hasClient e
-            in
-                hasClient
-            end
+        fun hasClient {basis, funcs, push} =
+            MonoUtil.Exp.exists {typ = fn _ => false,
+                                 exp = fn ERecv _ => push
+                                        | EFfiApp ("Basis", x, _) => SS.member (basis, x) 
+                                        | EJavaScript _ => not push
+                                        | ENamed n => IS.member (funcs, n)
+                                        | _ => false}
 
         fun decl ((d, _), (pull_ids, push_ids)) =
             let
-                val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids
-                val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids
+                val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false}
+                val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true}
             in
                 case d of
-                    DVal (_, n, _, e) => (if hasClientPull e then
+                    DVal (_, n, _, e, _) => (if hasClientPull e then
                                              IS.add (pull_ids, n)
                                           else
                                               pull_ids,
@@ -134,20 +67,12 @@ fun classify (ds, ps) =
                                               IS.add (push_ids, n)
                                           else
                                               push_ids)
-                  | DFun (_, n, _, _, e) => (if hasClientPull e then
-                                                 IS.add (pull_ids, n)
-                                             else
-                                                 pull_ids,
-                                             if hasClientPush e then
-                                                 IS.add (push_ids, n)
-                                             else
-                                                 push_ids)
-                  | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
+                  | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
                                        foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
                                              pull_ids xes
                                     else
                                         pull_ids,
-                                    if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then
+                                    if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then
                                         foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
                                               push_ids xes
                                     else
@@ -159,21 +84,21 @@ fun classify (ds, ps) =
 
         val foundBad = ref false
 
-        val ps = map (fn (ek, x, n, ts, t, _, b) =>
-                         (ek, x, n, ts, t,
-                          if IS.member (push_ids, n) then
-                              (if not (#persistent proto) andalso not (!foundBad) then
-                                   (foundBad := true;
-                                    ErrorMsg.error ("This program needs server push, but the current protocol ("
-                                                    ^ #name proto ^ ") doesn't support that."))
-                               else
-                                   ();
-                               ServerAndPullAndPush)
-                          else if IS.member (pull_ids, n) then
-                              ServerAndPull
-                          else
-                              ServerOnly,
-                          b)) ps
+        val all_ids = IS.union (pull_ids, push_ids)
+
+        val ps = map (fn n =>
+                         (n, if IS.member (push_ids, n) then
+                                 (if not (#persistent proto) andalso not (!foundBad) then
+                                      (foundBad := true;
+                                       ErrorMsg.error ("This program needs server push, but the current protocol ("
+                                                       ^ #name proto ^ ") doesn't support that."))
+                                  else
+                                      ();
+                                  ServerAndPullAndPush)
+                             else if IS.member (pull_ids, n) then
+                                 ServerAndPull
+                             else
+                                 ServerOnly)) (IS.listItems all_ids)
     in
         (ds, ps)
     end