summaryrefslogtreecommitdiff
path: root/src/scriptcheck.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/scriptcheck.sml')
-rw-r--r--src/scriptcheck.sml123
1 files changed, 123 insertions, 0 deletions
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
new file mode 100644
index 00000000..bfe87766
--- /dev/null
+++ b/src/scriptcheck.sml
@@ -0,0 +1,123 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure ScriptCheck :> SCRIPT_CHECK = struct
+
+open Cjr
+
+structure SS = BinarySetFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
+structure IS = IntBinarySet
+
+val csBasis = SS.addList (SS.empty,
+ ["new_client_source",
+ "get_client_source",
+ "set_client_source",
+ "alert"])
+
+fun classify (ds, ps) =
+ let
+ fun inString {needle, haystack} =
+ let
+ val (_, suffix) = Substring.position needle (Substring.full haystack)
+ in
+ not (Substring.isEmpty suffix)
+ end
+
+ fun hasClient csids =
+ let
+ fun hasClient e =
+ case #1 e of
+ EPrim (Prim.String s) => inString {needle = "<script", haystack = s}
+ | EPrim _ => false
+ | ERel _ => false
+ | ENamed n => IS.member (csids, n)
+ | ECon (_, _, NONE) => false
+ | ECon (_, _, SOME e) => hasClient e
+ | ENone _ => false
+ | ESome (_, e) => hasClient e
+ | EFfi ("Basis", x) => SS.member (csBasis, x)
+ | EFfi _ => false
+ | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
+ orelse List.exists hasClient es
+ | EFfiApp (_, _, es) => List.exists hasClient es
+ | EApp (e, es) => hasClient e orelse List.exists hasClient es
+ | EUnop (_, e) => hasClient e
+ | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
+ | ERecord (_, xes) => List.exists (hasClient o #2) xes
+ | EField (e, _) => hasClient e
+ | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
+ | EError (e, _) => hasClient e
+ | EWrite e => hasClient e
+ | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
+ | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
+ | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
+ orelse hasClient initial
+ | EDml {dml, ...} => hasClient dml
+ | ENextval {seq, ...} => hasClient seq
+ | EUnurlify (e, _) => hasClient e
+ in
+ hasClient
+ end
+
+ fun decl ((d, _), csids) =
+ let
+ val hasClient = hasClient csids
+ in
+ case d of
+ DVal (_, n, _, e) => if hasClient e then
+ IS.add (csids, n)
+ else
+ csids
+ | DFun (_, n, _, _, e) => if hasClient e then
+ IS.add (csids, n)
+ else
+ csids
+ | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then
+ foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n))
+ csids xes
+ else
+ csids
+ | _ => csids
+ end
+
+ val csids = foldl decl IS.empty ds
+
+ val ps = map (fn (ek, x, n, ts, t, _) =>
+ (ek, x, n, ts, t,
+ if IS.member (csids, n) then
+ ServerAndClient
+ else
+ ServerOnly)) ps
+ in
+ (ds, ps)
+ end
+
+end
+