Mercurial > urweb

annotate src/scriptcheck.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents 500e93aa436f
children 6fc633d990e7
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@693 46
adamc@645 47 val scriptWords = ["<script",
adamc@695 48 " onclick='"]
adamc@643 49
adamc@693 50 val pushWords = ["rv("]
adamc@693 51
adamc@643 52 fun classify (ds, ps) =
adamc@643 53 let
adamc@643 54 fun inString {needle, haystack} =
adamc@643 55 let
adamc@643 56 val (_, suffix) = Substring.position needle (Substring.full haystack)
adamc@643 57 in
adamc@643 58 not (Substring.isEmpty suffix)
adamc@643 59 end
adamc@643 60
adamc@695 61 fun hasClient {basis, words, onload} csids =
adamc@643 62 let
adamc@695 63 fun realOnload ss =
adamc@695 64 case ss of
adamc@695 65 [] => false
adamc@695 66 | (EFfiApp ("Basis", "get_settings", _), _) :: ss => realOnload ss
adamc@695 67 | (EPrim (Prim.String s), _) :: ss => not (String.isPrefix "'" s)
adamc@695 68 | _ => true
adamc@695 69
adamc@643 70 fun hasClient e =
adamc@643 71 case #1 e of
adamc@693 72 EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
adamc@643 73 | EPrim _ => false
adamc@643 74 | ERel _ => false
adamc@643 75 | ENamed n => IS.member (csids, n)
adamc@643 76 | ECon (_, _, NONE) => false
adamc@643 77 | ECon (_, _, SOME e) => hasClient e
adamc@643 78 | ENone _ => false
adamc@643 79 | ESome (_, e) => hasClient e
adamc@693 80 | EFfi ("Basis", x) => SS.member (basis, x)
adamc@643 81 | EFfi _ => false
adamc@695 82 | EFfiApp ("Basis", "strcat", all as ((EPrim (Prim.String s1), _) :: ss)) =>
adamc@695 83 if onload andalso String.isSuffix " onload='" s1 then
adamc@695 84 realOnload ss orelse List.exists hasClient all
adamc@695 85 else
adamc@695 86 List.exists hasClient all
adamc@693 87 | EFfiApp ("Basis", x, es) => SS.member (basis, x)
adamc@643 88 orelse List.exists hasClient es
adamc@643 89 | EFfiApp (_, _, es) => List.exists hasClient es
adamc@643 90 | EApp (e, es) => hasClient e orelse List.exists hasClient es
adamc@643 91 | EUnop (_, e) => hasClient e
adamc@643 92 | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643 93 | ERecord (_, xes) => List.exists (hasClient o #2) xes
adamc@643 94 | EField (e, _) => hasClient e
adamc@643 95 | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
adamc@643 96 | EError (e, _) => hasClient e
adamc@643 97 | EWrite e => hasClient e
adamc@643 98 | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
adamc@643 99 | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643 100 | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
adamc@643 101 orelse hasClient initial
adamc@643 102 | EDml {dml, ...} => hasClient dml
adamc@643 103 | ENextval {seq, ...} => hasClient seq
adamc@643 104 | EUnurlify (e, _) => hasClient e
adamc@643 105 in
adamc@643 106 hasClient
adamc@643 107 end
adamc@643 108
adamc@693 109 fun decl ((d, _), (pull_ids, push_ids)) =
adamc@643 110 let
adamc@695 111 val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids
adamc@695 112 val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids
adamc@643 113 in
adamc@643 114 case d of
adamc@693 115 DVal (_, n, _, e) => (if hasClientPull e then
adamc@693 116 IS.add (pull_ids, n)
adamc@693 117 else
adamc@693 118 pull_ids,
adamc@693 119 if hasClientPush e then
adamc@693 120 IS.add (push_ids, n)
adamc@693 121 else
adamc@693 122 push_ids)
adamc@693 123 | DFun (_, n, _, _, e) => (if hasClientPull e then
adamc@693 124 IS.add (pull_ids, n)
adamc@693 125 else
adamc@693 126 pull_ids,
adamc@693 127 if hasClientPush e then
adamc@693 128 IS.add (push_ids, n)
adamc@693 129 else
adamc@693 130 push_ids)
adamc@693 131 | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
adamc@693 132 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
adamc@693 133 pull_ids xes
adamc@693 134 else
adamc@693 135 pull_ids,
adamc@693 136 if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then
adamc@693 137 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
adamc@693 138 push_ids xes
adamc@693 139 else
adamc@693 140 push_ids)
adamc@693 141 | _ => (pull_ids, push_ids)
adamc@643 142 end
adamc@643 143
adamc@693 144 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
adamc@643 145
adamc@643 146 val ps = map (fn (ek, x, n, ts, t, _) =>
adamc@643 147 (ek, x, n, ts, t,
adamc@693 148 if IS.member (push_ids, n) then
adamc@693 149 ServerAndPullAndPush
adamc@693 150 else if IS.member (pull_ids, n) then
adamc@693 151 ServerAndPull
adamc@643 152 else
adamc@643 153 ServerOnly)) ps
adamc@643 154 in
adamc@643 155 (ds, ps)
adamc@643 156 end
adamc@643 157
adamc@643 158 end
adamc@643 159