Start SQL transactions as read-only when possible, based on conservative program analysis

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