summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb/urweb_cpp.h1
-rw-r--r--src/c/urweb.c9
-rw-r--r--src/cjr.sml3
-rw-r--r--src/cjr_print.sml8
-rw-r--r--src/cjrize.sml10
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml9
-rw-r--r--src/dbmodecheck.sig32
-rw-r--r--src/dbmodecheck.sml86
-rw-r--r--src/mono.sml9
-rw-r--r--src/scriptcheck.sml2
-rw-r--r--src/sources3
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-25 06:56:35 +0000