# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1386888168 18000
# Node ID 6745eafff617a5977a94966c7c8886c6beb7cfd5
# Parent  fda9d5af69e7443311aabf32bd444ab41107a74a
Start SQL transactions as read-only when possible, based on conservative program analysis

diff -r fda9d5af69e7 -r 6745eafff617 include/urweb/types_cpp.h
--- a/include/urweb/types_cpp.h	Thu Dec 12 10:31:34 2013 -0500
+++ b/include/urweb/types_cpp.h	Thu Dec 12 17:42:48 2013 -0500
@@ -82,7 +82,7 @@
   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 -r fda9d5af69e7 -r 6745eafff617 include/urweb/urweb_cpp.h
--- a/include/urweb/urweb_cpp.h	Thu Dec 12 10:31:34 2013 -0500
+++ b/include/urweb/urweb_cpp.h	Thu Dec 12 17:42:48 2013 -0500
@@ -86,6 +86,7 @@
 
 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 -r fda9d5af69e7 -r 6745eafff617 src/c/cgi.c
--- a/src/c/cgi.c	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/c/cgi.c	Thu Dec 12 17:42:48 2013 -0500
@@ -134,8 +134,7 @@
 }
 
 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 -r fda9d5af69e7 -r 6745eafff617 src/c/fastcgi.c
--- a/src/c/fastcgi.c	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/c/fastcgi.c	Thu Dec 12 17:42:48 2013 -0500
@@ -632,8 +632,7 @@
 }
 
 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 -r fda9d5af69e7 -r 6745eafff617 src/c/http.c
--- a/src/c/http.c	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/c/http.c	Thu Dec 12 17:42:48 2013 -0500
@@ -438,8 +438,7 @@
 }
 
 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 -r fda9d5af69e7 -r 6745eafff617 src/c/urweb.c
--- a/src/c/urweb.c	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/c/urweb.c	Thu Dec 12 17:42:48 2013 -0500
@@ -441,7 +441,7 @@
 
   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 @@
   ctx->script_header = "";
   ctx->needs_push = 0;
   ctx->needs_sig = 0;
+  ctx->could_write_db = 1;
 
   ctx->source_count = 0;
 
@@ -777,7 +778,7 @@
 
 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 @@
   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 @@
   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 @@
   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 @@
 
   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 -r fda9d5af69e7 -r 6745eafff617 src/cjr_print.sml
--- a/src/cjr_print.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/cjr_print.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -3001,11 +3001,18 @@
 
                 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 @@
                                     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 -r fda9d5af69e7 -r 6745eafff617 src/corify.sml
--- a/src/corify.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/corify.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -1046,7 +1046,7 @@
                                                                                 | _ => 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 -r fda9d5af69e7 -r 6745eafff617 src/effectize.sml
--- a/src/effectize.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/effectize.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -153,7 +153,7 @@
                 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 @@
                      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 -r fda9d5af69e7 -r 6745eafff617 src/export.sig
--- a/src/export.sig	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/export.sig	Thu Dec 12 17:42:48 2013 -0500
@@ -33,7 +33,7 @@
        | ReadWrite
 
 datatype export_kind =
-         Link
+         Link of effect
        | Action of effect
        | Rpc of effect
        | Extern of effect
diff -r fda9d5af69e7 -r 6745eafff617 src/export.sml
--- a/src/export.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/export.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -36,7 +36,7 @@
        | ReadWrite
 
 datatype export_kind =
-         Link
+         Link of effect
        | Action of effect
        | Rpc of effect
        | Extern of effect
@@ -49,7 +49,7 @@
 
 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 -r fda9d5af69e7 -r 6745eafff617 src/mysql.sml
--- a/src/mysql.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/mysql.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -577,7 +577,7 @@
              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 -r fda9d5af69e7 -r 6745eafff617 src/postgres.sml
--- a/src/postgres.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/postgres.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -402,11 +402,11 @@
          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 -r fda9d5af69e7 -r 6745eafff617 src/sqlite.sml
--- a/src/sqlite.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/sqlite.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -344,7 +344,7 @@
              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 -r fda9d5af69e7 -r 6745eafff617 src/tag.sml
--- a/src/tag.sml	Thu Dec 12 10:31:34 2013 -0500
+++ b/src/tag.sml	Thu Dec 12 17:42:48 2013 -0500
@@ -145,7 +145,7 @@
                                                        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 @@
 
           | 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 @@
                 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