adamc@643
|
1 (* Copyright (c) 2009, Adam Chlipala
|
adamc@643
|
2 * All rights reserved.
|
adamc@643
|
3 *
|
adamc@643
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@643
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@643
|
6 *
|
adamc@643
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@643
|
8 * this list of conditions and the following disclaimer.
|
adamc@643
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@643
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@643
|
11 * and/or other materials provided with the distribution.
|
adamc@643
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@643
|
13 * derived from this software without specific prior written permission.
|
adamc@643
|
14 *
|
adamc@643
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@643
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@643
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@643
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@643
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@643
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@643
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@643
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@643
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@643
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@643
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@643
|
26 *)
|
adamc@643
|
27
|
adamc@643
|
28 structure ScriptCheck :> SCRIPT_CHECK = struct
|
adamc@643
|
29
|
adamc@643
|
30 open Cjr
|
adamc@643
|
31
|
adamc@643
|
32 structure SS = BinarySetFn(struct
|
adamc@643
|
33 type ord_key = string
|
adamc@643
|
34 val compare = String.compare
|
adamc@643
|
35 end)
|
adamc@643
|
36 structure IS = IntBinarySet
|
adamc@643
|
37
|
adamc@693
|
38 val pullBasis = SS.addList (SS.empty,
|
adamc@693
|
39 ["new_client_source",
|
adamc@693
|
40 "get_client_source",
|
adamc@693
|
41 "set_client_source"])
|
adamc@645
|
42
|
adamc@693
|
43 val pushBasis = SS.addList (SS.empty,
|
adamc@693
|
44 ["new_channel",
|
adamc@693
|
45 "self"])
|
adamc@799
|
46
|
adamc@799
|
47 val events = ["abort",
|
adamc@799
|
48 "blur",
|
adamc@799
|
49 "change",
|
adamc@799
|
50 "click",
|
adamc@799
|
51 "dblclick",
|
adamc@799
|
52 "error",
|
adamc@799
|
53 "focus",
|
adamc@799
|
54 "keydown",
|
adamc@799
|
55 "keypress",
|
adamc@799
|
56 "keyup",
|
adamc@799
|
57 "load",
|
adamc@799
|
58 "mousedown",
|
adamc@799
|
59 "mousemove",
|
adamc@799
|
60 "mouseout",
|
adamc@799
|
61 "mouseover",
|
adamc@799
|
62 "mouseup",
|
adamc@799
|
63 "reset",
|
adamc@799
|
64 "resize",
|
adamc@799
|
65 "select",
|
adamc@799
|
66 "submit",
|
adamc@799
|
67 "unload"]
|
adamc@693
|
68
|
adamc@799
|
69 val scriptWords = "<script"
|
adamc@970
|
70 :: map (fn s => " on" ^ s ^ "='") events
|
adamc@643
|
71
|
adamc@693
|
72 val pushWords = ["rv("]
|
adamc@693
|
73
|
adamc@643
|
74 fun classify (ds, ps) =
|
adamc@643
|
75 let
|
adamc@855
|
76 val proto = Settings.currentProtocol ()
|
adamc@855
|
77
|
adamc@970
|
78 fun inString {needle, haystack} = String.isSubstring needle haystack
|
adamc@643
|
79
|
adamc@695
|
80 fun hasClient {basis, words, onload} csids =
|
adamc@643
|
81 let
|
adamc@643
|
82 fun hasClient e =
|
adamc@643
|
83 case #1 e of
|
adamc@693
|
84 EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
|
adamc@643
|
85 | EPrim _ => false
|
adamc@643
|
86 | ERel _ => false
|
adamc@643
|
87 | ENamed n => IS.member (csids, n)
|
adamc@643
|
88 | ECon (_, _, NONE) => false
|
adamc@643
|
89 | ECon (_, _, SOME e) => hasClient e
|
adamc@643
|
90 | ENone _ => false
|
adamc@643
|
91 | ESome (_, e) => hasClient e
|
adamc@693
|
92 | EFfi ("Basis", x) => SS.member (basis, x)
|
adamc@643
|
93 | EFfi _ => false
|
adamc@726
|
94 | EFfiApp ("Basis", "maybe_onload",
|
adam@1663
|
95 [((EFfiApp ("Basis", "strcat", all as [_, ((EPrim (Prim.String s), _), _)]), _), _)]) =>
|
adam@1663
|
96 List.exists (hasClient o #1) all
|
adamc@726
|
97 orelse (onload andalso size s > 0)
|
adamc@693
|
98 | EFfiApp ("Basis", x, es) => SS.member (basis, x)
|
adam@1663
|
99 orelse List.exists (hasClient o #1) es
|
adam@1663
|
100 | EFfiApp (_, _, es) => List.exists (hasClient o #1) es
|
adamc@643
|
101 | EApp (e, es) => hasClient e orelse List.exists hasClient es
|
adamc@643
|
102 | EUnop (_, e) => hasClient e
|
adamc@643
|
103 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
|
adamc@643
|
104 | ERecord (_, xes) => List.exists (hasClient o #2) xes
|
adamc@643
|
105 | EField (e, _) => hasClient e
|
adamc@643
|
106 | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
|
adamc@643
|
107 | EError (e, _) => hasClient e
|
adamc@741
|
108 | EReturnBlob {blob = e1, mimeType = e2, ...} => hasClient e1 orelse hasClient e2
|
adamc@1065
|
109 | ERedirect (e, _) => hasClient e
|
adamc@643
|
110 | EWrite e => hasClient e
|
adamc@643
|
111 | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
|
adamc@643
|
112 | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
|
adamc@643
|
113 | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
|
adamc@643
|
114 orelse hasClient initial
|
adamc@643
|
115 | EDml {dml, ...} => hasClient dml
|
adamc@643
|
116 | ENextval {seq, ...} => hasClient seq
|
adamc@1073
|
117 | ESetval {seq, count, ...} => hasClient seq orelse hasClient count
|
adamc@1112
|
118 | EUnurlify (e, _, _) => hasClient e
|
adamc@643
|
119 in
|
adamc@643
|
120 hasClient
|
adamc@643
|
121 end
|
adamc@643
|
122
|
adamc@693
|
123 fun decl ((d, _), (pull_ids, push_ids)) =
|
adamc@643
|
124 let
|
adamc@695
|
125 val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids
|
adamc@695
|
126 val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids
|
adamc@643
|
127 in
|
adamc@643
|
128 case d of
|
adamc@693
|
129 DVal (_, n, _, e) => (if hasClientPull e then
|
adamc@693
|
130 IS.add (pull_ids, n)
|
adamc@693
|
131 else
|
adamc@693
|
132 pull_ids,
|
adamc@693
|
133 if hasClientPush e then
|
adamc@693
|
134 IS.add (push_ids, n)
|
adamc@693
|
135 else
|
adamc@693
|
136 push_ids)
|
adamc@693
|
137 | DFun (_, n, _, _, e) => (if hasClientPull e then
|
adamc@693
|
138 IS.add (pull_ids, n)
|
adamc@693
|
139 else
|
adamc@693
|
140 pull_ids,
|
adamc@693
|
141 if hasClientPush e then
|
adamc@693
|
142 IS.add (push_ids, n)
|
adamc@693
|
143 else
|
adamc@693
|
144 push_ids)
|
adamc@693
|
145 | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
|
adamc@693
|
146 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
|
adamc@693
|
147 pull_ids xes
|
adamc@693
|
148 else
|
adamc@693
|
149 pull_ids,
|
adamc@693
|
150 if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then
|
adamc@693
|
151 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
|
adamc@693
|
152 push_ids xes
|
adamc@693
|
153 else
|
adamc@693
|
154 push_ids)
|
adamc@693
|
155 | _ => (pull_ids, push_ids)
|
adamc@643
|
156 end
|
adamc@643
|
157
|
adamc@693
|
158 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
|
adamc@643
|
159
|
adamc@855
|
160 val foundBad = ref false
|
adamc@855
|
161
|
adamc@1104
|
162 val ps = map (fn (ek, x, n, ts, t, _, b) =>
|
adamc@643
|
163 (ek, x, n, ts, t,
|
adamc@693
|
164 if IS.member (push_ids, n) then
|
adamc@858
|
165 (if not (#persistent proto) andalso not (!foundBad) then
|
adamc@855
|
166 (foundBad := true;
|
adamc@855
|
167 ErrorMsg.error ("This program needs server push, but the current protocol ("
|
adamc@855
|
168 ^ #name proto ^ ") doesn't support that."))
|
adamc@855
|
169 else
|
adamc@855
|
170 ();
|
adamc@855
|
171 ServerAndPullAndPush)
|
adamc@693
|
172 else if IS.member (pull_ids, n) then
|
adamc@693
|
173 ServerAndPull
|
adamc@643
|
174 else
|
adamc@1104
|
175 ServerOnly,
|
adamc@1104
|
176 b)) ps
|
adamc@643
|
177 in
|
adamc@643
|
178 (ds, ps)
|
adamc@643
|
179 end
|
adamc@643
|
180
|
adamc@643
|
181 end
|
adamc@643
|
182
|