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 = " " 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@970: fun inString {needle, haystack} = String.isSubstring needle haystack 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: