Mercurial > urweb

annotate src/scriptcheck.sml @ 2101:32e2752390ad

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fixing one small issue with changes to signature matching (grandfathered into release)
author Adam Chlipala <adam@chlipala.net>
date Sat, 03 Jan 2015 10:21:26 -0500
parents 3dd041b00087
children 25874084bf1f
rev   line source
adam@2064 1 (* Copyright (c) 2009, 2014, 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
adam@1845 30 open Mono
adamc@643 31
adam@2064 32 structure SM = BinaryMapFn(struct
adam@2064 33 type ord_key = string
adam@2064 34 val compare = String.compare
adam@2064 35 end)
adamc@643 36 structure SS = BinarySetFn(struct
adamc@643 37 type ord_key = string
adamc@643 38 val compare = String.compare
adamc@643 39 end)
adamc@643 40 structure IS = IntBinarySet
adamc@643 41
adamc@693 42 val pushBasis = SS.addList (SS.empty,
adamc@693 43 ["new_channel",
adamc@693 44 "self"])
adamc@799 45
adam@2064 46 datatype rpcmap =
adam@2064 47 Rpc of int (* ID of function definition *)
adam@2064 48 | Module of rpcmap SM.map
adam@2064 49
adam@2064 50 fun lookup (r : rpcmap, k : string) =
adam@2064 51 let
adam@2064 52 fun lookup' (r, ks) =
adam@2064 53 case r of
adam@2064 54 Rpc x => SOME x
adam@2064 55 | Module m =>
adam@2064 56 case ks of
adam@2064 57 [] => NONE
adam@2064 58 | k :: ks' =>
adam@2064 59 case SM.find (m, k) of
adam@2064 60 NONE => NONE
adam@2064 61 | SOME r' => lookup' (r', ks')
adam@2064 62 in
adam@2064 63 lookup' (r, String.tokens (fn ch => ch = #"/") k)
adam@2064 64 end
adam@2064 65
adam@2064 66 fun insert (r : rpcmap, k : string, v) =
adam@2064 67 let
adam@2064 68 fun insert' (r, ks) =
adam@2064 69 case r of
adam@2064 70 Rpc _ => Rpc v
adam@2064 71 | Module m =>
adam@2064 72 case ks of
adam@2064 73 [] => Rpc v
adam@2064 74 | k :: ks' =>
adam@2064 75 let
adam@2064 76 val r' = case SM.find (m, k) of
adam@2064 77 NONE => Module SM.empty
adam@2064 78 | SOME r' => r'
adam@2064 79 in
adam@2064 80 Module (SM.insert (m, k, insert' (r', ks')))
adam@2064 81 end
adam@2064 82 in
adam@2064 83 insert' (r, String.tokens (fn ch => ch = #"/") k)
adam@2064 84 end
adam@2064 85
adam@2064 86 fun dump (r : rpcmap) =
adam@2064 87 case r of
adam@2064 88 Rpc _ => print "ROOT\n"
adam@2064 89 | Module m => (print "<Module>\n";
adam@2064 90 SM.appi (fn (k, r') => (print (k ^ ":\n");
adam@2064 91 dump r')) m;
adam@2064 92 print "</Module>\n")
adam@2064 93
adamc@643 94 fun classify (ds, ps) =
adamc@643 95 let
adamc@855 96 val proto = Settings.currentProtocol ()
adamc@855 97
adamc@970 98 fun inString {needle, haystack} = String.isSubstring needle haystack
adamc@643 99
adam@2064 100 fun hasClient {basis, rpcs, funcs, push} =
adam@1845 101 MonoUtil.Exp.exists {typ = fn _ => false,
adam@1845 102 exp = fn ERecv _ => push
adam@1845 103 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
adam@1845 104 | EJavaScript _ => not push
adam@1845 105 | ENamed n => IS.member (funcs, n)
adam@2064 106 | EServerCall (e, _, _, _) =>
adam@2064 107 let
adam@2064 108 fun head (e : exp) =
adam@2064 109 case #1 e of
adam@2064 110 EStrcat (e1, _) => head e1
adam@2064 111 | EPrim (Prim.String (_, s)) => SOME s
adam@2064 112 | _ => NONE
adam@2064 113 in
adam@2064 114 case head e of
adam@2064 115 NONE => true
adam@2064 116 | SOME fcall =>
adam@2064 117 case lookup (rpcs, fcall) of
adam@2064 118 NONE => true
adam@2064 119 | SOME n => IS.member (funcs, n)
adam@2064 120 end
adam@1845 121 | _ => false}
adamc@643 122
adam@2064 123 fun decl ((d, _), rpcs) =
adam@2064 124 case d of
adam@2064 125 DExport (Mono.Rpc _, fcall, n, _, _, _) =>
adam@2064 126 insert (rpcs, fcall, n)
adam@2064 127 | _ => rpcs
adam@2064 128
adam@2064 129 val rpcs = foldl decl (Module SM.empty) ds
adam@2064 130
adamc@693 131 fun decl ((d, _), (pull_ids, push_ids)) =
adamc@643 132 let
adam@2064 133 val hasClientPull = hasClient {basis = SS.empty, rpcs = rpcs, funcs = pull_ids, push = false}
adam@2064 134 val hasClientPush = hasClient {basis = pushBasis, rpcs = rpcs, funcs = push_ids, push = true}
adamc@643 135 in
adamc@643 136 case d of
adam@1845 137 DVal (_, n, _, e, _) => (if hasClientPull e then
adam@2064 138 IS.add (pull_ids, n)
adam@2064 139 else
adam@2064 140 pull_ids,
adam@2064 141 if hasClientPush e then
adam@2064 142 IS.add (push_ids, n)
adam@2064 143 else
adam@2064 144 push_ids)
adam@1845 145 | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
adam@2064 146 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
adam@2064 147 pull_ids xes
adamc@693 148 else
adamc@693 149 pull_ids,
adam@1845 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
adam@1845 162 val all_ids = IS.union (pull_ids, push_ids)
adam@1845 163
adam@1845 164 val ps = map (fn n =>
adam@1845 165 (n, if IS.member (push_ids, n) then
adam@1845 166 (if not (#persistent proto) andalso not (!foundBad) then
adam@1845 167 (foundBad := true;
adam@1845 168 ErrorMsg.error ("This program needs server push, but the current protocol ("
adam@1845 169 ^ #name proto ^ ") doesn't support that."))
adam@1845 170 else
adam@1845 171 ();
adam@1845 172 ServerAndPullAndPush)
adam@1845 173 else if IS.member (pull_ids, n) then
adam@1845 174 ServerAndPull
adam@1845 175 else
adam@2056 176 ServerOnly, AnyDb)) (IS.listItems all_ids)
adamc@643 177 in
adamc@643 178 (ds, ps)
adamc@643 179 end
adamc@643 180
adamc@643 181 end
adamc@643 182