Ran a prepared statement with one string parameter

11 files changed, 391 insertions, 12 deletions

diff --git a/include/urweb.h b/include/urweb.h
index 059cea0d..2c7576d9 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -64,3 +64,5 @@ lw_Basis_int lw_Basis_sqlifyInt(lw_context, lw_Basis_int);
 lw_Basis_float lw_Basis_sqlifyFloat(lw_context, lw_Basis_float);
 lw_Basis_string lw_Basis_sqlifyString(lw_context, lw_Basis_string);
 lw_Basis_bool lw_Basis_sqlifyBool(lw_context, lw_Basis_bool);
+
+char *lw_Basis_ensqlBool(lw_Basis_bool);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index c37393f2..6f54e1a7 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -122,7 +122,7 @@ void lw_set_input(lw_context ctx, char *name, char *value) {
 
   ctx->inputs[n] = value;
 
-  printf("[%d] %s = %s\n", n, name, value);
+  //printf("[%d] %s = %s\n", n, name, value);
 }
 
 char *lw_get_input(lw_context ctx, int n) {
@@ -130,7 +130,7 @@ char *lw_get_input(lw_context ctx, int n) {
     lw_error(ctx, FATAL, "Negative input index %d", n);
   if (n >= lw_inputs_len)
     lw_error(ctx, FATAL, "Out-of-bounds input index %d", n);
-  printf("[%d] = %s\n", n, ctx->inputs[n]);
+  //printf("[%d] = %s\n", n, ctx->inputs[n]);
   return ctx->inputs[n];
 }
 
@@ -656,3 +656,13 @@ char *lw_Basis_sqlifyBool(lw_context ctx, lw_Basis_bool b) {
   else
     return "TRUE";
 }
+
+char *lw_Basis_ensqlBool(lw_Basis_bool b) {
+  static lw_Basis_int true = 1;
+  static lw_Basis_int false = 0;
+
+  if (b == lw_Basis_False)
+    return (char *)&false;
+  else
+    return (char *)&true;
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 4d6608ce..0f261de6 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -76,7 +76,8 @@ datatype exp' =
                      state : typ,
                      query : exp,
                      body : exp,
-                     initial : exp }
+                     initial : exp,
+                     prepared : int option }
 
 withtype exp = exp' located
 
@@ -90,6 +91,7 @@ datatype decl' =
 
        | DTable of string * (string * typ) list
        | DDatabase of string
+       | DPreparedStatements of (string * int) list
 
 withtype decl = decl' located
 
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 0859abe5..fc4833da 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -164,6 +164,7 @@ fun declBinds env (d, loc) =
                   end) env vis
       | DTable _ => env
       | DDatabase _ => env
+      | DPreparedStatements _ => env
 
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 50098a99..c813a260 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -333,6 +333,45 @@ fun p_unsql env (tAll as (t, loc)) e =
               Print.eprefaces' [("Type", p_typ env tAll)];
               string "ERROR")
 
+datatype sql_type =
+         Int
+       | Float
+       | String
+       | Bool
+
+fun p_sql_type t =
+    string (case t of
+                Int => "lw_Basis_int"
+              | Float => "lw_Basis_float"
+              | String => "lw_Basis_string"
+              | Bool => "lw_Basis_bool")
+
+fun getPargs (e, _) =
+    case e of
+        EPrim (Prim.String _) => []
+      | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
+
+      | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
+      | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
+      | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
+      | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
+
+      | _ => raise Fail "CjrPrint: getPargs"
+
+fun p_ensql t e =
+    case t of
+        Int => box [string "(char *)&", e]
+      | Float => box [string "(char *)&", e]
+      | String => e
+      | Bool => box [string "lw_Basis_ensqlBool(", e, string ")"]
+
+fun p_ensql_len t e =
+    case t of
+        Int => string "sizeof(lw_Basis_int)"
+      | Float => string "sizeof(lw_Basis_float)"
+      | String => box [string "strlen(", e, string ")"]
+      | Bool => string "sizeof(lw_Basis_bool)"
+
 fun p_exp' par env (e, loc) =
     case e of
         EPrim p => Prim.p_t_GCC p
@@ -560,7 +599,7 @@ fun p_exp' par env (e, loc) =
                                     newline,
                                     string "})"]
 
-      | EQuery {exps, tables, rnum, state, query, body, initial} =>
+      | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
         let
             val exps = map (fn (x, t) => ("__lwf_" ^ x, t)) exps
             val tables = ListUtil.mapConcat (fn (x, xts) =>
@@ -573,10 +612,54 @@ fun p_exp' par env (e, loc) =
                  newline,
                  string "PGconn *conn = lw_get_db(ctx);",
                  newline,
-                 string "char *query = ",
-                 p_exp env query,
-                 string ";",
-                 newline,
+                 case prepared of
+                     NONE => box [string "char *query = ",
+                                  p_exp env query,
+                                  string ";",
+                                  newline]
+                   | SOME _ =>
+                     let
+                         val ets = getPargs query
+                     in
+                         box [p_list_sepi newline
+                                          (fn i => fn (e, t) =>
+                                                      box [p_sql_type t,
+                                                           space,
+                                                           string "arg",
+                                                           string (Int.toString (i + 1)),
+                                                           space,
+                                                           string "=",
+                                                           space,
+                                                           p_exp env e,
+                                                           string ";"])
+                                          ets,
+                              newline,
+                              newline,
+
+                              string "const char *paramValues[] = { ",
+                              p_list_sepi (box [string ",", space])
+                              (fn i => fn (_, t) => p_ensql t (box [string "arg",
+                                                                    string (Int.toString (i + 1))]))
+                              ets,
+                              string " };",
+                              newline,
+                              newline,
+
+                              string "const int paramLengths[] = { ",
+                              p_list_sepi (box [string ",", space])
+                              (fn i => fn (_, t) => p_ensql_len t (box [string "arg",
+                                                                        string (Int.toString (i + 1))]))
+                              ets,
+                              string " };",
+                              newline,
+                              newline,
+                              
+                              string "const static int paramFormats[] = { ",
+                              p_list_sep (box [string ",", space]) (fn _ => string "1") ets,
+                              string " };",
+                              newline,
+                              newline]
+                     end,
                  string "int n, i;",
                  newline,
                  p_typ env state,
@@ -588,7 +671,14 @@ fun p_exp' par env (e, loc) =
                  p_exp env initial,
                  string ";",
                  newline,
-                 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);",
+                 string "PGresult *res = ",
+                 case prepared of
+                     NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 1);"
+                   | SOME n => box [string "PQexecPrepared(conn, \"lw",
+                                    string (Int.toString n),
+                                    string "\", ",
+                                    string (Int.toString (length (getPargs query))),
+                                    string ", paramValues, paramLengths, paramFormats, 1);"],
                  newline,
                  newline,
 
@@ -602,7 +692,11 @@ fun p_exp' par env (e, loc) =
                       newline,
                       string "lw_error(ctx, FATAL, \"",
                       string (ErrorMsg.spanToString loc),
-                      string ": Query failed:\\n%s\\n%s\", query, PQerrorMessage(conn));",
+                      string ": Query failed:\\n%s\\n%s\", ",
+                      case prepared of
+                          NONE => string "query"
+                        | SOME _ => p_exp env query,
+                      string ", PQerrorMessage(conn));",
                       newline],
                  string "}",
                  newline,
@@ -814,6 +908,8 @@ fun p_decl env (dAll as (d, _) : decl) =
                               newline]
       | DDatabase s => box [string "static void lw_db_validate(lw_context);",
                             newline,
+                            string "static void lw_db_prepare(lw_context);",
+                            newline,
                             newline,
                             string "void lw_db_init(lw_context ctx) {",
                             newline,
@@ -843,6 +939,8 @@ fun p_decl env (dAll as (d, _) : decl) =
                             newline,
                             string "lw_db_validate(ctx);",
                             newline,
+                            string "lw_db_prepare(ctx);",
+                            newline,
                             string "}",
                             newline,
                             newline,
@@ -853,6 +951,48 @@ fun p_decl env (dAll as (d, _) : decl) =
                             string "}",
                             newline]
 
+      | DPreparedStatements ss =>
+        box [string "static void lw_db_prepare(lw_context ctx) {",
+             newline,
+             string "PGconn *conn = lw_get_db(ctx);",
+             newline,
+             string "PGresult *res;",
+             newline,
+             newline,
+
+             p_list_sepi newline (fn i => fn (s, n) =>
+                                             box [string "res = PQprepare(conn, \"lw",
+                                                  string (Int.toString i),
+                                                  string "\", \"",
+                                                  string (String.toString s),
+                                                  string "\", ",
+                                                  string (Int.toString n),
+                                                  string ", NULL);",
+                                                  newline,
+                                                  string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+                                                  newline,
+                                                  box [string "char msg[1024];",
+                                                       newline,
+                                                       string "strncpy(msg, PQerrorMessage(conn), 1024);",
+                                                       newline,
+                                                       string "msg[1023] = 0;",
+                                                       newline,
+                                                       string "PQclear(res);",
+                                                       newline,
+                                                       string "PQfinish(conn);",
+                                                       newline,
+                                                       string "lw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
+                                                       string (String.toString s),
+                                                       string "\\n%s\", msg);",
+                                                       newline],
+                                                  string "}",
+                                                  newline,
+                                                  string "PQclear(res);",
+                                                  newline])
+                         ss,
+             
+             string "}"]
+
 datatype 'a search =
          Found of 'a
        | NotFound
diff --git a/src/cjrize.sml b/src/cjrize.sml
index ed8182c2..71bb2a0d 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -330,7 +330,7 @@ fun cifyExp (eAll as (e, loc), sm) =
             val (initial, sm) = cifyExp (initial, sm)
         in
             ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
-                         query = query, body = body, initial = initial}, loc), sm)
+                         query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
         end
 
 
diff --git a/src/compiler.sig b/src/compiler.sig
index 30fef941..33af4a82 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -68,6 +68,7 @@ signature COMPILER = sig
     val mono_reduce : (Mono.file, Mono.file) phase
     val mono_shake : (Mono.file, Mono.file) phase
     val cjrize : (Mono.file, Cjr.file) phase
+    val prepare : (Cjr.file, Cjr.file) phase
     val sqlify : (Mono.file, Cjr.file) phase
 
     val toParseJob : (string, job) transform
@@ -87,6 +88,7 @@ signature COMPILER = sig
     val toMono_shake : (string, Mono.file) transform
     val toMono_opt2 : (string, Mono.file) transform
     val toCjrize : (string, Cjr.file) transform
+    val toPrepare : (string, Cjr.file) transform
     val toSqlify : (string, Cjr.file) transform
 
 end
diff --git a/src/compiler.sml b/src/compiler.sml
index 263aaf9a..773cf578 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -451,6 +451,13 @@ val cjrize = {
 
 val toCjrize = transform cjrize "cjrize" o toMono_opt2
 
+val prepare = {
+    func = Prepare.prepare,
+    print = CjrPrint.p_file CjrEnv.empty
+}
+
+val toPrepare = transform prepare "prepare" o toCjrize
+
 val sqlify = {
     func = Cjrize.cjrize,
     print = CjrPrint.p_sql CjrEnv.empty
@@ -472,7 +479,7 @@ fun compileC {cname, oname, ename} =
     end
 
 fun compile job =
-    case run toCjrize job of
+    case run toPrepare job of
         NONE => print "Ur compilation failed\n"
       | SOME file =>
         let
diff --git a/src/prepare.sig b/src/prepare.sig
new file mode 100644
index 00000000..0977100d
--- /dev/null
+++ b/src/prepare.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2008, 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 PREPARE = sig
+
+    val prepare : Cjr.file -> Cjr.file
+
+end
diff --git a/src/prepare.sml b/src/prepare.sml
new file mode 100644
index 00000000..67f6e0b6
--- /dev/null
+++ b/src/prepare.sml
@@ -0,0 +1,180 @@
+(* Copyright (c) 2008, 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 Prepare :> PREPARE = struct
+
+open Cjr
+
+fun prepString (e, ss, n) =
+    case #1 e of
+        EPrim (Prim.String s) =>
+        SOME (s :: ss, n)
+      | EFfiApp ("Basis", "strcat", [e1, e2]) =>
+        (case prepString (e1, ss, n) of
+             NONE => NONE
+           | SOME (ss, n) => prepString (e2, ss, n))
+      | EFfiApp ("Basis", "sqlifyInt", [e]) =>
+        SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1)
+      | EFfiApp ("Basis", "sqlifyFloat", [e]) =>
+        SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1)
+      | EFfiApp ("Basis", "sqlifyString", [e]) =>
+        SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1)
+      | EFfiApp ("Basis", "sqlifyBool", [e]) =>
+        SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1)
+
+      | _ => NONE
+
+fun prepExp (e as (_, loc), sns) =
+    case #1 e of
+        EPrim _ => (e, sns)
+      | ERel _ => (e, sns)
+      | ENamed _ => (e, sns)
+      | ECon (_, _, NONE) => (e, sns)
+      | ECon (dk, pc, SOME e) =>
+        let
+            val (e, sns) = prepExp (e, sns)
+        in
+            ((ECon (dk, pc, SOME e), loc), sns)
+        end
+      | EFfi _ => (e, sns)
+      | EFfiApp (m, x, es) =>
+        let
+            val (es, sns) = ListUtil.foldlMap prepExp sns es
+        in
+            ((EFfiApp (m, x, es), loc), sns)
+        end
+      | EApp (e1, e2) =>
+        let
+            val (e1, sns) = prepExp (e1, sns)
+            val (e2, sns) = prepExp (e2, sns)
+        in
+            ((EApp (e1, e2), loc), sns)
+        end
+
+      | ERecord (rn, xes) =>
+        let
+            val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
+                                                   let
+                                                       val (e, sns) = prepExp (e, sns)
+                                                   in
+                                                       ((x, e), sns)
+                                                   end) sns xes
+        in
+            ((ERecord (rn, xes), loc), sns)
+        end
+      | EField (e, s) =>
+        let
+            val (e, sns) = prepExp (e, sns)
+        in
+            ((EField (e, s), loc), sns)
+        end
+
+      | ECase (e, pes, ts) =>
+        let
+            val (e, sns) = prepExp (e, sns)
+            val (pes, sns) = ListUtil.foldlMap (fn ((p, e), sns) =>
+                                                   let
+                                                       val (e, sns) = prepExp (e, sns)
+                                                   in
+                                                       ((p, e), sns)
+                                                   end) sns pes
+        in
+            ((ECase (e, pes, ts), loc), sns)
+        end
+
+      | EWrite e =>
+        let
+            val (e, sns) = prepExp (e, sns)
+        in
+            ((EWrite e, loc), sns)
+        end
+      | ESeq (e1, e2) =>
+        let
+            val (e1, sns) = prepExp (e1, sns)
+            val (e2, sns) = prepExp (e2, sns)
+        in
+            ((ESeq (e1, e2), loc), sns)
+        end
+      | ELet (x, t, e1, e2) =>
+        let
+            val (e1, sns) = prepExp (e1, sns)
+            val (e2, sns) = prepExp (e2, sns)
+        in
+            ((ELet (x, t, e1, e2), loc), sns)
+        end
+
+      | EQuery {exps, tables, rnum, state, query, body, initial, ...} =>
+        (case prepString (query, [], 0) of
+             NONE => (e, sns)
+           | SOME (ss, n) =>
+             ((EQuery {exps = exps, tables = tables, rnum = rnum,
+                       state = state, query = query, body = body,
+                       initial = initial, prepared = SOME (#2 sns)}, loc),
+              ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)))
+
+fun prepDecl (d as (_, loc), sns) =
+    case #1 d of
+        DStruct _ => (d, sns)
+      | DDatatype _ => (d, sns)
+      | DDatatypeForward _ => (d, sns)
+      | DVal (x, n, t, e) =>
+        let
+            val (e, sns) = prepExp (e, sns)
+        in
+            ((DVal (x, n, t, e), loc), sns)
+        end
+      | DFun (x, n, xts, t, e) =>
+        let
+            val (e, sns) = prepExp (e, sns)
+        in
+            ((DFun (x, n, xts, t, e), loc), sns)
+        end
+      | DFunRec fs =>
+        let
+            val (fs, sns) = ListUtil.foldlMap (fn ((x, n, xts, t, e), sns) =>
+                                                  let
+                                                      val (e, sns) = prepExp (e, sns)
+                                                  in
+                                                      ((x, n, xts, t, e), sns)
+                                                  end) sns fs
+        in
+            ((DFunRec fs, loc), sns)
+        end
+
+      | DTable _ => (d, sns)
+      | DDatabase _ => (d, sns)
+      | DPreparedStatements _ => (d, sns)
+
+fun prepare (ds, ps) =
+    let
+        val (ds, (sns, _)) = ListUtil.foldlMap prepDecl ([], 0) ds
+    in
+        ((DPreparedStatements (rev sns), ErrorMsg.dummySpan) :: ds, ps)
+    end
+
+end
+
diff --git a/src/sources b/src/sources
index c57a30b1..6c1c7ac8 100644
--- a/src/sources
+++ b/src/sources
@@ -121,5 +121,8 @@ cjr_print.sml
 cjrize.sig
 cjrize.sml
 
+prepare.sig
+prepare.sml
+
 compiler.sig
 compiler.sml