adamc@643: (* Copyright (c) 2009, 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: 
adamc@643: open Cjr
adamc@643: 
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 pullBasis = SS.addList (SS.empty,
adamc@693:                             ["new_client_source",
adamc@693:                              "get_client_source",
adamc@693:                              "set_client_source"])
adamc@645: 
adamc@693: val pushBasis = SS.addList (SS.empty,
adamc@693:                             ["new_channel",
adamc@693:                              "self"])
adamc@799: 
adamc@799: val events = ["abort",
adamc@799:               "blur",
adamc@799:               "change",
adamc@799:               "click",
adamc@799:               "dblclick",
adamc@799:               "error",
adamc@799:               "focus",
adamc@799:               "keydown",
adamc@799:               "keypress",
adamc@799:               "keyup",
adamc@799:               "load",
adamc@799:               "mousedown",
adamc@799:               "mousemove",
adamc@799:               "mouseout",
adamc@799:               "mouseover",
adamc@799:               "mouseup",
adamc@799:               "reset",
adamc@799:               "resize",
adamc@799:               "select",
adamc@799:               "submit",
adamc@799:               "unload"]
adamc@693:                 
adamc@799: val scriptWords = "<script"
adamc@799:                    :: map (fn s => "on" ^ s ^ " ='") events
adamc@643: 
adamc@693: val pushWords = ["rv("]
adamc@693: 
adamc@643: fun classify (ds, ps) =
adamc@643:     let
adamc@855:         val proto = Settings.currentProtocol ()
adamc@855: 
adamc@643:         fun inString {needle, haystack} =
adamc@643:             let
adamc@643:                 val (_, suffix) = Substring.position needle (Substring.full haystack)
adamc@643:             in
adamc@643:                 not (Substring.isEmpty suffix)
adamc@643:             end
adamc@643: 
adamc@695:         fun hasClient {basis, words, onload} csids =
adamc@643:             let
adamc@643:                 fun hasClient e =
adamc@643:                     case #1 e of
adamc@693:                         EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
adamc@643:                       | EPrim _ => false
adamc@643:                       | ERel _ => false
adamc@643:                       | ENamed n => IS.member (csids, n)
adamc@643:                       | ECon (_, _, NONE) => false
adamc@643:                       | ECon (_, _, SOME e) => hasClient e
adamc@643:                       | ENone _ => false
adamc@643:                       | ESome (_, e) => hasClient e
adamc@693:                       | EFfi ("Basis", x) => SS.member (basis, x)
adamc@643:                       | EFfi _ => false
adamc@726:                       | EFfiApp ("Basis", "maybe_onload",
adamc@726:                                  [(EFfiApp ("Basis", "strcat", all as [_, (EPrim (Prim.String s), _)]), _)]) =>
adamc@726:                         List.exists hasClient all
adamc@726:                         orelse (onload andalso size s > 0)
adamc@693:                       | EFfiApp ("Basis", x, es) => SS.member (basis, x)
adamc@643:                                                     orelse List.exists hasClient es
adamc@643:                       | EFfiApp (_, _, es) => List.exists hasClient es
adamc@643:                       | EApp (e, es) => hasClient e orelse List.exists hasClient es
adamc@643:                       | EUnop (_, e) => hasClient e
adamc@643:                       | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643:                       | ERecord (_, xes) => List.exists (hasClient o #2) xes
adamc@643:                       | EField (e, _) => hasClient e
adamc@643:                       | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
adamc@643:                       | EError (e, _) => hasClient e
adamc@741:                       | EReturnBlob {blob = e1, mimeType = e2, ...} => hasClient e1 orelse hasClient e2
adamc@643:                       | EWrite e => hasClient e
adamc@643:                       | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
adamc@643:                       | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
adamc@643:                       | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
adamc@643:                                                               orelse hasClient initial
adamc@643:                       | EDml {dml, ...} => hasClient dml
adamc@643:                       | ENextval {seq, ...} => hasClient seq
adamc@643:                       | EUnurlify (e, _) => hasClient e
adamc@643:             in
adamc@643:                 hasClient
adamc@643:             end
adamc@643: 
adamc@693:         fun decl ((d, _), (pull_ids, push_ids)) =
adamc@643:             let
adamc@695:                 val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids
adamc@695:                 val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids
adamc@643:             in
adamc@643:                 case d of
adamc@693:                     DVal (_, n, _, e) => (if hasClientPull e then
adamc@693:                                              IS.add (pull_ids, n)
adamc@693:                                           else
adamc@693:                                               pull_ids,
adamc@693:                                           if hasClientPush e then
adamc@693:                                               IS.add (push_ids, n)
adamc@693:                                           else
adamc@693:                                               push_ids)
adamc@693:                   | DFun (_, n, _, _, e) => (if hasClientPull e then
adamc@693:                                                  IS.add (pull_ids, n)
adamc@693:                                              else
adamc@693:                                                  pull_ids,
adamc@693:                                              if hasClientPush e then
adamc@693:                                                  IS.add (push_ids, n)
adamc@693:                                              else
adamc@693:                                                  push_ids)
adamc@693:                   | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
adamc@693:                                        foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
adamc@693:                                              pull_ids xes
adamc@693:                                     else
adamc@693:                                         pull_ids,
adamc@693:                                     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: 
adamc@643:         val ps = map (fn (ek, x, n, ts, t, _) =>
adamc@643:                          (ek, x, n, ts, t,
adamc@693:                           if IS.member (push_ids, n) then
adamc@858:                               (if not (#persistent proto) andalso not (!foundBad) then
adamc@855:                                    (foundBad := true;
adamc@855:                                     ErrorMsg.error ("This program needs server push, but the current protocol ("
adamc@855:                                                     ^ #name proto ^ ") doesn't support that."))
adamc@855:                                else
adamc@855:                                    ();
adamc@855:                                ServerAndPullAndPush)
adamc@693:                           else if IS.member (pull_ids, n) then
adamc@693:                               ServerAndPull
adamc@643:                           else
adamc@643:                               ServerOnly)) ps
adamc@643:     in
adamc@643:         (ds, ps)
adamc@643:     end
adamc@643: 
adamc@643: end
adamc@643: