Mercurial > urweb
diff src/scriptcheck.sml @ 1845:c1e3805e604e
Make Scriptcheck catch more script/message-passing uses, and move the phase earlier in compilation
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Fri, 15 Mar 2013 16:09:55 -0400 |
parents | 0577be31a435 |
children | a9159911c3ba |
line wrap: on
line diff
--- a/src/scriptcheck.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/scriptcheck.sml Fri Mar 15 16:09:55 2013 -0400 @@ -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 @@ 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 @@ 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 @@ 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