Mercurial > urweb

comparison src/scriptcheck.sml @ 1845:c1e3805e604e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
1844:2c5e6f78560c 1845:c1e3805e604e
25 * POSSIBILITY OF SUCH DAMAGE. 25 * POSSIBILITY OF SUCH DAMAGE.
26 *) 26 *)
27 27
28 structure ScriptCheck :> SCRIPT_CHECK = struct 28 structure ScriptCheck :> SCRIPT_CHECK = struct
29 29
30 open Cjr 30 open Mono
31 31
32 structure SS = BinarySetFn(struct 32 structure SS = BinarySetFn(struct
33 type ord_key = string 33 type ord_key = string
34 val compare = String.compare 34 val compare = String.compare
35 end) 35 end)
36 structure IS = IntBinarySet 36 structure IS = IntBinarySet
37 37
38 val pullBasis = SS.addList (SS.empty,
39 ["new_client_source",
40 "get_client_source",
41 "set_client_source"])
42
43 val pushBasis = SS.addList (SS.empty, 38 val pushBasis = SS.addList (SS.empty,
44 ["new_channel", 39 ["new_channel",
45 "self"]) 40 "self"])
46
47 val events = ["abort",
48 "blur",
49 "change",
50 "click",
51 "dblclick",
52 "error",
53 "focus",
54 "keydown",
55 "keypress",
56 "keyup",
57 "load",
58 "mousedown",
59 "mousemove",
60 "mouseout",
61 "mouseover",
62 "mouseup",
63 "reset",
64 "resize",
65 "select",
66 "submit",
67 "unload"]
68
69 val scriptWords = "<script"
70 :: map (fn s => " on" ^ s ^ "='") events
71
72 val pushWords = ["rv("]
73 41
74 fun classify (ds, ps) = 42 fun classify (ds, ps) =
75 let 43 let
76 val proto = Settings.currentProtocol () 44 val proto = Settings.currentProtocol ()
77 45
78 fun inString {needle, haystack} = String.isSubstring needle haystack 46 fun inString {needle, haystack} = String.isSubstring needle haystack
79 47
80 fun hasClient {basis, words, onload} csids = 48 fun hasClient {basis, funcs, push} =
81 let 49 MonoUtil.Exp.exists {typ = fn _ => false,
82 fun hasClient e = 50 exp = fn ERecv _ => push
83 case #1 e of 51 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
84 EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words 52 | EJavaScript _ => not push
85 | EPrim _ => false 53 | ENamed n => IS.member (funcs, n)
86 | ERel _ => false 54 | _ => false}
87 | ENamed n => IS.member (csids, n)
88 | ECon (_, _, NONE) => false
89 | ECon (_, _, SOME e) => hasClient e
90 | ENone _ => false
91 | ESome (_, e) => hasClient e
92 | EFfi ("Basis", x) => SS.member (basis, x)
93 | EFfi _ => false
94 | EFfiApp ("Basis", "maybe_onload",
95 [((EFfiApp ("Basis", "strcat", all as [_, ((EPrim (Prim.String s), _), _)]), _), _)]) =>
96 List.exists (hasClient o #1) all
97 orelse (onload andalso size s > 0)
98 | EFfiApp ("Basis", x, es) => SS.member (basis, x)
99 orelse List.exists (hasClient o #1) es
100 | EFfiApp (_, _, es) => List.exists (hasClient o #1) es
101 | EApp (e, es) => hasClient e orelse List.exists hasClient es
102 | EUnop (_, e) => hasClient e
103 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
104 | ERecord (_, xes) => List.exists (hasClient o #2) xes
105 | EField (e, _) => hasClient e
106 | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
107 | EError (e, _) => hasClient e
108 | EReturnBlob {blob = e1, mimeType = e2, ...} => hasClient e1 orelse hasClient e2
109 | ERedirect (e, _) => hasClient e
110 | EWrite e => hasClient e
111 | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
112 | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
113 | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
114 orelse hasClient initial
115 | EDml {dml, ...} => hasClient dml
116 | ENextval {seq, ...} => hasClient seq
117 | ESetval {seq, count, ...} => hasClient seq orelse hasClient count
118 | EUnurlify (e, _, _) => hasClient e
119 in
120 hasClient
121 end
122 55
123 fun decl ((d, _), (pull_ids, push_ids)) = 56 fun decl ((d, _), (pull_ids, push_ids)) =
124 let 57 let
125 val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids 58 val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false}
126 val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids 59 val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true}
127 in 60 in
128 case d of 61 case d of
129 DVal (_, n, _, e) => (if hasClientPull e then 62 DVal (_, n, _, e, _) => (if hasClientPull e then
130 IS.add (pull_ids, n) 63 IS.add (pull_ids, n)
131 else 64 else
132 pull_ids, 65 pull_ids,
133 if hasClientPush e then 66 if hasClientPush e then
134 IS.add (push_ids, n) 67 IS.add (push_ids, n)
135 else 68 else
136 push_ids) 69 push_ids)
137 | DFun (_, n, _, _, e) => (if hasClientPull e then 70 | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
138 IS.add (pull_ids, n)
139 else
140 pull_ids,
141 if hasClientPush e then
142 IS.add (push_ids, n)
143 else
144 push_ids)
145 | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
146 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) 71 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
147 pull_ids xes 72 pull_ids xes
148 else 73 else
149 pull_ids, 74 pull_ids,
150 if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then 75 if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then
151 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) 76 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
152 push_ids xes 77 push_ids xes
153 else 78 else
154 push_ids) 79 push_ids)
155 | _ => (pull_ids, push_ids) 80 | _ => (pull_ids, push_ids)
157 82
158 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds 83 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
159 84
160 val foundBad = ref false 85 val foundBad = ref false
161 86
162 val ps = map (fn (ek, x, n, ts, t, _, b) => 87 val all_ids = IS.union (pull_ids, push_ids)
163 (ek, x, n, ts, t, 88
164 if IS.member (push_ids, n) then 89 val ps = map (fn n =>
165 (if not (#persistent proto) andalso not (!foundBad) then 90 (n, if IS.member (push_ids, n) then
166 (foundBad := true; 91 (if not (#persistent proto) andalso not (!foundBad) then
167 ErrorMsg.error ("This program needs server push, but the current protocol (" 92 (foundBad := true;
168 ^ #name proto ^ ") doesn't support that.")) 93 ErrorMsg.error ("This program needs server push, but the current protocol ("
169 else 94 ^ #name proto ^ ") doesn't support that."))
170 (); 95 else
171 ServerAndPullAndPush) 96 ();
172 else if IS.member (pull_ids, n) then 97 ServerAndPullAndPush)
173 ServerAndPull 98 else if IS.member (pull_ids, n) then
174 else 99 ServerAndPull
175 ServerOnly, 100 else
176 b)) ps 101 ServerOnly)) (IS.listItems all_ids)
177 in 102 in
178 (ds, ps) 103 (ds, ps)
179 end 104 end
180 105
181 end 106 end