Mercurial > urweb
changeset 679:44f23712020d
Chat example working nicely, but without dead channel removal
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 26 Mar 2009 18:26:50 -0400 |
| parents | 5ff1ff38e2db |
| children | 54ec237a3028 |
| files | include/urweb.h lib/js/urweb.js src/c/urweb.c src/jscomp.sml src/monoize.sml src/rpcify.sml tests/chat.ur |
| diffstat | 7 files changed, 151 insertions(+), 47 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Thu Mar 26 16:22:34 2009 -0400 +++ b/include/urweb.h Thu Mar 26 18:26:50 2009 -0400 @@ -47,8 +47,8 @@ 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_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 **);
--- a/lib/js/urweb.js Thu Mar 26 16:22:34 2009 -0400 +++ b/lib/js/urweb.js Thu Mar 26 18:26:50 2009 -0400 @@ -257,7 +257,7 @@ 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 @@ connect(); } else { - try { + /*try { whine("Error querying remote server for messages! " + xhr.status); - } catch (e) { } + } catch (e) { }*/ } } }; @@ -300,10 +300,17 @@ 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 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"), " "); +}
--- a/src/c/urweb.c Thu Mar 26 16:22:34 2009 -0400 +++ b/src/c/urweb.c Thu Mar 26 18:26:50 2009 -0400 @@ -229,6 +229,7 @@ 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_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 @@ 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 @@ 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 @@ 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 @@ ++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 @@ } 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);
--- a/src/jscomp.sml Thu Mar 26 16:22:34 2009 -0400 +++ b/src/jscomp.sml Thu Mar 26 18:26:50 2009 -0400 @@ -48,7 +48,7 @@ (("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 @@ @ ["}"]), 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 @@ 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
--- a/src/monoize.sml Thu Mar 26 16:22:34 2009 -0400 +++ b/src/monoize.sml Thu Mar 26 18:26:50 2009 -0400 @@ -1871,7 +1871,7 @@ [] => (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 @@ 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 @@ 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 @@ 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
--- a/src/rpcify.sml Thu Mar 26 16:22:34 2009 -0400 +++ b/src/rpcify.sml Thu Mar 26 18:26:50 2009 -0400 @@ -51,13 +51,12 @@ "query", "dml", "nextval", - "new_channel", + "channel", "subscribe", "send"]) val csBasis = SS.addList (SS.empty, - ["source", - "get", + ["get", "set", "alert", "recv"]) @@ -76,15 +75,16 @@ 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 @@ 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 @@ 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
--- a/tests/chat.ur Thu Mar 26 16:22:34 2009 -0400 +++ b/tests/chat.ur Thu Mar 26 18:26:50 2009 -0400 @@ -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>)