From 64169805c117326ccd9af8198cd16d581cc25c2d Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 6 Dec 2013 08:44:26 -0500
Subject: Add 'xhead' case to Monoize

---
 src/monoize.sml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/monoize.sml b/src/monoize.sml
index 3df6ec92..228d22cd 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -215,6 +215,7 @@ fun monoType env =
 
                   | L.CFfi ("Basis", "unit") => (L'.TRecord [], loc)
                   | L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "xhead") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "xtable") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc)
-- 
cgit v1.2.3


From 4800d8054ee97979a4706daa178127985957b016 Mon Sep 17 00:00:00 2001
From: Sergey Mironov <grrwlf@gmail.com>
Date: Wed, 6 Nov 2013 13:54:07 +0400
Subject: Add -print-cinlude command line option

---
 src/main.mlton.sml | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index d176efcc..e68ecdd8 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -58,6 +58,8 @@ fun oneRun args =
 			              raise Code OS.Process.success)
         fun printCCompiler () = (print ((Settings.getCCompiler ()) ^ "\n");
 			              raise Code OS.Process.success)
+        fun printCInclude () = (print ((Config.includ) ^ "\n");
+			              raise Code OS.Process.success)
 
         fun doArgs args =
             case args of
@@ -71,6 +73,8 @@ fun oneRun args =
                  doArgs rest)
               | "-print-ccompiler" :: rest =>
                   printCCompiler ()
+              | "-print-cinclude" :: rest =>
+                  printCInclude ()
               | "-ccompiler" :: ccomp :: rest =>
                 (Settings.setCCompiler ccomp;
                  doArgs rest)
-- 
cgit v1.2.3


From eb64746b388cd3a3864e70039a0c04929b6bbd61 Mon Sep 17 00:00:00 2001
From: Sergey Mironov <grrwlf@gmail.com>
Date: Fri, 6 Dec 2013 13:59:39 +0400
Subject: Add activeHead tag.

activeHead is similar to active but produces xhead instead of xbody
---
 lib/ur/basis.urs |  3 +++
 src/monoize.sml  | 12 +++++++++++-
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 4931c97a..7637f8fa 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -782,6 +782,9 @@ val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] =
 val active : unit
              -> tag [Code = transaction xbody] body [] [] []
 
+val activeHead : unit
+             -> tag [Code = transaction xhead] head [] [] []
+
 val head : unit -> tag [] html head [] []
 val title : unit -> tag [] head [] [] []
 val link : unit -> tag [Id = id, Rel = string, Typ = string, Href = url, Media = string] head [] [] []
diff --git a/src/monoize.sml b/src/monoize.sml
index 3df6ec92..8889937e 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3264,7 +3264,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val (style, fm) = monoExp (env, st, fm) style
                 val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
 
-                val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active"]
+                val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active", "activeHead"]
 
                 fun isSome (e, _) =
                     case e of
@@ -3600,6 +3600,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 			      fm)
                            | _ => raise Fail "Monoize: Bad <active> attributes")
 
+                      | "activeHead" =>
+                        (case attrs of
+			     [("Code", e, _)] =>
+			     ((L'.EStrcat
+                                   ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">active(execD(")), loc),
+                                    (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
+                                                 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
+			      fm)
+                           | _ => raise Fail "Monoize: Bad <activeHead> attributes")
+
                       | "submit" => normal ("input type=\"submit\"", NONE)
                       | "image" => normal ("input type=\"image\"", NONE)
                       | "button" => normal ("input type=\"submit\"", NONE)
-- 
cgit v1.2.3


From 0eee402a615c957f006c01d0424dae45713a9376 Mon Sep 17 00:00:00 2001
From: Sergey Mironov <grrwlf@gmail.com>
Date: Fri, 6 Dec 2013 14:52:47 +0400
Subject: activeHead: don't modify the head. just execute the code provided

---
 lib/ur/basis.urs | 2 +-
 src/monoize.sml  | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 7637f8fa..66e65804 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -783,7 +783,7 @@ val active : unit
              -> tag [Code = transaction xbody] body [] [] []
 
 val activeHead : unit
-             -> tag [Code = transaction xhead] head [] [] []
+             -> tag [Code = transaction unit] head [] [] []
 
 val head : unit -> tag [] html head [] []
 val title : unit -> tag [] head [] [] []
diff --git a/src/monoize.sml b/src/monoize.sml
index 8889937e..d382194f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3604,9 +3604,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                         (case attrs of
 			     [("Code", e, _)] =>
 			     ((L'.EStrcat
-                                   ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">active(execD(")), loc),
+                                   ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execD(")), loc),
                                     (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
-                                                 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
+                                                 (L'.EPrim (Prim.String (")</script>")), loc)), loc)), loc),
 			      fm)
                            | _ => raise Fail "Monoize: Bad <activeHead> attributes")
 
-- 
cgit v1.2.3


From 377d1b9ccdf923b6803dc63a66babd90f08ba3f7 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 6 Dec 2013 08:54:03 -0500
Subject: Small reformatting and documentation for '-print-cinclude'

---
 doc/manual.tex     | 2 ++
 src/main.mlton.sml | 8 ++++----
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/doc/manual.tex b/doc/manual.tex
index ac12c3b7..84af835f 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -275,6 +275,8 @@ sqlite3 path/to/database/file <app.sql
 
 \item \texttt{-print-ccompiler}: Print the C compiler being used.
 
+\item \texttt{-print-cinclude}: Print the name of the directory where C/C++ header files are installed.
+
 \item \texttt{-protocol [http|cgi|fastcgi|static]}: Set the protocol that the generated application speaks.
   \begin{itemize}
   \item \texttt{http}: This is the default.  It is for building standalone web servers that can be accessed by web browsers directly.
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index e68ecdd8..b0c4e03f 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -56,10 +56,10 @@ fun oneRun args =
 		               raise Code OS.Process.success)
         fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
 			              raise Code OS.Process.success)
-        fun printCCompiler () = (print ((Settings.getCCompiler ()) ^ "\n");
-			              raise Code OS.Process.success)
-        fun printCInclude () = (print ((Config.includ) ^ "\n");
-			              raise Code OS.Process.success)
+        fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n");
+			         raise Code OS.Process.success)
+        fun printCInclude () = (print (Config.includ ^ "\n");
+			        raise Code OS.Process.success)
 
         fun doArgs args =
             case args of
-- 
cgit v1.2.3


From c6e641ffb3195827acbb2787bb202824fef0cfa6 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Mon, 9 Dec 2013 15:47:14 -0500
Subject: Rename <activeHead> to <script> and make it work properly

---
 doc/manual.tex   |  8 ++++++++
 lib/ur/basis.urs |  2 +-
 src/monoize.sml  | 10 +++++-----
 tests/ahead.ur   |  8 ++++++++
 4 files changed, 22 insertions(+), 6 deletions(-)
 create mode 100644 tests/ahead.ur

diff --git a/doc/manual.tex b/doc/manual.tex
index ac12c3b7..db1bfe1c 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2103,6 +2103,14 @@ $$\begin{array}{l}
   \mt{val} \; \mt{stopPropagation} : \mt{transaction} \; \mt{unit}
 \end{array}$$
 
+Finally, here is an HTML tag to leave a marker in the \cd{<head>} of a document asking for some side-effecting code to be run.  This pattern is \emph{much} less common in Ur/Web applications than in normal HTML/JavaScript applications; see Section \ref{signals} for the more idiomatic, functional way of manipulating the visible page.
+
+$$\begin{array}{l}
+  \mt{val} \; \mt{script} : \mt{unit} \to \mt{tag} \; [\mt{Code} = \mt{transaction} \; \mt{unit}] \; \mt{head} \; [] \; [] \; []
+\end{array}$$
+
+Note that the Ur/Web version of \cd{<script>} is used like \cd{<script code=\{...\}/>}, rather than \cd{<script>...</script>}.
+
 \subsubsection{Node IDs}
 
 There is an abstract type of node IDs that may be assigned to \cd{id} attributes of most HTML tags.
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 66e65804..73cef3d2 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -782,7 +782,7 @@ val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] =
 val active : unit
              -> tag [Code = transaction xbody] body [] [] []
 
-val activeHead : unit
+val script : unit
              -> tag [Code = transaction unit] head [] [] []
 
 val head : unit -> tag [] html head [] []
diff --git a/src/monoize.sml b/src/monoize.sml
index d382194f..291c0fa3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3264,7 +3264,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val (style, fm) = monoExp (env, st, fm) style
                 val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
 
-                val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active", "activeHead"]
+                val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script"]
 
                 fun isSome (e, _) =
                     case e of
@@ -3600,15 +3600,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 			      fm)
                            | _ => raise Fail "Monoize: Bad <active> attributes")
 
-                      | "activeHead" =>
+                      | "script" =>
                         (case attrs of
 			     [("Code", e, _)] =>
 			     ((L'.EStrcat
-                                   ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execD(")), loc),
+                                   ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execF(execD(")), loc),
                                     (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
-                                                 (L'.EPrim (Prim.String (")</script>")), loc)), loc)), loc),
+                                                 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
 			      fm)
-                           | _ => raise Fail "Monoize: Bad <activeHead> attributes")
+                           | _ => raise Fail "Monoize: Bad <script> attributes")
 
                       | "submit" => normal ("input type=\"submit\"", NONE)
                       | "image" => normal ("input type=\"image\"", NONE)
diff --git a/tests/ahead.ur b/tests/ahead.ur
new file mode 100644
index 00000000..29938d07
--- /dev/null
+++ b/tests/ahead.ur
@@ -0,0 +1,8 @@
+fun main () : transaction page = return <xml>
+  <head>
+    <script code={alert "Hi!"}/>
+  </head>
+  <body>
+    <active code={alert "Bye!"; return <xml/>}/>
+  </body>
+</xml>
-- 
cgit v1.2.3


From 31ab9f8c18c9e071392090960a8041febf7a2807 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Mon, 9 Dec 2013 17:23:25 -0500
Subject: Add JavaScript mappings for isprint and ord

---
 lib/js/urweb.js  | 3 ++-
 src/settings.sml | 2 ++
 2 files changed, 4 insertions(+), 1 deletion(-)

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 59708150..e211d318 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -35,10 +35,11 @@ function isAlnum(c) { return isAlpha(c) || isDigit(c); }
 function isBlank(c) { return c == ' ' || c == '\t'; }
 function isSpace(c) { return isBlank(c) || c == '\r' || c == '\n'; }
 function isXdigit(c) { return isDigit(c) || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F'); }
+function ord(c) { return c.charCodeAt(0); }
+function isPrint(c) { return ord(c) > 31 && ord(c) < 127; }
 function toLower(c) { return c.toLowerCase(); }
 function toUpper(c) { return c.toUpperCase(); }
 
-
 // Lists
 
 function cons(v, ls) {
diff --git a/src/settings.sml b/src/settings.sml
index 948906ed..7a75985e 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -299,8 +299,10 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("isblank", "isBlank"),
                           ("isspace", "isSpace"),
                           ("isxdigit", "isXdigit"),
+                          ("isprint", "isPrint"),
                           ("tolower", "toLower"),
                           ("toupper", "toUpper"),
+                          ("ord", "ord"),
 
                           ("checkUrl", "checkUrl"),
                           ("bless", "bless"),
-- 
cgit v1.2.3


From 521ba1a43e3d75deec4dcf2eafdf7e4e7b72b15e Mon Sep 17 00:00:00 2001
From: Sergey Mironov <grrwlf@gmail.com>
Date: Mon, 7 Oct 2013 14:08:10 +0400
Subject: Add show instance for 'id' type

---
 lib/ur/basis.urs | 1 +
 src/monoize.sml  | 6 ++++++
 2 files changed, 7 insertions(+)

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 73cef3d2..eefb5d2c 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -775,6 +775,7 @@ val redirect : t ::: Type -> url -> transaction t
 type id
 val fresh : transaction id
 val giveFocus : id -> transaction unit
+val show_id : show id
 
 val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [ctx ~ [Dyn]] => unit
           -> tag [Signal = signal (xml ([Dyn] ++ ctx) use bind)] ([Dyn] ++ ctx) [] use bind
diff --git a/src/monoize.sml b/src/monoize.sml
index ad53cf18..2b604325 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1267,6 +1267,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
             end
+          | L.EFfi ("Basis", "show_id") =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
+            end
           | L.EFfi ("Basis", "show_char") =>
             ((L'.EFfi ("Basis", "charToString"), loc), fm)
           | L.EFfi ("Basis", "show_bool") =>
-- 
cgit v1.2.3


From a22814f0ea7501eba5dc86413ba9851e97deed2e Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 11 Dec 2013 11:06:08 -0500
Subject: Add '-q' option to HTTP binaries

---
 src/c/http.c | 44 +++++++++++++++++++++++++++++---------------
 1 file changed, 29 insertions(+), 15 deletions(-)

diff --git a/src/c/http.c b/src/c/http.c
index f954a879..5ceca059 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -21,7 +21,7 @@
 extern uw_app uw_application;
 
 int uw_backlog = SOMAXCONN;
-static int keepalive = 0;
+static int keepalive = 0, quiet = 0;
 
 static char *get_header(void *data, const char *h) {
   char *s = data;
@@ -62,10 +62,12 @@ static void log_error(void *data, const char *fmt, ...) {
 }
 
 static void log_debug(void *data, const char *fmt, ...) {
-  va_list ap;
-  va_start(ap, fmt);
+  if (!quiet) {
+    va_list ap;
+    va_start(ap, fmt);
 
-  vprintf(fmt, ap);
+    vprintf(fmt, ap);
+  }
 }
 
 static void *worker(void *data) {
@@ -82,7 +84,8 @@ static void *worker(void *data) {
       sock = uw_dequeue();
     }
 
-    printf("Handling connection with thread #%d.\n", me);
+    if (!quiet)
+      printf("Handling connection with thread #%d.\n", me);
 
     while (1) {
       int r;
@@ -99,14 +102,16 @@ static void *worker(void *data) {
       r = recv(sock, back, buf_size - 1 - (back - buf), 0);
 
       if (r < 0) {
-        fprintf(stderr, "Recv failed\n");
+        if (!quiet)
+          fprintf(stderr, "Recv failed\n");
         close(sock);
         sock = 0;
         break;
       }
 
       if (r == 0) {
-        printf("Connection closed.\n");
+        if (!quiet)
+          printf("Connection closed.\n");
         close(sock);
         sock = 0;
         break;
@@ -148,14 +153,16 @@ static void *worker(void *data) {
             r = recv(sock, back, buf_size - 1 - (back - buf), 0);
 
             if (r < 0) {
-              fprintf(stderr, "Recv failed\n");
+              if (!quiet)
+                fprintf(stderr, "Recv failed\n");
               close(sock);
               sock = 0;
               goto done;
             }
 
             if (r == 0) {
-              fprintf(stderr, "Connection closed.\n");
+              if (!quiet)
+                fprintf(stderr, "Connection closed.\n");
               close(sock);
               sock = 0;
               goto done;
@@ -218,7 +225,8 @@ static void *worker(void *data) {
         uw_set_headers(ctx, get_header, headers);
         uw_set_env(ctx, get_env, NULL);
 
-        printf("Serving URI %s....\n", path);
+        if (!quiet)
+          printf("Serving URI %s....\n", path);
         rr = uw_request(rc, ctx, method, path, query_string, body, back - body,
                         on_success, on_failure,
                         NULL, log_error, log_debug,
@@ -267,7 +275,7 @@ static void *worker(void *data) {
 }
 
 static void help(char *cmd) {
-  printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-k]\nThe '-k' option turns on HTTP keepalive.\n", cmd);
+  printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-k] [-q]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\n", cmd);
 }
 
 static void sigint(int signum) {
@@ -291,10 +299,10 @@ int main(int argc, char *argv[]) {
   my_addr.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP
   memset(my_addr.sin_zero, '\0', sizeof my_addr.sin_zero);
 
-  while ((opt = getopt(argc, argv, "hp:a:t:k")) != -1) {
+  while ((opt = getopt(argc, argv, "hp:a:t:kq")) != -1) {
     switch (opt) {
     case '?':
-      fprintf(stderr, "Unknown command-line option");
+      fprintf(stderr, "Unknown command-line option\n");
       help(argv[0]);
       return 1;
 
@@ -332,6 +340,10 @@ int main(int argc, char *argv[]) {
       keepalive = 1;
       break;
 
+    case 'q':
+      quiet = 1;
+      break;
+
     default:
       fprintf(stderr, "Unexpected getopt() behavior\n");
       return 1;
@@ -369,7 +381,8 @@ int main(int argc, char *argv[]) {
 
   sin_size = sizeof their_addr;
 
-  printf("Listening on port %d....\n", uw_port);
+  if (!quiet)
+    printf("Listening on port %d....\n", uw_port);
 
   {
     pthread_t thread;
@@ -397,7 +410,8 @@ int main(int argc, char *argv[]) {
       return 1;
     }
 
-    printf("Accepted connection.\n");
+    if (!quiet)
+      printf("Accepted connection.\n");
 
     if (keepalive) {
       int flag = 1; 
-- 
cgit v1.2.3


From a8459c0104ca36fd058ea527890116c7a1bca8fd Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 11 Dec 2013 14:57:54 -0500
Subject: Fix regression in http.c for long-polling connections; add lazy
 initialization of database connections, to avoid the overhead in handlers
 that don't use SQL

---
 include/urweb/urweb_cpp.h |  1 +
 src/c/http.c              |  4 +++-
 src/c/urweb.c             | 24 +++++++++++++++++-------
 src/cjr_print.sml         | 12 +++++++++++-
 4 files changed, 32 insertions(+), 9 deletions(-)

diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 4779b95a..fb3c83a2 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -37,6 +37,7 @@ void uw_set_on_success(char *);
 void uw_set_headers(struct uw_context *, char *(*get_header)(void *, const char *), void *get_header_data);
 void uw_set_env(struct uw_context *, char *(*get_env)(void *, const char *), void *get_env_data);
 failure_kind uw_begin(struct uw_context *, char *path);
+void uw_ensure_transaction(struct uw_context *);
 failure_kind uw_begin_onError(struct uw_context *, char *msg);
 void uw_login(struct uw_context *);
 void uw_commit(struct uw_context *);
diff --git a/src/c/http.c b/src/c/http.c
index 5ceca059..d19ce350 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -260,7 +260,9 @@ static void *worker(void *data) {
             close(sock);
             sock = 0;
           }
-        } else if (rr != KEEP_OPEN)
+        } else if (rr == KEEP_OPEN)
+          sock = 0;
+        else
           fprintf(stderr, "Illegal uw_request return code: %d\n", rr);
 
         break;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 8bd5ada9..cd724cbf 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -431,6 +431,7 @@ struct uw_context {
   unsigned long long source_count;
 
   void *db;
+  int transaction_started;
 
   jmp_buf jmp_buf;
 
@@ -507,6 +508,7 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
   ctx->sz_inputs = ctx->n_subinputs = ctx->used_subinputs = 0;
 
   ctx->db = NULL;
+  ctx->transaction_started = 0;
 
   ctx->regions = NULL;
 
@@ -631,6 +633,7 @@ void uw_reset_keep_error_message(uw_context ctx) {
   ctx->amInitializing = 0;
   ctx->usedSig = 0;
   ctx->needsResig = 0;
+  ctx->transaction_started = 0;
 }
 
 void uw_reset_keep_request(uw_context ctx) {
@@ -766,16 +769,20 @@ void uw_login(uw_context ctx) {
 failure_kind uw_begin(uw_context ctx, char *path) {
   int r = setjmp(ctx->jmp_buf);
 
-  if (r == 0) {
-    if (ctx->app->db_begin(ctx))
-      uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
-
+  if (r == 0)
     ctx->app->handle(ctx, path);
-  }
 
   return r;
 }
 
+void uw_ensure_transaction(uw_context ctx) {
+  if (!ctx->transaction_started) {
+    if (ctx->app->db_begin(ctx))
+      uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
+    ctx->transaction_started = 1;
+  }
+}
+
 uw_Basis_client uw_Basis_self(uw_context ctx) {
   if (ctx->client == NULL)
     uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code");
@@ -3205,7 +3212,7 @@ int uw_rollback(uw_context ctx, int will_retry) {
     if (ctx->transactionals[i].free)
       ctx->transactionals[i].free(ctx->transactionals[i].data, will_retry);
 
-  return ctx->app ? ctx->app->db_rollback(ctx) : 0;
+  return (ctx->app && ctx->transaction_started) ? ctx->app->db_rollback(ctx) : 0;
 }
 
 static const char begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">";
@@ -3262,7 +3269,7 @@ void uw_commit(uw_context ctx) {
         }
       }
 
-  if (ctx->app->db_commit(ctx)) {
+  if (ctx->transaction_started && ctx->app->db_commit(ctx)) {
     uw_set_error_message(ctx, "Error running SQL COMMIT");
     return;
   }
@@ -3453,6 +3460,7 @@ failure_kind uw_initialize(uw_context ctx) {
   if (r == 0) {
     if (ctx->app->db_begin(ctx))
       uw_error(ctx, FATAL, "Error running SQL BEGIN");
+    ctx->transaction_started = 1;
     ctx->app->initializer(ctx);
     if (ctx->app->db_commit(ctx))
       uw_error(ctx, FATAL, "Error running SQL COMMIT");
@@ -4037,6 +4045,7 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
   if (r == 0) {
     if (ctx->app->db_begin(ctx))
       uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
+    ctx->transaction_started = 1;
 
     callback(ctx);
   }
@@ -4085,6 +4094,7 @@ failure_kind uw_begin_onError(uw_context ctx, char *msg) {
     if (r == 0) {
       if (ctx->app->db_begin(ctx))
         uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
+      ctx->transaction_started = 1;
 
       uw_buffer_reset(&ctx->outHeaders);
       if (on_success[0])
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index bc8f1be6..e98918e6 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2079,6 +2079,8 @@ and p_exp' par tail env (e, loc) =
                  newline,
                  string "int dummy = (uw_begin_region(ctx), 0);",
                  newline,
+                 string "uw_ensure_transaction(ctx);",
+                 newline,
                  
                  case prepared of
                      NONE =>
@@ -2140,6 +2142,8 @@ and p_exp' par tail env (e, loc) =
                               p_exp' false false env dml,
                               string ";",
                               newline,
+                              string "uw_ensure_transaction(ctx);",
+                              newline,
                               newline,
                               #dml (Settings.currentDbms ()) (loc, mode)]
                | SOME {id, dml = dml'} =>
@@ -2159,8 +2163,10 @@ and p_exp' par tail env (e, loc) =
                                                        string ";"])
                                       inputs,
                           newline,
+                          string "uw_ensure_transaction(ctx);",
                           newline,
-
+                          newline,
+                          
                           #dmlPrepared (Settings.currentDbms ()) {loc = loc,
                                                                   id = id,
                                                                   dml = dml',
@@ -2184,6 +2190,8 @@ and p_exp' par tail env (e, loc) =
              newline,
              string "uw_Basis_int n;",
              newline,
+             string "uw_ensure_transaction(ctx);",
+             newline,
 
              case prepared of
                  NONE => #nextval (Settings.currentDbms ()) {loc = loc,
@@ -2204,6 +2212,8 @@ and p_exp' par tail env (e, loc) =
       | ESetval {seq, count} =>
         box [string "({",
              newline,
+             string "uw_ensure_transaction(ctx);",
+             newline,
 
              #setval (Settings.currentDbms ()) {loc = loc,
                                                 seqE = p_exp' false false env seq,
-- 
cgit v1.2.3


From d7c4817af0c7f4ea2ed30b4a34408f2f92e9e979 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 11 Dec 2013 18:22:10 -0500
Subject: Change handling of returned text blobs, to activate the normal EWrite
 optimizations

---
 include/urweb/urweb_cpp.h |  2 ++
 src/c/urweb.c             | 34 ++++++++++++++++++++++++++++++++++
 src/checknest.sml         |  6 ++++--
 src/cjr.sml               |  2 +-
 src/cjr_print.sml         | 26 ++++++++++++++++++++++++--
 src/cjrize.sml            | 11 +++++++++--
 src/iflow.sml             |  9 ++++++---
 src/jscomp.sml            | 10 ++++++++--
 src/mono.sml              |  2 +-
 src/mono_print.sml        | 36 ++++++++++++++++++++++++------------
 src/mono_reduce.sml       |  6 ++++--
 src/mono_util.sml         | 13 ++++++++++---
 src/monoize.sml           | 20 +++++++++++++++++++-
 src/prepare.sml           |  9 ++++++++-
 14 files changed, 154 insertions(+), 32 deletions(-)

diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index fb3c83a2..d1fb4d37 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -209,6 +209,7 @@ uw_Basis_string uw_Basis_requestHeader(struct uw_context *, uw_Basis_string);
 
 void uw_write_header(struct uw_context *, uw_Basis_string);
 void uw_clear_headers(struct uw_context *);
+void uw_Basis_clear_page(struct uw_context *);
 
 uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c);
 uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure);
@@ -255,6 +256,7 @@ uw_Basis_postBody uw_getPostBody(struct uw_context *);
 
 void uw_mayReturnIndirectly(struct uw_context *);
 __attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType);
+__attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType);
 __attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url);
 
 uw_Basis_time uw_Basis_now(struct uw_context *);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cd724cbf..1201b09b 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1351,6 +1351,10 @@ void uw_clear_headers(uw_context ctx) {
   uw_buffer_reset(&ctx->outHeaders);
 }
 
+void uw_Basis_clear_page(uw_context ctx) {
+  uw_buffer_reset(&ctx->page);
+}
+
 static void uw_check_script(uw_context ctx, size_t extra) {
   ctx_uw_buffer_check(ctx, "script", &ctx->script, extra);
 }
@@ -3736,6 +3740,36 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
   longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
 }
 
+__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) {
+  cleanup *cl;
+  int len;
+  char *oldh;
+
+  if (!ctx->allowed_to_return_indirectly)
+    uw_error(ctx, FATAL, "Tried to return a blob from an RPC");
+
+  ctx->returning_indirectly = 1;
+  oldh = old_headers(ctx);
+  uw_buffer_reset(&ctx->outHeaders);
+
+  uw_write_header(ctx, on_success);
+  uw_write_header(ctx, "Content-Type: ");
+  uw_write_header(ctx, mimeType);
+  uw_write_header(ctx, "\r\nContent-Length: ");
+  ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
+  sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len);
+  ctx->outHeaders.front += len;
+  uw_write_header(ctx, "\r\n");
+  if (oldh) uw_write_header(ctx, oldh);
+
+  for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
+    cl->func(cl->arg);
+
+  ctx->cleanup_front = ctx->cleanup;
+
+  longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
+}
+
 __attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) {
   cleanup *cl;
   char *s;
diff --git a/src/checknest.sml b/src/checknest.sml
index 05ad8e9a..fa418d89 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -56,7 +56,8 @@ fun expUses globals =
               | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
 
               | EError (e, _) => eu e
-              | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
+              | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType
+              | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
               | ERedirect (e, _) => eu e
 
               | EWrite e => eu e
@@ -118,7 +119,8 @@ fun annotateExp globals =
               | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
 
               | EError (e, t) => (EError (ae e, t), loc)
-              | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc)
+              | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc)
+              | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc)
               | ERedirect (e, t) => (ERedirect (ae e, t), loc)
 
               | EWrite e => (EWrite (ae e), loc)
diff --git a/src/cjr.sml b/src/cjr.sml
index 3a37b26f..8cbabdcc 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -78,7 +78,7 @@ datatype exp' =
        | ECase of exp * (pat * exp) list * { disc : typ, result : typ }
 
        | EError of exp * typ
-       | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
+       | EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
        | ERedirect of exp * typ
 
        | EWrite of exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e98918e6..dec21eb3 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1628,7 +1628,7 @@ and p_exp' par tail env (e, loc) =
              string "tmp;",
              newline,
              string "})"]
-      | EReturnBlob {blob, mimeType, t} =>
+      | EReturnBlob {blob = SOME blob, mimeType, t} =>
         box [string "({",
              newline,
              string "uw_Basis_blob",
@@ -1658,6 +1658,27 @@ and p_exp' par tail env (e, loc) =
              string "tmp;",
              newline,
              string "})"]
+      | EReturnBlob {blob = NONE, mimeType, t} =>
+        box [string "({",
+             newline,
+             string "uw_Basis_string",
+             space,
+             string "mimeType",
+             space,
+             string "=",
+             space,
+             p_exp' false false env mimeType,
+             string ";",
+             newline,
+             p_typ env t,
+             space,
+             string "tmp;",
+             newline,
+             string "uw_return_blob_from_page(ctx, mimeType);",
+             newline,
+             string "tmp;",
+             newline,
+             string "})"]
       | ERedirect (e, t) =>
         box [string "({",
              newline,
@@ -3180,7 +3201,8 @@ fun p_file env (ds, ps) =
               | EField (e, _) => expDb e
               | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
               | EError (e, _) => expDb e
-              | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
+              | EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2
+              | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
               | ERedirect (e, _) => expDb e
               | EWrite e => expDb e
               | ESeq (e1, e2) => expDb e1 orelse expDb e2
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 0f4bdb42..d153feff 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -372,13 +372,20 @@ fun cifyExp (eAll as (e, loc), sm) =
             in
                 ((L'.EError (e, t), loc), sm)
             end
-          | L.EReturnBlob {blob, mimeType, t} =>
+          | L.EReturnBlob {blob = NONE, mimeType, t} =>
+            let
+                val (mimeType, sm) = cifyExp (mimeType, sm)
+                val (t, sm) = cifyTyp (t, sm)
+            in
+                ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm)
+            end
+          | L.EReturnBlob {blob = SOME blob, mimeType, t} =>
             let
                 val (blob, sm) = cifyExp (blob, sm)
                 val (mimeType, sm) = cifyExp (mimeType, sm)
                 val (t, sm) = cifyTyp (t, sm)
             in
-                ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
+                ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm)
             end
           | L.ERedirect (e, t) =>
             let
diff --git a/src/iflow.sml b/src/iflow.sml
index 0c94cd47..461dc956 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1587,7 +1587,8 @@ fun evalExp env (e as (_, loc)) k =
                 evalExp env e2 (fn e2 =>
                                    k (Func (Other "cat", [e1, e2]))))
           | EError (e, _) => evalExp env e (fn e => St.send (e, loc))
-          | EReturnBlob {blob = b, mimeType = m, ...} =>
+          | EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization"
+          | EReturnBlob {blob = SOME b, mimeType = m, ...} =>
             evalExp env b (fn b =>
                               (St.send (b, loc);
                                evalExp env m
@@ -2060,8 +2061,10 @@ fun check (file : file) =
                             end
                           | EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc)
                           | EError (e1, t) => (EError (doExp env e1, t), loc)
-                          | EReturnBlob {blob = b, mimeType = m, t} =>
-                            (EReturnBlob {blob = doExp env b, mimeType = doExp env m, t = t}, loc)
+                          | EReturnBlob {blob = NONE, mimeType = m, t} =>
+                            (EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc)
+                          | EReturnBlob {blob = SOME b, mimeType = m, t} =>
+                            (EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc)
                           | ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc)
                           | EWrite e1 => (EWrite (doExp env e1), loc)
                           | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc)
diff --git a/src/jscomp.sml b/src/jscomp.sml
index e0d87a8e..4a2c0365 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -1118,12 +1118,18 @@ fun process (file : file) =
                  in
                      ((EError (e, t), loc), st)
                  end
-               | EReturnBlob {blob, mimeType, t} =>
+               | EReturnBlob {blob = NONE, mimeType, t} =>
+                 let
+                     val (mimeType, st) = exp outer (mimeType, st)
+                 in
+                     ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st)
+                 end
+               | EReturnBlob {blob = SOME blob, mimeType, t} =>
                  let
                      val (blob, st) = exp outer (blob, st)
                      val (mimeType, st) = exp outer (mimeType, st)
                  in
-                     ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
+                     ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st)
                  end
                | ERedirect (e, t) =>
                  let
diff --git a/src/mono.sml b/src/mono.sml
index f5260419..78740d70 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -93,7 +93,7 @@ datatype exp' =
        | EStrcat of exp * exp
 
        | EError of exp * typ
-       | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
+       | EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
        | ERedirect of exp * typ
 
        | EWrite of exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a5156aca..c81b362a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -235,18 +235,30 @@ fun p_exp' par env (e, _) =
                               space,
                               p_typ env t,
                               string ")"]
-      | EReturnBlob {blob, mimeType, t} => box [string "(blob",
-                                                space,
-                                                p_exp env blob,
-                                                space,
-                                                string "in",
-                                                space,
-                                                p_exp env mimeType,
-                                                space,
-                                                string ":",
-                                                space,
-                                                p_typ env t,
-                                                string ")"]
+      | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "(blob",
+                                                            space,
+                                                            p_exp env blob,
+                                                            space,
+                                                            string "in",
+                                                            space,
+                                                            p_exp env mimeType,
+                                                            space,
+                                                            string ":",
+                                                            space,
+                                                            p_typ env t,
+                                                            string ")"]
+      | EReturnBlob {blob = NONE, mimeType, t} => box [string "(blob",
+                                                       space,
+                                                       string "<page>",
+                                                       space,
+                                                       string "in",
+                                                       space,
+                                                       p_exp env mimeType,
+                                                       space,
+                                                       string ":",
+                                                       space,
+                                                       p_typ env t,
+                                                       string ")"]
       | ERedirect (e, t) => box [string "(redirect",
                                  space,
                                  p_exp env e,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0dfb7558..e96a0e8f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -101,7 +101,8 @@ fun impure (e, _) =
       | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
 
       | EError _ => true
-      | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
+      | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2
+      | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2
       | ERedirect (e, _) => impure e
 
       | EStrcat (e1, e2) => impure e1 orelse impure e2
@@ -492,7 +493,8 @@ fun reduce (file : file) =
                       | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
 
                       | EError (e, _) => summarize d e @ [Abort]
-                      | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
+                      | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort]
+                      | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
                       | ERedirect (e, _) => summarize d e @ [Abort]
 
                       | EWrite e => summarize d e @ [WritePage]
diff --git a/src/mono_util.sml b/src/mono_util.sml
index cb871891..cc531625 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -261,14 +261,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                             S.map2 (mft t,
                                     fn t' =>
                                        (EError (e', t'), loc)))
-              | EReturnBlob {blob, mimeType, t} =>
+              | EReturnBlob {blob = NONE, mimeType, t} =>
+                S.bind2 (mfe ctx mimeType,
+                      fn mimeType' =>
+                         S.map2 (mft t,
+                              fn t' =>
+                                 (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc)))
+              | EReturnBlob {blob = SOME blob, mimeType, t} =>
                 S.bind2 (mfe ctx blob,
                          fn blob' =>
                             S.bind2 (mfe ctx mimeType,
                                   fn mimeType' =>
                                      S.map2 (mft t,
                                           fn t' =>
-                                             (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc))))
+                                             (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc))))
               | ERedirect (e, t) =>
                 S.bind2 (mfe ctx e,
                          fn e' =>
@@ -495,7 +501,8 @@ fun appLoc f =
                | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
                | EStrcat (e1, e2) => (appl e1; appl e2)
                | EError (e1, _) => appl e1
-               | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2)
+               | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2
+               | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2)
                | ERedirect (e1, _) => appl e1
                | EWrite e1 => appl e1
                | ESeq (e1, e2) => (appl e1; appl e2)
diff --git a/src/monoize.sml b/src/monoize.sml
index 2b604325..b1166734 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4053,6 +4053,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
                  fm)
             end
+          | L.EApp (
+            (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
+            (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
+            let
+                val t = monoType env t
+                val un = (L'.TRecord [], loc)
+                val (e, fm) = monoExp (env, st, fm) e
+            in
+                ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
+                           (L'.EAbs ("_", un, t,
+                                     (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
+                                               (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
+                                                         (L'.EReturnBlob {blob = NONE,
+                                                                          mimeType = (L'.ERel 1, loc),
+                                                                          t = t}, loc)), loc)), loc)), loc)),
+                  loc),
+                 fm)
+            end
           | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
             let
                 val t = monoType env t
@@ -4062,7 +4080,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
                            (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
                                      (L'.EAbs ("_", un, t,
-                                               (L'.EReturnBlob {blob = (L'.ERel 2, loc),
+                                               (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
                                                                 mimeType = (L'.ERel 1, loc),
                                                                 t = t}, loc)), loc)), loc)), loc),
                  fm)
diff --git a/src/prepare.sml b/src/prepare.sml
index 7f55959c..89cd1b43 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -201,7 +201,14 @@ fun prepExp (e as (_, loc), st) =
 
       | EReturnBlob {blob, mimeType, t} =>
         let
-            val (blob, st) = prepExp (blob, st)
+            val (blob, st) = case blob of
+                                 NONE => (blob, st)
+                               | SOME blob =>
+                                 let
+                                     val (b, st) = prepExp (blob, st)
+                                 in
+                                     (SOME b, st)
+                                 end
             val (mimeType, st) = prepExp (mimeType, st)
         in
             ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
-- 
cgit v1.2.3


From bc4cdf7f4a995846125917ac0abb1a67bfd81fca Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 11 Dec 2013 18:54:42 -0500
Subject: RAND_bytes isn't thread-safe, so wrap it with a lock

---
 src/c/urweb.c | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 1201b09b..1c66e9e8 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -4023,9 +4023,13 @@ uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) {
   return uw_unit_v;
 }
 
+static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER;
+
 uw_Basis_int uw_Basis_rand(uw_context ctx) {
   uw_Basis_int ret;
+  pthread_mutex_lock(&rand_mutex);
   int r = RAND_bytes((unsigned char *)&ret, sizeof ret);
+  pthread_mutex_unlock(&rand_mutex);
   
   if (r)
     return abs(ret);
-- 
cgit v1.2.3


From fdeb6edadce0a9da274449ac1450e871e183734b Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 12 Dec 2013 10:24:38 -0500
Subject: HTTP: avoid duplicate Content-length

---
 include/urweb/urweb_cpp.h |  1 +
 src/c/http.c              | 11 +++++++----
 src/c/urweb.c             |  8 ++++++--
 3 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index d1fb4d37..cf046e83 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -209,6 +209,7 @@ uw_Basis_string uw_Basis_requestHeader(struct uw_context *, uw_Basis_string);
 
 void uw_write_header(struct uw_context *, uw_Basis_string);
 void uw_clear_headers(struct uw_context *);
+int uw_has_contentLength(struct uw_context *);
 void uw_Basis_clear_page(struct uw_context *);
 
 uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c);
diff --git a/src/c/http.c b/src/c/http.c
index d19ce350..ebe50bea 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -233,8 +233,6 @@ static void *worker(void *data) {
                         sock, uw_really_send, close);
 
         if (rr != KEEP_OPEN) {
-          char clen[100];
-
           if (keepalive) {
             char *connection = uw_Basis_requestHeader(ctx, "Connection");
 
@@ -244,8 +242,13 @@ static void *worker(void *data) {
           if (!should_keepalive)
             uw_write_header(ctx, "Connection: close\r\n");
 
-          sprintf(clen, "Content-length: %d\r\n", uw_pagelen(ctx));
-          uw_write_header(ctx, clen);
+          if (!uw_has_contentLength(ctx)) {
+            char clen[100];
+
+            sprintf(clen, "Content-length: %d\r\n", uw_pagelen(ctx));
+            uw_write_header(ctx, clen);
+          }
+
           uw_send(ctx, sock);
         }
 
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 1c66e9e8..9641333c 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1347,6 +1347,10 @@ void uw_write_header(uw_context ctx, uw_Basis_string s) {
   ctx->outHeaders.front += len;
 }
 
+int uw_has_contentLength(uw_context ctx) {
+  return strstr(ctx->outHeaders.start, "Content-length: ") != NULL;
+}
+
 void uw_clear_headers(uw_context ctx) {
   uw_buffer_reset(&ctx->outHeaders);
 }
@@ -3723,7 +3727,7 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
   uw_write_header(ctx, on_success);
   uw_write_header(ctx, "Content-Type: ");
   uw_write_header(ctx, mimeType);
-  uw_write_header(ctx, "\r\nContent-Length: ");
+  uw_write_header(ctx, "\r\nContent-length: ");
   ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
   sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)b.size, &len);
   ctx->outHeaders.front += len;
@@ -3755,7 +3759,7 @@ __attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis
   uw_write_header(ctx, on_success);
   uw_write_header(ctx, "Content-Type: ");
   uw_write_header(ctx, mimeType);
-  uw_write_header(ctx, "\r\nContent-Length: ");
+  uw_write_header(ctx, "\r\nContent-length: ");
   ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
   sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len);
   ctx->outHeaders.front += len;
-- 
cgit v1.2.3


From 106d1b7275e44cf419665e92b2682e009b51f095 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 12 Dec 2013 10:31:34 -0500
Subject: Only output Content-script-type header when there is client-side code

---
 src/cjr_print.sml | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index dec21eb3..798492d6 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3072,8 +3072,10 @@ fun p_file env (ds, ps) =
                                              newline]
                             | _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");",
                                     newline,
-                                    string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
-                                    newline,
+                                    case side of
+                                        ServerOnly => box []
+                                      | _ => box [string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
+                                                  newline],
                                     string "uw_write(ctx, begin_xhtml);",
                                     newline,
                                     string "uw_mayReturnIndirectly(ctx);",
-- 
cgit v1.2.3


From a24c2bdaf85c3d4eef19783e95b11d1cf15add09 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 12 Dec 2013 17:42:48 -0500
Subject: Start SQL transactions as read-only when possible, based on
 conservative program analysis

---
 include/urweb/types_cpp.h |  2 +-
 include/urweb/urweb_cpp.h |  1 +
 src/c/cgi.c               |  3 +--
 src/c/fastcgi.c           |  3 +--
 src/c/http.c              |  3 +--
 src/c/urweb.c             | 21 ++++++++++-----------
 src/cjr_print.sml         | 13 ++++++++++++-
 src/corify.sml            |  2 +-
 src/effectize.sml         | 10 ++++++++--
 src/export.sig            |  2 +-
 src/export.sml            |  4 ++--
 src/mysql.sml             |  2 +-
 src/postgres.sml          |  4 ++--
 src/sqlite.sml            |  2 +-
 src/tag.sml               |  6 +++---
 15 files changed, 46 insertions(+), 32 deletions(-)

diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index 330f7755..789aecb1 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -82,7 +82,7 @@ typedef struct {
   void (*expunger)(struct uw_context *, uw_Basis_client);
 
   void (*db_init)(struct uw_context *);
-  int (*db_begin)(struct uw_context *);
+  int (*db_begin)(struct uw_context *, int could_write);
   int (*db_commit)(struct uw_context *);
   int (*db_rollback)(struct uw_context *);
   void (*db_close)(struct uw_context *);
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index cf046e83..8dfffdf9 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -86,6 +86,7 @@ uw_Basis_string uw_Basis_maybe_onunload(struct uw_context *, uw_Basis_string);
 
 void uw_set_needs_push(struct uw_context *, int);
 void uw_set_needs_sig(struct uw_context *, int);
+void uw_set_could_write_db(struct uw_context *, int);
 
 char *uw_Basis_htmlifyInt(struct uw_context *, uw_Basis_int);
 char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float);
diff --git a/src/c/cgi.c b/src/c/cgi.c
index 52c0ca2e..c9ec744a 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -134,8 +134,7 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  if (uw_get_app(ctx)->db_begin(ctx))
-    uw_error(ctx, FATAL, "Error running SQL BEGIN");
+  uw_ensure_transaction(ctx);
   uw_get_app(ctx)->expunger(ctx, cli);
   uw_commit(ctx);
 }
diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index 9e3c8d7e..d6d2391d 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -632,8 +632,7 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  if (uw_get_app(ctx)->db_begin(ctx))
-    uw_error(ctx, FATAL, "Error running SQL BEGIN");
+  uw_ensure_transaction(ctx);
   uw_get_app(ctx)->expunger(ctx, cli);
   uw_commit(ctx);
 }
diff --git a/src/c/http.c b/src/c/http.c
index ebe50bea..230d07f0 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -438,8 +438,7 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  if (uw_get_app(ctx)->db_begin(ctx))
-    uw_error(ctx, FATAL, "Error running SQL BEGIN");
+  uw_ensure_transaction(ctx);
   uw_get_app(ctx)->expunger(ctx, cli);
   uw_commit(ctx);
 }
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 9641333c..3082f110 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -441,7 +441,7 @@ struct uw_context {
 
   const char *script_header;
 
-  int needs_push, needs_sig;
+  int needs_push, needs_sig, could_write_db;
 
   size_t n_deltas, used_deltas;
   delta *deltas;
@@ -517,6 +517,7 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
   ctx->script_header = "";
   ctx->needs_push = 0;
   ctx->needs_sig = 0;
+  ctx->could_write_db = 1;
 
   ctx->source_count = 0;
 
@@ -777,7 +778,7 @@ failure_kind uw_begin(uw_context ctx, char *path) {
 
 void uw_ensure_transaction(uw_context ctx) {
   if (!ctx->transaction_started) {
-    if (ctx->app->db_begin(ctx))
+    if (ctx->app->db_begin(ctx, ctx->could_write_db))
       uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
     ctx->transaction_started = 1;
   }
@@ -1191,6 +1192,10 @@ void uw_set_needs_sig(uw_context ctx, int n) {
   ctx->needs_sig = n;
 }
 
+void uw_set_could_write_db(uw_context ctx, int n) {
+  ctx->could_write_db = n;
+}
+
 
 static void uw_buffer_check_ctx(uw_context ctx, const char *kind, uw_buffer *b, size_t extra, const char *desc) {
   if (b->back - b->front < extra) {
@@ -3466,9 +3471,7 @@ failure_kind uw_initialize(uw_context ctx) {
   int r = setjmp(ctx->jmp_buf);
 
   if (r == 0) {
-    if (ctx->app->db_begin(ctx))
-      uw_error(ctx, FATAL, "Error running SQL BEGIN");
-    ctx->transaction_started = 1;
+    uw_ensure_transaction(ctx);
     ctx->app->initializer(ctx);
     if (ctx->app->db_commit(ctx))
       uw_error(ctx, FATAL, "Error running SQL COMMIT");
@@ -4085,9 +4088,7 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
   int r = setjmp(ctx->jmp_buf);
 
   if (r == 0) {
-    if (ctx->app->db_begin(ctx))
-      uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
-    ctx->transaction_started = 1;
+    uw_ensure_transaction(ctx);
 
     callback(ctx);
   }
@@ -4134,9 +4135,7 @@ failure_kind uw_begin_onError(uw_context ctx, char *msg) {
 
   if (ctx->app->on_error) {
     if (r == 0) {
-      if (ctx->app->db_begin(ctx))
-        uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
-      ctx->transaction_started = 1;
+      uw_ensure_transaction(ctx);
 
       uw_buffer_reset(&ctx->outHeaders);
       if (on_success[0])
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 798492d6..5d697eac 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3001,11 +3001,18 @@ fun p_file env (ds, ps) =
 
                 fun couldWrite ek =
                     case ek of
-                        Link => false
+                        Link _ => false
                       | Action ef => ef = ReadCookieWrite
                       | Rpc ef => ef = ReadCookieWrite
                       | Extern _ => false
 
+                fun couldWriteDb ek =
+                    case ek of
+                        Link ef => ef <> ReadOnly
+                      | Action ef => ef <> ReadOnly
+                      | Rpc ef => ef <> ReadOnly
+                      | Extern ef => ef <> ReadOnly
+
                 val s =
                     case Settings.getUrlPrefix () of
                         "" => s
@@ -3091,6 +3098,10 @@ fun p_file env (ds, ps) =
                                     end,
                                     string "\");",
                                     newline]),
+                     string "uw_set_could_write_db(ctx, ",
+                     string (if couldWriteDb ek then "1" else "0"),
+                     string ");",
+                     newline,
                      string "uw_set_needs_push(ctx, ",
                      string (case side of
                                  ServerAndPullAndPush => "1"
diff --git a/src/corify.sml b/src/corify.sml
index c06d62ca..c1c60045 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1046,7 +1046,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
                                                                                 | _ => false) args then
                                                                L'.Extern L'.ReadCookieWrite
                                                            else
-                                                               L'.Link
+                                                               L'.Link L'.ReadCookieWrite
                                          in
                                              ((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds,
                                               (fn st =>
diff --git a/src/effectize.sml b/src/effectize.sml
index 6ced952b..d711e620 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -153,7 +153,7 @@ fun effectize file =
                 in
                     (d, loop (writers, readers, pushers))
                 end
-              | DExport (Link, n, t) =>
+              | DExport (Link _, n, t) =>
                 (case IM.find (writers, n) of
                      NONE => ()
                    | SOME (loc, s) =>
@@ -162,7 +162,13 @@ fun effectize file =
                      else
                          ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s
                                                ^ "\") accessible via GET could cause side effects; try accessing it only via forms, removing it from the signature of the main program module, or whitelisting it with the 'safeGet' .urp directive");
-                 ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs))
+                 ((DExport (Link (if IM.inDomain (writers, n) then
+                                      if IM.inDomain (readers, n) then
+                                          ReadCookieWrite
+                                      else
+                                          ReadWrite
+                                  else
+                                      ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs))
               | DExport (Action _, n, _) =>
                 ((DExport (Action (if IM.inDomain (writers, n) then
                                        if IM.inDomain (readers, n) then
diff --git a/src/export.sig b/src/export.sig
index 9bcfa0d4..881459c5 100644
--- a/src/export.sig
+++ b/src/export.sig
@@ -33,7 +33,7 @@ datatype effect =
        | ReadWrite
 
 datatype export_kind =
-         Link
+         Link of effect
        | Action of effect
        | Rpc of effect
        | Extern of effect
diff --git a/src/export.sml b/src/export.sml
index 5d200894..a99d0b70 100644
--- a/src/export.sml
+++ b/src/export.sml
@@ -36,7 +36,7 @@ datatype effect =
        | ReadWrite
 
 datatype export_kind =
-         Link
+         Link of effect
        | Action of effect
        | Rpc of effect
        | Extern of effect
@@ -49,7 +49,7 @@ fun p_effect ef =
 
 fun p_export_kind ck =
     case ck of
-        Link => string "link"
+        Link ef => box [string "link(", p_effect ef, string ")"]
       | Action ef => box [string "action(", p_effect ef, string ")"]
       | Rpc ef => box [string "rpc(", p_effect ef, string ")"]
       | Extern ef => box [string "extern(", p_effect ef, string ")"]
diff --git a/src/mysql.sml b/src/mysql.sml
index c70a1cdd..884cde36 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -577,7 +577,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
              newline,
              newline,
 
-             string "static int uw_db_begin(uw_context ctx) {",
+             string "static int uw_db_begin(uw_context ctx, int could_write) {",
              newline,
              string "uw_conn *conn = uw_get_db(ctx);",
              newline,
diff --git a/src/postgres.sml b/src/postgres.sml
index 41529173..272097e7 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -402,11 +402,11 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
          newline,
          newline,
 
-         string "static int uw_db_begin(uw_context ctx) {",
+         string "static int uw_db_begin(uw_context ctx, int could_write) {",
          newline,
          string "PGconn *conn = uw_get_db(ctx);",
          newline,
-         string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
+         string "PGresult *res = PQexec(conn, could_write ? \"BEGIN ISOLATION LEVEL SERIALIZABLE\" : \"BEGIN ISOLATION LEVEL SERIALIZABLE, READ ONLY\");",
          newline,
          newline,
          string "if (res == NULL) return 1;",
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 09c4c683..c138415b 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -344,7 +344,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
              newline,
              newline,
 
-             string "static int uw_db_begin(uw_context ctx) {",
+             string "static int uw_db_begin(uw_context ctx, int could_write) {",
              newline,
              string "uw_conn *conn = uw_get_db(ctx);",
              newline,
diff --git a/src/tag.sml b/src/tag.sml
index 9c4807c6..865e7f53 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -145,7 +145,7 @@ fun exp env (e, s) =
                                                        end
                                                in
                                                    case x of
-                                                       (CName "Link", _) => tagIt' (Link, "Link")
+                                                       (CName "Link", _) => tagIt' (Link ReadWrite, "Link")
                                                      | (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
                                                      | _ => ((x, e, t), s)
                                                end)
@@ -180,7 +180,7 @@ fun exp env (e, s) =
 
           | EFfiApp ("Basis", "url", [(e, t)]) =>
             let
-                val (e, s) = tagIt (e, Link, "Url", s)
+                val (e, s) = tagIt (e, Link ReadWrite, "Url", s)
             in
                 (EFfiApp ("Basis", "url", [(e, t)]), s)
             end
@@ -201,7 +201,7 @@ fun exp env (e, s) =
                 case eo of
                     SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
                     let
-                        val (e, s) = tagIt (e', Link, "Url", s)
+                        val (e, s) = tagIt (e', Link ReadWrite, "Url", s)
                     in
                         (EFfiApp ("Basis", "url", [(e, t)]), s)
                     end
-- 
cgit v1.2.3


From 2f6649aa0b392fefe08e3eb604a93220a0c64324 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 17 Dec 2013 20:12:33 -0500
Subject: Fix compilation of apps that don't use database; fix HTTP pipelining

---
 src/c/http.c      | 47 ++++++++++++++++++++++++++++-------------------
 src/cjr_print.sml |  2 +-
 2 files changed, 29 insertions(+), 20 deletions(-)

diff --git a/src/c/http.c b/src/c/http.c
index 230d07f0..c57740e9 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -73,7 +73,7 @@ static void log_debug(void *data, const char *fmt, ...) {
 static void *worker(void *data) {
   int me = *(int *)data;
   uw_context ctx = uw_request_new_context(me, &uw_application, NULL, log_error, log_debug);
-  size_t buf_size = 2;
+  size_t buf_size = 1024;
   char *buf = malloc(buf_size), *back = buf;
   uw_request_context rc = uw_new_request_context();
   int sock = 0;
@@ -99,28 +99,32 @@ static void *worker(void *data) {
         buf = new_buf;
       }
 
-      r = recv(sock, back, buf_size - 1 - (back - buf), 0);
+      *back = 0;
+      body = strstr(buf, "\r\n\r\n");
+      if (body == NULL) {
+        r = recv(sock, back, buf_size - 1 - (back - buf), 0);
 
-      if (r < 0) {
-        if (!quiet)
-          fprintf(stderr, "Recv failed\n");
-        close(sock);
-        sock = 0;
-        break;
-      }
+        if (r < 0) {
+          if (!quiet)
+            fprintf(stderr, "Recv failed\n");
+          close(sock);
+          sock = 0;
+          break;
+        }
 
-      if (r == 0) {
-        if (!quiet)
-          printf("Connection closed.\n");
-        close(sock);
-        sock = 0;
-        break;
-      }
+        if (r == 0) {
+          if (!quiet)
+            printf("Connection closed.\n");
+          close(sock);
+          sock = 0;
+          break;
+        }
 
-      back += r;
-      *back = 0;
+        back += r;
+        *back = 0;
+      }
 
-      if ((body = strstr(buf, "\r\n\r\n"))) {
+      if (body != NULL || (body = strstr(buf, "\r\n\r\n"))) {
         request_result rr;
         int should_keepalive = 0;
 
@@ -213,6 +217,11 @@ static void *worker(void *data) {
 
         s = headers;
         while ((s2 = strchr(s, '\r'))) {
+          if (s2 == s) {
+            *s = 0;
+            break;
+          }
+
           s = s2;
 
           if (s[1] == 0)
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 5d697eac..1fc0b40f 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3364,7 +3364,7 @@ fun p_file env (ds, ps) =
                       newline,
                       string "static void uw_db_init(uw_context ctx) { };",
                       newline,
-                      string "static int uw_db_begin(uw_context ctx) { return 0; };",
+                      string "static int uw_db_begin(uw_context ctx, int could_write) { return 0; };",
                       newline,
                       string "static void uw_db_close(uw_context ctx) { };",
                       newline,
-- 
cgit v1.2.3


From fac05ae0a6d7d080436c953d2085e137d75c5796 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Mon, 23 Dec 2013 15:59:17 +0000
Subject: Proper handling of serialization failures during SQL COMMIT

---
 include/urweb/urweb_cpp.h |  3 ++-
 src/c/cgi.c               |  7 ++++---
 src/c/fastcgi.c           |  7 ++++---
 src/c/http.c              |  7 ++++---
 src/c/request.c           |  6 ++++--
 src/c/urweb.c             | 29 ++++++++++++++++++++++-------
 src/postgres.sml          | 18 +++++++++++++++++-
 7 files changed, 57 insertions(+), 20 deletions(-)

diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 8dfffdf9..248e54e4 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -40,7 +40,8 @@ failure_kind uw_begin(struct uw_context *, char *path);
 void uw_ensure_transaction(struct uw_context *);
 failure_kind uw_begin_onError(struct uw_context *, char *msg);
 void uw_login(struct uw_context *);
-void uw_commit(struct uw_context *);
+int uw_commit(struct uw_context *);
+// ^-- returns nonzero if the transaction should be restarted
 int uw_rollback(struct uw_context *, int will_retry);
 
 __attribute__((noreturn)) void uw_error(struct uw_context *, failure_kind, const char *fmt, ...);
diff --git a/src/c/cgi.c b/src/c/cgi.c
index c9ec744a..f1482589 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -134,9 +134,10 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  uw_ensure_transaction(ctx);
-  uw_get_app(ctx)->expunger(ctx, cli);
-  uw_commit(ctx);
+  do {
+    uw_ensure_transaction(ctx);
+    uw_get_app(ctx)->expunger(ctx, cli);
+  } while (uw_commit(ctx) && (uw_rollback(ctx, 1), 1));
 }
 
 void uw_post_expunge(uw_context ctx, void *data) {
diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index d6d2391d..bbda0f57 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -632,9 +632,10 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  uw_ensure_transaction(ctx);
-  uw_get_app(ctx)->expunger(ctx, cli);
-  uw_commit(ctx);
+  do {
+    uw_ensure_transaction(ctx);
+    uw_get_app(ctx)->expunger(ctx, cli);
+  } while (uw_commit(ctx) && (uw_rollback(ctx, 1), 1));
 }
 
 void uw_post_expunge(uw_context ctx, void *data) {
diff --git a/src/c/http.c b/src/c/http.c
index c57740e9..9050aaf4 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -447,9 +447,10 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  uw_ensure_transaction(ctx);
-  uw_get_app(ctx)->expunger(ctx, cli);
-  uw_commit(ctx);
+  do {
+    uw_ensure_transaction(ctx);
+    uw_get_app(ctx)->expunger(ctx, cli);
+  } while (uw_commit(ctx) && (uw_rollback(ctx, 1), 1));
 }
 
 void uw_post_expunge(uw_context ctx, void *data) {
diff --git a/src/c/request.c b/src/c/request.c
index 5973d979..b925cc3c 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -116,8 +116,10 @@ static void *periodic_loop(void *data) {
           return NULL;
     } while (r == UNLIMITED_RETRY || (r == BOUNDED_RETRY && retries_left > 0));
 
-    if (r != FATAL && r != BOUNDED_RETRY)
-      uw_commit(ctx);
+    if (r != FATAL && r != BOUNDED_RETRY) {
+      if (uw_commit(ctx))
+	r = UNLIMITED_RETRY;
+    }
 
     sleep(p->pdic.period);
   };
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 3082f110..57f57694 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3253,13 +3253,13 @@ static char *find_sig(char *haystack) {
   return s;
 }
 
-void uw_commit(uw_context ctx) {
+int uw_commit(uw_context ctx) {
   int i;
   char *sig;
 
   if (uw_has_error(ctx)) {
     uw_rollback(ctx, 0);
-    return;
+    return 0;
   }
 
   for (i = ctx->used_transactionals-1; i >= 0; --i)
@@ -3268,7 +3268,7 @@ void uw_commit(uw_context ctx) {
         ctx->transactionals[i].commit(ctx->transactionals[i].data);
         if (uw_has_error(ctx)) {
           uw_rollback(ctx, 0);
-          return;
+          return 0;
         }
       }
 
@@ -3278,13 +3278,26 @@ void uw_commit(uw_context ctx) {
         ctx->transactionals[i].commit(ctx->transactionals[i].data);
         if (uw_has_error(ctx)) {
           uw_rollback(ctx, 0);
-          return;
+          return 0;
         }
       }
 
-  if (ctx->transaction_started && ctx->app->db_commit(ctx)) {
-    uw_set_error_message(ctx, "Error running SQL COMMIT");
-    return;
+  if (ctx->transaction_started) {
+    int code =ctx->app->db_commit(ctx);
+
+    if (code) {
+      if (code == -1) {
+	uw_rollback(ctx, 1);
+	return 1;
+      }
+
+      for (i = ctx->used_transactionals-1; i >= 0; --i)
+	if (ctx->transactionals[i].free)
+	  ctx->transactionals[i].free(ctx->transactionals[i].data, 0);
+
+      uw_set_error_message(ctx, "Error running SQL COMMIT");
+      return 0;
+    }
   }
 
   for (i = 0; i < ctx->used_deltas; ++i) {
@@ -3390,6 +3403,8 @@ void uw_commit(uw_context ctx) {
       } while (sig);
     }
   }
+
+  return 0;
 }
 
 
diff --git a/src/postgres.sml b/src/postgres.sml
index 272097e7..8cfa5f48 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -438,7 +438,23 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
          newline,
          newline,
          string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
-         box [string "PQclear(res);",
+         box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
+              box [newline,
+                   string "PQclear(res);",
+                   newline,
+                   string "return -1;",
+                   newline],
+              string "}",
+              newline,
+              string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
+              box [newline,
+                   string "PQclear(res);",
+                   newline,
+                   string "return -1;",
+                   newline],
+              string "}",
+              newline,
+	      string "PQclear(res);",
               newline,
               string "return 1;",
               newline],
-- 
cgit v1.2.3


From 718185cc88b56e376d4fe4f973accaa6d7c33675 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 25 Dec 2013 11:43:41 -0500
Subject: No need to ROLLBACK after a failed COMMIT

---
 src/c/urweb.c | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 57f57694..ab6e5b1f 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3283,13 +3283,11 @@ int uw_commit(uw_context ctx) {
       }
 
   if (ctx->transaction_started) {
-    int code =ctx->app->db_commit(ctx);
+    int code = ctx->app->db_commit(ctx);
 
     if (code) {
-      if (code == -1) {
-	uw_rollback(ctx, 1);
+      if (code == -1)
 	return 1;
-      }
 
       for (i = ctx->used_transactionals-1; i >= 0; --i)
 	if (ctx->transactionals[i].free)
-- 
cgit v1.2.3


From 2555c24cbd50d7afc517f7c9e6cac77ba87f0d99 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 25 Dec 2013 12:02:42 -0500
Subject: Add a bit of manual clarification about channels and clients

---
 doc/manual.tex | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/doc/manual.tex b/doc/manual.tex
index 968d93eb..9bc52f4c 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2194,7 +2194,7 @@ $$\begin{array}{l}
   \mt{val} \; \mt{self} : \mt{transaction} \; \mt{client}
 \end{array}$$
 
-\emph{Channels} are the means of message-passing.  Each channel is created in the context of a client and belongs to that client; no other client may receive the channel's messages.  Each channel type includes the type of values that may be sent over the channel.  Sending and receiving are asynchronous, in the sense that a client need not be ready to receive a message right away.  Rather, sent messages may queue up, waiting to be processed.
+\emph{Channels} are the means of message-passing.  Each channel is created in the context of a client and belongs to that client; no other client may receive the channel's messages.  Note that here \emph{client} has a technical Ur/Web meaning so that it describes only \emph{single page views}, so a user following a traditional link within an application will remove the ability for \emph{any} code to receive messages on the channels associated with the previous client.  Each channel type includes the type of values that may be sent over the channel.  Sending and receiving are asynchronous, in the sense that a client need not be ready to receive a message right away.  Rather, sent messages may queue up, waiting to be processed.
 
 $$\begin{array}{l}
   \mt{con} \; \mt{channel} :: \mt{Type} \to \mt{Type} \\
-- 
cgit v1.2.3


From aea9e6db8a7a72dd555913a38cb893d247c3c09e Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 25 Dec 2013 13:11:43 -0500
Subject: Tweaking handling of database transactions

---
 src/c/cgi.c     | 9 +++++----
 src/c/fastcgi.c | 9 +++++----
 src/c/http.c    | 9 +++++----
 src/c/urweb.c   | 8 ++++++--
 4 files changed, 21 insertions(+), 14 deletions(-)

diff --git a/src/c/cgi.c b/src/c/cgi.c
index f1482589..539b83c2 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -134,10 +134,11 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  do {
-    uw_ensure_transaction(ctx);
-    uw_get_app(ctx)->expunger(ctx, cli);
-  } while (uw_commit(ctx) && (uw_rollback(ctx, 1), 1));
+  uw_ensure_transaction(ctx);
+  uw_get_app(ctx)->expunger(ctx, cli);
+
+  if (uw_commit(ctx))
+    uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction");
 }
 
 void uw_post_expunge(uw_context ctx, void *data) {
diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index bbda0f57..5c80d3ae 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -632,10 +632,11 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  do {
-    uw_ensure_transaction(ctx);
-    uw_get_app(ctx)->expunger(ctx, cli);
-  } while (uw_commit(ctx) && (uw_rollback(ctx, 1), 1));
+  uw_ensure_transaction(ctx);
+  uw_get_app(ctx)->expunger(ctx, cli);
+
+  if (uw_commit(ctx))
+    uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction");
 }
 
 void uw_post_expunge(uw_context ctx, void *data) {
diff --git a/src/c/http.c b/src/c/http.c
index 9050aaf4..17833ce1 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -447,10 +447,11 @@ void uw_copy_client_data(void *dst, void *src) {
 }
 
 void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
-  do {
-    uw_ensure_transaction(ctx);
-    uw_get_app(ctx)->expunger(ctx, cli);
-  } while (uw_commit(ctx) && (uw_rollback(ctx, 1), 1));
+  uw_ensure_transaction(ctx);
+  uw_get_app(ctx)->expunger(ctx, cli);
+
+  if (uw_commit(ctx))
+    uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction");
 }
 
 void uw_post_expunge(uw_context ctx, void *data) {
diff --git a/src/c/urweb.c b/src/c/urweb.c
index ab6e5b1f..af5cc461 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3225,7 +3225,11 @@ int uw_rollback(uw_context ctx, int will_retry) {
     if (ctx->transactionals[i].free)
       ctx->transactionals[i].free(ctx->transactionals[i].data, will_retry);
 
-  return (ctx->app && ctx->transaction_started) ? ctx->app->db_rollback(ctx) : 0;
+  if (ctx->app && ctx->transaction_started) {
+    ctx->transaction_started = 0;
+    return ctx->app->db_rollback(ctx);
+  } else
+    return 0;
 }
 
 static const char begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">";
@@ -3461,8 +3465,8 @@ void uw_prune_clients(uw_context ctx) {
         prev->next = next;
       else
         clients_used = next;
-      uw_reset(ctx);
       while (fk == UNLIMITED_RETRY) {
+        uw_reset(ctx);
         fk = uw_expunge(ctx, c->id, c->data);
         if (fk == UNLIMITED_RETRY)
           printf("Unlimited retry during expunge: %s\n", uw_error_message(ctx));
-- 
cgit v1.2.3


From d99d4f09bb2947a09eb6e1c12057bd805dac070c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 27 Dec 2013 12:10:03 -0500
Subject: Raise exception when recv()ing from someone else's channel; improve
 setting of client ID in RPCs

---
 lib/js/urweb.js        |  2 +-
 src/c/urweb.c          | 48 +++++++++++++++++++++++-------------------------
 tests/channelThief.ur  | 32 ++++++++++++++++++++++++++++++++
 tests/channelThief.urp |  5 +++++
 tests/channelThief.urs |  1 +
 5 files changed, 62 insertions(+), 26 deletions(-)
 create mode 100644 tests/channelThief.ur
 create mode 100644 tests/channelThief.urp
 create mode 100644 tests/channelThief.urs

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index e211d318..6830945a 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1575,7 +1575,7 @@ function rv(chn, parse, k) {
         er("May not 'recv' in main thread of 'code' for <active>");
 
     if (chn == null)
-        return;
+        er("Client-side code tried to recv() from a channel belonging to a different page view.");
 
     if (chn < 0)
         whine("Out-of-bounds channel receive");
diff --git a/src/c/urweb.c b/src/c/urweb.c
index af5cc461..0265c67f 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -734,36 +734,34 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) {
 char *uw_Basis_htmlifyString(uw_context, const char *);
 
 void uw_login(uw_context ctx) {
-  if (ctx->needs_push) {
-    char *id_s, *pass_s;
+  char *id_s, *pass_s;
 
-    if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client"))
-        && (pass_s = uw_Basis_requestHeader(ctx, "UrWeb-Pass"))) {
-      unsigned id = atoi(id_s);
-      int pass = atoi(pass_s);
-      client *c = find_client(id);
-
-      if (c == NULL)
-        uw_error(ctx, FATAL, "Unknown client ID in HTTP headers (%s, %s)", uw_Basis_htmlifyString(ctx, id_s), uw_Basis_htmlifyString(ctx, pass_s));
-      else {
-        use_client(c);
-        ctx->client = c;
-
-        if (c->mode != USED)
-          uw_error(ctx, FATAL, "Stale client ID (%u) in subscription request", id);
-        if (c->pass != pass)
-          uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass);
-      }
-    } else {
-      client *c = new_client();
-
-      if (c == NULL)
-        uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients");
+  if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client"))
+      && (pass_s = uw_Basis_requestHeader(ctx, "UrWeb-Pass"))) {
+    unsigned id = atoi(id_s);
+    int pass = atoi(pass_s);
+    client *c = find_client(id);
 
+    if (c == NULL)
+      uw_error(ctx, FATAL, "Unknown client ID in HTTP headers (%s, %s)", uw_Basis_htmlifyString(ctx, id_s), uw_Basis_htmlifyString(ctx, pass_s));
+    else {
       use_client(c);
-      uw_copy_client_data(c->data, ctx->client_data);
       ctx->client = c;
+
+      if (c->mode != USED)
+        uw_error(ctx, FATAL, "Stale client ID (%u) in subscription request", id);
+      if (c->pass != pass)
+        uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass);
     }
+  } else if (ctx->needs_push) {
+    client *c = new_client();
+
+    if (c == NULL)
+      uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients");
+
+    use_client(c);
+    uw_copy_client_data(c->data, ctx->client_data);
+    ctx->client = c;
   }
 }
 
diff --git a/tests/channelThief.ur b/tests/channelThief.ur
new file mode 100644
index 00000000..1893979a
--- /dev/null
+++ b/tests/channelThief.ur
@@ -0,0 +1,32 @@
+table t : { Ch : channel string }
+
+fun go () =
+    let
+        fun overwrite () =
+            dml (DELETE FROM t WHERE TRUE);
+            ch <- channel;
+            dml (INSERT INTO t (Ch) VALUES ({[ch]}));
+            return ch
+
+        fun retrieve () =
+            oneRowE1 (SELECT (t.Ch) FROM t)
+
+        fun transmit () =
+            ch <- retrieve ();
+            send ch "Test"
+
+        fun listenOn ch =
+            s <- recv ch;
+            alert s
+    in
+        ch <- overwrite ();
+        return <xml><body onload={listenOn ch}>
+          <button value="overwrite" onclick={fn _ => ch <- rpc (overwrite ()); listenOn ch}/>
+          <button value="retrieve" onclick={fn _ => ch <- rpc (retrieve ()); listenOn ch}/>
+          <button value="transmit" onclick={fn _ => rpc (transmit ())}/>
+        </body></xml>
+    end
+
+fun main () = return <xml><body>
+  <form><submit action={go}/></form>
+</body></xml>
diff --git a/tests/channelThief.urp b/tests/channelThief.urp
new file mode 100644
index 00000000..dee402d4
--- /dev/null
+++ b/tests/channelThief.urp
@@ -0,0 +1,5 @@
+database dbname=test
+sql channelThief.sql
+rewrite url ChannelThief/*
+
+channelThief
diff --git a/tests/channelThief.urs b/tests/channelThief.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/channelThief.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3


From 27a80131fdfd2915c374aee33c444469edb44666 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 27 Dec 2013 12:30:44 -0500
Subject: Change where a transaction is marked finished, to avoid forgetting to
 rollback a failed transaction

---
 src/c/urweb.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 0265c67f..0a385cae 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -634,7 +634,6 @@ void uw_reset_keep_error_message(uw_context ctx) {
   ctx->amInitializing = 0;
   ctx->usedSig = 0;
   ctx->needsResig = 0;
-  ctx->transaction_started = 0;
 }
 
 void uw_reset_keep_request(uw_context ctx) {
@@ -648,6 +647,7 @@ void uw_reset(uw_context ctx) {
     memset(ctx->inputs, 0, ctx->app->inputs_len * sizeof(input));
   memset(ctx->subinputs, 0, ctx->n_subinputs * sizeof(input));
   ctx->used_subinputs = ctx->hasPostBody = ctx->isPost = 0;
+  ctx->transaction_started = 0;
 }
 
 failure_kind uw_begin_init(uw_context ctx) {
-- 
cgit v1.2.3


From 057c34363567b9047afac15a763b18ba5cf1eeaa Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 28 Dec 2013 06:27:08 -0500
Subject: Make HTTP keepalive switch between available connections to improve
 throughput

---
 src/c/http.c | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/src/c/http.c b/src/c/http.c
index 17833ce1..a0a8c1c9 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -266,8 +266,18 @@ static void *worker(void *data) {
             // In case any other requests are queued up, shift
             // unprocessed part of buffer to front.
             int kept = back - after;
-            memmove(buf, after, kept);
-            back = buf + kept;
+
+            if (/kept == 0) {
+              // No pipelining going on here.
+              // We'd might as well try to switch to a different connection,
+              // while we wait for more input on this one.
+              uw_enqueue(sock);
+              sock = 0;
+            } else {
+              // More input!  Move it to the front and continue in this loop.
+              memmove(buf, after, kept);
+              back = buf + kept;
+            }
           } else {
             close(sock);
             sock = 0;
-- 
cgit v1.2.3


From efba66057b97d1f207f29a0f4b1e5ede66f9fe2b Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 28 Dec 2013 06:30:21 -0500
Subject: How embarrassing; didn't try compiling before committing

---
 src/c/http.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/c/http.c b/src/c/http.c
index a0a8c1c9..18e188da 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -267,7 +267,7 @@ static void *worker(void *data) {
             // unprocessed part of buffer to front.
             int kept = back - after;
 
-            if (/kept == 0) {
+            if (kept == 0) {
               // No pipelining going on here.
               // We'd might as well try to switch to a different connection,
               // while we wait for more input on this one.
-- 
cgit v1.2.3


From 44c3bfba2420a555eee8fefe7377d059c4666ef8 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 29 Dec 2013 10:29:26 -0500
Subject: Avoid some spurious error messages about link/form incompatibility;
 change the text of that error message to include RPC handlers

---
 src/tag.sml | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/tag.sml b/src/tag.sml
index 865e7f53..6fef50d1 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -41,9 +41,9 @@ structure SM = BinaryMapFn(struct
 fun kind (k, s) = (k, s)
 fun con (c, s) = (c, s)
 
-fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a link and a form");
+fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for multiple modes (link, form, RPC handler).");
                      TextIO.output (TextIO.stdErr,
-                                    "Make sure that the signature of the containing module hides any form handlers.\n"))
+                                    "Make sure that the signature of the containing module hides any form/RPC handlers.\n"))
 
 fun exp env (e, s) =
     let
@@ -145,7 +145,7 @@ fun exp env (e, s) =
                                                        end
                                                in
                                                    case x of
-                                                       (CName "Link", _) => tagIt' (Link ReadWrite, "Link")
+                                                       (CName "Link", _) => tagIt' (Link ReadCookieWrite, "Link")
                                                      | (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
                                                      | _ => ((x, e, t), s)
                                                end)
@@ -180,7 +180,7 @@ fun exp env (e, s) =
 
           | EFfiApp ("Basis", "url", [(e, t)]) =>
             let
-                val (e, s) = tagIt (e, Link ReadWrite, "Url", s)
+                val (e, s) = tagIt (e, Link ReadCookieWrite, "Url", s)
             in
                 (EFfiApp ("Basis", "url", [(e, t)]), s)
             end
@@ -201,7 +201,7 @@ fun exp env (e, s) =
                 case eo of
                     SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
                     let
-                        val (e, s) = tagIt (e', Link ReadWrite, "Url", s)
+                        val (e, s) = tagIt (e', Link ReadCookieWrite, "Url", s)
                     in
                         (EFfiApp ("Basis", "url", [(e, t)]), s)
                     end
-- 
cgit v1.2.3


From ca6926d0e0d1af6ea0531c6c558943beb08f646c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 29 Dec 2013 13:18:50 -0500
Subject: Compile-time error for periodic tasks in nonpersistent protocols

---
 src/monoize.sml | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/src/monoize.sml b/src/monoize.sml
index b1166734..aeb99d94 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4442,7 +4442,13 @@ fun monoDecl (env, fm) (all as (d, loc)) =
 
                 val un = (L'.TRecord [], loc)
                 val t = if MonoUtil.Exp.exists {typ = fn _ => false,
-                                                exp = fn L'.EFfiApp ("Basis", "periodic", _) => true
+                                                exp = fn L'.EFfiApp ("Basis", "periodic", _) =>
+                                                         (if #persistent (Settings.currentProtocol ()) then
+                                                              ()
+                                                          else
+                                                              E.errorAt (#2 e1)
+                                                                        ("Periodic tasks aren't allowed in the selected protocol (" ^ #name (Settings.currentProtocol ()) ^ ").");
+                                                          true)
                                                        | _ => false} e1 then
                             (L'.TFfi ("Basis", "int"), loc)
                         else
-- 
cgit v1.2.3


From 3f3e77a6694283b6eae525a0ebfba4fc3bbb8163 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Mon, 30 Dec 2013 11:01:42 -0500
Subject: HTTP: continue after accept() failure

---
 src/c/http.c | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/src/c/http.c b/src/c/http.c
index 18e188da..25d2a320 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -430,19 +430,19 @@ int main(int argc, char *argv[]) {
     int new_fd = accept(sockfd, (struct sockaddr *)&their_addr, &sin_size);
 
     if (new_fd < 0) {
-      fprintf(stderr, "Socket accept failed\n");
-      return 1;
-    }
+      if (!quiet)
+        fprintf(stderr, "Socket accept failed\n");
+    } else {
+      if (!quiet)
+        printf("Accepted connection.\n");
 
-    if (!quiet)
-      printf("Accepted connection.\n");
+      if (keepalive) {
+        int flag = 1; 
+        setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int));
+      }
 
-    if (keepalive) {
-      int flag = 1; 
-      setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int));
+      uw_enqueue(new_fd);
     }
-
-    uw_enqueue(new_fd);
   }
 }
 
-- 
cgit v1.2.3


From b6eff4f490ecaf4ba0b4dabb8aab50b6a2227504 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 31 Dec 2013 09:34:41 -0500
Subject: Do a bit of extra userspace copying to send HTTP response with a
 single system call

---
 src/c/urweb.c | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 0a385cae..3a5933c5 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -474,6 +474,9 @@ struct uw_context {
   char error_message[ERROR_BUF_LEN];
 
   int usedSig, needsResig;
+
+  char *output_buffer;
+  size_t output_buffer_size;
 };
 
 size_t uw_headers_max = SIZE_MAX;
@@ -554,6 +557,9 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
   ctx->usedSig = 0;
   ctx->needsResig = 0;
 
+  ctx->output_buffer = malloc(1);
+  ctx->output_buffer_size = 1;
+
   return ctx;
 }
 
@@ -612,6 +618,8 @@ void uw_free(uw_context ctx) {
       ctx->globals[i].free(ctx->globals[i].data);
   free(ctx->globals);
 
+  free(ctx->output_buffer);
+
   free(ctx);
 }
 
@@ -1297,17 +1305,20 @@ int uw_pagelen(uw_context ctx) {
 }
 
 int uw_send(uw_context ctx, int sock) {
-  int n = uw_really_send(sock, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start);
+  size_t target_length = (ctx->outHeaders.front - ctx->outHeaders.start) + 2 + (ctx->page.front - ctx->page.start);
 
-  if (n < 0)
-    return n;
-
-  n = uw_really_send(sock, "\r\n", 2);
+  if (ctx->output_buffer_size < target_length) {
+    do {
+      ctx->output_buffer_size *= 2;
+    } while (ctx->output_buffer_size < target_length);
+    ctx->output_buffer = realloc(ctx->output_buffer, ctx->output_buffer_size);
+  }
 
-  if (n < 0)
-    return n;
+  memcpy(ctx->output_buffer, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start);
+  memcpy(ctx->output_buffer + (ctx->outHeaders.front - ctx->outHeaders.start), "\r\n", 2);
+  memcpy(ctx->output_buffer + (ctx->outHeaders.front - ctx->outHeaders.start) + 2, ctx->page.start, ctx->page.front - ctx->page.start);
 
-  return uw_really_send(sock, ctx->page.start, ctx->page.front - ctx->page.start);
+  return uw_really_send(sock, ctx->output_buffer, target_length);
 }
 
 int uw_print(uw_context ctx, int fd) {
-- 
cgit v1.2.3


From e0bc70d2a6b6c524889a820c6eeba20f616bcc44 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 31 Dec 2013 10:48:50 -0500
Subject: New release

---
 CHANGELOG    | 12 ++++++++++++
 configure.ac |  4 ++--
 2 files changed, 14 insertions(+), 2 deletions(-)

diff --git a/CHANGELOG b/CHANGELOG
index 25e27738..7d5d1b6c 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,15 @@
+========
+20131231
+========
+
+- Performance optimizations for Ur/Web's standalone HTTP servers
+- New command-line options for those servers: '-k' and '-q'
+- New HTML pseudo-tag: <script>
+- Trying to recv() from a different client's channel now triggers a run-time
+  error.
+- New compiler command-line argument: -print-cinclude
+- Bug fixes and improvements to optimizations, error messages, and documentation
+
 ========
 20131124
 ========
diff --git a/configure.ac b/configure.ac
index fbf6b162..27e0f0b8 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,5 +1,5 @@
-AC_INIT([urweb], [20131124])
-WORKING_VERSION=1
+AC_INIT([urweb], [20131231])
+WORKING_VERSION=0
 AC_USE_SYSTEM_EXTENSIONS
 
 # automake 1.12 requires this, but automake 1.11 doesn't recognize it
-- 
cgit v1.2.3


From 5284cd673fe4eba612ca6828cefee714361a8f65 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 31 Dec 2013 11:10:19 -0500
Subject: Return to working version mode

---
 configure.ac | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/configure.ac b/configure.ac
index 27e0f0b8..795e46a6 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,5 +1,5 @@
 AC_INIT([urweb], [20131231])
-WORKING_VERSION=0
+WORKING_VERSION=1
 AC_USE_SYSTEM_EXTENSIONS
 
 # automake 1.12 requires this, but automake 1.11 doesn't recognize it
-- 
cgit v1.2.3


From d7c4eb5eb07091dfa292943c8a6825a2ec7f244c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 1 Jan 2014 10:51:47 -0500
Subject: Add some URL-related benignEffectful functions

---
 src/settings.sml | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/settings.sml b/src/settings.sml
index 7a75985e..eaaa374d 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -187,7 +187,10 @@ val benignBase = basis ["get_cookie",
                         "preventDefault",
                         "stopPropagation",
                         "fresh",
-                        "giveFocus"]
+                        "giveFocus",
+                        "currentUrlHasPost",
+                        "currentUrlHasQueryString",
+                        "currentUrl"]
 
 val benign = ref benignBase
 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
-- 
cgit v1.2.3


From 771723435b7949b0a0ccb1e55ce919994a97613f Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 4 Jan 2014 19:02:14 -0500
Subject: noMangleSql .urp directive

---
 doc/manual.tex   |  1 +
 src/compiler.sml |  1 +
 src/monoize.sml  | 62 ++++++++++++++++++++++++++++----------------------------
 src/mysql.sml    | 57 +++++++++++++++++++++++++++++++--------------------
 src/postgres.sml | 25 +++++++++++++++--------
 src/settings.sig |  9 ++++++--
 src/settings.sml | 20 ++++++++++++++++++
 7 files changed, 111 insertions(+), 64 deletions(-)

diff --git a/doc/manual.tex b/doc/manual.tex
index 9bc52f4c..6fe1a92c 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -170,6 +170,7 @@ Here is the complete list of directive forms.  ``FFI'' stands for ``foreign func
 \item \texttt{linker CMD} sets \texttt{CMD} as the command line prefix to use for linking C object files.  The command line will be completed with a space-separated list of \texttt{.o} and \texttt{.a} files, \texttt{-L} and \texttt{-l} flags, and finally with a \texttt{-o} flag to set the location where the executable should be written.
 \item \texttt{minHeap NUMBYTES} sets the initial size for thread-local heaps used in handling requests.  These heaps grow automatically as needed (up to any maximum set with \texttt{limit}), but each regrow requires restarting the request handling process.
 \item \texttt{monoInline TREESIZE} sets how many nodes the AST of a function definition may have before the optimizer stops trying hard to inline calls to that function.  (This is one of two options for one of two intermediate languages within the compiler.)
+\item \texttt{noMangleSql} avoids adding a \texttt{uw\_} prefix in front of each identifier in SQL.  With this experimental feature, the burden is on the programmer to avoid naming tables or columns after SQL keywords!
 \item \texttt{noXsrfProtection URIPREFIX} turns off automatic cross-site request forgery protection for the page handler identified by the given URI prefix.  This will avoid checking cryptographic signatures on cookies, which is generally a reasonable idea for some pages, such as login pages that are going to discard all old cookie values, anyway.
 \item \texttt{onError Module.var} changes the handling of fatal application errors.  Instead of displaying a default, ugly error 500 page, the error page will be generated by calling function \texttt{Module.var} on a piece of XML representing the error message.  The error handler should have type $\mt{xbody} \to \mt{transaction} \; \mt{page}$.  Note that the error handler \emph{cannot} be in the application's main module, since that would register it as explicitly callable via URLs.
 \item \texttt{path NAME=VALUE} creates a mapping from \texttt{NAME} to \texttt{VALUE}.  This mapping may be used at the beginnings of filesystem paths given to various other configuration directives.  A path like \texttt{\$NAME/rest} is expanded to \texttt{VALUE/rest}.  There is an initial mapping from the empty name (for paths like \texttt{\$/list}) to the directory where the Ur/Web standard library is installed.  If you accept the default \texttt{configure} options, this directory is \texttt{/usr/local/lib/urweb/ur}.
diff --git a/src/compiler.sml b/src/compiler.sml
index b2635e5e..5e60288b 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -864,6 +864,7 @@ fun parseUrp' accLibs fname =
                                    | "alwaysInline" => Settings.addAlwaysInline arg
                                    | "noXsrfProtection" => Settings.addNoXsrfProtection arg
                                    | "timeFormat" => Settings.setTimeFormat arg
+                                   | "noMangleSql" => Settings.setMangleSql false
 
                                    | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
                                  read ()
diff --git a/src/monoize.sml b/src/monoize.sml
index aeb99d94..000ba7b6 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1624,7 +1624,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.EPrim (Prim.String
                                           (String.concatWith ", "
                                                              (map (fn (x, _) =>
-                                                                      "uw_" ^ monoNameLc env x
+                                                                      Settings.mangleSql (monoNameLc env x)
                                                                       ^ (if #textKeysNeedLengths (Settings.currentDbms ())
                                                                             andalso isBlobby t then
                                                                              "(767)"
@@ -1668,7 +1668,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EPrim (Prim.String ("UNIQUE ("
                                          ^ String.concatWith ", "
-                                                             (map (fn (x, t) => "uw_" ^ monoNameLc env x
+                                                             (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
                                                                                 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
                                                                                       andalso isBlobby t then
                                                                                        "(767)"
@@ -1714,19 +1714,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.EAbs ("m", mat, mat,
                                      (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
                                                 [((L'.PPrim (Prim.String ""), loc),
-                                                  (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)),
+                                                  (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))),
                                                                       loc), string),
-                                                               ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)),
+                                                               ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))),
                                                                       loc), string)], loc)),
                                                  ((L'.PWild, loc),
                                                   (L'.ERecord [("1", (L'.EStrcat (
-                                                                      (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1
+                                                                      (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1)
                                                                                               ^ ", ")),
                                                                        loc),
                                                                       (L'.EField ((L'.ERel 0, loc), "1"), loc)),
                                                                       loc), string),
                                                                ("2", (L'.EStrcat (
-                                                                      (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2
+                                                                      (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2)
                                                                                               ^ ", ")), loc),
                                                                       (L'.EField ((L'.ERel 0, loc), "2"), loc)),
                                                                       loc), string)],
@@ -1857,7 +1857,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                           strcat [sc "INSERT INTO ",
                                                   (L'.ERel 1, loc),
                                                   sc " (",
-                                                  strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields),
+                                                  strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields),
                                                   sc ") VALUES (",
                                                   strcatComma (map (fn (x, _) =>
                                                                        (L'.EField ((L'.ERel 0, loc),
@@ -1884,7 +1884,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                                 (L'.ERel 1, loc),
                                                                 sc " AS T_T SET ",
                                                                 strcatComma (map (fn (x, _) =>
-                                                                                     strcat [sc ("uw_" ^ x
+                                                                                     strcat [sc (Settings.mangleSql x
                                                                                                  ^ " = "),
                                                                                              (L'.EField
                                                                                                   ((L'.ERel 2,
@@ -1898,7 +1898,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                                 (L'.ERel 1, loc),
                                                                 sc " SET ",
                                                                 strcatComma (map (fn (x, _) =>
-                                                                                     strcat [sc ("uw_" ^ x
+                                                                                     strcat [sc (Settings.mangleSql x
                                                                                                  ^ " = "),
                                                                                              (L'.EFfiApp ("Basis", "unAs",
                                                                                                           [((L'.EField
@@ -2090,14 +2090,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                            strcatComma (map (fn (x, t) =>
                                                                 strcat [
                                                                 (L'.EField (gf "SelectExps", x), loc),
-                                                                sc (" AS uw_" ^ x)
+                                                                sc (" AS " ^ Settings.mangleSql x)
                                                             ]) sexps
                                                         @ map (fn (x, xts) =>
                                                                   strcatComma
                                                                       (map (fn (x', _) =>
                                                                                sc ("T_" ^ x
-										   ^ ".uw_"
-										   ^ x'))
+										   ^ "."
+										   ^ Settings.mangleSql x'))
                                                                            xts)) stables),
                                            (L'.ECase (gf "From",
                                                       [((L'.PPrim (Prim.String ""), loc),
@@ -2131,8 +2131,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                                     strcatComma
                                                                         (map (fn (x', _) =>
                                                                                  sc ("T_" ^ x
-										     ^ ".uw_"
-										     ^ x'))
+										     ^ ""
+										     ^ Settings.mangleSql x'))
                                                                              xts)) grouped)
                                                ],
 
@@ -2626,7 +2626,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                _), _),
               _), _),
              (L.CName tab, _)), _),
-            (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm)
+            (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm)
 
           | L.ECApp (
             (L.ECApp (
@@ -2638,7 +2638,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                _), _),
               _), _),
              _), _),
-            (L.CName nm, _)) => ((L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm)), loc), fm)
+            (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm)
 
           | L.ECApp (
             (L.ECApp (
@@ -4368,7 +4368,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
                 val t' = (L'.TFfi ("Basis", "string"), loc)
-                val s = "uw_" ^ s
+                val s = Settings.mangleSqlTable s
                 val e_name = (L'.EPrim (Prim.String s), loc)
 
                 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4386,7 +4386,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
                 val t' = (L'.TFfi ("Basis", "string"), loc)
-                val s = "uw_" ^ s
+                val s = Settings.mangleSqlTable s
                 val e_name = (L'.EPrim (Prim.String s), loc)
 
                 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4404,7 +4404,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
                 val t' = (L'.TFfi ("Basis", "string"), loc)
-                val s = "uw_" ^ s
+                val s = Settings.mangleSql s
                 val e = (L'.EPrim (Prim.String s), loc)
             in
                 SOME (Env.pushENamed env x n t NONE s,
@@ -4553,7 +4553,7 @@ fun monoize env file =
                             val (nullable, notNullable) = calcClientish xts
 
                             fun cond (x, v) =
-                                (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
+                                (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x
                                                                      ^ (case v of
                                                                             Client => ""
                                                                           | Channel => " >> 32")
@@ -4564,10 +4564,10 @@ fun monoize env file =
                                 foldl (fn ((x, v), e) =>
                                           (L'.ESeq (
                                            (L'.EDml ((L'.EStrcat (
-                                                      (L'.EPrim (Prim.String ("UPDATE uw_"
-                                                                              ^ tab
-                                                                              ^ " SET uw_"
-                                                                              ^ x
+                                                      (L'.EPrim (Prim.String ("UPDATE "
+                                                                              ^ Settings.mangleSql tab
+                                                                              ^ " SET "
+                                                                              ^ Settings.mangleSql x
                                                                               ^ " = NULL WHERE ")), loc),
                                                       cond (x, v)), loc), L'.Error), loc),
                                            e), loc))
@@ -4584,8 +4584,8 @@ fun monoize env file =
                                                                     (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
                                                                                   loc),
                                                                                  cond eb), loc)), loc))
-                                                   (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
-                                                                                        ^ tab
+                                                   (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM "
+                                                                                        ^ Settings.mangleSql tab
                                                                                         ^ " WHERE ")), loc),
                                                                 cond eb), loc)
                                                    ebs, L'.Error), loc),
@@ -4618,11 +4618,11 @@ fun monoize env file =
                                     (L'.ESeq (
                                      (L'.EDml ((L'.EPrim (Prim.String
                                                               (foldl (fn ((x, _), s) =>
-                                                                         s ^ ", uw_" ^ x ^ " = NULL")
+                                                                         s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
                                                                      ("UPDATE uw_"
                                                                       ^ tab
-                                                                      ^ " SET uw_"
-                                                                      ^ x
+                                                                      ^ " SET "
+                                                                      ^ Settings.mangleSql x
                                                                       ^ " = NULL")
                                                                      ebs)), loc), L'.Error), loc),
                                      e), loc)
@@ -4632,8 +4632,8 @@ fun monoize env file =
                                     [] => e
                                   | eb :: ebs =>
                                     (L'.ESeq (
-                                     (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_"
-                                                                       ^ tab)), loc), L'.Error), loc),
+                                     (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM "
+                                                                       ^ Settings.mangleSql tab)), loc), L'.Error), loc),
                                      e), loc)
                         in
                             e
diff --git a/src/mysql.sml b/src/mysql.sml
index 884cde36..a119321c 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -76,7 +76,11 @@ val ident = String.translate (fn #"'" => "PRIME"
 fun checkRel (table, checkNullable) (s, xts) =
     let
         val sl = CharVector.map Char.toLower s
-        val both = "table_name IN ('" ^ sl ^ "', '" ^ s ^ "')"
+        val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
+                     String.substring (sl, 1, size sl - 2)
+                 else
+                     sl
+        val both = "LOWER(table_name) = ('" ^ sl ^ "')"
 
         val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE " ^ both
 
@@ -85,14 +89,17 @@ fun checkRel (table, checkNullable) (s, xts) =
                                 " AND (",
                                 case String.concatWith " OR "
                                                        (map (fn (x, t) =>
-                                                                String.concat ["(column_name IN ('uw_",
-                                                                               CharVector.map
-                                                                                   Char.toLower (ident x),
-                                                                               "', 'uw_",
-                                                                               ident x,
-                                                                               "') AND data_type = '",
-                                                                               p_sql_type_base t,
-                                                                               "'",
+                                                                String.concat ["(LOWER(column_name) = '",
+                                                                               Settings.mangleSqlCatalog
+                                                                                   (CharVector.map
+                                                                                        Char.toLower (ident x)),
+                                                                               "' AND data_type ",
+                                                                               case p_sql_type_base t of
+                                                                                   "bigint" =>
+                                                                                   "IN ('bigint', 'int')"
+                                                                                 | "longtext" =>
+                                                                                   "IN ('longtext', 'varchar')"
+                                                                                 | s => "= '" ^ s ^ "'",
                                                                                if checkNullable then
                                                                                    (" AND is_nullable = '"
                                                                                     ^ (if isNotNull t then
@@ -109,7 +116,7 @@ fun checkRel (table, checkNullable) (s, xts) =
 
         val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ",
                                  both,
-                                 " AND column_name LIKE 'uw_%'"]
+                                 " AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
     in
         box [string "if (mysql_query(conn->conn, \"",
              string q,
@@ -174,7 +181,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                   string "mysql_close(conn->conn);",
                   newline,
                   string "uw_error(ctx, FATAL, \"Table '",
-                  string s,
+                  string sl,
                   string "' does not exist.\");",
                   newline],
              string "}",
@@ -249,7 +256,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                   string "mysql_close(conn->conn);",
                   newline,
                   string "uw_error(ctx, FATAL, \"Table '",
-                  string s,
+                  string sl,
                   string "' has the wrong column types.\");",
                   newline],
              string "}",
@@ -324,7 +331,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                   string "mysql_close(conn->conn);",
                   newline,
                   string "uw_error(ctx, FATAL, \"Table '",
-                  string s,
+                  string sl,
                   string "' has extra columns.\");",
                   newline],
              string "}",
@@ -1201,15 +1208,21 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
              box []]
 
 fun dmlCommon {loc, dml, mode} =
-    box [string "if (mysql_stmt_execute(stmt)) ",
-         case mode of
-             Settings.Error => box [string "uw_error(ctx, FATAL, \"",
-                                    string (ErrorMsg.spanToString loc),
-                                    string ": Error executing DML: %s\\n%s\", ",
-                                    dml,
-                                    string ", mysql_error(conn->conn));"]
-           | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
-         newline,
+    box [string "if (mysql_stmt_execute(stmt)) {",
+         box [string "if (mysql_errno(conn->conn) == 1213)",
+              newline,
+              box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
+                   newline],
+              newline,
+              case mode of
+                  Settings.Error => box [string "uw_error(ctx, FATAL, \"",
+                                         string (ErrorMsg.spanToString loc),
+                                         string ": Error executing DML: %s\\n%s\", ",
+                                         dml,
+                                         string ", mysql_error(conn->conn));"]
+                | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));",
+              newline],
+         string "}",
          newline]
 
 fun dml (loc, mode) =
diff --git a/src/postgres.sml b/src/postgres.sml
index 8cfa5f48..6ed7eeb0 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -63,8 +63,12 @@ fun p_sql_type_base t =
 fun checkRel (table, checkNullable) (s, xts) =
     let
         val sl = CharVector.map Char.toLower s
+        val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then
+                     String.substring (sl, 1, size sl - 2)
+                 else
+                     sl
 
-        val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
+        val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE LOWER(table_name) = '"
                 ^ sl ^ "'"
 
         val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
@@ -72,12 +76,15 @@ fun checkRel (table, checkNullable) (s, xts) =
                                 "' AND (",
                                 case String.concatWith " OR "
                                                        (map (fn (x, t) =>
-                                                                String.concat ["(column_name = 'uw_",
-                                                                               CharVector.map
-                                                                                   Char.toLower (ident x),
+                                                                String.concat ["(LOWER(column_name) = '",
+                                                                               Settings.mangleSqlCatalog
+                                                                                   (CharVector.map
+                                                                                        Char.toLower (ident x)),
                                                                                (case p_sql_type_base t of
                                                                                     "bigint" =>
-                                                                                    "' AND data_type IN ('bigint', 'numeric')"
+                                                                                    "' AND data_type IN ('bigint', 'numeric', 'integer')"
+                                                                                  | "text" =>
+                                                                                    "' AND data_type IN ('text', 'character varying')"                                                                          
                                                                                   | t =>
                                                                                     String.concat ["' AND data_type = '",
                                                                                                    t,
@@ -98,7 +105,7 @@ fun checkRel (table, checkNullable) (s, xts) =
 
         val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
                                  sl,
-                                 "' AND column_name LIKE 'uw_%'"]
+                                 "' AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"]
     in
         box [string "res = PQexec(conn, \"",
              string q,
@@ -140,7 +147,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                   string "PQfinish(conn);",
                   newline,
                   string "uw_error(ctx, FATAL, \"Table '",
-                  string s,
+                  string sl,
                   string "' does not exist.\");",
                   newline],
              string "}",
@@ -191,7 +198,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                   string "PQfinish(conn);",
                   newline,
                   string "uw_error(ctx, FATAL, \"Table '",
-                  string s,
+                  string sl,
                   string "' has the wrong column types.\");",
                   newline],
              string "}",
@@ -243,7 +250,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                   string "PQfinish(conn);",
                   newline,
                   string "uw_error(ctx, FATAL, \"Table '",
-                  string s,
+                  string sl,
                   string "' has extra columns.\");",
                   newline],
              string "}",
diff --git a/src/settings.sig b/src/settings.sig
index 40cfbacc..847cb5f6 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -258,6 +258,11 @@ signature SETTINGS = sig
     val setTimeFormat : string -> unit
     val getTimeFormat : unit -> string
 
-	val getCCompiler : unit -> string
-	val setCCompiler : string -> unit
+    val getCCompiler : unit -> string
+    val setCCompiler : string -> unit
+
+    val setMangleSql : bool -> unit
+    val mangleSql : string -> string
+    val mangleSqlCatalog : string -> string
+    val mangleSqlTable : string -> string
 end
diff --git a/src/settings.sml b/src/settings.sml
index eaaa374d..ebe38b17 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -696,4 +696,24 @@ val timeFormat = ref "%c"
 fun setTimeFormat v = timeFormat := v
 fun getTimeFormat () = !timeFormat
 
+fun lowercase s =
+    case s of
+        "" => ""
+      | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+fun capitalize s =
+    case s of
+        "" => ""
+      | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+val mangle = ref true
+fun setMangleSql x = mangle := x
+fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s
+                       else if #name (currentDbms ()) = "mysql" then capitalize s
+                       else "\"" ^ lowercase s ^ "\""
+fun mangleSql s = if !mangle then "uw_" ^ s
+                  else if #name (currentDbms ()) = "mysql" then lowercase s
+                  else "\"" ^ lowercase s ^ "\""
+fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
+
 end
-- 
cgit v1.2.3


From f00f54541df6722f06057da89da38ba906252058 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 5 Jan 2014 20:20:09 -0500
Subject: MySQL: catch deadlocks during queries

---
 src/mysql.sml | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/src/mysql.sml b/src/mysql.sml
index a119321c..3b59d1c1 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -854,11 +854,20 @@ fun queryCommon {loc, query, cols, doCols} =
          newline,
          newline,
 
-         string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"",
-         string (ErrorMsg.spanToString loc),
-         string ": Error executing query: %s\\n%s\", ",
-         query,
-         string ", mysql_error(conn->conn));",
+         string "if (mysql_stmt_execute(stmt)) {",
+         newline,
+         box [string "if (mysql_errno(conn->conn) == 1213)",
+              newline,
+              box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
+                   newline],
+              newline,
+              string "uw_error(ctx, FATAL, \"",
+              string (ErrorMsg.spanToString loc),
+              string ": Error executing query: %s\\n%s\", ",
+              query,
+              string ", mysql_error(conn->conn));",
+              newline],
+         string "}",
          newline,
          newline,
 
-- 
cgit v1.2.3


From bb567cd6c1490dcabf53a3dd18f1aebd8e3055e0 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 7 Jan 2014 08:36:18 -0500
Subject: MySQL: Combine transaction setup commands into one mysql_query()

---
 src/mysql.sml | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/src/mysql.sml b/src/mysql.sml
index 3b59d1c1..472b72d1 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -536,7 +536,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                | SOME n => string (Int.toString n),
              string ", ",
              stringOf unix_socket,
-             string ", 0) == NULL) {",
+             string ", CLIENT_MULTI_STATEMENTS) == NULL) {",
              newline,
              box [string "char msg[1024];",
                   newline,
@@ -589,9 +589,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
              string "uw_conn *conn = uw_get_db(ctx);",
              newline,
              newline,
-             string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE\")",
-             newline,
-             string "  || mysql_query(conn->conn, \"BEGIN\");",
+             string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE; BEGIN\") ? 1 : (mysql_next_result(conn->conn), 0);",
              newline,
              string "}",
              newline,
-- 
cgit v1.2.3


From 55d485365f4d52a84d06bc38d6d34b6a47890b57 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 9 Jan 2014 17:27:24 -0500
Subject: Add 'html5' .urp directive

---
 doc/manual.tex            |  1 +
 include/urweb/types_cpp.h |  2 ++
 include/urweb/urweb_cpp.h |  2 ++
 src/c/urweb.c             | 12 ++++++++----
 src/cjr_print.sml         | 12 +++++++-----
 src/compiler.sml          |  1 +
 src/settings.sig          |  3 +++
 src/settings.sml          |  4 ++++
 8 files changed, 28 insertions(+), 9 deletions(-)

diff --git a/doc/manual.tex b/doc/manual.tex
index 6fe1a92c..ea053a81 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -146,6 +146,7 @@ Here is the complete list of directive forms.  ``FFI'' stands for ``foreign func
 \item \texttt{effectful Module.ident} registers an FFI function or transaction as having side effects.  The optimizer avoids removing, moving, or duplicating calls to such functions.  This is the default behavior for \texttt{transaction}-based types.
 \item \texttt{exe FILENAME} sets the filename to which to write the output executable.  The default for file \texttt{P.urp} is \texttt{P.exe}.  
 \item \texttt{ffi FILENAME} reads the file \texttt{FILENAME.urs} to determine the interface to a new FFI module.  The name of the module is calculated from \texttt{FILENAME} in the same way as for normal source files.  See the files \texttt{include/urweb/urweb\_cpp.h} and \texttt{src/c/urweb.c} for examples of C headers and implementations for FFI modules.  In general, every type or value \texttt{Module.ident} becomes \texttt{uw\_Module\_ident} in C.
+\item \texttt{html5} activates work-in-progress support for generating HTML5 instead of XHTML.  For now, this option only affects the first few tokens on any page, which are always the same.
 \item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources.  This is most useful for interfacing with new FFI modules.
 \item \texttt{jsFunc Module.ident=name} gives the JavaScript name of an FFI value.
 \item \texttt{library FILENAME} parses \texttt{FILENAME.urp} and merges its contents with the rest of the current file's contents.  If \texttt{FILENAME.urp} doesn't exist, the compiler also tries \texttt{FILENAME/lib.urp}.
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index 789aecb1..cd80b0e7 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -102,6 +102,8 @@ typedef struct {
   uw_periodic *periodics; // 0-terminated array
 
   uw_Basis_string time_format;
+
+  int is_html5;
 } uw_app;
 
 #define ERROR_BUF_LEN 1024
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 248e54e4..1943a9f9 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -377,4 +377,6 @@ uw_Basis_string uw_Basis_fieldValue(struct uw_context *, uw_Basis_postField);
 uw_Basis_string uw_Basis_remainingFields(struct uw_context *, uw_Basis_postField);
 uw_Basis_postField *uw_Basis_firstFormField(struct uw_context *, uw_Basis_string);
 
+extern const char uw_begin_xhtml[], uw_begin_html5[];
+
 #endif
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 3a5933c5..c0c339c1 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3241,7 +3241,8 @@ int uw_rollback(uw_context ctx, int will_retry) {
     return 0;
 }
 
-static const char begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">";
+const char uw_begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">";
+const char uw_begin_html5[] = "<!DOCTYPE html><html>";
 
 extern int uw_hash_blocksize;
 
@@ -3331,11 +3332,14 @@ int uw_commit(uw_context ctx) {
   uw_check(ctx, 1);
   *ctx->page.front = 0;
 
-  if (!ctx->returning_indirectly && !strncmp(ctx->page.start, begin_xhtml, sizeof begin_xhtml - 1)) {
+  if (!ctx->returning_indirectly
+      && (ctx->app->is_html5
+          ? !strncmp(ctx->page.start, uw_begin_html5, sizeof uw_begin_html5 - 1)
+          : !strncmp(ctx->page.start, uw_begin_xhtml, sizeof uw_begin_xhtml - 1))) {
     char *s;
 
     // Splice script data into appropriate part of page, also adding <head> if needed.
-    s = ctx->page.start + sizeof begin_xhtml - 1;
+    s = ctx->page.start + (ctx->app->is_html5 ? sizeof uw_begin_html5 - 1 : sizeof uw_begin_xhtml - 1);
     s = strchr(s, '<');
     if (s == NULL) {
       // Weird.  Document has no tags!
@@ -4170,7 +4174,7 @@ failure_kind uw_begin_onError(uw_context ctx, char *msg) {
         uw_write_header(ctx, "Status: ");
       uw_write_header(ctx, "500 Internal Server Error\r\n");
       uw_write_header(ctx, "Content-type: text/html\r\n");
-      uw_write(ctx, begin_xhtml);
+      uw_write(ctx, ctx->app->is_html5 ? uw_begin_html5 : uw_begin_xhtml);
       ctx->app->on_error(ctx, msg);
       uw_write(ctx, "</html>");
     }
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 1fc0b40f..05dce35e 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3083,7 +3083,11 @@ fun p_file env (ds, ps) =
                                         ServerOnly => box []
                                       | _ => box [string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
                                                   newline],
-                                    string "uw_write(ctx, begin_xhtml);",
+                                    string ("uw_write(ctx, uw_begin_" ^
+                                            (if Settings.getIsHtml5 () then
+                                                 "html5"
+                                             else
+                                                 "xhtml") ^ ");"),
                                     newline,
                                     string "uw_mayReturnIndirectly(ctx);",
                                     newline,
@@ -3374,9 +3378,6 @@ fun p_file env (ds, ps) =
              newline,
              newline,
 
-             string "static const char begin_xhtml[] = \"<?xml version=\\\"1.0\\\" encoding=\\\"utf-8\\\" ?>\\n<!DOCTYPE html PUBLIC \\\"-//W3C//DTD XHTML 1.0 Transitional//EN\\\" \\\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\\\">\\n<html xmlns=\\\"http://www.w3.org/1999/xhtml\\\" xml:lang=\\\"en\\\" lang=\\\"en\\\">\";",
-             newline,
-             newline,
 
              p_list_sep newline (fn x => x) pds,
              newline,
@@ -3588,7 +3589,8 @@ fun p_file env (ds, ps) =
                          "uw_handle",
                          "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar",
                          case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics",
-                         "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\""],
+                         "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"",
+                         if Settings.getIsHtml5 () then "1" else "0"],
              string "};",
              newline]
     end
diff --git a/src/compiler.sml b/src/compiler.sml
index 5e60288b..0ffab01c 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -865,6 +865,7 @@ fun parseUrp' accLibs fname =
                                    | "noXsrfProtection" => Settings.addNoXsrfProtection arg
                                    | "timeFormat" => Settings.setTimeFormat arg
                                    | "noMangleSql" => Settings.setMangleSql false
+                                   | "html5" => Settings.setIsHtml5 true
 
                                    | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
                                  read ()
diff --git a/src/settings.sig b/src/settings.sig
index 847cb5f6..a7a41447 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -265,4 +265,7 @@ signature SETTINGS = sig
     val mangleSql : string -> string
     val mangleSqlCatalog : string -> string
     val mangleSqlTable : string -> string
+
+    val setIsHtml5 : bool -> unit
+    val getIsHtml5 : unit -> bool
 end
diff --git a/src/settings.sml b/src/settings.sml
index ebe38b17..be998ec2 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -716,4 +716,8 @@ fun mangleSql s = if !mangle then "uw_" ^ s
                   else "\"" ^ lowercase s ^ "\""
 fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
 
+val html5 = ref false
+fun setIsHtml5 b = html5 := b
+fun getIsHtml5 () = !html5
+
 end
-- 
cgit v1.2.3


From 1d2f9948f488cd4bb55b2434478726a59a3acce9 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 14 Jan 2014 19:22:53 -0500
Subject: MySQL: set character set when opening a new connection

---
 src/mysql.sml | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

diff --git a/src/mysql.sml b/src/mysql.sml
index 472b72d1..e34efbd4 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -551,6 +551,23 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
              newline,
              string "}",
              newline,
+             newline,
+             string "if (mysql_set_character_set(mysql, \"utf8\")) {",
+             newline,
+             box [string "char msg[1024];",
+                  newline,
+                  string "strncpy(msg, mysql_error(mysql), 1024);",
+                  newline,
+                  string "msg[1023] = 0;",
+                  newline,
+                  string "mysql_close(mysql);",
+                  newline,
+                  string "uw_error(ctx, FATAL, ",
+                  string "\"Error setting UTF-8 character set for MySQL connection: %s\", msg);"],
+             newline,
+             string "}",
+             newline,
+             newline,
              string "conn = calloc(1, sizeof(uw_conn));",
              newline,
              string "conn->conn = mysql;",
-- 
cgit v1.2.3


From 1973011a14931c9946d9d7a04efc90087c7828ff Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 15 Jan 2014 14:54:26 -0500
Subject: Postgres: look up table names case-sensitively in catalog

---
 src/postgres.sml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/postgres.sml b/src/postgres.sml
index 6ed7eeb0..b97226c1 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -68,7 +68,7 @@ fun checkRel (table, checkNullable) (s, xts) =
                  else
                      sl
 
-        val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE LOWER(table_name) = '"
+        val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
                 ^ sl ^ "'"
 
         val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
-- 
cgit v1.2.3


From d9f5cfc01bf3aac3efb9b0890090a378aeaf15e5 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Wed, 15 Jan 2014 15:46:46 -0500
Subject: Stop quoting Postgres identifiers in 'noMangleSql' mode

---
 src/settings.sml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/settings.sml b/src/settings.sml
index be998ec2..93f54427 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -710,10 +710,10 @@ val mangle = ref true
 fun setMangleSql x = mangle := x
 fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s
                        else if #name (currentDbms ()) = "mysql" then capitalize s
-                       else "\"" ^ lowercase s ^ "\""
+                       else lowercase s
 fun mangleSql s = if !mangle then "uw_" ^ s
                   else if #name (currentDbms ()) = "mysql" then lowercase s
-                  else "\"" ^ lowercase s ^ "\""
+                  else lowercase s
 fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s
 
 val html5 = ref false
-- 
cgit v1.2.3


From 6787b686afe5fd3e65b3d377d4c363b4cd086dad Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 18 Jan 2014 08:34:19 -0500
Subject: Manual: remove database version numbers from Debian package names,
 where possible

---
 doc/manual.tex | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/doc/manual.tex b/doc/manual.tex
index ea053a81..0a088436 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -64,7 +64,7 @@ apt-get install mlton libssl-dev
 
 To build programs that access SQL databases, you also need one of these client libraries for supported backends.
 \begin{verbatim}
-apt-get install libpq-dev libmysqlclient15-dev libsqlite3-dev
+apt-get install libpq-dev libmysqlclient-dev libsqlite3-dev
 \end{verbatim}
 
 It is also possible to access the modules of the Ur/Web compiler interactively, within Standard ML of New Jersey.  To install the prerequisites in Debian testing:
@@ -77,7 +77,7 @@ To begin an interactive session with the Ur compiler modules, run \texttt{make s
 To run an SQL-backed application with a backend besides SQLite, you will probably want to install one of these servers.
 
 \begin{verbatim}
-apt-get install postgresql-8.4 mysql-server-5.1
+apt-get install postgresql mysql-server
 \end{verbatim}
 
 To use the Emacs mode, you must have a modern Emacs installed.  We assume that you already know how to do this, if you're in the business of looking for an Emacs mode.  The demo generation facility of the compiler will also call out to Emacs to syntax-highlight code, and that process depends on the \texttt{htmlize} module, which can be installed in Debian testing via:
-- 
cgit v1.2.3