From b05b60f5cdaa0da92af54640f8a2db6e18a283ba Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 4 Apr 2009 15:56:47 -0400
Subject: sleep and better Scriptcheck

---
 include/urweb.h     |  2 ++
 lib/ur/basis.urs    |  1 +
 src/c/urweb.c       | 14 ++++++++++++--
 src/cjrize.sml      |  1 +
 src/jscomp.sml      | 15 +++++++++++++++
 src/mono.sml        |  1 +
 src/mono_print.sml  |  5 +++++
 src/mono_reduce.sml |  2 ++
 src/mono_util.sml   | 18 ++++++++++++------
 src/monoize.sml     | 37 +++++++++++++++++++++++++++----------
 src/scriptcheck.sml | 21 ++++++++++++++++-----
 src/urweb.grm       |  2 +-
 tests/sleep.ur      |  7 +++++++
 tests/sleep.urp     |  3 +++
 14 files changed, 105 insertions(+), 24 deletions(-)
 create mode 100644 tests/sleep.ur
 create mode 100644 tests/sleep.urp

diff --git a/include/urweb.h b/include/urweb.h
index 4e0992fd..759fc5ac 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -52,6 +52,8 @@ void uw_set_script_header(uw_context, const char*);
 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);
+
 void uw_set_needs_push(uw_context, int);
 
 char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 19a7a9f1..0d5d3d71 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -106,6 +106,7 @@ val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit
 
 val alert : string -> transaction unit
 val spawn : transaction unit -> transaction unit
+val sleep : int -> transaction unit
 
 
 (** Channels *)
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 6f6f1fc8..476fb09b 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -693,14 +693,24 @@ const char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
   if (ctx->script_header[0] == 0)
     return "";
   else {
-    char *r = uw_malloc(ctx, strlen(ctx->script_header) + 18 + buf_used(&ctx->script));
-    sprintf(r, "%s<script>%s</script>",
+    char *r = uw_malloc(ctx, strlen(ctx->script_header) + 42 + buf_used(&ctx->script));
+    sprintf(r, "%s<script type=\"text/javascript\">%s</script>",
             ctx->script_header,
             ctx->script.start);
     return r;
   }
 }
 
+uw_Basis_string uw_Basis_maybe_onload(uw_context ctx, uw_Basis_string s) {
+  if (s[0] == 0)
+    return "";
+  else {
+    char *r = uw_malloc(ctx, 11 + strlen(s));
+    sprintf(r, " onload='%s'", s);
+    return r;
+  }
+}
+
 const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) {
   if (ctx->client == NULL)
     return "";
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 998ae38e..5e4b647a 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -431,6 +431,7 @@ fun cifyExp (eAll as (e, loc), sm) =
 
       | L.EServerCall _ => raise Fail "Cjrize EServerCall"
       | L.ERecv _ => raise Fail "Cjrize ERecv"
+      | L.ESleep _ => raise Fail "Cjrize ESleep"
 
 fun cifyDecl ((d, loc), sm) =
     case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index c7577d0c..9cefc60f 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -110,6 +110,7 @@ fun varDepth (e, _) =
       | ESignalSource e => varDepth e
       | EServerCall (e, ek, _) => Int.max (varDepth e, varDepth ek)
       | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
+      | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
 
 fun closedUpto d =
     let
@@ -152,6 +153,7 @@ fun closedUpto d =
               | ESignalSource e => cu inner e
               | EServerCall (e, ek, _) => cu inner e andalso cu inner ek
               | ERecv (e, ek, _) => cu inner e andalso cu inner ek
+              | ESleep (e, ek) => cu inner e andalso cu inner ek
     in
         cu 0
     end
@@ -973,6 +975,19 @@ fun process file =
                                          str ")"],
                                  st)
                             end
+
+                          | ESleep (e, ek) =>
+                            let
+                                val (e, st) = jsE inner (e, st)
+                                val (ek, st) = jsE inner (ek, st)
+                            in
+                                (strcat [str "window.setTimeout(",
+                                         ek,
+                                         str ", ",
+                                         e,
+                                         str ")"],
+                                 st)
+                            end
                     end
             in
                 jsE
diff --git a/src/mono.sml b/src/mono.sml
index f4bbc868..02afb2c0 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -111,6 +111,7 @@ datatype exp' =
 
        | EServerCall of exp * exp * typ
        | ERecv of exp * exp * typ
+       | ESleep of exp * exp
 
 withtype exp = exp' located
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index b30fa4e8..a8ece085 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -318,6 +318,11 @@ fun p_exp' par env (e, _) =
                                 string ")[",
                                 p_exp env e,
                                 string "]"]
+      | ESleep (n, e) => box [string "Sleep(",
+                              p_exp env n,
+                              string ")[",
+                              p_exp env e,
+                              string "]"]
 
 and p_exp env = p_exp' false env
 
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 08d5ad6d..2f60b26e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -88,6 +88,7 @@ fun impure (e, _) =
       | ESignalSource e => impure e
       | EServerCall _ => true
       | ERecv _ => true
+      | ESleep _ => true
 
 
 val liftExpInExp = Monoize.liftExpInExp
@@ -361,6 +362,7 @@ fun reduce file =
 
                       | EServerCall (e, ek, _) => summarize d e @ summarize d ek @ [Unsure]
                       | ERecv (e, ek, _) => summarize d e @ summarize d ek @ [Unsure]
+                      | ESleep (e, ek) => summarize d e @ summarize d ek @ [Unsure]
             in
                 (*Print.prefaces "Summarize"
                                [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
diff --git a/src/mono_util.sml b/src/mono_util.sml
index bbc9c7e7..9455435c 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -360,12 +360,18 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                                              (EServerCall (s', ek', t'), loc))))
               | ERecv (s, ek, t) =>
                 S.bind2 (mfe ctx s,
-                         fn s' =>
-                            S.bind2 (mfe ctx ek,
-                                  fn ek' =>
-                                     S.map2 (mft t,
-                                          fn t' =>
-                                             (ERecv (s', ek', t'), loc))))
+                      fn s' =>
+                         S.bind2 (mfe ctx ek,
+                               fn ek' =>
+                                  S.map2 (mft t,
+                                       fn t' =>
+                                          (ERecv (s', ek', t'), loc))))
+              | ESleep (s, ek) =>
+                S.bind2 (mfe ctx s,
+                      fn s' =>
+                         S.map2 (mfe ctx ek,
+                               fn ek' =>
+                                  (ESleep (s', ek'), loc)))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index ea2ce751..d974e373 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1002,6 +1002,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                 t1), loc)), loc)), loc),
                  fm)
             end
+          | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
+                             (L.EFfi ("Basis", "transaction_monad"), _)), _),
+                    (L.EAbs (_, _, _,
+                             (L.EFfiApp ("Basis", "sleep", [n]), _)), loc)) =>
+            let
+                val t2 = monoType env t2
+                val un = (L'.TRecord [], loc)
+                val mt2 = (L'.TFun (un, t2), loc)
+                val (n, fm) = monoExp (env, st, fm) n
+            in
+                ((L'.EAbs ("m2", (L'.TFun (un, mt2), loc), (L'.TFun (un, un), loc),
+                           (L'.EAbs ("_", un, un,
+                                     (L'.ESleep (n, (L'.EApp ((L'.ERel 1, loc),
+                                                              (L'.ERecord [], loc)), loc)),
+                                      loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
             let
@@ -1952,12 +1969,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                            NONE => tagStart
                                          | SOME extra => (L'.EStrcat (tagStart, extra), loc)
 
+                        val xml = case extraInner of
+                                      NONE => xml
+                                    | SOME ei => (L.EFfiApp ("Basis", "strcat", [ei, xml]), loc)
+
                         fun normal () =
                             let
                                 val (xml, fm) = monoExp (env, st, fm) xml
-                                val xml = case extraInner of
-                                                   NONE => xml
-                                                 | SOME ei => (L'.EStrcat (ei, xml), loc)
                             in
                                 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
                                               (L'.EStrcat (xml,
@@ -2012,13 +2030,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                          end
                     in
                         normal ("body",
-                                SOME (L'.EStrcat ((L'.EPrim (Prim.String " onload='"), loc),
-                                                  (L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
-                                                                            [(L'.ERecord [], loc)]), loc),
-                                                               (L'.EStrcat (onload,
-                                                                            (L'.EPrim (Prim.String "'"),
-                                                                             loc)), loc)), loc)), loc),
-                                SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+                                SOME (L'.EFfiApp ("Basis", "maybe_onload",
+                                                  [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
+                                                                             [(L'.ERecord [], loc)]), loc),
+                                                                onload), loc)]),
+                                      loc),
+                                SOME (L.EFfiApp ("Basis", "get_script", [(L.ERecord [], loc)]), loc))
                     end
 
                   | "dyn" =>
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 34bf2337..a3928921 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -45,8 +45,7 @@ val pushBasis = SS.addList (SS.empty,
                              "self"])
                 
 val scriptWords = ["<script",
-                   " onclick=",
-                   " onload="]
+                   " onclick='"]
 
 val pushWords = ["rv("]
 
@@ -59,8 +58,15 @@ fun classify (ds, ps) =
                 not (Substring.isEmpty suffix)
             end
 
-        fun hasClient {basis, words} csids =
+        fun hasClient {basis, words, onload} csids =
             let
+                fun realOnload ss =
+                    case ss of
+                        [] => false
+                      | (EFfiApp ("Basis", "get_settings", _), _) :: ss => realOnload ss
+                      | (EPrim (Prim.String s), _) :: ss => not (String.isPrefix "'" s)
+                      | _ => true
+
                 fun hasClient e =
                     case #1 e of
                         EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words
@@ -73,6 +79,11 @@ fun classify (ds, ps) =
                       | ESome (_, e) => hasClient e
                       | EFfi ("Basis", x) => SS.member (basis, x)
                       | EFfi _ => false
+                      | EFfiApp ("Basis", "strcat", all as ((EPrim (Prim.String s1), _) :: ss)) =>
+                        if onload andalso String.isSuffix " onload='" s1 then
+                            realOnload ss orelse List.exists hasClient all
+                        else
+                            List.exists hasClient all
                       | EFfiApp ("Basis", x, es) => SS.member (basis, x)
                                                     orelse List.exists hasClient es
                       | EFfiApp (_, _, es) => List.exists hasClient es
@@ -97,8 +108,8 @@ fun classify (ds, ps) =
 
         fun decl ((d, _), (pull_ids, push_ids)) =
             let
-                val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids
-                val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids
+                val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids
+                val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids
             in
                 case d of
                     DVal (_, n, _, e) => (if hasClientPull e then
diff --git a/src/urweb.grm b/src/urweb.grm
index e6f0ddeb..98ba295a 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2009, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
diff --git a/tests/sleep.ur b/tests/sleep.ur
new file mode 100644
index 00000000..132479e5
--- /dev/null
+++ b/tests/sleep.ur
@@ -0,0 +1,7 @@
+fun annoyer () =
+    alert "Hi!";
+    sleep 5000;
+    annoyer ()
+
+fun main () : transaction page = return <xml><body onload={annoyer ()}/></xml>
+
diff --git a/tests/sleep.urp b/tests/sleep.urp
new file mode 100644
index 00000000..f6eaf9fe
--- /dev/null
+++ b/tests/sleep.urp
@@ -0,0 +1,3 @@
+debug
+
+sleep
-- 
cgit v1.2.3