summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c12
-rw-r--r--src/cjr.sml6
-rw-r--r--src/cjr_print.sml12
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/monoize.sml4
-rw-r--r--src/scriptcheck.sig32
-rw-r--r--src/scriptcheck.sml123
-rw-r--r--src/sources3
10 files changed, 194 insertions, 11 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index e28fa5f4..823e8824 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -42,6 +42,8 @@ struct uw_context {
cleanup *cleanup, *cleanup_front, *cleanup_back;
+ const char *script_header;
+
char error_message[ERROR_BUF_LEN];
};
@@ -71,6 +73,8 @@ uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, si
ctx->cleanup_front = ctx->cleanup_back = ctx->cleanup = malloc(0);
+ ctx->script_header = "";
+
ctx->error_message[0] = 0;
ctx->script_front = ctx->script = malloc(script_len);
@@ -235,6 +239,10 @@ char *uw_get_optional_input(uw_context ctx, int n) {
return (ctx->inputs[n] == NULL ? "" : ctx->inputs[n]);
}
+void uw_set_script_header(uw_context ctx, const char *s) {
+ ctx->script_header = s;
+}
+
static void uw_check_heap(uw_context ctx, size_t extra) {
if (ctx->heap_back - ctx->heap_front < extra) {
size_t desired = ctx->heap_front - ctx->heap + extra, next;
@@ -380,9 +388,9 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
r[0] = 0;
return r;
} else {
- char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script));
+ char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script) + strlen(ctx->script_header));
- sprintf(r, "<script>%s</script>", ctx->script);
+ sprintf(r, "%s<script>%s</script>", ctx->script_header, ctx->script);
return r;
}
}
diff --git a/src/cjr.sml b/src/cjr.sml
index a38a1b0d..688326e4 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -113,6 +113,10 @@ datatype decl' =
withtype decl = decl' located
-type file = decl list * (Core.export_kind * string * int * typ list * typ) list
+datatype sidedness =
+ ServerOnly
+ | ServerAndClient
+
+type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index aff5efd3..ab808426 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2009, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -2130,7 +2130,7 @@ fun p_file env (ds, ps) =
E.declBinds env d))
env ds
- val fields = foldl (fn ((ek, _, _, ts, _), fields) =>
+ val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
case ek of
Core.Link => fields
| Core.Rpc => fields
@@ -2251,7 +2251,7 @@ fun p_file env (ds, ps) =
string "}"]
end
- fun p_page (ek, s, n, ts, ran) =
+ fun p_page (ek, s, n, ts, ran, side) =
let
val (ts, defInputs, inputsVar) =
case ek of
@@ -2346,6 +2346,12 @@ fun p_file env (ds, ps) =
string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
newline,
string "uw_write(ctx, \"<html>\");",
+ newline,
+ string "uw_set_script_header(ctx, \"",
+ string (case side of
+ ServerAndClient => "<script src=\\\"/app.js\\\"></script>\\n"
+ | ServerOnly => ""),
+ string "\");",
newline]),
box [string "{",
newline,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 9d9ab36c..e637c82c 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -519,7 +519,7 @@ fun cifyDecl ((d, loc), sm) =
val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
val (t, sm) = cifyTyp (t, sm)
in
- (NONE, SOME (ek, "/" ^ s, n, ts, t), sm)
+ (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndClient), sm)
end
| L.DTable (s, xts) =>
diff --git a/src/compiler.sig b/src/compiler.sig
index b7418f2a..8ef41a58 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -80,6 +80,7 @@ signature COMPILER = sig
val fuse : (Mono.file, Mono.file) phase
val pathcheck : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
+ val scriptcheck : (Cjr.file, Cjr.file) phase
val prepare : (Cjr.file, Cjr.file) phase
val sqlify : (Mono.file, Cjr.file) phase
@@ -115,6 +116,7 @@ signature COMPILER = sig
val toMono_shake2 : (string, Mono.file) transform
val toPathcheck : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
+ val toScriptcheck : (string, Cjr.file) transform
val toPrepare : (string, Cjr.file) transform
val toSqlify : (string, Cjr.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index d74da2a6..b433a7b6 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -558,12 +558,19 @@ val cjrize = {
val toCjrize = transform cjrize "cjrize" o toPathcheck
+val scriptcheck = {
+ func = ScriptCheck.classify,
+ print = CjrPrint.p_file CjrEnv.empty
+}
+
+val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
+
val prepare = {
func = Prepare.prepare,
print = CjrPrint.p_file CjrEnv.empty
}
-val toPrepare = transform prepare "prepare" o toCjrize
+val toPrepare = transform prepare "prepare" o toScriptcheck
val sqlify = {
func = Cjrize.cjrize,
diff --git a/src/monoize.sml b/src/monoize.sml
index 892ae81f..57bf26e3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1924,9 +1924,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
case tag of
"body" => normal ("body", NONE,
- SOME (L'.EStrcat ((L'.EPrim (Prim.String "<script src=\"/app.js\"></script>"), loc),
- (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]),
- loc)), loc))
+ SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
| "dyn" =>
(case attrs of
diff --git a/src/scriptcheck.sig b/src/scriptcheck.sig
new file mode 100644
index 00000000..bc9b6377
--- /dev/null
+++ b/src/scriptcheck.sig
@@ -0,0 +1,32 @@
+(* 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.
+ *)
+
+signature SCRIPT_CHECK = sig
+
+ val classify : Cjr.file -> Cjr.file
+
+end
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
+
diff --git a/src/sources b/src/sources
index f5574365..ba453f62 100644
--- a/src/sources
+++ b/src/sources
@@ -160,6 +160,9 @@ cjr_print.sml
cjrize.sig
cjrize.sml
+scriptcheck.sig
+scriptcheck.sml
+
prepare.sig
prepare.sml
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-15 15:12:07 +0000