Mercurial > urweb

comparison src/scriptcheck.sml @ 643:aa2290c32ce2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Avoid any JavaScript when pages don't need it; update demo prose
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Mar 2009 10:44:26 -0400
parents
children 1b571a05874c
comparison
equal deleted inserted replaced
642:4a125bbc602d 643:aa2290c32ce2
1 (* Copyright (c) 2009, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure ScriptCheck :> SCRIPT_CHECK = struct
29
30 open Cjr
31
32 structure SS = BinarySetFn(struct
33 type ord_key = string
34 val compare = String.compare
35 end)
36 structure IS = IntBinarySet
37
38 val csBasis = SS.addList (SS.empty,
39 ["new_client_source",
40 "get_client_source",
41 "set_client_source",
42 "alert"])
43
44 fun classify (ds, ps) =
45 let
46 fun inString {needle, haystack} =
47 let
48 val (_, suffix) = Substring.position needle (Substring.full haystack)
49 in
50 not (Substring.isEmpty suffix)
51 end
52
53 fun hasClient csids =
54 let
55 fun hasClient e =
56 case #1 e of
57 EPrim (Prim.String s) => inString {needle = "<script", haystack = s}
58 | EPrim _ => false
59 | ERel _ => false
60 | ENamed n => IS.member (csids, n)
61 | ECon (_, _, NONE) => false
62 | ECon (_, _, SOME e) => hasClient e
63 | ENone _ => false
64 | ESome (_, e) => hasClient e
65 | EFfi ("Basis", x) => SS.member (csBasis, x)
66 | EFfi _ => false
67 | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
68 orelse List.exists hasClient es
69 | EFfiApp (_, _, es) => List.exists hasClient es
70 | EApp (e, es) => hasClient e orelse List.exists hasClient es
71 | EUnop (_, e) => hasClient e
72 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
73 | ERecord (_, xes) => List.exists (hasClient o #2) xes
74 | EField (e, _) => hasClient e
75 | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
76 | EError (e, _) => hasClient e
77 | EWrite e => hasClient e
78 | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
79 | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
80 | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
81 orelse hasClient initial
82 | EDml {dml, ...} => hasClient dml
83 | ENextval {seq, ...} => hasClient seq
84 | EUnurlify (e, _) => hasClient e
85 in
86 hasClient
87 end
88
89 fun decl ((d, _), csids) =
90 let
91 val hasClient = hasClient csids
92 in
93 case d of
94 DVal (_, n, _, e) => if hasClient e then
95 IS.add (csids, n)
96 else
97 csids
98 | DFun (_, n, _, _, e) => if hasClient e then
99 IS.add (csids, n)
100 else
101 csids
102 | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then
103 foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n))
104 csids xes
105 else
106 csids
107 | _ => csids
108 end
109
110 val csids = foldl decl IS.empty ds
111
112 val ps = map (fn (ek, x, n, ts, t, _) =>
113 (ek, x, n, ts, t,
114 if IS.member (csids, n) then
115 ServerAndClient
116 else
117 ServerOnly)) ps
118 in
119 (ds, ps)
120 end
121
122 end
123