Mercurial > urweb
changeset 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 | 2c5e6f78560c |
| children | bcae365efa85 |
| files | src/cjr.sml src/cjrize.sml src/compiler.sig src/compiler.sml src/fuse.sml src/iflow.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/name_js.sml src/pathcheck.sml src/scriptcheck.sig src/scriptcheck.sml src/untangle.sml |
| diffstat | 18 files changed, 118 insertions(+), 183 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/cjr.sml Fri Mar 15 16:09:55 2013 -0400 @@ -128,10 +128,7 @@ withtype decl = decl' located -datatype sidedness = - ServerOnly - | ServerAndPull - | ServerAndPullAndPush +datatype sidedness = datatype Mono.sidedness datatype effect = datatype Export.effect datatype export_kind = datatype Export.export_kind
--- a/src/cjrize.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/cjrize.sml Fri Mar 15 16:09:55 2013 -0400 @@ -694,7 +694,7 @@ | L.DPolicy _ => (NONE, NONE, sm) | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) -fun cjrize ds = +fun cjrize (ds, sideInfo) = let val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let @@ -722,6 +722,13 @@ (dsF, ds, ps, Sm.clearDeclares sm) end) ([], [], [], Sm.empty) ds + + val sideInfo = foldl (fn ((n, mode), mp) => IM.insert (mp, n, mode)) IM.empty sideInfo + + val ps = map (fn (ek, s, n, ts, t, _, b) => + (ek, s, n, ts, t, + getOpt (IM.find (sideInfo, n), L'.ServerOnly), + b)) ps in (List.revAppend (dsF, rev ds), ps)
--- a/src/compiler.sig Tue Mar 12 16:21:20 2013 -0400 +++ b/src/compiler.sig Fri Mar 15 16:09:55 2013 -0400 @@ -116,12 +116,12 @@ val mono_shake : (Mono.file, Mono.file) phase val iflow : (Mono.file, Mono.file) phase val namejs : (Mono.file, Mono.file) phase + val scriptcheck : (Mono.file, Mono.file) phase val jscomp : (Mono.file, Mono.file) phase val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase - val scriptcheck : (Cjr.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase val sqlify : (Mono.file, Cjr.file) phase @@ -170,6 +170,7 @@ val toIflow : (string, Mono.file) transform val toNamejs : (string, Mono.file) transform val toNamejs_untangle : (string, Mono.file) transform + val toScriptcheck : (string, Mono.file) transform val toJscomp : (string, Mono.file) transform val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform @@ -184,7 +185,6 @@ val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform - val toScriptcheck : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform val toSqlify : (string, Cjr.file) transform
--- a/src/compiler.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/compiler.sml Fri Mar 15 16:09:55 2013 -0400 @@ -1363,12 +1363,19 @@ val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs +val scriptcheck = { + func = ScriptCheck.classify, + print = MonoPrint.p_file MonoEnv.empty +} + +val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toNamejs_untangle +val toJscomp = transform jscomp "jscomp" o toScriptcheck val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp @@ -1410,19 +1417,12 @@ val toCjrize = transform cjrize "cjrize" o toSidecheck -val scriptcheck = { - func = ScriptCheck.classify, - print = CjrPrint.p_file CjrEnv.empty -} - -val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize - val prepare = { func = Prepare.prepare, print = CjrPrint.p_file CjrEnv.empty } -val toPrepare = transform prepare "prepare" o toScriptcheck +val toPrepare = transform prepare "prepare" o toCjrize val checknest = { func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
--- a/src/fuse.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/fuse.sml Fri Mar 15 16:09:55 2013 -0400 @@ -144,9 +144,9 @@ (funcs, maxName)) end - val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file + val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file) in - file + (ds, #2 file) end end
--- a/src/iflow.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/iflow.sml Fri Mar 15 16:09:55 2013 -0400 @@ -1795,7 +1795,7 @@ datatype var_source = Input of int | SubInput of int | Unknown -fun check file = +fun check (file : file) = let val () = (St.reset (); rfuns := IM.empty) @@ -1810,7 +1810,7 @@ val exptd = foldl (fn ((d, _), exptd) => case d of DExport (_, _, n, _, _, _) => IS.add (exptd, n) - | _ => exptd) IS.empty file + | _ => exptd) IS.empty (#1 file) fun decl (d, loc) = case d of @@ -2071,7 +2071,7 @@ | _ => () in - app decl file + app decl (#1 file) end val check = fn file =>
--- a/src/jscomp.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/jscomp.sml Fri Mar 15 16:09:55 2013 -0400 @@ -61,7 +61,7 @@ fun inString {needle, haystack} = String.isSubstring needle haystack -fun process file = +fun process (file : file) = let val (someTs, nameds) = foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) @@ -77,7 +77,7 @@ someTs) someTs dts, nameds) | (_, state) => state) - (IM.empty, IM.empty) file + (IM.empty, IM.empty) (#1 file) fun str loc s = (EPrim (Prim.String s), loc) @@ -1304,7 +1304,7 @@ listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} - file + (#1 file) val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) fun lines acc = @@ -1334,7 +1334,7 @@ "" in TextIO.closeIn inf; - (DJavaScript script, ErrorMsg.dummySpan) :: ds + ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file) end end
--- a/src/mono.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/mono.sml Fri Mar 15 16:09:55 2013 -0400 @@ -157,6 +157,11 @@ withtype decl = decl' located -type file = decl list +datatype sidedness = + ServerOnly + | ServerAndPull + | ServerAndPullAndPush + +type file = decl list * (int * sidedness) list end
--- a/src/mono_print.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/mono_print.sml Fri Mar 15 16:09:55 2013 -0400 @@ -530,7 +530,7 @@ p_policy env p] | DOnError _ => string "ONERROR" -fun p_file env file = +fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) => (p_decl env d,
--- a/src/mono_reduce.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/mono_reduce.sml Fri Mar 15 16:09:55 2013 -0400 @@ -308,7 +308,7 @@ U.Exp.RelE _ => n + 1 | _ => n} 0 -fun reduce file = +fun reduce (file : file) = let val (timpures, impures, absCounts) = foldl (fn ((d, _), (timpures, impures, absCounts)) => @@ -366,7 +366,7 @@ absCounts vis) | _ => (timpures, impures, absCounts) end) - (IS.empty, IS.empty, IM.empty) file + (IS.empty, IS.empty, IM.empty) (#1 file) val uses = U.File.fold {typ = fn (_, m) => m, exp = fn (e, m) =>
--- a/src/mono_shake.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/mono_shake.sml Fri Mar 15 16:09:55 2013 -0400 @@ -41,7 +41,7 @@ exp : IS.set } -fun shake file = +fun shake (file : file) = let val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef) @@ -60,7 +60,7 @@ | ((DTask _, _), acc) => acc | ((DPolicy _, _), acc) => acc | ((DOnError _, _), acc) => acc) - (IM.empty, IM.empty) file + (IM.empty, IM.empty) (#1 file) fun typ (c, s) = case c of @@ -130,7 +130,7 @@ usedVars st e1 end | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) - | (_, st) => st) (IS.empty, IS.empty) file + | (_, st) => st) (IS.empty, IS.empty) (#1 file) val s = {con = page_cs, exp = page_es} @@ -145,20 +145,20 @@ NONE => raise Fail "MonoShake: Couldn't find 'val'" | SOME (t, e) => shakeExp s e) s page_es in - List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts - | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) - | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis - | (DExport _, _) => true - | (DTable _, _) => true - | (DSequence _, _) => true - | (DView _, _) => true - | (DDatabase _, _) => true - | (DJavaScript _, _) => true - | (DCookie _, _) => true - | (DStyle _, _) => true - | (DTask _, _) => true - | (DPolicy _, _) => true - | (DOnError _, _) => true) file + (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts + | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) + | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis + | (DExport _, _) => true + | (DTable _, _) => true + | (DSequence _, _) => true + | (DView _, _) => true + | (DDatabase _, _) => true + | (DJavaScript _, _) => true + | (DCookie _, _) => true + | (DStyle _, _) => true + | (DTask _, _) => true + | (DPolicy _, _) => true + | (DOnError _, _) => true) (#1 file), #2 file) end end
--- a/src/mono_util.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/mono_util.sml Fri Mar 15 16:09:55 2013 -0400 @@ -664,9 +664,9 @@ let val mfd = Decl.mapfoldB all - fun mff ctx ds = + fun mff ctx (ds, ps) = case ds of - nil => S.return2 nil + nil => S.return2 (nil, ps) | d :: ds' => S.bind2 (mfd ctx d, fn d' => @@ -705,9 +705,9 @@ | DPolicy _ => ctx | DOnError _ => ctx in - S.map2 (mff ctx' ds', - fn ds' => - d' :: ds') + S.map2 (mff ctx' (ds', ps), + fn (ds', _) => + (d' :: ds', ps)) end) in mff @@ -741,27 +741,28 @@ S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" -val maxName = foldl (fn ((d, _) : decl, count) => - case d of - DDatatype dts => - foldl (fn ((_, n, ns), count) => - foldl (fn ((_, n', _), m) => Int.max (n', m)) - (Int.max (n, count)) ns) count dts - | DVal (_, n, _, _, _) => Int.max (n, count) - | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis - | DExport _ => count - | DTable _ => count - | DSequence _ => count - | DView _ => count - | DDatabase _ => count - | DJavaScript _ => count - | DCookie _ => count - | DStyle _ => count - | DTask _ => count - | DPolicy _ => count - | DOnError _ => count) 0 +fun maxName (f : file) = + foldl (fn ((d, _) : decl, count) => + case d of + DDatatype dts => + foldl (fn ((_, n, ns), count) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns) count dts + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable _ => count + | DSequence _ => count + | DView _ => count + | DDatabase _ => count + | DJavaScript _ => count + | DCookie _ => count + | DStyle _ => count + | DTask _ => count + | DPolicy _ => count + | DOnError _ => count) 0 (#1 f) -fun appLoc f = +fun appLoc f (fl : file) = let val eal = Exp.appLoc f @@ -790,7 +791,7 @@ | PolUpdate e1 => eal e1 | PolSequence e1 => eal e1 in - app appl + app appl (#1 fl) end end
--- a/src/monoize.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/monoize.sml Fri Mar 15 16:09:55 2013 -0400 @@ -4656,7 +4656,7 @@ pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - rev ds + (rev ds, []) end end
--- a/src/name_js.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/name_js.sml Fri Mar 15 16:09:55 2013 -0400 @@ -72,7 +72,7 @@ fun rewrite file = let - val (file, _) = ListUtil.foldlMapConcat (fn (d, nextName) => + val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => let val (d, (nextName, newDs)) = U.Decl.foldMapB {typ = fn x => x, @@ -143,9 +143,9 @@ DValRec vis => [(DValRec (vis @ newDs), #2 d)] | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]), nextName) - end) (U.File.maxName file + 1) file + end) (U.File.maxName file + 1) (#1 file) in - file + (ds, #2 file) end end
--- a/src/pathcheck.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/pathcheck.sml Fri Mar 15 16:09:55 2013 -0400 @@ -110,6 +110,6 @@ | _ => (funcs, rels, cookies, styles) end -fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) +fun check (ds, _) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) end
--- a/src/scriptcheck.sig Tue Mar 12 16:21:20 2013 -0400 +++ b/src/scriptcheck.sig Fri Mar 15 16:09:55 2013 -0400 @@ -27,6 +27,6 @@ signature SCRIPT_CHECK = sig - val classify : Cjr.file -> Cjr.file + val classify : Mono.file -> Mono.file end
--- 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
--- a/src/untangle.sml Tue Mar 12 16:21:20 2013 -0400 +++ b/src/untangle.sml Fri Mar 15 16:09:55 2013 -0400 @@ -43,7 +43,7 @@ | _ => s -fun untangle file = +fun untangle (file : file) = let fun decl (dAll as (d, loc)) = case d of @@ -208,7 +208,7 @@ end | _ => [dAll] in - ListUtil.mapConcat decl file + (ListUtil.mapConcat decl (#1 file), #2 file) end end