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
ziv@2252:  * 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 "<Module>\n";
adam@2064:                      SM.appi (fn (k, r') => (print (k ^ ":\n");
adam@2064:                                              dump r')) m;
adam@2064:                      print "</Module>\n")
adam@2064: 
ziv@2252: 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
ziv@2252:                                         | 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
ziv@2252:         (ds, ps)
adamc@643:     end
adamc@643: 
adamc@643: end
ziv@2252: