Explicitly abort in-flight RPCs onunload

4 files changed, 62 insertions, 22 deletions

diff --git a/include/urweb.h b/include/urweb.h
index 0f753b71..55068966 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -69,6 +69,7 @@ const char *uw_Basis_get_settings(uw_context, uw_unit);
 const char *uw_Basis_get_script(uw_context, uw_unit);
 
 uw_Basis_string uw_Basis_maybe_onload(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_maybe_onunload(uw_context, uw_Basis_string);
 
 void uw_set_needs_push(uw_context, int);
 void uw_set_needs_sig(uw_context, int);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index c37ff07d..98b615c0 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -627,7 +627,20 @@ function getXHR(uri)
 
 var sig = null;
 
+var unloading = false, inFlight = null;
+
+function unload() {
+  unloading = true;
+
+  for (; inFlight; inFlight = inFlight.next) {
+    inFlight.data.abort();
+  }
+}
+
 function requestUri(xhr, uri, needsSig) {
+  if (unloading)
+    return;
+
   xhr.open("POST", uri, true);
 
   if (client_id != null) {
@@ -642,9 +655,15 @@ function requestUri(xhr, uri, needsSig) {
     xhr.setRequestHeader("UrWeb-Sig", sig);
   }
 
+  inFlight = cons(xhr, inFlight);
   xhr.send(null);
 }
 
+function xhrFinished(xhr) {
+  xhr.abort();
+  inFlight = remove(xhr, inFlight);
+}
+
 function rc(prefix, uri, parse, k, needsSig) {
   uri = cat(prefix, uri);
   uri = flattenLocal(uri);
@@ -668,6 +687,8 @@ function rc(prefix, uri, parse, k, needsSig) {
       } else {
         conn();
       }
+
+      xhrFinished(xhr);
     }
   };
 
@@ -772,7 +793,7 @@ function listener() {
           }
         }
 
-        xhr.abort();
+        xhrFinished(xhr);
 
         connect();
       }
@@ -786,7 +807,7 @@ function listener() {
   };
 
   onTimeout = function() {
-    xhr.abort();
+    xhrFinished(xhr);
     connect();
   };
 
diff --git a/src/c/urweb.c b/src/c/urweb.c
index e75d0c66..344ef2ad 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1173,6 +1173,16 @@ uw_Basis_string uw_Basis_maybe_onload(uw_context ctx, uw_Basis_string s) {
   }
 }
 
+uw_Basis_string uw_Basis_maybe_onunload(uw_context ctx, uw_Basis_string s) {
+  if (ctx->script_header[0] == 0)
+    return "";
+  else {
+    char *r = uw_malloc(ctx, 22 + strlen(s));
+    sprintf(r, " onunload='unload();%s'", s);
+    return r;
+  }
+}
+
 extern uw_Basis_string uw_cookie_sig(uw_context);
 
 const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) {
diff --git a/src/monoize.sml b/src/monoize.sml
index 4e337388..7effa885 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2483,13 +2483,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                     else
                         attrs
 
-                fun findOnload (attrs, acc) =
+                fun findOnload (attrs, onload, onunload, acc) =
                     case attrs of
-                        [] => (NONE, acc)
-                      | ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest))
-                      | x :: rest => findOnload (rest, x :: acc)
+                        [] => (onload, onunload, acc)
+                      | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
+                      | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
+                      | x :: rest => findOnload (rest, onload, onunload, x :: acc)
                                      
-                val (onload, attrs) = findOnload (attrs, [])
+                val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, [])
 
                 val (class, fm) = monoExp (env, st, fm) class
 
@@ -2669,26 +2670,33 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                          :: str ";"
                                          :: assgns)
                     end
+
+                fun execify e =
+                    case e of
+                        NONE => (L'.EPrim (Prim.String ""), loc)
+                      | SOME e =>
+                        let
+                            val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
+                        in
+                            (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
+                                         (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
+                                                      (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
+                        end
             in
                 case tag of
                     "body" => let
-                        val onload = case onload of
-                                         NONE => (L'.EPrim (Prim.String ""), loc)
-                                       | SOME e =>
-                                         let
-                                             val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
-                                         in
-                                             (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
-                                                          (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
-                                                                       (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
-                                         end
+                        val onload = execify onload
+                        val onunload = execify onunload
                     in
                         normal ("body",
-                                SOME (L'.EFfiApp ("Basis", "maybe_onload",
-                                                  [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
-                                                                             [(L'.ERecord [], loc)]), loc),
-                                                                onload), loc)]),
-                                      loc),
+                                SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
+                                                               [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
+                                                                                          [(L'.ERecord [], loc)]), loc),
+                                                                             onload), loc)]),
+                                                   loc),
+                                                  (L'.EFfiApp ("Basis", "maybe_onunload",
+                                                               [onunload]),
+                                                   loc)), loc),
                                 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
                     end