Mercurial > urweb

annotate src/scriptcheck.sml @ 1437:493e087f5479

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Exit periodic loop if a ROLLBACK fails, to avoid infinite looping when the database server is brought down
author Adam Chlipala <adam@chlipala.net>
date Fri, 18 Mar 2011 09:12:55 -0400
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