summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/js/urweb.js78
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/jscomp.sml22
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_print.sml5
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml8
-rw-r--r--src/monoize.sml18
-rw-r--r--src/rpcify.sml3
-rw-r--r--src/scriptcheck.sml4
-rw-r--r--tests/channel.ur11
12 files changed, 147 insertions, 7 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 18842188..6cb5c60a 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1,6 +1,7 @@
function cons(v, ls) {
return { n : ls, v : v };
}
+
function callAll(ls) {
for (; ls; ls = ls.n)
ls.v();
@@ -192,7 +193,6 @@ function rc(uri, parse, k) {
requestUri(xhr, uri);
}
-
function path_join(s1, s2) {
if (s1.length > 0 && s1[s1.length-1] == '/')
return s1 + s2;
@@ -200,6 +200,37 @@ function path_join(s1, s2) {
return s1 + "/" + s2;
}
+var channels = [];
+
+function newQueue() {
+ return { front : null, back : null };
+}
+function enqueue(q, v) {
+ if (q.front == null) {
+ q.front = cons(v, null);
+ q.back = q.front;
+ } else {
+ var node = cons(v, null);
+ q.back.n = node;
+ q.back = node;
+ }
+}
+function dequeue(q) {
+ if (q.front == null)
+ return null;
+ else {
+ var r = q.front.v;
+ q.front = q.front.n;
+ if (q.front == null)
+ q.back = null;
+ return r;
+ }
+}
+
+function newChannel() {
+ return { msgs : newQueue(), listeners : newQueue() };
+}
+
function listener() {
var uri = path_join(url_prefix, ".msgs");
var xhr = getXHR();
@@ -218,7 +249,26 @@ function listener() {
whine("Empty message from remote server");
for (var i = 0; i+1 < lines.length; i += 2) {
- alert("Message(" + lines[i] + "): " + lines[i+1]);
+ var chn = lines[i];
+ var msg = lines[i+1];
+
+ if (chn < 0)
+ whine("Out-of-bounds channel in message from remote server");
+
+ var ch;
+
+ if (chn >= channels.length || channels[chn] == null) {
+ ch = newChannel();
+ channels[chn] = ch;
+ } else
+ ch = channels[chn];
+
+ var listener = dequeue(ch.listeners);
+ if (listener == null) {
+ enqueue(ch.msgs, msg);
+ } else {
+ listener(msg);
+ }
}
xhr.onreadystatechange = orsc;
@@ -233,3 +283,27 @@ function listener() {
xhr.onreadystatechange = orsc;
requestUri(xhr, uri);
}
+
+function rv(chn, parse, k) {
+ if (chn < 0)
+ whine("Out-of-bounds channel receive");
+
+ var ch;
+
+ if (chn >= channels.length || channels[chn] == null) {
+ ch = newChannel();
+ channels[chn] = ch;
+ } else
+ ch = channels[chn];
+
+ var msg = dequeue(ch.msgs);
+ if (msg == null) {
+ enqueue(ch.listeners, function(msg) { k(parse(msg))(null); });
+ } else {
+ k(parse(msg))(null);
+ }
+}
+
+function unesc(s) {
+ return unescape(s).replace("+", " ");
+}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index e7172db1..8c28dacb 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -460,3 +460,4 @@ con channel :: Type -> Type
val channel : t ::: Type -> transaction (channel t)
val subscribe : t ::: Type -> channel t -> transaction unit
val send : t ::: Type -> channel t -> t -> transaction unit
+val recv : t ::: Type -> channel t -> transaction t
diff --git a/src/cjrize.sml b/src/cjrize.sml
index e637c82c..27287d6e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -430,6 +430,7 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
| L.EServerCall _ => raise Fail "Cjrize EServerCall"
+ | L.ERecv _ => raise Fail "Cjrize ERecv"
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index be227035..36d42754 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -49,7 +49,8 @@ val funcs = [(("Basis", "alert"), "alert"),
(("Basis", "urlifyInt"), "ts"),
(("Basis", "urlifyFloat"), "ts"),
(("Basis", "urlifyString"), "escape"),
- (("Basis", "urlifyChannel"), "ts")]
+ (("Basis", "urlifyChannel"), "ts"),
+ (("Basis", "recv"), "rv")]
structure FM = BinaryMapFn(struct
type ord_key = string * string
@@ -106,6 +107,7 @@ fun varDepth (e, _) =
| ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
| ESignalSource e => varDepth e
| EServerCall (e, ek, _) => Int.max (varDepth e, varDepth ek)
+ | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
fun closedUpto d =
let
@@ -147,6 +149,7 @@ fun closedUpto d =
| ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
| ESignalSource e => cu inner e
| EServerCall (e, ek, _) => cu inner e andalso cu inner ek
+ | ERecv (e, ek, _) => cu inner e andalso cu inner ek
in
cu 0
end
@@ -342,7 +345,7 @@ fun process file =
@ ["}"]), st)
end
- | TFfi ("Basis", "string") => ("unescape(t[i++])", st)
+ | TFfi ("Basis", "string") => ("unesc(t[i++])", st)
| TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
| TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
@@ -952,6 +955,21 @@ fun process file =
str ")"],
st)
end
+
+ | ERecv (e, ek, t) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ val (ek, st) = jsE inner (ek, st)
+ val (unurl, st) = unurlifyExp loc (t, st)
+ in
+ (strcat [str "rv(",
+ e,
+ str (", function(s){var t=s.split(\"/\");var i=0;return "
+ ^ unurl ^ "},"),
+ ek,
+ str ")"],
+ st)
+ end
end
in
jsE
diff --git a/src/mono.sml b/src/mono.sml
index b0be4c5f..3aa65b6a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -110,6 +110,7 @@ datatype exp' =
| ESignalSource of exp
| EServerCall of exp * exp * typ
+ | ERecv of exp * exp * typ
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a61b5847..cbe90371 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -313,6 +313,11 @@ fun p_exp' par env (e, _) =
string ")[",
p_exp env e,
string "]"]
+ | ERecv (n, e, _) => box [string "Recv(",
+ p_exp env n,
+ string ")[",
+ p_exp env e,
+ string "]"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index b789e05f..b2f0ecee 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -85,6 +85,7 @@ fun impure (e, _) =
| ESignalBind (e1, e2) => impure e1 orelse impure e2
| ESignalSource e => impure e
| EServerCall _ => true
+ | ERecv _ => true
val liftExpInExp = Monoize.liftExpInExp
@@ -355,6 +356,7 @@ fun reduce file =
| ESignalSource e => summarize d e
| EServerCall (e, ek, _) => summarize d e @ summarize d ek @ [Unsure]
+ | ERecv (e, ek, _) => summarize d e @ summarize d ek @ [Unsure]
in
(*Print.prefaces "Summarize"
[("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
diff --git a/src/mono_util.sml b/src/mono_util.sml
index dd5107c6..bbc9c7e7 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -358,6 +358,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EServerCall (s', ek', t'), loc))))
+ | ERecv (s, ek, t) =>
+ S.bind2 (mfe ctx s,
+ fn s' =>
+ S.bind2 (mfe ctx ek,
+ fn ek' =>
+ S.map2 (mft t,
+ fn t' =>
+ (ERecv (s', ek', t'), loc))))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index d6b5ae15..87530070 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -979,6 +979,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc)), loc)), loc)), loc)), loc),
fm)
end
+ | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
+ (L.EFfi ("Basis", "transaction_monad"), _)), _),
+ (L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _),
+ ch), loc)) =>
+ let
+ val t1 = monoType env t1
+ val t2 = monoType env t2
+ val un = (L'.TRecord [], loc)
+ val mt2 = (L'.TFun (un, t2), loc)
+ val (ch, fm) = monoExp (env, st, fm) ch
+ in
+ ((L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
+ (L'.EAbs ("_", un, un,
+ (L'.ERecv (liftExpInExp 0 (liftExpInExp 0 ch),
+ (L'.ERel 1, loc),
+ t1), loc)), loc)), loc),
+ fm)
+ end
| L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
let
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 1212b81e..a4bfe71a 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -59,7 +59,8 @@ val csBasis = SS.addList (SS.empty,
["source",
"get",
"set",
- "alert"])
+ "alert",
+ "recv"])
type state = {
cpsed : int IM.map,
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 2bc185f9..0b51747f 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -41,10 +41,12 @@ val csBasis = SS.addList (SS.empty,
"set_client_source",
"new_channel",
"subscribe",
+ "send",
"recv"])
val scriptWords = ["<script",
- " onclick="]
+ " onclick=",
+ " onload="]
fun classify (ds, ps) =
let
diff --git a/tests/channel.ur b/tests/channel.ur
index 6b98f5d7..df50ea27 100644
--- a/tests/channel.ur
+++ b/tests/channel.ur
@@ -1,10 +1,19 @@
fun main () : transaction page =
ch <- channel;
let
- fun onload () =
+ fun make () =
subscribe ch;
send ch "Hello world!"
+ fun echo () =
+ msg <- recv ch;
+ alert(msg);
+ echo ()
+
+ fun onload () =
+ make ();
+ echo ()
+
fun haveAnother () =
send ch "Here's another."
in
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 05:14:07 +0000