Mercurial > urweb

annotate 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
rev   line source
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@643 38 val csBasis = SS.addList (SS.empty,
adamc@643 39 ["new_client_source",
adamc@643 40 "get_client_source",
adamc@643 41 "set_client_source",
adamc@643 42 "alert"])
adamc@643 43
adamc@643 44 fun classify (ds, ps) =
adamc@643 45 let
adamc@643 46 fun inString {needle, haystack} =
adamc@643 47 let
adamc@643 48 val (_, suffix) = Substring.position needle (Substring.full haystack)
adamc@643 49 in
adamc@643 50 not (Substring.isEmpty suffix)
adamc@643 51 end
adamc@643 52
adamc@643 53 fun hasClient csids =
adamc@643 54 let
adamc@643 55 fun hasClient e =
adamc@643 56 case #1 e of
adamc@643 57 EPrim (Prim.String s) => inString {needle = "<script", haystack = s}
adamc@643 58 | EPrim _ => false
adamc@643 59 | ERel _ => false
adamc@643 60 | ENamed n => IS.member (csids, n)
adamc@643 61 | ECon (_, _, NONE) => false
adamc@643 62 | ECon (_, _, SOME e) => hasClient e
adamc@643 63 | ENone _ => false
adamc@643 64 | ESome (_, e) => hasClient e
adamc@643 65 | EFfi ("Basis", x) => SS.member (csBasis, x)
adamc@643 66 | EFfi _ => false
adamc@643 67 | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
adamc@643 68 orelse List.exists hasClient es
adamc@643 69 | EFfiApp (_, _, es) => List.exists hasClient es
adamc@643 70 | EApp (e, es) => hasClient e orelse List.exists hasClient es
adamc@643 71 | EUnop (_, e) => hasClient e
adamc@643 72 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643 73 | ERecord (_, xes) => List.exists (hasClient o #2) xes
adamc@643 74 | EField (e, _) => hasClient e
adamc@643 75 | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
adamc@643 76 | EError (e, _) => hasClient e
adamc@643 77 | EWrite e => hasClient e
adamc@643 78 | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
adamc@643 79 | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643 80 | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
adamc@643 81 orelse hasClient initial
adamc@643 82 | EDml {dml, ...} => hasClient dml
adamc@643 83 | ENextval {seq, ...} => hasClient seq
adamc@643 84 | EUnurlify (e, _) => hasClient e
adamc@643 85 in
adamc@643 86 hasClient
adamc@643 87 end
adamc@643 88
adamc@643 89 fun decl ((d, _), csids) =
adamc@643 90 let
adamc@643 91 val hasClient = hasClient csids
adamc@643 92 in
adamc@643 93 case d of
adamc@643 94 DVal (_, n, _, e) => if hasClient e then
adamc@643 95 IS.add (csids, n)
adamc@643 96 else
adamc@643 97 csids
adamc@643 98 | DFun (_, n, _, _, e) => if hasClient e then
adamc@643 99 IS.add (csids, n)
adamc@643 100 else
adamc@643 101 csids
adamc@643 102 | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then
adamc@643 103 foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n))
adamc@643 104 csids xes
adamc@643 105 else
adamc@643 106 csids
adamc@643 107 | _ => csids
adamc@643 108 end
adamc@643 109
adamc@643 110 val csids = foldl decl IS.empty ds
adamc@643 111
adamc@643 112 val ps = map (fn (ek, x, n, ts, t, _) =>
adamc@643 113 (ek, x, n, ts, t,
adamc@643 114 if IS.member (csids, n) then
adamc@643 115 ServerAndClient
adamc@643 116 else
adamc@643 117 ServerOnly)) ps
adamc@643 118 in
adamc@643 119 (ds, ps)
adamc@643 120 end
adamc@643 121
adamc@643 122 end
adamc@643 123