summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h4
-rw-r--r--lib/js/urweb.js21
-rw-r--r--src/c/urweb.c62
-rw-r--r--src/jscomp.sml9
-rw-r--r--src/monoize.sml13
-rw-r--r--src/rpcify.sml28
-rw-r--r--tests/chat.ur61
7 files changed, 151 insertions, 47 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 22fe12ac..02a4da5b 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -47,8 +47,8 @@ uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string);
uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string);
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);
-const char *uw_Basis_get_listener(uw_context, uw_Basis_string);
char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float);
@@ -77,11 +77,13 @@ char *uw_Basis_urlifyFloat(uw_context, uw_Basis_float);
char *uw_Basis_urlifyString(uw_context, uw_Basis_string);
char *uw_Basis_urlifyBool(uw_context, uw_Basis_bool);
char *uw_Basis_urlifyTime(uw_context, uw_Basis_time);
+char *uw_Basis_urlifyChannel(uw_context, uw_Basis_channel);
uw_unit uw_Basis_urlifyInt_w(uw_context, uw_Basis_int);
uw_unit uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float);
uw_unit uw_Basis_urlifyString_w(uw_context, uw_Basis_string);
uw_unit uw_Basis_urlifyBool_w(uw_context, uw_Basis_bool);
+uw_unit uw_Basis_urlifyChannel_w(uw_context, uw_Basis_channel);
uw_Basis_int uw_Basis_unurlifyInt(uw_context, char **);
uw_Basis_float uw_Basis_unurlifyFloat(uw_context, char **);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 6d405347..39f9f7cf 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -257,7 +257,7 @@ function listener() {
if (isok) {
var lines = xhr.responseText.split("\n");
if (lines.length < 2)
- throw "Empty message from remote server";
+ return; //throw "Empty message from remote server";
for (var i = 0; i+1 < lines.length; i += 2) {
var chn = lines[i];
@@ -285,9 +285,9 @@ function listener() {
connect();
}
else {
- try {
+ /*try {
whine("Error querying remote server for messages! " + xhr.status);
- } catch (e) { }
+ } catch (e) { }*/
}
}
};
@@ -300,10 +300,17 @@ function listener() {
connect();
}
+var listener_started = false;
+
function rv(chn, parse, k) {
if (chn < 0)
whine("Out-of-bounds channel receive");
+ if (!listener_started) {
+ listener_started = true;
+ listener();
+ }
+
var ch;
if (chn >= channels.length || channels[chn] == null) {
@@ -320,6 +327,10 @@ function rv(chn, parse, k) {
}
}
-function unesc(s) {
- return unescape(s).replace("+", " ");
+function uf(s) {
+ return escape(s).replace(new RegExp ("/", "g"), "%2F");
+}
+
+function uu(s) {
+ return unescape(s).replace(new RegExp ("\\+", "g"), " ");
}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 75f7675f..c8fe39ca 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -229,6 +229,7 @@ void uw_client_connect(size_t id, int pass, int sock) {
if (buf_used(&c->data.used.msgs) > 0) {
uw_really_send(sock, begin_msgs, sizeof(begin_msgs) - 1);
uw_really_send(sock, c->data.used.msgs.start, buf_used(&c->data.used.msgs));
+ buf_reset(&c->data.used.msgs);
close(sock);
}
else
@@ -382,10 +383,17 @@ static void uw_release_channel(channel *ch) {
}
static void uw_subscribe(channel *ch, client *c) {
- client_list *cs = malloc(sizeof(client_list));
+ client_list *cs;
pthread_mutex_lock(&ch->data.used.lock);
+ for (cs = ch->data.used.clients; cs; cs = cs->next)
+ if (cs->data == c) {
+ pthread_mutex_unlock(&ch->data.used.lock);
+ return;
+ }
+
+ cs = malloc(sizeof(client_list));
cs->data = c;
cs->next = ch->data.used.clients;
ch->data.used.clients = cs;
@@ -838,29 +846,29 @@ const char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
int pass;
client *c = uw_new_client(&pass);
- char *r = uw_malloc(ctx, strlen(ctx->script_header) + 65 + 3 * INTS_MAX + buf_used(&ctx->script)
- + strlen(ctx->url_prefix));
- sprintf(r, "%s<script>client_id=%d;client_pass=%d;url_prefix=\"%s\";timeout=%d;%s</script>",
+ char *r = uw_malloc(ctx, strlen(ctx->script_header) + 18 + buf_used(&ctx->script));
+ sprintf(r, "%s<script>%s</script>",
ctx->script_header,
- (int)c->id,
- c->data.used.pass,
- ctx->url_prefix,
- ctx->timeout,
ctx->script.start);
return r;
}
}
-const char *uw_Basis_get_listener(uw_context ctx, uw_Basis_string onload) {
+const char *uw_Basis_get_settings(uw_context ctx, uw_Basis_string onload) {
if (ctx->script_header[0] == 0)
return "";
- else if (onload[0] == 0)
- return " onload='listener()'";
else {
- uw_Basis_string s = uw_malloc(ctx, strlen(onload) + 22);
+ int pass;
+ client *c = uw_new_client(&pass);
- sprintf(s, " onload='listener();%s'", onload);
- return s;
+ char *r = uw_malloc(ctx, 41 + 3 * INTS_MAX + strlen(ctx->url_prefix) + strlen(onload));
+ sprintf(r, " onload='client_id=%d;client_pass=%d;url_prefix=\"%s\";timeout=%d;%s'",
+ (int)c->id,
+ c->data.used.pass,
+ ctx->url_prefix,
+ ctx->timeout,
+ onload);
+ return r;
}
}
@@ -1108,6 +1116,17 @@ char *uw_Basis_urlifyInt(uw_context ctx, uw_Basis_int n) {
return r;
}
+char *uw_Basis_urlifyChannel(uw_context ctx, uw_Basis_channel n) {
+ int len;
+ char *r;
+
+ uw_check_heap(ctx, INTS_MAX);
+ r = ctx->heap.front;
+ sprintf(r, "%lld%n", (long long)n, &len);
+ ctx->heap.front += len+1;
+ return r;
+}
+
char *uw_Basis_urlifyFloat(uw_context ctx, uw_Basis_float n) {
int len;
char *r;
@@ -1163,6 +1182,16 @@ uw_unit uw_Basis_urlifyInt_w(uw_context ctx, uw_Basis_int n) {
return uw_unit_v;
}
+uw_unit uw_Basis_urlifyChannel_w(uw_context ctx, uw_Basis_channel n) {
+ int len;
+
+ uw_check(ctx, INTS_MAX);
+ sprintf(ctx->page.front, "%lld%n", (long long)n, &len);
+ ctx->page.front += len;
+
+ return uw_unit_v;
+}
+
uw_unit uw_Basis_urlifyFloat_w(uw_context ctx, uw_Basis_float n) {
int len;
@@ -1916,6 +1945,9 @@ static channel_delta *allocate_delta(uw_context ctx, channel *ch) {
++ctx->n_deltas;
ctx->deltas = realloc(ctx->deltas, sizeof(channel_delta) * ctx->n_deltas);
cd = &ctx->deltas[ctx->n_deltas-1];
+ cd->n_subscribed = 0;
+ cd->subscribed = malloc(0);
+ buf_init(&cd->msgs, 0);
}
cd->mode = USED;
@@ -1958,7 +1990,7 @@ uw_unit uw_Basis_subscribe(uw_context ctx, uw_Basis_channel chn) {
} else if (c->data.used.pass != pass) {
uw_release_channel(ch);
uw_release_client(c);
- uw_error(ctx, FATAL, "Wrong client password in subscription request");
+ uw_error(ctx, FATAL, "Wrong client password (%d) in subscription request", pass);
} else {
size_t i;
channel_delta *cd = allocate_delta(ctx, ch);
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 36d42754..f5627e24 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -48,7 +48,7 @@ val funcs = [(("Basis", "alert"), "alert"),
(("Basis", "stringToInt_error"), "pi"),
(("Basis", "urlifyInt"), "ts"),
(("Basis", "urlifyFloat"), "ts"),
- (("Basis", "urlifyString"), "escape"),
+ (("Basis", "urlifyString"), "uf"),
(("Basis", "urlifyChannel"), "ts"),
(("Basis", "recv"), "rv")]
@@ -345,9 +345,10 @@ fun process file =
@ ["}"]), st)
end
- | TFfi ("Basis", "string") => ("unesc(t[i++])", st)
+ | TFfi ("Basis", "string") => ("uu(t[i++])", st)
| TFfi ("Basis", "int") => ("parseInt(t[i++])", st)
| TFfi ("Basis", "float") => ("parseFloat(t[i++])", st)
+ | TFfi ("Basis", "channel") => ("parseInt(t[i++])", st)
| TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st)
@@ -806,14 +807,14 @@ fun process file =
end
| ECase (e', pes, {result, ...}) =>
- if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
+ (*if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
let
val (e', st) = quoteExp result ((ERel 0, loc), st)
in
((ELet ("js", result, e, e'), loc),
st)
end
- else
+ else*)
let
val plen = length pes
diff --git a/src/monoize.sml b/src/monoize.sml
index eb3f81b3..03ce6311 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1871,7 +1871,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
[] => (NONE, acc)
| ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest))
| x :: rest => findOnload (rest, x :: acc)
-
+
val (onload, attrs) = findOnload (attrs, [])
fun lowercaseFirst "" = ""
@@ -1972,8 +1972,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val (xml, fm) = monoExp (env, st, fm) xml
val xml = case extraInner of
- NONE => xml
- | SOME ei => (L'.EStrcat (ei, xml), loc)
+ NONE => xml
+ | SOME ei => (L'.EStrcat (ei, xml), loc)
in
((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
(L'.EStrcat (xml,
@@ -2017,8 +2017,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
in
case tag of
- "body" =>
- let
+ "body" => let
val onload = case onload of
NONE => (L'.EPrim (Prim.String ""), loc)
| SOME e =>
@@ -2026,10 +2025,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
in
(L'.EJavaScript (L'.Attribute, e, NONE), loc)
- end
+ end
in
normal ("body",
- SOME (L'.EFfiApp ("Basis", "get_listener", [onload]), loc),
+ SOME (L'.EFfiApp ("Basis", "get_settings", [onload]), loc),
SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
end
diff --git a/src/rpcify.sml b/src/rpcify.sml
index a4bfe71a..dc8ecc52 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -51,13 +51,12 @@ val ssBasis = SS.addList (SS.empty,
"query",
"dml",
"nextval",
- "new_channel",
+ "channel",
"subscribe",
"send"])
val csBasis = SS.addList (SS.empty,
- ["source",
- "get",
+ ["get",
"set",
"alert",
"recv"])
@@ -76,15 +75,16 @@ type state = {
fun frob file =
let
fun sideish (basis, ssids) e =
- case #1 e of
- ERecord _ => false
- | _ =>
- U.Exp.exists {kind = fn _ => false,
- con = fn _ => false,
- exp = fn ENamed n => IS.member (ssids, n)
- | EFfi ("Basis", x) => SS.member (basis, x)
- | EFfiApp ("Basis", x, _) => SS.member (basis, x)
- | _ => false} e
+ U.Exp.exists {kind = fn _ => false,
+ con = fn _ => false,
+ exp = fn ENamed n => IS.member (ssids, n)
+ | EFfi ("Basis", x) => SS.member (basis, x)
+ | EFfiApp ("Basis", x, _) => SS.member (basis, x)
+ | _ => false}
+ (U.Exp.map {kind = fn x => x,
+ con = fn x => x,
+ exp = fn ERecord _ => ERecord []
+ | x => x} e)
fun whichIds basis =
let
@@ -156,7 +156,7 @@ fun frob file =
ENamed n => (n, args)
| EApp (e1, e2) => getApp (e1, e2 :: args)
| _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
- Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];
+ (*Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
(0, []))
end
@@ -184,7 +184,7 @@ fun frob file =
val ran =
case IM.find (tfuncs, n) of
- NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];
+ NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
| SOME (_, _, ran, _) => ran
diff --git a/tests/chat.ur b/tests/chat.ur
index 710d97d4..2d79cd00 100644
--- a/tests/chat.ur
+++ b/tests/chat.ur
@@ -1,10 +1,69 @@
+datatype log = End | Line of string * source log
+
+fun render log =
+ case log of
+ End => <xml/>
+ | Line (line, logS) => <xml>{[line]}<br/><dyn signal={renderS logS}/></xml>
+
+and renderS logS =
+ log <- signal logS;
+ return (render log)
+
sequence s
table t : { Id : int, Title : string, Chan : option (channel string) }
+fun chat id =
+ r <- oneRow (SELECT t.Title, t.Chan FROM t WHERE t.Id = {[id]});
+ ch <- (case r.T.Chan of
+ None => (ch <- channel;
+ dml (UPDATE t SET Chan = {[Some ch]} WHERE Id = {[id]});
+ return ch)
+ | Some ch => return ch);
+
+ newLine <- source "";
+ logHead <- source End;
+ logTail <- source logHead;
+
+ let
+ fun join () = subscribe ch
+
+ fun onload () =
+ let
+ fun listener () =
+ s <- recv ch;
+ oldTail <- get logTail;
+ newTail <- source End;
+ set oldTail (Line (s, newTail));
+ set logTail newTail;
+ listener ()
+ in
+ join ();
+ listener ()
+ end
+
+ fun speak line =
+ send ch line
+
+ fun doSpeak () =
+ line <- get newLine;
+ speak line
+ in
+ return <xml><body onload={onload ()}>
+ <h1>{[r.T.Title]}</h1>
+
+ <button value="Send:" onclick={doSpeak ()}/> <ctextbox source={newLine}/>
+
+ <h2>Messages</h2>
+
+ <dyn signal={renderS logHead}/>
+
+ </body></xml>
+ end
+
fun list () =
queryX (SELECT * FROM t)
(fn r => <xml><tr>
- <td>{[r.T.Id]}</td> <td>{[r.T.Title]}</td>
+ <td>{[r.T.Id]}</td> <td><a link={chat r.T.Id}>{[r.T.Title]}</a></td>
<td><a link={delete r.T.Id}>[delete]</a></td>
</tr></xml>)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-04 23:37:53 +0000