New phase: Dbmodecheck

12 files changed, 160 insertions, 13 deletions

diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 72997a12..d83b2cbb 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -90,6 +90,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);
+void uw_set_at_most_one_query(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/urweb.c b/src/c/urweb.c
index 43c73661..d7bc05e3 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, could_write_db;
+  int needs_push, needs_sig, could_write_db, at_most_one_query;
 
   size_t n_deltas, used_deltas;
   delta *deltas;
@@ -520,6 +520,7 @@ uw_context uw_init(int id, uw_loggers *lg) {
   ctx->needs_push = 0;
   ctx->needs_sig = 0;
   ctx->could_write_db = 1;
+  ctx->at_most_one_query = 0;
 
   ctx->source_count = 0;
 
@@ -786,7 +787,7 @@ failure_kind uw_begin(uw_context ctx, char *path) {
 }
 
 void uw_ensure_transaction(uw_context ctx) {
-  if (!ctx->transaction_started) {
+  if (!ctx->transaction_started && !ctx->at_most_one_query) {
     if (ctx->app->db_begin(ctx, ctx->could_write_db))
       uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
     ctx->transaction_started = 1;
@@ -1205,6 +1206,10 @@ void uw_set_could_write_db(uw_context ctx, int n) {
   ctx->could_write_db = n;
 }
 
+void uw_set_at_most_one_query(uw_context ctx, int n) {
+  ctx->at_most_one_query = 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) {
diff --git a/src/cjr.sml b/src/cjr.sml
index 8cbabdcc..3742a06f 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -129,10 +129,11 @@ datatype decl' =
 withtype decl = decl' located
 
 datatype sidedness = datatype Mono.sidedness
+datatype dbmode = datatype Mono.dbmode
 
 datatype effect = datatype Export.effect
 datatype export_kind = datatype Export.export_kind
 
-type file = decl list * (export_kind * string * int * typ list * typ * sidedness * bool) list
+type file = decl list * (export_kind * string * int * typ list * typ * sidedness * dbmode * bool) list
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index a4cc8c54..0867f001 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2634,7 +2634,7 @@ fun p_file env (ds, ps) =
                 end
               | _ => NONE
 
-        val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
+        val fields = foldl (fn ((ek, _, _, ts, _, _, _, _), fields) =>
                                case ek of
                                    Action eff =>
                                    (case List.nth (ts, length ts - 2) of
@@ -2956,7 +2956,7 @@ fun p_file env (ds, ps) =
                       scripts (Settings.getScripts ())
             end
 
-        fun p_page (ek, s, n, ts, ran, side, tellSig) =
+        fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) =
             let
                 val (ts, defInputs, inputsVar, fields) =
                     case ek of
@@ -3106,6 +3106,10 @@ fun p_file env (ds, ps) =
                      string (if couldWriteDb ek then "1" else "0"),
                      string ");",
                      newline,
+                     string "uw_set_at_most_one_query(ctx, ",
+                     string (case dbmode of OneQuery => "1" | _ => "0"),
+                     string ");",
+                     newline,
                      string "uw_set_needs_push(ctx, ",
                      string (case side of
                                  ServerAndPullAndPush => "1"
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6dc0299c..11174162 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -730,12 +730,14 @@ fun cjrize (ds, sideInfo) =
                                           end)
                                       ([], [], [], Sm.empty) ds
 
-        val sideInfo = foldl (fn ((n, mode), mp) => IM.insert (mp, n, mode)) IM.empty sideInfo
+        val sideInfo = foldl (fn ((n, mode, dbmode), mp) => IM.insert (mp, n, (mode, dbmode))) IM.empty sideInfo
 
         val ps = map (fn (ek, s, n, ts, t, _, b) =>
-                         (ek, s, n, ts, t,
-                          getOpt (IM.find (sideInfo, n), L'.ServerOnly),
-                          b)) ps
+                         let
+                             val (side, db) = getOpt (IM.find (sideInfo, n), (L'.ServerOnly, L'.AnyDb))
+                         in
+                             (ek, s, n, ts, t, side, db, b)
+                         end) ps
     in
         (List.revAppend (dsF, rev ds),
          ps)
diff --git a/src/compiler.sig b/src/compiler.sig
index fa131cf4..d74ec533 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -172,6 +172,7 @@ signature COMPILER = sig
     val toNamejs : (string, Mono.file) transform
     val toNamejs_untangle : (string, Mono.file) transform
     val toScriptcheck : (string, Mono.file) transform
+    val toDbmodecheck : (string, Mono.file) transform
     val toJscomp : (string, Mono.file) transform
     val toMono_opt3 : (string, Mono.file) transform
     val toFuse : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 2190684a..716cc3d3 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1401,12 +1401,19 @@ val scriptcheck = {
 
 val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle
 
+val dbmodecheck = {
+    func = DbModeCheck.classify,
+    print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck
+
 val jscomp = {
     func = JsComp.process,
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toJscomp = transform jscomp "jscomp" o toScriptcheck
+val toJscomp = transform jscomp "jscomp" o toDbmodecheck
 
 val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
 
diff --git a/src/dbmodecheck.sig b/src/dbmodecheck.sig
new file mode 100644
index 00000000..4d4873c4
--- /dev/null
+++ b/src/dbmodecheck.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2014, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature DB_MODE_CHECK = sig
+
+    val classify : Mono.file -> Mono.file
+
+end
diff --git a/src/dbmodecheck.sml b/src/dbmodecheck.sml
new file mode 100644
index 00000000..eb416cea
--- /dev/null
+++ b/src/dbmodecheck.sml
@@ -0,0 +1,86 @@
+(* Copyright (c) 2014, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure DbModeCheck :> DB_MODE_CHECK = struct
+
+open Mono
+
+structure IM = IntBinaryMap
+
+fun classify (ds, ps) =
+    let
+        fun mergeModes (m1, m2) =
+            case (m1, m2) of
+                (NoDb, _) => m2
+              | (_, NoDb) => m1
+              | _ => AnyDb
+
+        fun modeOf modes =
+            MonoUtil.Exp.fold {typ = fn (_, dbm) => dbm,
+                               exp = fn (EQuery _, dbm) => mergeModes (OneQuery, dbm)
+                                      | (EDml _, _) => AnyDb
+                                      | (ENextval _, _) => AnyDb
+                                      | (ESetval _, _) => AnyDb
+                                      | (ENamed n, dbm) =>
+                                        (case IM.find (modes, n) of
+                                             NONE => dbm
+                                           | SOME dbm' => mergeModes (dbm, dbm'))
+                                      | (_, dbm) => dbm} NoDb
+
+        fun decl ((d, _), modes) =
+            case d of
+                DVal (x, n, _, e, _) => IM.insert (modes, n, modeOf modes e)
+              | DValRec xes =>
+                let
+                    val mode = foldl (fn ((_, _, _, e, _), mode) =>
+                                         let
+                                             val mode' = modeOf modes e
+                                         in
+                                             case mode' of
+                                                 NoDb => mode
+                                               | _ => AnyDb
+                                         end) NoDb xes
+                in
+                    foldl (fn ((_, n, _, _, _), modes) => IM.insert (modes, n, mode)) modes xes
+                end
+              | _ => modes
+
+        val modes = foldl decl IM.empty ds
+
+        val (ps, modes) = ListUtil.foldlMap (fn ((n, side, _), modes) =>
+                                                case IM.find (modes, n) of
+                                                    NONE => ((n, side, AnyDb), modes)
+                                                  | SOME mode => ((n, side, mode), #1 (IM.remove (modes, n))))
+                                            modes ps
+
+        val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes
+    in
+        (ds, ps)
+    end
+
+end
+
diff --git a/src/mono.sml b/src/mono.sml
index 78740d70..1e402e57 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2010, 2013, Adam Chlipala
+(* Copyright (c) 2008-2010, 2013-2014, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -162,6 +162,11 @@ datatype sidedness =
        | ServerAndPull
        | ServerAndPullAndPush
 
-type file = decl list * (int * sidedness) list
+datatype dbmode =
+         NoDb
+       | OneQuery
+       | AnyDb
+
+type file = decl list * (int * sidedness * dbmode) list
 
 end
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index e5db476a..4bc2a4cf 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -98,7 +98,7 @@ fun classify (ds, ps) =
                              else if IS.member (pull_ids, n) then
                                  ServerAndPull
                              else
-                                 ServerOnly)) (IS.listItems all_ids)
+                                 ServerOnly, AnyDb)) (IS.listItems all_ids)
     in
         (ds, ps)
     end
diff --git a/src/sources b/src/sources
index f75803a3..a5235357 100644
--- a/src/sources
+++ b/src/sources
@@ -223,6 +223,9 @@ $(SRC)/cjrize.sml
 $(SRC)/scriptcheck.sig
 $(SRC)/scriptcheck.sml
 
+$(SRC)/dbmodecheck.sig
+$(SRC)/dbmodecheck.sml
+
 $(SRC)/prepare.sig
 $(SRC)/prepare.sml