Mercurial > urweb
changeset 728:2197f0e24a9f
Avoid thread death via message receive
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 16 Apr 2009 13:00:40 -0400 |
| parents | ba4c230b7231 |
| children | 7c6b6c3c7b79 |
| files | lib/js/urweb.js lib/ur/basis.urs tests/buffer.ur tests/buffer.urs tests/roundTrip.ur tests/roundTrip.urp tests/roundTrip.urs tests/threads.ur tests/threads.urp tests/threads.urs |
| diffstat | 10 files changed, 129 insertions(+), 8 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Thu Apr 16 12:43:55 2009 -0400 +++ b/lib/js/urweb.js Thu Apr 16 13:00:40 2009 -0400 @@ -75,6 +75,14 @@ return tr; } +function flattenLocal(s) { + var cls = {v : null}; + var r = flatten(cls, s); + for (cl = cls.v; cl != null; cl = cl.next) + freeClosure(cl.data); + return r; +} + // Dynamic tree management @@ -259,7 +267,21 @@ function er(s) { for (var ls = errorHandlers; ls; ls = ls.next) ls.data(s)(null); - throw s; + throw {uw_error: s}; +} + +var failHandlers = null; + +function onFail(f) { + failHandlers = cons(f, failHandlers); +} + +function doExn(v) { + if (v == null || v.uw_error == null) { + var s = (v == null ? "null" : v.toString()); + for (var ls = failHandlers; ls; ls = ls.next) + ls.data(s)(null); + } } @@ -299,11 +321,7 @@ } function rc(uri, parse, k) { - var cls = {v : null}; - uri = flatten(cls, uri); - for (cl = cls.v; cl != null; cl = cl.next) - freeClosure(cl.data); - + uri = flattenLocal(uri); var xhr = getXHR(); xhr.onreadystatechange = function() { @@ -410,7 +428,11 @@ if (listener == null) { enqueue(ch.msgs, msg); } else { - listener(msg); + try { + listener(msg); + } catch (v) { + doExn(v); + } } } @@ -451,7 +473,11 @@ if (msg == null) { enqueue(ch.listeners, function(msg) { k(parse(msg))(null); }); } else { - k(parse(msg))(null); + try { + k(parse(msg))(null); + } catch (v) { + doExn(v); + } } }
--- a/lib/ur/basis.urs Thu Apr 16 12:43:55 2009 -0400 +++ b/lib/ur/basis.urs Thu Apr 16 13:00:40 2009 -0400 @@ -553,6 +553,7 @@ val error : t ::: Type -> xbody -> t val onError : (xbody -> transaction unit) -> transaction unit +val onFail : (string -> transaction unit) -> transaction unit (* Client-side only *) val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/buffer.ur Thu Apr 16 13:00:40 2009 -0400 @@ -0,0 +1,25 @@ +datatype lines = End | Line of string * source lines + +type t = { Head : source lines, Tail : source (source lines) } + +val create = + head <- source End; + tail <- source head; + return {Head = head, Tail = tail} + +fun renderL lines = + case lines of + End => <xml/> + | Line (line, linesS) => <xml>{[line]}<br/><dyn signal={renderS linesS}/></xml> + +and renderS linesS = + lines <- signal linesS; + return (renderL lines) + +fun render t = renderS t.Head + +fun write t s = + oldTail <- get t.Tail; + newTail <- source End; + set oldTail (Line (s, newTail)); + set t.Tail newTail
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/buffer.urs Thu Apr 16 13:00:40 2009 -0400 @@ -0,0 +1,5 @@ +type t + +val create : transaction t +val render : t -> signal xbody +val write : t -> string -> transaction unit
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/roundTrip.ur Thu Apr 16 13:00:40 2009 -0400 @@ -0,0 +1,36 @@ +table channels : { Client : client, Channel : channel (string * int * float) } + PRIMARY KEY Client + +fun writeBack v = + me <- self; + r <- oneRow (SELECT channels.Channel FROM channels WHERE channels.Client = {[me]}); + send r.Channels.Channel v + +fun main () = + me <- self; + ch <- channel; + dml (INSERT INTO channels (Client, Channel) VALUES ({[me]}, {[ch]})); + + buf <- Buffer.create; + + let + fun receiverA () = + v <- recv ch; + Buffer.write buf ("A:(" ^ v.1 ^ ", " ^ show v.2 ^ ", " ^ show v.3 ^ ")"); + receiverA () + + fun receiverB () = + v <- recv ch; + Buffer.write buf ("B:(" ^ v.1 ^ ", " ^ show v.2 ^ ", " ^ show v.3 ^ ")"); + error <xml>Bail out!</xml>; + receiverB () + + fun sender s n f = + sleep 9; + writeBack (s, n, f); + sender (s ^ "!") (n + 1) (f + 1.23) + in + return <xml><body onload={spawn (receiverA ()); spawn (receiverB ()); sender "" 0 0.0}> + <dyn signal={Buffer.render buf}/> + </body></xml> + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/roundTrip.urp Thu Apr 16 13:00:40 2009 -0400 @@ -0,0 +1,5 @@ +database dbname=roundtrip +sql roundTrip.sql + +buffer +roundTrip
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/roundTrip.urs Thu Apr 16 13:00:40 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/threads.ur Thu Apr 16 13:00:40 2009 -0400 @@ -0,0 +1,18 @@ +fun main () = + buf <- Buffer.create; + let + fun loop1 () = + Buffer.write buf "A"; + sleep 9; + loop1 () + + fun loop2 () = + Buffer.write buf "B"; + sleep 9; + error <xml>Darn</xml> + loop2 () + in + return <xml><body onload={spawn (loop1 ()); loop2 ()}> + <dyn signal={Buffer.render buf}/> + </body></xml> + end