Some client-side error handling

8 files changed, 177 insertions, 71 deletions

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 534769a5..877ed77f 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -23,6 +23,79 @@ function length(ls) {
 }
 
 
+// Error handling
+
+function whine(msg) {
+  alert(msg);
+  throw msg;
+}
+
+function pf() {
+  whine("Pattern match failure");
+}
+
+function runHandlers(ls, arg) {
+  for (; ls; ls = ls.next)
+    try {
+      ls.data(arg)(null);
+    } catch (v) { }
+}
+
+var errorHandlers = null;
+
+function onError(f) {
+  errorHandlers = cons(f, errorHandlers);
+}
+
+function er(s) {
+  runHandlers(errorHandlers, 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());
+    runHandlers(failHandlers, s);
+  }
+}
+
+var disconnectHandlers = null;
+
+function onDisconnect(f) {
+  disconnectHandlers = cons(function (_){return f}, disconnectHandlers);
+}
+
+function discon() {
+  runHandlers(disconnectHandlers, null);
+}
+
+var connectHandlers = null;
+
+function onConnectFail(f) {
+  connectHandlers = cons(function (_){return f}, connectHandlers);
+}
+
+function conn() {
+  runHandlers(connectHandlers, null);
+}
+
+var serverHandlers = null;
+
+function onServerError(f) {
+  serverHandlers = cons(f, serverHandlers);
+}
+
+function servErr(s) {
+  runHandlers(serverHandlers, s);
+}
+
+
 // Embedding closures in XML strings
 
 function cs(f) {
@@ -90,19 +163,23 @@ function flattenLocal(s) {
 function populate(node) {
   var s = node.signal;
   var oldSources = node.sources;
-  var sr = s();
-  var newSources = sr.sources;
+  try {
+    var sr = s();
+    var newSources = sr.sources;
 
-  for (var sp = oldSources; sp; sp = sp.next)
-    if (!member(sp.data, newSources))
-      sp.data.dyns = remove(node, sp.data.dyns);
+    for (var sp = oldSources; sp; sp = sp.next)
+      if (!member(sp.data, newSources))
+        sp.data.dyns = remove(node, sp.data.dyns);
 
-  for (var sp = newSources; sp; sp = sp.next)
-    if (!member(sp.data, oldSources))
-      sp.data.dyns = cons(node, sp.data.dyns);
+    for (var sp = newSources; sp; sp = sp.next)
+      if (!member(sp.data, oldSources))
+        sp.data.dyns = cons(node, sp.data.dyns);
 
-  node.sources = newSources;
-  node.recreate(sr.data);
+    node.sources = newSources;
+    node.recreate(sr.data);
+  } catch (v) {
+    doExn(v);
+  }
 }
 
 function sc(v) {
@@ -160,7 +237,11 @@ function runScripts(node) {
     scriptsCopy[i] = scripts[i];
   for (var i = 0; i < len; ++i) {
     thisScript = scriptsCopy[i];
-    eval(thisScript.textContent);
+    try {
+      eval(thisScript.textContent);
+    } catch (v) {
+      doExn(v);
+    }
   }
 
   thisScript = savedScript;
@@ -227,7 +308,7 @@ function pi(s) {
   if (r.toString() == s)
     return r;
   else
-    throw "Can't parse int: " + s;
+    er("Can't parse int: " + s);
 }
 
 function pfl(s) {
@@ -235,7 +316,7 @@ function pfl(s) {
   if (r.toString() == s)
     return r;
   else
-    throw "Can't parse float: " + s;
+    er("Can't parse float: " + s);
 }
 
 function uf(s) {
@@ -247,43 +328,6 @@ function uu(s) {
 }
 
 
-// Error handling
-
-function whine(msg) {
-  alert(msg);
-  throw msg;
-}
-
-function pf() {
-  whine("Pattern match failure");
-}
-
-var errorHandlers = null;
-
-function onError(f) {
-  errorHandlers = cons(f, errorHandlers);
-}
-
-function er(s) {
-  for (var ls = errorHandlers; ls; ls = ls.next)
-    ls.data(s)(null);
-  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);
-  }
-}
-
 
 // Remote calls
 
@@ -333,10 +377,14 @@ function rc(uri, parse, k) {
           isok = true;
       } catch (e) { }
 
-      if (isok)
-        k(parse(xhr.responseText));
-      else {
-        whine("Error querying remote server!");
+      if (isok) {
+        try {
+          k(parse(xhr.responseText));
+        } catch (v) {
+          doExn(v);
+        }
+      } else {
+        conn();
       }
     }
   };
@@ -406,8 +454,10 @@ function listener() {
 
       if (isok) {
         var lines = xhr.responseText.split("\n");
-        if (lines.length < 2) 
-          return; // throw "Empty message from remote server";
+        if (lines.length < 2) {
+          discon();
+          return;
+        }
 
         for (var i = 0; i+1 < lines.length; i += 2) {
           var chn = lines[i];
@@ -439,9 +489,9 @@ function listener() {
         connect();
       }
       else {
-        /*try {
-          whine("Error querying remote server for messages! " + xhr.status);
-        } catch (e) { }*/
+        try {
+          servError("Error querying remote server for messages: " + xhr.status);
+        } catch (e) { servError("Error querying remote server for messages"); }
       }
     }
   };
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index af1cf972..99ac50fe 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -552,8 +552,11 @@ val td : other ::: {Unit} -> [other ~ [Body, Tr]] =>
 
 val error : t ::: Type -> xbody -> t
 
+(* Client-side-only handlers: *)
 val onError : (xbody -> transaction unit) -> transaction unit
 val onFail : (string -> transaction unit) -> transaction unit
-(* Client-side only *)
+val onConnectFail : transaction unit -> transaction unit
+val onDisconnect : transaction unit -> transaction unit
+val onServerError : (string -> transaction unit) -> transaction unit
 
 val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind)
diff --git a/src/jscomp.sml b/src/jscomp.sml
index d7a74fab..f839a67d 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -53,7 +53,11 @@ val funcs = [(("Basis", "alert"), "alert"),
              (("Basis", "strcat"), "cat"),
              (("Basis", "intToString"), "ts"),
              (("Basis", "floatToString"), "ts"),
-             (("Basis", "onError"), "onError")]
+             (("Basis", "onError"), "onError"),
+             (("Basis", "onFail"), "onFail"),
+             (("Basis", "onConnectFail"), "onConnectFail"),
+             (("Basis", "onDisconnect"), "onDisconnect"),
+             (("Basis", "onServerError"), "onServerError")]
 
 structure FM = BinaryMapFn(struct
                            type ord_key = string * string
@@ -764,6 +768,11 @@ fun process file =
                             end
                           | EBinop (s, e1, e2) =>
                             let
+                                val s =
+                                    case s of
+                                        "!strcmp" => "=="
+                                      | _ => s
+
                                 val (e1, st) = jsE inner (e1, st)
                                 val (e2, st) = jsE inner (e2, st)
                             in
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 19140b81..4c337e14 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -62,6 +62,10 @@ fun impure (e, _) =
       | EFfiApp ("Basis", "subscribe", _) => true
       | EFfiApp ("Basis", "send", _) => true
       | EFfiApp ("Basis", "onError", _) => true
+      | EFfiApp ("Basis", "onFail", _) => true
+      | EFfiApp ("Basis", "onConnectFail", _) => true
+      | EFfiApp ("Basis", "onDisconnect", _) => true
+      | EFfiApp ("Basis", "onServerError", _) => true
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
       | EApp _ => true
@@ -287,6 +291,10 @@ fun reduce file =
                       | EFfiApp ("Basis", "subscribe", es) => ffi es
                       | EFfiApp ("Basis", "send", es) => ffi es
                       | EFfiApp ("Basis", "onError", es) => ffi es
+                      | EFfiApp ("Basis", "onFail", es) => ffi es
+                      | EFfiApp ("Basis", "onConnectFail", es) => ffi es
+                      | EFfiApp ("Basis", "onDisconnect", es) => ffi es
+                      | EFfiApp ("Basis", "onServerError", es) => ffi es
                       | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
                       | EApp ((EFfi _, _), e) => summarize d e
                       | EApp _ =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 238f65d3..c7309df4 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -325,15 +325,19 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                                 fn t' =>
                                    (EUnurlify (e', t'), loc)))
               | EJavaScript (m, e, NONE) =>
-                S.map2 (mfe ctx e,
-                     fn e' =>
-                        (EJavaScript (m, e', NONE), loc))
+                S.bind2 (mfmode ctx m,
+                         fn m' =>
+                            S.map2 (mfe ctx e,
+                                 fn e' =>
+                                    (EJavaScript (m', e', NONE), loc)))
               | EJavaScript (m, e, SOME e2) =>
-                S.bind2 (mfe ctx e,
-                     fn e' =>
-                        S.map2 (mfe ctx e2,
-                             fn e2' =>
-                                (EJavaScript (m, e', SOME e2'), loc)))
+                S.bind2 (mfmode ctx m,
+                         fn m' =>
+                            S.bind2 (mfe ctx e,
+                                  fn e' =>
+                                     S.map2 (mfe ctx e2,
+                                          fn e2' =>
+                                             (EJavaScript (m, e', SOME e2'), loc))))
 
               | ESignalReturn e =>
                 S.map2 (mfe ctx e,
@@ -372,6 +376,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                          S.map2 (mfe ctx ek,
                                fn ek' =>
                                   (ESleep (s', ek'), loc)))
+
+        and mfmode ctx mode =
+            case mode of
+                Attribute => S.return2 mode
+              | Script => S.return2 mode
+              | Source t =>
+                S.map2 (mft t,
+                     fn t' => Source t')
     in
         mfe
     end
diff --git a/tests/roundTrip.ur b/tests/roundTrip.ur
index 26a0113e..d22b2d41 100644
--- a/tests/roundTrip.ur
+++ b/tests/roundTrip.ur
@@ -26,11 +26,14 @@ fun main () =
             receiverB ()
 
         fun sender s n f =
-            sleep 9;
+            sleep 2000;
             writeBack (s, n, f);
             sender (s ^ "!") (n + 1) (f + 1.23)
     in
-        return <xml><body onload={spawn (receiverA ()); spawn (receiverB ()); sender "" 0 0.0}>
+        return <xml><body onload={onDisconnect (alert "Server booted me");
+                                  onConnectFail (alert "Connection failed");
+                                  onServerError (fn s => alert ("Server error: " ^ s));
+                                  spawn (receiverA ()); spawn (receiverB ()); sender "" 0 0.0}>
           <dyn signal={Buffer.render buf}/>
         </body></xml>
     end
diff --git a/tests/updateErr.ur b/tests/updateErr.ur
new file mode 100644
index 00000000..345e3aa8
--- /dev/null
+++ b/tests/updateErr.ur
@@ -0,0 +1,17 @@
+fun main () : transaction page =
+    s <- source "";
+    b <- Buffer.create;
+    txt <- source "";
+
+    return <xml><body onload={onError (fn xml => Buffer.write b (show xml));
+                              onFail (fn s => alert ("FAIL! " ^ s))}>
+      <dyn signal={s <- signal s; return <xml>{[s]}</xml>}/><br/>
+      <dyn signal={s <- signal s; if s = "" then return <xml>Init</xml> else error <xml>Crapky</xml>}/><br/>
+      <dyn signal={s <- signal s; return <xml>"{[s]}"</xml>}/><br/>
+
+      <ctextbox source={txt}/> <button onclick={s' <- get txt; set s s'; set txt ""}/>
+
+      <hr/>
+
+      <dyn signal={Buffer.render b}/>
+    </body></xml>
diff --git a/tests/updateErr.urp b/tests/updateErr.urp
new file mode 100644
index 00000000..80d8200b
--- /dev/null
+++ b/tests/updateErr.urp
@@ -0,0 +1,4 @@
+debug
+
+buffer
+updateErr