summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-11-24 09:24:25 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-11-24 09:24:25 -0500
commit7463b805e4510b4f187851e91c53bb28db3ba044 (patch)
treec7e296a3f9f17fcb036db1231ba57d295924ddb0
parentcf3fc72603a3ad499f2c3177beee709b3a5c53f8 (diff)
Explicitly abort in-flight RPCs onunload
-rw-r--r--include/urweb.h1
-rw-r--r--lib/js/urweb.js25
-rw-r--r--src/c/urweb.c10
-rw-r--r--src/monoize.sml48
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