adam@2064: (* Copyright (c) 2009, 2014, Adam Chlipala adamc@643: * All rights reserved. adamc@643: * adamc@643: * Redistribution and use in source and binary forms, with or without adamc@643: * modification, are permitted provided that the following conditions are met: adamc@643: * adamc@643: * - Redistributions of source code must retain the above copyright notice, adamc@643: * this list of conditions and the following disclaimer. adamc@643: * - Redistributions in binary form must reproduce the above copyright notice, adamc@643: * this list of conditions and the following disclaimer in the documentation adamc@643: * and/or other materials provided with the distribution. adamc@643: * - The names of contributors may not be used to endorse or promote products adamc@643: * derived from this software without specific prior written permission. adamc@643: * adamc@643: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@643: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@643: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@643: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@643: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@643: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@643: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@643: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@643: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@643: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@643: * POSSIBILITY OF SUCH DAMAGE. adamc@643: *) adamc@643: adamc@643: structure ScriptCheck :> SCRIPT_CHECK = struct adamc@643: adam@1845: open Mono adamc@643: adam@2064: structure SM = BinaryMapFn(struct adam@2064: type ord_key = string adam@2064: val compare = String.compare adam@2064: end) adamc@643: structure SS = BinarySetFn(struct adamc@643: type ord_key = string adamc@643: val compare = String.compare adamc@643: end) adamc@643: structure IS = IntBinarySet adamc@643: adamc@693: val pushBasis = SS.addList (SS.empty, adamc@693: ["new_channel", adamc@693: "self"]) adamc@799: adam@2064: datatype rpcmap = adam@2064: Rpc of int (* ID of function definition *) adam@2064: | Module of rpcmap SM.map adam@2064: adam@2064: fun lookup (r : rpcmap, k : string) = adam@2064: let adam@2064: fun lookup' (r, ks) = adam@2064: case r of adam@2064: Rpc x => SOME x adam@2064: | Module m => adam@2064: case ks of adam@2064: [] => NONE adam@2064: | k :: ks' => adam@2064: case SM.find (m, k) of adam@2064: NONE => NONE adam@2064: | SOME r' => lookup' (r', ks') adam@2064: in adam@2064: lookup' (r, String.tokens (fn ch => ch = #"/") k) adam@2064: end adam@2064: adam@2064: fun insert (r : rpcmap, k : string, v) = adam@2064: let adam@2064: fun insert' (r, ks) = adam@2064: case r of adam@2064: Rpc _ => Rpc v adam@2064: | Module m => adam@2064: case ks of adam@2064: [] => Rpc v adam@2064: | k :: ks' => adam@2064: let adam@2064: val r' = case SM.find (m, k) of adam@2064: NONE => Module SM.empty adam@2064: | SOME r' => r' adam@2064: in adam@2064: Module (SM.insert (m, k, insert' (r', ks'))) adam@2064: end adam@2064: in adam@2064: insert' (r, String.tokens (fn ch => ch = #"/") k) adam@2064: end adam@2064: adam@2064: fun dump (r : rpcmap) = adam@2064: case r of adam@2064: Rpc _ => print "ROOT\n" adam@2064: | Module m => (print "\n"; adam@2064: SM.appi (fn (k, r') => (print (k ^ ":\n"); adam@2064: dump r')) m; adam@2064: print "\n") adam@2064: adamc@643: fun classify (ds, ps) = adamc@643: let adamc@855: val proto = Settings.currentProtocol () adamc@855: adamc@970: fun inString {needle, haystack} = String.isSubstring needle haystack adamc@643: adam@2064: fun hasClient {basis, rpcs, funcs, push} = adam@1845: MonoUtil.Exp.exists {typ = fn _ => false, adam@1845: exp = fn ERecv _ => push adam@1845: | EFfiApp ("Basis", x, _) => SS.member (basis, x) adam@1845: | EJavaScript _ => not push adam@1845: | ENamed n => IS.member (funcs, n) adam@2064: | EServerCall (e, _, _, _) => adam@2064: let adam@2064: fun head (e : exp) = adam@2064: case #1 e of adam@2064: EStrcat (e1, _) => head e1 adam@2064: | EPrim (Prim.String (_, s)) => SOME s adam@2064: | _ => NONE adam@2064: in adam@2064: case head e of adam@2064: NONE => true adam@2064: | SOME fcall => adam@2064: case lookup (rpcs, fcall) of adam@2064: NONE => true adam@2064: | SOME n => IS.member (funcs, n) adam@2064: end adam@1845: | _ => false} adamc@643: adam@2064: fun decl ((d, _), rpcs) = adam@2064: case d of adam@2064: DExport (Mono.Rpc _, fcall, n, _, _, _) => adam@2064: insert (rpcs, fcall, n) adam@2064: | _ => rpcs adam@2064: adam@2064: val rpcs = foldl decl (Module SM.empty) ds adam@2064: adamc@693: fun decl ((d, _), (pull_ids, push_ids)) = adamc@643: let adam@2064: val hasClientPull = hasClient {basis = SS.empty, rpcs = rpcs, funcs = pull_ids, push = false} adam@2064: val hasClientPush = hasClient {basis = pushBasis, rpcs = rpcs, funcs = push_ids, push = true} adamc@643: in adamc@643: case d of adam@1845: DVal (_, n, _, e, _) => (if hasClientPull e then adam@2064: IS.add (pull_ids, n) adam@2064: else adam@2064: pull_ids, adam@2064: if hasClientPush e then adam@2064: IS.add (push_ids, n) adam@2064: else adam@2064: push_ids) adam@1845: | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then adam@2064: foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) adam@2064: pull_ids xes adamc@693: else adamc@693: pull_ids, adam@1845: if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then adamc@693: foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) adamc@693: push_ids xes adamc@693: else adamc@693: push_ids) adamc@693: | _ => (pull_ids, push_ids) adamc@643: end adamc@643: adamc@693: val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds adamc@643: adamc@855: val foundBad = ref false adamc@855: adam@1845: val all_ids = IS.union (pull_ids, push_ids) adam@1845: adam@1845: val ps = map (fn n => adam@1845: (n, if IS.member (push_ids, n) then adam@1845: (if not (#persistent proto) andalso not (!foundBad) then adam@1845: (foundBad := true; adam@1845: ErrorMsg.error ("This program needs server push, but the current protocol (" adam@1845: ^ #name proto ^ ") doesn't support that.")) adam@1845: else adam@1845: (); adam@1845: ServerAndPullAndPush) adam@1845: else if IS.member (pull_ids, n) then adam@1845: ServerAndPull adam@1845: else adam@2056: ServerOnly, AnyDb)) (IS.listItems all_ids) adamc@643: in adamc@643: (ds, ps) adamc@643: end adamc@643: adamc@643: end adamc@643: