Finishes initial prototype, caching parameterless pages with table-match-based invalidation. Still has problems parsing non-Postgres SQL dialects properly.

7 files changed, 106 insertions, 20 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index ffcc0146..d4c0b439 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -477,6 +477,9 @@ struct uw_context {
 
   char *output_buffer;
   size_t output_buffer_size;
+
+  // For caching.
+  char *recording;
 };
 
 size_t uw_headers_max = SIZE_MAX;
@@ -560,6 +563,8 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
   ctx->output_buffer = malloc(1);
   ctx->output_buffer_size = 1;
 
+  ctx->recording = 0;
+
   return ctx;
 }
 
@@ -1636,6 +1641,19 @@ void uw_write(uw_context ctx, const char* s) {
   *ctx->page.front = 0;
 }
 
+void uw_recordingStart(uw_context ctx) {
+  // TODO: remove following debug statement.
+  uw_write(ctx, "<!--Recording started here-->");
+  ctx->recording = ctx->page.front;
+}
+
+char *uw_recordingRead(uw_context ctx) {
+  char *recording = strdup(ctx->recording);
+  // TODO: remove following debug statement.
+  uw_write(ctx, "<!--Recording read here-->");
+  return recording;
+}
+
 char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) {
   char *result;
   int len;
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 05dce35e..ecd29f71 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -16,7 +16,7 @@
  * 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 
+ * 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
@@ -734,7 +734,7 @@ fun unurlify fromClient env (t, loc) =
                                                  string (Int.toString (size has_arg)),
                                                  string ", ((*request)[0] == '/' ? ++*request : NULL), ",
                                                  newline,
-                                                 
+
                                                  if unboxable then
                                                      unurlify' "(*request)" (#1 t)
                                                  else
@@ -914,7 +914,7 @@ fun unurlify fromClient env (t, loc) =
                                               space,
                                               string "4, ((*request)[0] == '/' ? ++*request : NULL), ",
                                               newline,
-                                              
+
                                               string "({",
                                               newline,
                                               p_typ env (t, loc),
@@ -1188,7 +1188,7 @@ fun urlify env t =
                          string "(ctx,",
                          space,
                          string "it",
-                         string (Int.toString level), 
+                         string (Int.toString level),
                          string ");",
                          newline]
                 else
@@ -1388,7 +1388,7 @@ fun urlify env t =
                           string (Int.toString level),
                           string ");",
                           newline])
-                    
+
               | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
                       space)
     in
@@ -1578,7 +1578,7 @@ and p_exp' par tail env (e, loc) =
                                     newline],
                  string "tmp;",
                  newline,
-                 string "})"]          
+                 string "})"]
         end
       | ENone _ => string "NULL"
       | ESome (t, e) =>
@@ -2078,7 +2078,7 @@ and p_exp' par tail env (e, loc) =
                      space,
                      p_exp' false false (E.pushERel
                                              (E.pushERel env "r" (TRecord rnum, loc))
-                                             "acc" state) 
+                                             "acc" state)
                             body,
                      string ";",
                      newline]
@@ -2102,7 +2102,7 @@ and p_exp' par tail env (e, loc) =
                  newline,
                  string "uw_ensure_transaction(ctx);",
                  newline,
-                 
+
                  case prepared of
                      NONE =>
                      box [string "char *query = ",
@@ -2187,7 +2187,7 @@ and p_exp' par tail env (e, loc) =
                           string "uw_ensure_transaction(ctx);",
                           newline,
                           newline,
-                          
+
                           #dmlPrepared (Settings.currentDbms ()) {loc = loc,
                                                                   id = id,
                                                                   dml = dml',
@@ -3378,6 +3378,50 @@ fun p_file env (ds, ps) =
              newline,
              newline,
 
+             (* For caching. *)
+             box (List.map
+                      (fn index =>
+                          let val i = Int.toString index
+                          in box [string "static char *cache",
+                                  string i,
+                                  string " = NULL;",
+                                  newline,
+                                  string "static uw_Basis_bool uw_Cache_check",
+                                  string i,
+                                  string "(uw_context ctx) { puts(\"Checked ",
+                                  string i,
+                                  string "\"); if (cache",
+                                  string i,
+                                  string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache",
+                                  string i,
+                                  string "); return uw_Basis_True; } };",
+                                  newline,
+                                  string "static uw_unit uw_Cache_store",
+                                  string i,
+                                  string "(uw_context ctx) { cache",
+                                  string i,
+                                  string " = uw_recordingRead(ctx); puts(\"Stored ",
+                                  string i,
+                                  string "\"); return uw_unit_v; };",
+                                  newline,
+                                  string "static uw_unit uw_Cache_flush",
+                                  string i,
+                                  string "(uw_context ctx) { free(cache",
+                                  string i,
+                                  string "); cache",
+                                  string i,
+                                  string " = NULL; puts(\"Flushed ",
+                                  string i,
+                                  string "\"); return uw_unit_v; };",
+                                  newline,
+                                  string "static uw_unit uw_Cache_ready",
+                                  string i,
+                                  string "(uw_context ctx) { return uw_unit_v; };",
+                                  newline,
+                                  newline]
+                          end)
+                      (!SqlCache.ffiIndices)),
+             newline,
 
              p_list_sep newline (fn x => x) pds,
              newline,
@@ -3433,7 +3477,7 @@ fun p_file env (ds, ps) =
 
              makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()),
              newline,
-             
+
              string "extern void uw_sign(const char *in, char *out);",
              newline,
              string "extern int uw_hash_blocksize;",
@@ -3480,7 +3524,7 @@ fun p_file env (ds, ps) =
                   newline,
                   string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
                   newline,
-                  string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),                  
+                  string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
                   newline,
                   string "uw_write(ctx, jslib);",
                   newline,
diff --git a/src/compiler.sml b/src/compiler.sml
index de10d8c8..37272758 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -606,7 +606,7 @@ fun parseUrp' accLibs fname =
                                  filterEnv = rev (!env),
                                  sources = sources,
                                  protocol = !protocol,
-                                 dbms = !dbms,
+                                 dbms = (*!dbms*) SOME "sqlite",
                                  sigFile = !sigFile,
                                  safeGets = rev (!safeGets),
                                  onError = !onError,
diff --git a/src/sources b/src/sources
index f75803a3..b468c9a5 100644
--- a/src/sources
+++ b/src/sources
@@ -186,8 +186,13 @@ $(SRC)/mono_shake.sml
 $(SRC)/fuse.sig
 $(SRC)/fuse.sml
 
+$(SRC)/sql.sig
 $(SRC)/sql.sml
 
+$(SRC)/multimap_fn.sml
+
+$(SRC)/sql_cache.sml
+
 $(SRC)/iflow.sig
 $(SRC)/iflow.sml
 
diff --git a/src/sql.sig b/src/sql.sig
index 540844c3..573a8baf 100644
--- a/src/sql.sig
+++ b/src/sql.sig
@@ -1,10 +1,8 @@
 signature SQL = sig
 
-val fu : Mono.file -> unit
-
 val debug : bool ref
 
-type lvar
+type lvar = int
 
 datatype func =
          DtCon0 of string
@@ -41,7 +39,13 @@ datatype prop =
        | Reln of reln * exp list
        | Cond of exp * prop
 
-datatype ('a, 'b) sum = inl of 'a | inr of 'b
+datatype chunk =
+         String of string
+       | Exp of Mono.exp
+
+type 'a parser = chunk list -> ('a * chunk list) option
+
+val parse : 'a parser -> Mono.exp -> 'a option
 
 datatype Rel =
          Exps of exp * exp -> prop
@@ -61,19 +65,27 @@ datatype sqexp =
        | Unmodeled
        | Null
 
+datatype ('a,'b) sum = inl of 'a | inr of 'b
+
 datatype sitem =
          SqField of string * string
        | SqExp of sqexp * string
 
-type query1
+type query1 = {Select : sitem list,
+              From : (string * string) list,
+              Where : sqexp option}
 
 datatype query =
          Query1 of query1
        | Union of query * query
 
+val query : query parser
+
 datatype dml =
          Insert of string * (string * sqexp) list
        | Delete of string * sqexp
        | Update of string * (string * sqexp) list * sqexp
 
+val dml : dml parser
+
 end
diff --git a/src/sql.sml b/src/sql.sml
index 6ac8bc68..8642c9d2 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -1,4 +1,4 @@
-structure Sql = struct
+structure Sql :> SQL = struct
 
 open Mono
 
diff --git a/src/sql_cache.sml b/src/sql_cache.sml
index 072eefb5..7f9d98d0 100644
--- a/src/sql_cache.sml
+++ b/src/sql_cache.sml
@@ -10,6 +10,10 @@ structure SS = BinarySetFn (StringKey)
 structure SM = BinaryMapFn (StringKey)
 structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS)
 
+val ffiIndices : int list ref = ref []
+val rs : int list ref = ref []
+val ws : int list ref = ref []
+
 val rec tablesRead =
  fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs)
   | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2)
@@ -54,8 +58,8 @@ fun boolPat (b, loc) = (PCon (Enum,
                         loc)
 fun boolTyp loc = (TFfi ("Basis", "int"), loc)
 
-fun ffiAppExp (module, func, arg, loc) =
-    (EFfiApp (module, func, [(intExp (arg, loc), intTyp loc)]), loc)
+fun ffiAppExp (module, func, index, loc) =
+    (EFfiApp (module, func ^ Int.toString index, []), loc)
 
 fun sequence (befores, center, afters, loc) =
     List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc))
@@ -173,6 +177,9 @@ fun go file =
         val {readers, writers} = handlerIndices file
         val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers)
     in
+        rs := IS.listItems readers;
+        ws := IS.listItems writers;
+        ffiIndices := IS.listItems readers;
         addCacheFlushing (fileWithChecks, tablesToIndices, writers)
     end