Mercurial > urweb

annotate src/scriptcheck.sml @ 1327:1cc67fdac4d3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New argument to transactional free functions, to specify whether we are about to retry
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Dec 2010 11:15:20 -0500
parents 7a31e0cf25e9
children 0577be31a435
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@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",
adamc@726 95 [(EFfiApp ("Basis", "strcat", all as [_, (EPrim (Prim.String s), _)]), _)]) =>
adamc@726 96 List.exists hasClient all
adamc@726 97 orelse (onload andalso size s > 0)
adamc@693 98 | EFfiApp ("Basis", x, es) => SS.member (basis, x)
adamc@643 99 orelse List.exists hasClient es
adamc@643 100 | EFfiApp (_, _, es) => List.exists hasClient 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