Avoid thread death via message receive

2 files changed, 35 insertions, 8 deletions

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 5cf159ad..534769a5 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -75,6 +75,14 @@ function flatten(cls, tr) {
     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 onError(f) {
 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 requestUri(xhr, uri) {
 }
 
 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 @@ function listener() {
           if (listener == null) {
             enqueue(ch.msgs, msg);
           } else {
-            listener(msg);
+            try {
+              listener(msg);
+            } catch (v) {
+              doExn(v);
+            }
           }
         }
 
@@ -451,7 +473,11 @@ function rv(chn, parse, k) {
   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);
+    }
   }
 }
 
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 173324f0..af1cf972 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -553,6 +553,7 @@ val td : other ::: {Unit} -> [other ~ [Body, Tr]] =>
 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)