summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h2
-rw-r--r--lib/js/urweb.js30
-rw-r--r--src/c/urweb.c9
-rw-r--r--src/cjr.sml3
-rw-r--r--src/cjr_print.sml17
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/jscomp.sml10
-rw-r--r--src/scriptcheck.sml80
8 files changed, 100 insertions, 53 deletions
diff --git a/include/urweb.h b/include/urweb.h
index aa574ff3..daf965b0 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -52,6 +52,8 @@ void uw_set_script_header(uw_context, const char*);
const char *uw_Basis_get_settings(uw_context, uw_Basis_string);
const char *uw_Basis_get_script(uw_context, uw_unit);
+void uw_set_needs_push(uw_context, int);
+
char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float);
char *uw_Basis_htmlifyString(uw_context, uw_Basis_string);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index fe996833..de956d3f 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -22,11 +22,19 @@ function union(ls1, ls2) {
// Embedding closures in XML strings
+function cs(f) {
+ return {closure: f};
+}
+
+function isWeird(v) {
+ return v.closure != null || v.cat1 != null;
+}
+
function cat(s1, s2) {
- if (s1.length && s2.length)
- return s1 + s2;
+ if (isWeird(s1) || isWeird(s2))
+ return {cat1: s1, cat2: s2};
else
- return {_1: s1, _2: s2};
+ return s1 + s2;
}
var closures = [];
@@ -42,12 +50,12 @@ function cr(n) {
}
function flatten(tr) {
- if (tr.length)
- return tr;
- else if (tr._1)
- return cs(tr._1) + cs(tr._2);
+ if (tr.cat1 != null)
+ return flatten(tr.cat1) + flatten(tr.cat2);
+ else if (tr.closure != null)
+ return "cr(" + newClosure(tr.closure) + ")";
else
- return "cr(" + newClosure(tr) + ")";
+ return tr;
}
function clearClosures() {
@@ -157,7 +165,7 @@ function dyn(s) {
ls.data.dyns = remove(span, ls.data.dyns);
}
- x.innerHTML = v;
+ x.innerHTML = flatten(v);
runScripts(x);
if (--dynDepth == 0)
@@ -412,3 +420,7 @@ function rv(chn, parse, k) {
k(parse(msg))(null);
}
}
+
+
+// App-specific code
+
diff --git a/src/c/urweb.c b/src/c/urweb.c
index ed19305e..880cd143 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -300,6 +300,8 @@ struct uw_context {
const char *script_header, *url_prefix;
+ int needs_push;
+
size_t n_deltas, used_deltas;
delta *deltas;
@@ -333,6 +335,7 @@ uw_context uw_init() {
ctx->script_header = "";
ctx->url_prefix = "/";
+ ctx->needs_push = 0;
ctx->error_message[0] = 0;
@@ -476,7 +479,7 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) {
}
void uw_login(uw_context ctx) {
- if (ctx->script_header[0]) {
+ if (ctx->needs_push) {
char *id_s, *pass_s;
if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client"))
@@ -578,6 +581,10 @@ void uw_set_url_prefix(uw_context ctx, const char *s) {
ctx->url_prefix = s;
}
+void uw_set_needs_push(uw_context ctx, int n) {
+ ctx->needs_push = n;
+}
+
static void buf_check_ctx(uw_context ctx, buf *b, size_t extra, const char *desc) {
if (b->back - b->front < extra) {
diff --git a/src/cjr.sml b/src/cjr.sml
index 41bb6a4c..78c2e63b 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -115,7 +115,8 @@ withtype decl = decl' located
datatype sidedness =
ServerOnly
- | ServerAndClient
+ | ServerAndPull
+ | ServerAndPullAndPush
type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 9c652d4a..54ec3cbf 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2391,12 +2391,19 @@ fun p_file env (ds, ps) =
newline,
string "uw_set_script_header(ctx, \"",
string (case side of
- ServerAndClient => "<script src=\\\""
- ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix,
- file = "app.js"}
- ^ "\\\"></script>\\n"
- | ServerOnly => ""),
+ ServerOnly => ""
+ | _ => "<script src=\\\""
+ ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix,
+ file = "app.js"}
+ ^ "\\\"></script>\\n"),
string "\");",
+ newline,
+ string "uw_set_needs_push(ctx, ",
+ string (case side of
+ ServerAndPullAndPush => "1"
+ | _ => "0"),
+ string ");",
+ newline,
string "uw_set_url_prefix(ctx, \"",
string (!Monoize.urlPrefix),
string "\");",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 27287d6e..998ae38e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -520,7 +520,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, L'.ServerAndClient), sm)
+ (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm)
end
| L.DTable (s, xts) =>
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1409a0cb..c28f58d0 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -850,7 +850,7 @@ fun process file =
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
- (strcat [str "(", e1, str "+", e2, str ")"], st)
+ (strcat [str "cat(", e1, str ",", e2, str ")"], st)
end
| EError (e, _) =>
@@ -891,9 +891,9 @@ fun process file =
| EJavaScript (Source _, _, SOME _) => (e, st)
| EJavaScript (_, _, SOME e) =>
- (strcat [str "function(){return ",
+ (strcat [str "cs(function(){return ",
e,
- str "}"],
+ str "})"],
st)
| EClosure _ => unsupported "EClosure"
@@ -905,9 +905,9 @@ fun process file =
let
val (e, st) = jsE inner (e, st)
in
- (strcat [str "function(){return ",
+ (strcat [str "cs(function(){return ",
e,
- str "}"],
+ str "})"],
st)
end
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 0b51747f..34bf2337 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -35,19 +35,21 @@ structure SS = BinarySetFn(struct
end)
structure IS = IntBinarySet
-val csBasis = SS.addList (SS.empty,
- ["new_client_source",
- "get_client_source",
- "set_client_source",
- "new_channel",
- "subscribe",
- "send",
- "recv"])
+val pullBasis = SS.addList (SS.empty,
+ ["new_client_source",
+ "get_client_source",
+ "set_client_source"])
+val pushBasis = SS.addList (SS.empty,
+ ["new_channel",
+ "self"])
+
val scriptWords = ["<script",
" onclick=",
" onload="]
+val pushWords = ["rv("]
+
fun classify (ds, ps) =
let
fun inString {needle, haystack} =
@@ -57,11 +59,11 @@ fun classify (ds, ps) =
not (Substring.isEmpty suffix)
end
- fun hasClient csids =
+ fun hasClient {basis, words} csids =
let
fun hasClient e =
case #1 e of
- EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) scriptWords
+ EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
| EPrim _ => false
| ERel _ => false
| ENamed n => IS.member (csids, n)
@@ -69,9 +71,9 @@ fun classify (ds, ps) =
| ECon (_, _, SOME e) => hasClient e
| ENone _ => false
| ESome (_, e) => hasClient e
- | EFfi ("Basis", x) => SS.member (csBasis, x)
+ | EFfi ("Basis", x) => SS.member (basis, x)
| EFfi _ => false
- | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
+ | EFfiApp ("Basis", x, es) => SS.member (basis, x)
orelse List.exists hasClient es
| EFfiApp (_, _, es) => List.exists hasClient es
| EApp (e, es) => hasClient e orelse List.exists hasClient es
@@ -93,33 +95,49 @@ fun classify (ds, ps) =
hasClient
end
- fun decl ((d, _), csids) =
+ fun decl ((d, _), (pull_ids, push_ids)) =
let
- val hasClient = hasClient csids
+ val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids
+ val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids
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
+ DVal (_, n, _, e) => (if hasClientPull e then
+ IS.add (pull_ids, n)
+ else
+ pull_ids,
+ if hasClientPush e then
+ IS.add (push_ids, n)
+ else
+ push_ids)
+ | DFun (_, n, _, _, e) => (if hasClientPull e then
+ IS.add (pull_ids, n)
+ else
+ pull_ids,
+ if hasClientPush e then
+ IS.add (push_ids, n)
+ else
+ push_ids)
+ | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then
+ foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
+ pull_ids xes
+ else
+ pull_ids,
+ if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then
+ foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
+ push_ids xes
+ else
+ push_ids)
+ | _ => (pull_ids, push_ids)
end
- val csids = foldl decl IS.empty ds
+ val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
val ps = map (fn (ek, x, n, ts, t, _) =>
(ek, x, n, ts, t,
- if IS.member (csids, n) then
- ServerAndClient
+ if IS.member (push_ids, n) then
+ ServerAndPullAndPush
+ else if IS.member (pull_ids, n) then
+ ServerAndPull
else
ServerOnly)) ps
in
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-10 07:31:24 +0000