Mercurial > urweb

annotate src/scriptcheck.sml @ 2118:7bdfc365f456

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Return to working version mode
author Adam Chlipala <adam@chlipala.net>
date Sat, 14 Feb 2015 08:27:50 -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