Mercurial > urweb
changeset 282:0236d9412ad2
Ran a prepared statement with one string parameter
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 07 Sep 2008 09:28:13 -0400 |
| parents | 7d5860add50f |
| children | c0e4ac23522d |
| files | include/urweb.h src/c/urweb.c src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/compiler.sig src/compiler.sml src/prepare.sig src/prepare.sml src/sources |
| diffstat | 11 files changed, 391 insertions(+), 12 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Thu Sep 04 10:27:21 2008 -0400 +++ b/include/urweb.h Sun Sep 07 09:28:13 2008 -0400 @@ -64,3 +64,5 @@ 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);
--- a/src/c/urweb.c Thu Sep 04 10:27:21 2008 -0400 +++ b/src/c/urweb.c Sun Sep 07 09:28:13 2008 -0400 @@ -122,7 +122,7 @@ 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 @@ 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 @@ 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; +}
--- a/src/cjr.sml Thu Sep 04 10:27:21 2008 -0400 +++ b/src/cjr.sml Sun Sep 07 09:28:13 2008 -0400 @@ -76,7 +76,8 @@ state : typ, query : exp, body : exp, - initial : exp } + initial : exp, + prepared : int option } withtype exp = exp' located @@ -90,6 +91,7 @@ | DTable of string * (string * typ) list | DDatabase of string + | DPreparedStatements of (string * int) list withtype decl = decl' located
--- a/src/cjr_env.sml Thu Sep 04 10:27:21 2008 -0400 +++ b/src/cjr_env.sml Sun Sep 07 09:28:13 2008 -0400 @@ -164,6 +164,7 @@ end) env vis | DTable _ => env | DDatabase _ => env + | DPreparedStatements _ => env end
--- a/src/cjr_print.sml Thu Sep 04 10:27:21 2008 -0400 +++ b/src/cjr_print.sml Sun Sep 07 09:28:13 2008 -0400 @@ -333,6 +333,45 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ newline, string "lw_db_validate(ctx);", newline, + string "lw_db_prepare(ctx);", + newline, string "}", newline, newline, @@ -853,6 +951,48 @@ 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
--- a/src/cjrize.sml Thu Sep 04 10:27:21 2008 -0400 +++ b/src/cjrize.sml Sun Sep 07 09:28:13 2008 -0400 @@ -330,7 +330,7 @@ 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
--- a/src/compiler.sig Thu Sep 04 10:27:21 2008 -0400 +++ b/src/compiler.sig Sun Sep 07 09:28:13 2008 -0400 @@ -68,6 +68,7 @@ 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 @@ 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
--- a/src/compiler.sml Thu Sep 04 10:27:21 2008 -0400 +++ b/src/compiler.sml Sun Sep 07 09:28:13 2008 -0400 @@ -451,6 +451,13 @@ 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 @@ end fun compile job = - case run toCjrize job of + case run toPrepare job of NONE => print "Ur compilation failed\n" | SOME file => let
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/prepare.sig Sun Sep 07 09:28:13 2008 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/prepare.sml Sun Sep 07 09:28:13 2008 -0400 @@ -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 +