Mercurial > urweb

comparison src/scriptcheck.sml @ 693:655bcc9b77e0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
_Really_ implement embedded closure GC; extend Scriptcheck to figure out when client IDs must be assigned
author Adam Chlipala <adamc@hcoop.net>
date Sat, 04 Apr 2009 14:03:39 -0400
parents f73913d97a40
children 500e93aa436f
comparison
equal deleted inserted replaced
692:09df0c85f306 693:655bcc9b77e0
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 csBasis = SS.addList (SS.empty, 38 val pullBasis = SS.addList (SS.empty,
39 ["new_client_source", 39 ["new_client_source",
40 "get_client_source", 40 "get_client_source",
41 "set_client_source", 41 "set_client_source"])
42 "new_channel",
43 "subscribe",
44 "send",
45 "recv"])
46 42
43 val pushBasis = SS.addList (SS.empty,
44 ["new_channel",
45 "self"])
46
47 val scriptWords = ["<script", 47 val scriptWords = ["<script",
48 " onclick=", 48 " onclick=",
49 " onload="] 49 " onload="]
50
51 val pushWords = ["rv("]
50 52
51 fun classify (ds, ps) = 53 fun classify (ds, ps) =
52 let 54 let
53 fun inString {needle, haystack} = 55 fun inString {needle, haystack} =
54 let 56 let
55 val (_, suffix) = Substring.position needle (Substring.full haystack) 57 val (_, suffix) = Substring.position needle (Substring.full haystack)
56 in 58 in
57 not (Substring.isEmpty suffix) 59 not (Substring.isEmpty suffix)
58 end 60 end
59 61
60 fun hasClient csids = 62 fun hasClient {basis, words} csids =
61 let 63 let
62 fun hasClient e = 64 fun hasClient e =
63 case #1 e of 65 case #1 e of
64 EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) scriptWords 66 EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
65 | EPrim _ => false 67 | EPrim _ => false
66 | ERel _ => false 68 | ERel _ => false
67 | ENamed n => IS.member (csids, n) 69 | ENamed n => IS.member (csids, n)
68 | ECon (_, _, NONE) => false 70 | ECon (_, _, NONE) => false
69 | ECon (_, _, SOME e) => hasClient e 71 | ECon (_, _, SOME e) => hasClient e
70 | ENone _ => false 72 | ENone _ => false
71 | ESome (_, e) => hasClient e 73 | ESome (_, e) => hasClient e
72 | EFfi ("Basis", x) => SS.member (csBasis, x) 74 | EFfi ("Basis", x) => SS.member (basis, x)
73 | EFfi _ => false 75 | EFfi _ => false
74 | EFfiApp ("Basis", x, es) => SS.member (csBasis, x) 76 | EFfiApp ("Basis", x, es) => SS.member (basis, x)
75 orelse List.exists hasClient es 77 orelse List.exists hasClient es
76 | EFfiApp (_, _, es) => List.exists hasClient es 78 | EFfiApp (_, _, es) => List.exists hasClient es
77 | EApp (e, es) => hasClient e orelse List.exists hasClient es 79 | EApp (e, es) => hasClient e orelse List.exists hasClient es
78 | EUnop (_, e) => hasClient e 80 | EUnop (_, e) => hasClient e
79 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2 81 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
91 | EUnurlify (e, _) => hasClient e 93 | EUnurlify (e, _) => hasClient e
92 in 94 in
93 hasClient 95 hasClient
94 end 96 end
95 97
96 fun decl ((d, _), csids) = 98 fun decl ((d, _), (pull_ids, push_ids)) =
97 let 99 let
98 val hasClient = hasClient csids 100 val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids
101 val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids
99 in 102 in
100 case d of 103 case d of
101 DVal (_, n, _, e) => if hasClient e then 104 DVal (_, n, _, e) => (if hasClientPull e then
102 IS.add (csids, n) 105 IS.add (pull_ids, n)
103 else 106 else
104 csids 107 pull_ids,
105 | DFun (_, n, _, _, e) => if hasClient e then 108 if hasClientPush e then
106 IS.add (csids, n) 109 IS.add (push_ids, n)
107 else 110 else
108 csids 111 push_ids)
109 | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then 112 | DFun (_, n, _, _, e) => (if hasClientPull e then
110 foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n)) 113 IS.add (pull_ids, n)
111 csids xes 114 else
112 else 115 pull_ids,
113 csids 116 if hasClientPush e then
114 | _ => csids 117 IS.add (push_ids, n)
118 else
119 push_ids)
120 | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
121 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
122 pull_ids xes
123 else
124 pull_ids,
125 if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then
126 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
127 push_ids xes
128 else
129 push_ids)
130 | _ => (pull_ids, push_ids)
115 end 131 end
116 132
117 val csids = foldl decl IS.empty ds 133 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
118 134
119 val ps = map (fn (ek, x, n, ts, t, _) => 135 val ps = map (fn (ek, x, n, ts, t, _) =>
120 (ek, x, n, ts, t, 136 (ek, x, n, ts, t,
121 if IS.member (csids, n) then 137 if IS.member (push_ids, n) then
122 ServerAndClient 138 ServerAndPullAndPush
139 else if IS.member (pull_ids, n) then
140 ServerAndPull
123 else 141 else
124 ServerOnly)) ps 142 ServerOnly)) ps
125 in 143 in
126 (ds, ps) 144 (ds, ps)
127 end 145 end