adam@1295
|
1 (* Copyright (c) 2008-2010, Adam Chlipala
|
adamc@866
|
2 * All rights reserved.
|
adamc@866
|
3 *
|
adamc@866
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@866
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@866
|
6 *
|
adamc@866
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@866
|
8 * this list of conditions and the following disclaimer.
|
adamc@866
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@866
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@866
|
11 * and/or other materials provided with the distribution.
|
adamc@866
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@866
|
13 * derived from this software without specific prior written permission.
|
adamc@866
|
14 *
|
adamc@866
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@866
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@866
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@866
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adam@1682
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@866
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@866
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@866
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@866
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@866
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@866
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@866
|
26 *)
|
adamc@866
|
27
|
adamc@866
|
28 structure Postgres :> POSTGRES = struct
|
adamc@866
|
29
|
adamc@866
|
30 open Settings
|
adamc@866
|
31 open Print.PD
|
adamc@866
|
32 open Print
|
adamc@866
|
33
|
adamc@870
|
34 val ident = String.translate (fn #"'" => "PRIME"
|
adamc@870
|
35 | ch => str ch)
|
adamc@870
|
36
|
adamc@873
|
37 fun p_sql_type t =
|
adamc@873
|
38 case t of
|
adamc@873
|
39 Int => "int8"
|
adamc@873
|
40 | Float => "float8"
|
adamc@873
|
41 | String => "text"
|
adamc@1011
|
42 | Char => "char"
|
adamc@873
|
43 | Bool => "bool"
|
adamc@873
|
44 | Time => "timestamp"
|
adamc@873
|
45 | Blob => "bytea"
|
adamc@873
|
46 | Channel => "int8"
|
adamc@873
|
47 | Client => "int4"
|
adamc@873
|
48 | Nullable t => p_sql_type t
|
adamc@873
|
49
|
adamc@870
|
50 fun p_sql_type_base t =
|
adamc@870
|
51 case t of
|
adamc@871
|
52 Int => "bigint"
|
adamc@871
|
53 | Float => "double precision"
|
adamc@870
|
54 | String => "text"
|
adamc@1011
|
55 | Char => "character"
|
adamc@871
|
56 | Bool => "boolean"
|
adamc@871
|
57 | Time => "timestamp without time zone"
|
adamc@870
|
58 | Blob => "bytea"
|
adamc@871
|
59 | Channel => "bigint"
|
adamc@871
|
60 | Client => "integer"
|
adamc@870
|
61 | Nullable t => p_sql_type_base t
|
adamc@870
|
62
|
adamc@872
|
63 fun checkRel (table, checkNullable) (s, xts) =
|
adamc@871
|
64 let
|
adamc@871
|
65 val sl = CharVector.map Char.toLower s
|
adamc@871
|
66
|
adamc@872
|
67 val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '"
|
adamc@871
|
68 ^ sl ^ "'"
|
adamc@871
|
69
|
adamc@871
|
70 val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
|
adamc@871
|
71 sl,
|
adamc@871
|
72 "' AND (",
|
adam@1600
|
73 case String.concatWith " OR "
|
adam@1600
|
74 (map (fn (x, t) =>
|
adam@1600
|
75 String.concat ["(column_name = 'uw_",
|
adam@1600
|
76 CharVector.map
|
adam@1600
|
77 Char.toLower (ident x),
|
adam@1600
|
78 (case p_sql_type_base t of
|
adam@1600
|
79 "bigint" =>
|
adam@1600
|
80 "' AND data_type IN ('bigint', 'numeric')"
|
adam@1600
|
81 | t =>
|
adam@1600
|
82 String.concat ["' AND data_type = '",
|
adam@1600
|
83 t,
|
adam@1600
|
84 "'"]),
|
adam@1600
|
85 if checkNullable then
|
adam@1600
|
86 (" AND is_nullable = '"
|
adam@1600
|
87 ^ (if isNotNull t then
|
adam@1600
|
88 "NO"
|
adam@1600
|
89 else
|
adam@1600
|
90 "YES")
|
adam@1600
|
91 ^ "'")
|
adam@1600
|
92 else
|
adam@1600
|
93 "",
|
adam@1600
|
94 ")"]) xts) of
|
adam@1600
|
95 "" => "FALSE"
|
adam@1600
|
96 | s => s,
|
adamc@871
|
97 ")"]
|
adamc@871
|
98
|
adamc@871
|
99 val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '",
|
adamc@871
|
100 sl,
|
adamc@871
|
101 "' AND column_name LIKE 'uw_%'"]
|
adamc@871
|
102 in
|
adamc@871
|
103 box [string "res = PQexec(conn, \"",
|
adamc@871
|
104 string q,
|
adamc@871
|
105 string "\");",
|
adamc@871
|
106 newline,
|
adamc@871
|
107 newline,
|
adamc@871
|
108 string "if (res == NULL) {",
|
adamc@871
|
109 newline,
|
adamc@871
|
110 box [string "PQfinish(conn);",
|
adamc@871
|
111 newline,
|
adamc@871
|
112 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@871
|
113 newline],
|
adamc@871
|
114 string "}",
|
adamc@871
|
115 newline,
|
adamc@871
|
116 newline,
|
adamc@871
|
117 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@871
|
118 newline,
|
adamc@871
|
119 box [string "char msg[1024];",
|
adamc@871
|
120 newline,
|
adamc@871
|
121 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@871
|
122 newline,
|
adamc@871
|
123 string "msg[1023] = 0;",
|
adamc@871
|
124 newline,
|
adamc@871
|
125 string "PQclear(res);",
|
adamc@871
|
126 newline,
|
adamc@871
|
127 string "PQfinish(conn);",
|
adamc@871
|
128 newline,
|
adamc@871
|
129 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@871
|
130 string q,
|
adamc@871
|
131 string "\\n%s\", msg);",
|
adamc@871
|
132 newline],
|
adamc@871
|
133 string "}",
|
adamc@871
|
134 newline,
|
adamc@871
|
135 newline,
|
adamc@871
|
136 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
|
adamc@871
|
137 newline,
|
adamc@871
|
138 box [string "PQclear(res);",
|
adamc@871
|
139 newline,
|
adamc@871
|
140 string "PQfinish(conn);",
|
adamc@871
|
141 newline,
|
adamc@871
|
142 string "uw_error(ctx, FATAL, \"Table '",
|
adamc@871
|
143 string s,
|
adamc@871
|
144 string "' does not exist.\");",
|
adamc@871
|
145 newline],
|
adamc@871
|
146 string "}",
|
adamc@871
|
147 newline,
|
adamc@871
|
148 newline,
|
adamc@871
|
149 string "PQclear(res);",
|
adamc@871
|
150 newline,
|
adamc@871
|
151
|
adamc@871
|
152 string "res = PQexec(conn, \"",
|
adamc@871
|
153 string q',
|
adamc@871
|
154 string "\");",
|
adamc@871
|
155 newline,
|
adamc@871
|
156 newline,
|
adamc@871
|
157 string "if (res == NULL) {",
|
adamc@871
|
158 newline,
|
adamc@871
|
159 box [string "PQfinish(conn);",
|
adamc@871
|
160 newline,
|
adamc@871
|
161 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@871
|
162 newline],
|
adamc@871
|
163 string "}",
|
adamc@871
|
164 newline,
|
adamc@871
|
165 newline,
|
adamc@871
|
166 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@871
|
167 newline,
|
adamc@871
|
168 box [string "char msg[1024];",
|
adamc@871
|
169 newline,
|
adamc@871
|
170 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@871
|
171 newline,
|
adamc@871
|
172 string "msg[1023] = 0;",
|
adamc@871
|
173 newline,
|
adamc@871
|
174 string "PQclear(res);",
|
adamc@871
|
175 newline,
|
adamc@871
|
176 string "PQfinish(conn);",
|
adamc@871
|
177 newline,
|
adamc@871
|
178 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@871
|
179 string q',
|
adamc@871
|
180 string "\\n%s\", msg);",
|
adamc@871
|
181 newline],
|
adamc@871
|
182 string "}",
|
adamc@871
|
183 newline,
|
adamc@871
|
184 newline,
|
adamc@871
|
185 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
|
adamc@871
|
186 string (Int.toString (length xts)),
|
adamc@871
|
187 string "\")) {",
|
adamc@871
|
188 newline,
|
adamc@871
|
189 box [string "PQclear(res);",
|
adamc@871
|
190 newline,
|
adamc@871
|
191 string "PQfinish(conn);",
|
adamc@871
|
192 newline,
|
adamc@871
|
193 string "uw_error(ctx, FATAL, \"Table '",
|
adamc@871
|
194 string s,
|
adamc@871
|
195 string "' has the wrong column types.\");",
|
adamc@871
|
196 newline],
|
adamc@871
|
197 string "}",
|
adamc@871
|
198 newline,
|
adamc@871
|
199 newline,
|
adamc@871
|
200 string "PQclear(res);",
|
adamc@871
|
201 newline,
|
adamc@871
|
202 newline,
|
adamc@871
|
203
|
adamc@871
|
204 string "res = PQexec(conn, \"",
|
adamc@871
|
205 string q'',
|
adamc@871
|
206 string "\");",
|
adamc@871
|
207 newline,
|
adamc@871
|
208 newline,
|
adamc@871
|
209 string "if (res == NULL) {",
|
adamc@871
|
210 newline,
|
adamc@871
|
211 box [string "PQfinish(conn);",
|
adamc@871
|
212 newline,
|
adamc@871
|
213 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@871
|
214 newline],
|
adamc@871
|
215 string "}",
|
adamc@871
|
216 newline,
|
adamc@871
|
217 newline,
|
adamc@871
|
218 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@871
|
219 newline,
|
adamc@871
|
220 box [string "char msg[1024];",
|
adamc@871
|
221 newline,
|
adamc@871
|
222 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@871
|
223 newline,
|
adamc@871
|
224 string "msg[1023] = 0;",
|
adamc@871
|
225 newline,
|
adamc@871
|
226 string "PQclear(res);",
|
adamc@871
|
227 newline,
|
adamc@871
|
228 string "PQfinish(conn);",
|
adamc@871
|
229 newline,
|
adamc@871
|
230 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@871
|
231 string q'',
|
adamc@871
|
232 string "\\n%s\", msg);",
|
adamc@871
|
233 newline],
|
adamc@871
|
234 string "}",
|
adamc@871
|
235 newline,
|
adamc@871
|
236 newline,
|
adamc@871
|
237 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
|
adamc@871
|
238 string (Int.toString (length xts)),
|
adamc@871
|
239 string "\")) {",
|
adamc@871
|
240 newline,
|
adamc@871
|
241 box [string "PQclear(res);",
|
adamc@871
|
242 newline,
|
adamc@871
|
243 string "PQfinish(conn);",
|
adamc@871
|
244 newline,
|
adamc@871
|
245 string "uw_error(ctx, FATAL, \"Table '",
|
adamc@871
|
246 string s,
|
adamc@871
|
247 string "' has extra columns.\");",
|
adamc@871
|
248 newline],
|
adamc@871
|
249 string "}",
|
adamc@871
|
250 newline,
|
adamc@871
|
251 newline,
|
adamc@871
|
252 string "PQclear(res);",
|
adamc@871
|
253 newline]
|
adamc@871
|
254 end
|
adamc@871
|
255
|
adamc@872
|
256 fun init {dbstring, prepared = ss, tables, views, sequences} =
|
adamc@866
|
257 box [if #persistent (currentProtocol ()) then
|
adamc@1094
|
258 box [string "static void uw_db_validate(uw_context ctx) {",
|
adamc@870
|
259 newline,
|
adamc@870
|
260 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@870
|
261 newline,
|
adamc@870
|
262 string "PGresult *res;",
|
adamc@870
|
263 newline,
|
adamc@870
|
264 newline,
|
adamc@872
|
265 p_list_sep newline (checkRel ("tables", true)) tables,
|
adamc@872
|
266 p_list_sep newline (checkRel ("views", false)) views,
|
adamc@870
|
267
|
adamc@870
|
268 p_list_sep newline
|
adamc@870
|
269 (fn s =>
|
adamc@870
|
270 let
|
adamc@870
|
271 val sl = CharVector.map Char.toLower s
|
adamc@870
|
272
|
adamc@870
|
273 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
|
adamc@870
|
274 ^ sl ^ "' AND relkind = 'S'"
|
adamc@870
|
275 in
|
adamc@870
|
276 box [string "res = PQexec(conn, \"",
|
adamc@870
|
277 string q,
|
adamc@870
|
278 string "\");",
|
adamc@870
|
279 newline,
|
adamc@870
|
280 newline,
|
adamc@870
|
281 string "if (res == NULL) {",
|
adamc@870
|
282 newline,
|
adamc@870
|
283 box [string "PQfinish(conn);",
|
adamc@870
|
284 newline,
|
adamc@870
|
285 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@870
|
286 newline],
|
adamc@870
|
287 string "}",
|
adamc@870
|
288 newline,
|
adamc@870
|
289 newline,
|
adamc@870
|
290 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@870
|
291 newline,
|
adamc@870
|
292 box [string "char msg[1024];",
|
adamc@870
|
293 newline,
|
adamc@870
|
294 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@870
|
295 newline,
|
adamc@870
|
296 string "msg[1023] = 0;",
|
adamc@870
|
297 newline,
|
adamc@870
|
298 string "PQclear(res);",
|
adamc@870
|
299 newline,
|
adamc@870
|
300 string "PQfinish(conn);",
|
adamc@870
|
301 newline,
|
adamc@870
|
302 string "uw_error(ctx, FATAL, \"Query failed:\\n",
|
adamc@870
|
303 string q,
|
adamc@870
|
304 string "\\n%s\", msg);",
|
adamc@870
|
305 newline],
|
adamc@870
|
306 string "}",
|
adamc@870
|
307 newline,
|
adamc@870
|
308 newline,
|
adamc@870
|
309 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
|
adamc@870
|
310 newline,
|
adamc@870
|
311 box [string "PQclear(res);",
|
adamc@870
|
312 newline,
|
adamc@870
|
313 string "PQfinish(conn);",
|
adamc@870
|
314 newline,
|
adamc@870
|
315 string "uw_error(ctx, FATAL, \"Sequence '",
|
adamc@870
|
316 string s,
|
adamc@870
|
317 string "' does not exist.\");",
|
adamc@870
|
318 newline],
|
adamc@870
|
319 string "}",
|
adamc@870
|
320 newline,
|
adamc@870
|
321 newline,
|
adamc@870
|
322 string "PQclear(res);",
|
adamc@870
|
323 newline]
|
adamc@870
|
324 end) sequences,
|
adamc@870
|
325
|
adamc@870
|
326 string "}",
|
adamc@870
|
327
|
adamc@870
|
328 string "static void uw_db_prepare(uw_context ctx) {",
|
adamc@866
|
329 newline,
|
adamc@866
|
330 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@866
|
331 newline,
|
adamc@866
|
332 string "PGresult *res;",
|
adamc@866
|
333 newline,
|
adamc@866
|
334 newline,
|
adamc@866
|
335
|
adamc@866
|
336 p_list_sepi newline (fn i => fn (s, n) =>
|
adamc@866
|
337 box [string "res = PQprepare(conn, \"uw",
|
adamc@866
|
338 string (Int.toString i),
|
adamc@866
|
339 string "\", \"",
|
adam@1656
|
340 string (Prim.toCString s),
|
adamc@866
|
341 string "\", ",
|
adamc@866
|
342 string (Int.toString n),
|
adamc@866
|
343 string ", NULL);",
|
adamc@866
|
344 newline,
|
adamc@866
|
345 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@866
|
346 newline,
|
adamc@866
|
347 box [string "char msg[1024];",
|
adamc@866
|
348 newline,
|
adamc@866
|
349 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@866
|
350 newline,
|
adamc@866
|
351 string "msg[1023] = 0;",
|
adamc@866
|
352 newline,
|
adamc@866
|
353 string "PQclear(res);",
|
adamc@866
|
354 newline,
|
adamc@866
|
355 string "PQfinish(conn);",
|
adamc@866
|
356 newline,
|
adamc@866
|
357 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
|
adam@1656
|
358 string (Prim.toCString s),
|
adamc@866
|
359 string "\\n%s\", msg);",
|
adamc@866
|
360 newline],
|
adamc@866
|
361 string "}",
|
adamc@866
|
362 newline,
|
adamc@866
|
363 string "PQclear(res);",
|
adamc@866
|
364 newline])
|
adamc@866
|
365 ss,
|
adamc@866
|
366
|
adamc@866
|
367 string "}",
|
adamc@866
|
368 newline,
|
adamc@866
|
369 newline]
|
adamc@866
|
370 else
|
adamc@870
|
371 box [string "static void uw_db_validate(uw_context ctx) { }",
|
adamc@870
|
372 newline,
|
adamc@870
|
373 string "static void uw_db_prepare(uw_context ctx) { }"],
|
adamc@870
|
374
|
adamc@1094
|
375 string "static void uw_client_init(void) {",
|
adamc@1094
|
376 newline,
|
adamc@1094
|
377 box [string "uw_sqlfmtInt = \"%lld::int8%n\";",
|
adamc@1094
|
378 newline,
|
adamc@1094
|
379 string "uw_sqlfmtFloat = \"%g::float8%n\";",
|
adamc@1094
|
380 newline,
|
adamc@1094
|
381 string "uw_Estrings = 1;",
|
adamc@1094
|
382 newline,
|
adamc@1094
|
383 string "uw_sqlsuffixString = \"::text\";",
|
adamc@1094
|
384 newline,
|
adamc@1094
|
385 string "uw_sqlsuffixChar = \"::char\";",
|
adamc@1094
|
386 newline,
|
adamc@1094
|
387 string "uw_sqlsuffixBlob = \"::bytea\";",
|
adamc@1094
|
388 newline,
|
adamc@1094
|
389 string "uw_sqlfmtUint4 = \"%u::int4%n\";",
|
adamc@1094
|
390 newline],
|
adamc@1094
|
391 string "}",
|
adamc@866
|
392 newline,
|
adamc@866
|
393 newline,
|
adamc@866
|
394
|
adamc@1094
|
395 string "static void uw_db_close(uw_context ctx) {",
|
adamc@1094
|
396 newline,
|
adamc@1094
|
397 string "PQfinish(uw_get_db(ctx));",
|
adamc@1094
|
398 newline,
|
adamc@1094
|
399 string "}",
|
adamc@1094
|
400 newline,
|
adamc@1094
|
401 newline,
|
adamc@1094
|
402
|
adamc@1094
|
403 string "static int uw_db_begin(uw_context ctx) {",
|
adamc@1094
|
404 newline,
|
adamc@1094
|
405 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@1094
|
406 newline,
|
adamc@1094
|
407 string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
|
adamc@1094
|
408 newline,
|
adamc@1094
|
409 newline,
|
adamc@1094
|
410 string "if (res == NULL) return 1;",
|
adamc@1094
|
411 newline,
|
adamc@1094
|
412 newline,
|
adamc@1094
|
413 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@1094
|
414 box [string "PQclear(res);",
|
adamc@1094
|
415 newline,
|
adamc@1094
|
416 string "return 1;",
|
adamc@1094
|
417 newline],
|
adamc@1094
|
418 string "}",
|
adamc@1094
|
419 newline,
|
adamc@1144
|
420 string "PQclear(res);",
|
adamc@1144
|
421 newline,
|
adamc@1094
|
422 string "return 0;",
|
adamc@1094
|
423 newline,
|
adamc@1094
|
424 string "}",
|
adamc@1094
|
425 newline,
|
adamc@1094
|
426 newline,
|
adamc@1094
|
427
|
adamc@1094
|
428 string "static int uw_db_commit(uw_context ctx) {",
|
adamc@1094
|
429 newline,
|
adamc@1094
|
430 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@1094
|
431 newline,
|
adamc@1094
|
432 string "PGresult *res = PQexec(conn, \"COMMIT\");",
|
adamc@1094
|
433 newline,
|
adamc@1094
|
434 newline,
|
adamc@1094
|
435 string "if (res == NULL) return 1;",
|
adamc@1094
|
436 newline,
|
adamc@1094
|
437 newline,
|
adamc@1094
|
438 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@1094
|
439 box [string "PQclear(res);",
|
adamc@1094
|
440 newline,
|
adamc@1094
|
441 string "return 1;",
|
adamc@1094
|
442 newline],
|
adamc@1094
|
443 string "}",
|
adamc@1094
|
444 newline,
|
adamc@1144
|
445 string "PQclear(res);",
|
adamc@1144
|
446 newline,
|
adamc@1094
|
447 string "return 0;",
|
adamc@1094
|
448 newline,
|
adamc@1094
|
449 string "}",
|
adamc@1094
|
450 newline,
|
adamc@1094
|
451 newline,
|
adamc@1094
|
452
|
adamc@1094
|
453 string "static int uw_db_rollback(uw_context ctx) {",
|
adamc@1094
|
454 newline,
|
adamc@1094
|
455 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@1094
|
456 newline,
|
adamc@1094
|
457 string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
|
adamc@1094
|
458 newline,
|
adamc@1094
|
459 newline,
|
adamc@1094
|
460 string "if (res == NULL) return 1;",
|
adamc@1094
|
461 newline,
|
adamc@1094
|
462 newline,
|
adamc@1094
|
463 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@1094
|
464 box [string "PQclear(res);",
|
adamc@1094
|
465 newline,
|
adamc@1094
|
466 string "return 1;",
|
adamc@1094
|
467 newline],
|
adamc@1094
|
468 string "}",
|
adamc@1094
|
469 newline,
|
adamc@1144
|
470 string "PQclear(res);",
|
adamc@1144
|
471 newline,
|
adamc@1094
|
472 string "return 0;",
|
adamc@1094
|
473 newline,
|
adamc@1094
|
474 string "}",
|
adamc@1094
|
475
|
adamc@1094
|
476 newline,
|
adamc@1094
|
477 newline,
|
adamc@1094
|
478
|
adamc@1094
|
479 string "static void uw_db_init(uw_context ctx) {",
|
adamc@866
|
480 newline,
|
as@1564
|
481 string "char *env_db_str = getenv(\"URWEB_PQ_CON\");",
|
as@1564
|
482 newline,
|
as@1564
|
483 string "PGconn *conn = PQconnectdb(env_db_str == NULL ? \"",
|
adam@1656
|
484 string (Prim.toCString dbstring),
|
as@1564
|
485 string "\" : env_db_str);",
|
adamc@866
|
486 newline,
|
adamc@866
|
487 string "if (conn == NULL) uw_error(ctx, FATAL, ",
|
adamc@866
|
488 string "\"libpq can't allocate a connection.\");",
|
adamc@866
|
489 newline,
|
adamc@866
|
490 string "if (PQstatus(conn) != CONNECTION_OK) {",
|
adamc@866
|
491 newline,
|
adamc@866
|
492 box [string "char msg[1024];",
|
adamc@866
|
493 newline,
|
adamc@866
|
494 string "strncpy(msg, PQerrorMessage(conn), 1024);",
|
adamc@866
|
495 newline,
|
adamc@866
|
496 string "msg[1023] = 0;",
|
adamc@866
|
497 newline,
|
adamc@866
|
498 string "PQfinish(conn);",
|
adamc@866
|
499 newline,
|
adamc@866
|
500 string "uw_error(ctx, BOUNDED_RETRY, ",
|
adamc@866
|
501 string "\"Connection to Postgres server failed: %s\", msg);"],
|
adamc@866
|
502 newline,
|
adamc@866
|
503 string "}",
|
adamc@866
|
504 newline,
|
adamc@866
|
505 string "uw_set_db(ctx, conn);",
|
adamc@866
|
506 newline,
|
adamc@866
|
507 string "uw_db_validate(ctx);",
|
adamc@866
|
508 newline,
|
adamc@866
|
509 string "uw_db_prepare(ctx);",
|
adamc@866
|
510 newline,
|
adamc@866
|
511 string "}"]
|
adamc@866
|
512
|
adamc@880
|
513 fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
|
adamc@867
|
514 let
|
adamc@867
|
515 fun p_unsql t e eLen =
|
adamc@867
|
516 case t of
|
adamc@867
|
517 Int => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
|
adamc@867
|
518 | Float => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
|
adamc@867
|
519 | String =>
|
adamc@867
|
520 if wontLeakStrings then
|
adamc@867
|
521 e
|
adamc@867
|
522 else
|
adamc@867
|
523 box [string "uw_strdup(ctx, ", e, string ")"]
|
adamc@1011
|
524 | Char => box [e, string "[0]"]
|
adamc@867
|
525 | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
|
adamc@939
|
526 | Time => box [string "uw_Basis_unsqlTime(ctx, ", e, string ")"]
|
adamc@867
|
527 | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ",
|
adamc@867
|
528 e,
|
adamc@867
|
529 string ", ",
|
adamc@867
|
530 eLen,
|
adamc@867
|
531 string ")"]
|
adamc@867
|
532 | Channel => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
|
adamc@867
|
533 | Client => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
|
adamc@867
|
534
|
adamc@867
|
535 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
|
adamc@867
|
536
|
adamc@867
|
537 fun getter t =
|
adamc@867
|
538 case t of
|
adamc@867
|
539 Nullable t =>
|
adamc@867
|
540 box [string "(PQgetisnull(res, i, ",
|
adamc@867
|
541 string (Int.toString i),
|
adamc@867
|
542 string ") ? NULL : ",
|
adamc@867
|
543 case t of
|
adamc@867
|
544 String => getter t
|
adamc@867
|
545 | _ => box [string "({",
|
adamc@867
|
546 newline,
|
adamc@874
|
547 string (p_sql_ctype t),
|
adamc@867
|
548 space,
|
adamc@867
|
549 string "*tmp = uw_malloc(ctx, sizeof(",
|
adamc@874
|
550 string (p_sql_ctype t),
|
adamc@867
|
551 string "));",
|
adamc@867
|
552 newline,
|
adamc@867
|
553 string "*tmp = ",
|
adamc@867
|
554 getter t,
|
adamc@867
|
555 string ";",
|
adamc@867
|
556 newline,
|
adamc@867
|
557 string "tmp;",
|
adamc@867
|
558 newline,
|
adamc@867
|
559 string "})"],
|
adamc@867
|
560 string ")"]
|
adamc@867
|
561 | _ =>
|
adamc@867
|
562 box [string "(PQgetisnull(res, i, ",
|
adamc@867
|
563 string (Int.toString i),
|
adamc@867
|
564 string ") ? ",
|
adamc@867
|
565 box [string "({",
|
adamc@874
|
566 string (p_sql_ctype t),
|
adamc@867
|
567 space,
|
adamc@867
|
568 string "tmp;",
|
adamc@867
|
569 newline,
|
adamc@880
|
570 string "uw_error(ctx, FATAL, \"",
|
adamc@880
|
571 string (ErrorMsg.spanToString loc),
|
adamc@880
|
572 string ": Unexpectedly NULL field #",
|
adamc@867
|
573 string (Int.toString i),
|
adamc@867
|
574 string "\");",
|
adamc@867
|
575 newline,
|
adamc@867
|
576 string "tmp;",
|
adamc@867
|
577 newline,
|
adamc@867
|
578 string "})"],
|
adamc@867
|
579 string " : ",
|
adamc@867
|
580 p_unsql t
|
adamc@867
|
581 (box [string "PQgetvalue(res, i, ",
|
adamc@867
|
582 string (Int.toString i),
|
adamc@867
|
583 string ")"])
|
adamc@867
|
584 (box [string "PQgetlength(res, i, ",
|
adamc@867
|
585 string (Int.toString i),
|
adamc@867
|
586 string ")"]),
|
adamc@867
|
587 string ")"]
|
adamc@867
|
588 in
|
adamc@867
|
589 getter t
|
adamc@867
|
590 end
|
adamc@867
|
591
|
adamc@873
|
592 fun queryCommon {loc, query, cols, doCols} =
|
adamc@867
|
593 box [string "int n, i;",
|
adamc@867
|
594 newline,
|
adamc@867
|
595 newline,
|
adamc@867
|
596
|
adamc@867
|
597 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
|
adamc@867
|
598 newline,
|
adamc@867
|
599 newline,
|
adamc@867
|
600
|
adamc@867
|
601 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@867
|
602 newline,
|
adamc@867
|
603 box [string "PQclear(res);",
|
adamc@867
|
604 newline,
|
adamc@867
|
605 string "uw_error(ctx, FATAL, \"",
|
adamc@867
|
606 string (ErrorMsg.spanToString loc),
|
adamc@867
|
607 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@867
|
608 query,
|
adamc@867
|
609 string ", PQerrorMessage(conn));",
|
adamc@867
|
610 newline],
|
adamc@867
|
611 string "}",
|
adamc@867
|
612 newline,
|
adamc@867
|
613 newline,
|
adamc@867
|
614
|
adamc@867
|
615 string "if (PQnfields(res) != ",
|
adamc@873
|
616 string (Int.toString (length cols)),
|
adamc@867
|
617 string ") {",
|
adamc@867
|
618 newline,
|
adamc@867
|
619 box [string "int nf = PQnfields(res);",
|
adamc@867
|
620 newline,
|
adamc@867
|
621 string "PQclear(res);",
|
adamc@867
|
622 newline,
|
adamc@867
|
623 string "uw_error(ctx, FATAL, \"",
|
adamc@867
|
624 string (ErrorMsg.spanToString loc),
|
adamc@867
|
625 string ": Query returned %d columns instead of ",
|
adamc@873
|
626 string (Int.toString (length cols)),
|
adamc@867
|
627 string ":\\n%s\\n%s\", nf, ",
|
adamc@867
|
628 query,
|
adamc@867
|
629 string ", PQerrorMessage(conn));",
|
adamc@867
|
630 newline],
|
adamc@867
|
631 string "}",
|
adamc@867
|
632 newline,
|
adamc@867
|
633 newline,
|
adamc@867
|
634
|
adamc@867
|
635 string "uw_end_region(ctx);",
|
adamc@867
|
636 newline,
|
adamc@867
|
637 string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);",
|
adamc@867
|
638 newline,
|
adamc@867
|
639 string "n = PQntuples(res);",
|
adamc@867
|
640 newline,
|
adamc@867
|
641 string "for (i = 0; i < n; ++i) {",
|
adamc@867
|
642 newline,
|
adamc@867
|
643 doCols p_getcol,
|
adamc@867
|
644 string "}",
|
adamc@867
|
645 newline,
|
adamc@867
|
646 newline,
|
adamc@867
|
647 string "uw_pop_cleanup(ctx);",
|
adam@1682
|
648 newline]
|
adamc@867
|
649
|
adamc@873
|
650 fun query {loc, cols, doCols} =
|
adamc@867
|
651 box [string "PGconn *conn = uw_get_db(ctx);",
|
adamc@867
|
652 newline,
|
adamc@867
|
653 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
|
adamc@867
|
654 newline,
|
adamc@867
|
655 newline,
|
adamc@873
|
656 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}]
|
adamc@867
|
657
|
adamc@867
|
658 fun p_ensql t e =
|
adamc@867
|
659 case t of
|
adamc@867
|
660 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
|
adamc@867
|
661 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
|
adamc@867
|
662 | String => e
|
adamc@1011
|
663 | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"]
|
adamc@867
|
664 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
|
adam@1364
|
665 | Time => box [string "uw_Basis_ensqlTime(ctx, ", e, string ")"]
|
adamc@867
|
666 | Blob => box [e, string ".data"]
|
adamc@867
|
667 | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
|
adamc@867
|
668 | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
|
adamc@867
|
669 | Nullable String => e
|
adamc@867
|
670 | Nullable t => box [string "(",
|
adamc@867
|
671 e,
|
adamc@867
|
672 string " == NULL ? NULL : ",
|
adamc@867
|
673 p_ensql t (box [string "(*", e, string ")"]),
|
adamc@867
|
674 string ")"]
|
adamc@867
|
675
|
adam@1431
|
676 fun makeParams inputs =
|
adam@1431
|
677 box [string "static const int paramFormats[] = { ",
|
adamc@867
|
678 p_list_sep (box [string ",", space])
|
adamc@867
|
679 (fn t => if isBlob t then string "1" else string "0") inputs,
|
adamc@867
|
680 string " };",
|
adamc@867
|
681 newline,
|
adam@1431
|
682 if List.exists isBlob inputs then
|
adam@1650
|
683 box [string "int *paramLengths = uw_malloc(ctx, ",
|
adam@1431
|
684 string (Int.toString (length inputs)),
|
adam@1431
|
685 string " * sizeof(int));",
|
adam@1431
|
686 newline,
|
adam@1431
|
687 p_list_sepi (box [])
|
adam@1431
|
688 (fn i => fn t =>
|
adam@1431
|
689 box [string "paramLengths[",
|
adam@1431
|
690 string (Int.toString i),
|
adam@1431
|
691 string "] = ",
|
adam@1431
|
692 case t of
|
adam@1431
|
693 Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
|
adam@1431
|
694 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
|
adam@1431
|
695 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
|
adam@1431
|
696 | _ => string "0",
|
adam@1431
|
697 string ";",
|
adam@1431
|
698 newline]) inputs,
|
adam@1431
|
699 newline]
|
adam@1431
|
700 else
|
adam@1431
|
701 box [string "const int *paramLengths = paramFormats;",
|
adam@1431
|
702 newline],
|
adam@1431
|
703
|
adam@1431
|
704 string "const char **paramValues = uw_malloc(ctx, ",
|
adam@1431
|
705 string (Int.toString (length inputs)),
|
adam@1431
|
706 string " * sizeof(char*));",
|
adamc@867
|
707 newline,
|
adam@1431
|
708 p_list_sepi (box [])
|
adam@1431
|
709 (fn i => fn t => box [string "paramValues[",
|
adam@1431
|
710 string (Int.toString i),
|
adam@1431
|
711 string "] = ",
|
adam@1431
|
712 p_ensql t (box [string "arg",
|
adam@1431
|
713 string (Int.toString (i + 1))]),
|
adam@1431
|
714 string ";",
|
adam@1431
|
715 newline])
|
adamc@867
|
716 inputs,
|
adam@1431
|
717 newline]
|
adam@1431
|
718
|
adam@1431
|
719 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} =
|
adam@1431
|
720 box [string "PGconn *conn = uw_get_db(ctx);",
|
adamc@867
|
721 newline,
|
adam@1431
|
722
|
adam@1431
|
723 makeParams inputs,
|
adam@1431
|
724
|
adamc@867
|
725 newline,
|
adamc@867
|
726 string "PGresult *res = ",
|
adamc@867
|
727 if #persistent (Settings.currentProtocol ()) then
|
adamc@867
|
728 box [string "PQexecPrepared(conn, \"uw",
|
adamc@867
|
729 string (Int.toString id),
|
adamc@867
|
730 string "\", ",
|
adamc@867
|
731 string (Int.toString (length inputs)),
|
adamc@867
|
732 string ", paramValues, paramLengths, paramFormats, 0);"]
|
adamc@867
|
733 else
|
adamc@867
|
734 box [string "PQexecParams(conn, \"",
|
adam@1656
|
735 string (Prim.toCString query),
|
adamc@867
|
736 string "\", ",
|
adamc@867
|
737 string (Int.toString (length inputs)),
|
adamc@867
|
738 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
|
adamc@867
|
739 newline,
|
adamc@867
|
740 newline,
|
adamc@873
|
741 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
|
adam@1656
|
742 string (Prim.toCString query),
|
adamc@873
|
743 string "\""]}]
|
adamc@867
|
744
|
adam@1293
|
745 fun dmlCommon {loc, dml, mode} =
|
adamc@868
|
746 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
|
adamc@868
|
747 newline,
|
adamc@868
|
748 newline,
|
adamc@868
|
749
|
adamc@868
|
750 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@868
|
751 newline,
|
adamc@868
|
752 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
|
adamc@868
|
753 box [newline,
|
adamc@868
|
754 string "PQclear(res);",
|
adamc@868
|
755 newline,
|
adamc@868
|
756 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
|
adamc@868
|
757 newline],
|
adamc@868
|
758 string "}",
|
adamc@868
|
759 newline,
|
adam@1550
|
760 string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
|
adam@1550
|
761 box [newline,
|
adam@1550
|
762 string "PQclear(res);",
|
adam@1550
|
763 newline,
|
adam@1550
|
764 string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
|
adam@1550
|
765 newline],
|
adam@1550
|
766 string "}",
|
adam@1550
|
767 newline,
|
adam@1293
|
768 case mode of
|
adam@1293
|
769 Settings.Error => box [string "PQclear(res);",
|
adam@1293
|
770 newline,
|
adam@1293
|
771 string "uw_error(ctx, FATAL, \"",
|
adam@1293
|
772 string (ErrorMsg.spanToString loc),
|
adam@1293
|
773 string ": DML failed:\\n%s\\n%s\", ",
|
adam@1293
|
774 dml,
|
adam@1293
|
775 string ", PQerrorMessage(conn));"]
|
adam@1295
|
776 | Settings.None => box [string "uw_set_error_message(ctx, PQerrorMessage(conn));",
|
adam@1295
|
777 newline,
|
adam@1295
|
778 newline,
|
adam@1295
|
779
|
adam@1295
|
780 string "res = PQexec(conn, \"ROLLBACK TO s\");",
|
adam@1295
|
781 newline,
|
adam@1295
|
782 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
|
adam@1295
|
783 newline,
|
adam@1295
|
784 newline,
|
adam@1295
|
785
|
adam@1295
|
786 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adam@1295
|
787 newline,
|
adam@1295
|
788 box [string "PQclear(res);",
|
adam@1295
|
789 newline,
|
adam@1295
|
790 string "uw_error(ctx, FATAL, \"",
|
adam@1295
|
791 string (ErrorMsg.spanToString loc),
|
adam@1295
|
792 string ": ROLLBACK TO failed:\\n%s\\n%s\", ",
|
adam@1295
|
793 dml,
|
adam@1295
|
794 string ", PQerrorMessage(conn));",
|
adam@1295
|
795 newline,
|
adam@1295
|
796 string "}"],
|
adam@1295
|
797 newline,
|
adam@1295
|
798
|
adam@1295
|
799 string "PQclear(res);",
|
adam@1295
|
800 newline],
|
adamc@868
|
801 newline],
|
adamc@868
|
802 string "}",
|
adamc@868
|
803
|
adam@1295
|
804 case mode of
|
adam@1295
|
805 Error => box [newline,
|
adam@1295
|
806 newline,
|
adam@1295
|
807 string "PQclear(res);",
|
adam@1295
|
808 newline]
|
adam@1295
|
809 | None => box[string " else {",
|
adam@1295
|
810 newline,
|
adam@1295
|
811 box [string "PQclear(res);",
|
adam@1295
|
812 newline,
|
adam@1295
|
813 string "res = PQexec(conn, \"RELEASE s\");",
|
adam@1295
|
814 newline,
|
adam@1295
|
815 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
|
adam@1295
|
816 newline,
|
adam@1295
|
817 newline,
|
adam@1295
|
818
|
adam@1295
|
819 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adam@1295
|
820 newline,
|
adam@1295
|
821 box [string "PQclear(res);",
|
adam@1295
|
822 newline,
|
adam@1295
|
823 string "uw_error(ctx, FATAL, \"",
|
adam@1295
|
824 string (ErrorMsg.spanToString loc),
|
adam@1295
|
825 string ": RELEASE failed:\\n%s\\n%s\", ",
|
adam@1295
|
826 dml,
|
adam@1295
|
827 string ", PQerrorMessage(conn));",
|
adam@1295
|
828 newline],
|
adam@1295
|
829 string "}",
|
adam@1295
|
830 newline,
|
adam@1295
|
831 string "PQclear(res);",
|
adam@1295
|
832 newline],
|
adam@1295
|
833 string "}",
|
adam@1295
|
834 newline]]
|
adam@1295
|
835
|
adam@1295
|
836 fun makeSavepoint mode =
|
adam@1295
|
837 case mode of
|
adam@1295
|
838 Error => box []
|
adam@1295
|
839 | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");",
|
adam@1295
|
840 newline,
|
adam@1295
|
841 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
|
adam@1295
|
842 newline,
|
adam@1295
|
843 newline,
|
adam@1295
|
844 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adam@1295
|
845 box [newline,
|
adam@1295
|
846 string "PQclear(res);",
|
adam@1295
|
847 newline,
|
adam@1295
|
848 string "uw_error(ctx, FATAL, \"Error creating SAVEPOINT\");",
|
adam@1295
|
849 newline],
|
adam@1295
|
850 string "}",
|
adam@1295
|
851 newline,
|
adam@1295
|
852 string "PQclear(res);",
|
adam@1295
|
853 newline,
|
adam@1295
|
854 newline]
|
adamc@868
|
855
|
adam@1293
|
856 fun dml (loc, mode) =
|
adamc@868
|
857 box [string "PGconn *conn = uw_get_db(ctx);",
|
adamc@868
|
858 newline,
|
adam@1295
|
859 string "PGresult *res;",
|
adam@1295
|
860 newline,
|
adam@1295
|
861
|
adam@1295
|
862 makeSavepoint mode,
|
adam@1295
|
863
|
adam@1295
|
864 string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
|
adamc@868
|
865 newline,
|
adamc@868
|
866 newline,
|
adam@1293
|
867 dmlCommon {loc = loc, dml = string "dml", mode = mode}]
|
adamc@868
|
868
|
adam@1293
|
869 fun dmlPrepared {loc, id, dml, inputs, mode} =
|
adamc@868
|
870 box [string "PGconn *conn = uw_get_db(ctx);",
|
adamc@868
|
871 newline,
|
adam@1431
|
872
|
adam@1431
|
873 makeParams inputs,
|
adam@1431
|
874
|
adamc@868
|
875 newline,
|
adam@1295
|
876 string "PGresult *res;",
|
adam@1295
|
877 newline,
|
adam@1295
|
878 newline,
|
adam@1295
|
879
|
adam@1295
|
880 makeSavepoint mode,
|
adam@1295
|
881
|
adam@1295
|
882 string "res = ",
|
adamc@868
|
883 if #persistent (Settings.currentProtocol ()) then
|
adamc@868
|
884 box [string "PQexecPrepared(conn, \"uw",
|
adamc@868
|
885 string (Int.toString id),
|
adamc@868
|
886 string "\", ",
|
adamc@868
|
887 string (Int.toString (length inputs)),
|
adamc@868
|
888 string ", paramValues, paramLengths, paramFormats, 0);"]
|
adamc@868
|
889 else
|
adamc@868
|
890 box [string "PQexecParams(conn, \"",
|
adam@1656
|
891 string (Prim.toCString dml),
|
adamc@868
|
892 string "\", ",
|
adamc@868
|
893 string (Int.toString (length inputs)),
|
adamc@868
|
894 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
|
adamc@868
|
895 newline,
|
adamc@868
|
896 newline,
|
adamc@868
|
897 dmlCommon {loc = loc, dml = box [string "\"",
|
adam@1656
|
898 string (Prim.toCString dml),
|
adam@1293
|
899 string "\""], mode = mode}]
|
adamc@868
|
900
|
adamc@869
|
901 fun nextvalCommon {loc, query} =
|
adamc@869
|
902 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");",
|
adamc@869
|
903 newline,
|
adamc@869
|
904 newline,
|
adamc@869
|
905
|
adamc@869
|
906 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@869
|
907 newline,
|
adamc@869
|
908 box [string "PQclear(res);",
|
adamc@869
|
909 newline,
|
adamc@869
|
910 string "uw_error(ctx, FATAL, \"",
|
adamc@869
|
911 string (ErrorMsg.spanToString loc),
|
adamc@869
|
912 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@869
|
913 query,
|
adamc@869
|
914 string ", PQerrorMessage(conn));",
|
adamc@869
|
915 newline],
|
adamc@869
|
916 string "}",
|
adamc@869
|
917 newline,
|
adamc@869
|
918 newline,
|
adamc@869
|
919
|
adamc@869
|
920 string "n = PQntuples(res);",
|
adamc@869
|
921 newline,
|
adamc@869
|
922 string "if (n != 1) {",
|
adamc@869
|
923 newline,
|
adamc@869
|
924 box [string "PQclear(res);",
|
adamc@869
|
925 newline,
|
adamc@869
|
926 string "uw_error(ctx, FATAL, \"",
|
adamc@869
|
927 string (ErrorMsg.spanToString loc),
|
adamc@869
|
928 string ": Wrong number of result rows:\\n%s\\n%s\", ",
|
adamc@869
|
929 query,
|
adamc@869
|
930 string ", PQerrorMessage(conn));",
|
adamc@869
|
931 newline],
|
adamc@869
|
932 string "}",
|
adamc@869
|
933 newline,
|
adamc@869
|
934 newline,
|
adamc@869
|
935
|
adamc@869
|
936 string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));",
|
adamc@869
|
937 newline,
|
adamc@869
|
938 string "PQclear(res);",
|
adamc@869
|
939 newline]
|
adamc@869
|
940
|
adamc@878
|
941 open Cjr
|
adamc@878
|
942
|
adamc@878
|
943 fun nextval {loc, seqE, seqName} =
|
adamc@878
|
944 let
|
adamc@878
|
945 val query = case seqName of
|
adamc@878
|
946 SOME s =>
|
adamc@879
|
947 string ("\"SELECT NEXTVAL('" ^ s ^ "')\"")
|
adamc@878
|
948 | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ",
|
adamc@878
|
949 seqE,
|
adamc@878
|
950 string ", \"')\"))"]
|
adamc@878
|
951 in
|
adamc@878
|
952 box [string "char *query = ",
|
adamc@878
|
953 query,
|
adamc@878
|
954 string ";",
|
adamc@878
|
955 newline,
|
adamc@878
|
956 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@878
|
957 newline,
|
adamc@878
|
958 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
|
adamc@878
|
959 newline,
|
adamc@878
|
960 newline,
|
adamc@878
|
961 nextvalCommon {loc = loc, query = string "query"}]
|
adamc@878
|
962 end
|
adamc@869
|
963
|
adamc@869
|
964 fun nextvalPrepared {loc, id, query} =
|
adamc@869
|
965 box [string "PGconn *conn = uw_get_db(ctx);",
|
adamc@869
|
966 newline,
|
adamc@869
|
967 newline,
|
adamc@869
|
968 string "PGresult *res = ",
|
adamc@869
|
969 if #persistent (Settings.currentProtocol ()) then
|
adamc@869
|
970 box [string "PQexecPrepared(conn, \"uw",
|
adamc@869
|
971 string (Int.toString id),
|
adamc@869
|
972 string "\", 0, NULL, NULL, NULL, 0);"]
|
adamc@869
|
973 else
|
adamc@869
|
974 box [string "PQexecParams(conn, \"",
|
adam@1656
|
975 string (Prim.toCString query),
|
adamc@869
|
976 string "\", 0, NULL, NULL, NULL, NULL, 0);"],
|
adamc@869
|
977 newline,
|
adamc@869
|
978 newline,
|
adamc@869
|
979 nextvalCommon {loc = loc, query = box [string "\"",
|
adam@1656
|
980 string (Prim.toCString query),
|
adamc@869
|
981 string "\""]}]
|
adamc@869
|
982
|
adamc@1073
|
983 fun setvalCommon {loc, query} =
|
adamc@1073
|
984 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");",
|
adamc@1073
|
985 newline,
|
adamc@1073
|
986 newline,
|
adamc@1073
|
987
|
adamc@1073
|
988 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@1073
|
989 newline,
|
adamc@1073
|
990 box [string "PQclear(res);",
|
adamc@1073
|
991 newline,
|
adamc@1073
|
992 string "uw_error(ctx, FATAL, \"",
|
adamc@1073
|
993 string (ErrorMsg.spanToString loc),
|
adamc@1073
|
994 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@1073
|
995 query,
|
adamc@1073
|
996 string ", PQerrorMessage(conn));",
|
adamc@1073
|
997 newline],
|
adamc@1073
|
998 string "}",
|
adamc@1073
|
999 newline,
|
adamc@1073
|
1000 newline,
|
adamc@1073
|
1001
|
adamc@1073
|
1002 string "PQclear(res);",
|
adamc@1073
|
1003 newline]
|
adamc@1073
|
1004
|
adamc@1073
|
1005 fun setval {loc, seqE, count} =
|
adamc@1073
|
1006 let
|
adamc@1073
|
1007 val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ",
|
adamc@1073
|
1008 seqE,
|
adamc@1073
|
1009 string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ",
|
adamc@1073
|
1010 count,
|
adamc@1073
|
1011 string "), \")\"))))"]
|
adamc@1073
|
1012 in
|
adamc@1073
|
1013 box [string "char *query = ",
|
adamc@1073
|
1014 query,
|
adamc@1073
|
1015 string ";",
|
adamc@1073
|
1016 newline,
|
adamc@1073
|
1017 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@1073
|
1018 newline,
|
adamc@1073
|
1019 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
|
adamc@1073
|
1020 newline,
|
adamc@1073
|
1021 newline,
|
adamc@1073
|
1022 setvalCommon {loc = loc, query = string "query"}]
|
adamc@1073
|
1023 end
|
adamc@1073
|
1024
|
adamc@874
|
1025 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
|
adamc@874
|
1026 | #"\\" => "\\\\"
|
adamc@874
|
1027 | ch =>
|
adamc@874
|
1028 if Char.isPrint ch then
|
adamc@874
|
1029 str ch
|
adamc@874
|
1030 else
|
adamc@874
|
1031 "\\" ^ StringCvt.padLeft #"0" 3
|
adamc@874
|
1032 (Int.fmt StringCvt.OCT (ord ch)))
|
adam@1656
|
1033 (Prim.toCString s) ^ "'::text"
|
adamc@874
|
1034
|
adamc@874
|
1035 fun p_cast (s, t) = s ^ "::" ^ p_sql_type t
|
adamc@874
|
1036
|
adamc@874
|
1037 fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t)
|
adamc@874
|
1038
|
adamc@866
|
1039 val () = addDbms {name = "postgres",
|
adam@1682
|
1040 randomFunction = "RANDOM",
|
adam@1464
|
1041 header = Config.pgheader,
|
adamc@866
|
1042 link = "-lpq",
|
adamc@873
|
1043 p_sql_type = p_sql_type,
|
adamc@867
|
1044 init = init,
|
adamc@867
|
1045 query = query,
|
adamc@868
|
1046 queryPrepared = queryPrepared,
|
adamc@868
|
1047 dml = dml,
|
adamc@869
|
1048 dmlPrepared = dmlPrepared,
|
adamc@869
|
1049 nextval = nextval,
|
adamc@874
|
1050 nextvalPrepared = nextvalPrepared,
|
adamc@1073
|
1051 setval = setval,
|
adamc@874
|
1052 sqlifyString = sqlifyString,
|
adamc@874
|
1053 p_cast = p_cast,
|
adamc@874
|
1054 p_blank = p_blank,
|
adamc@877
|
1055 supportsDeleteAs = true,
|
adamc@886
|
1056 supportsUpdateAs = true,
|
adamc@877
|
1057 createSequence = fn s => "CREATE SEQUENCE " ^ s,
|
adamc@878
|
1058 textKeysNeedLengths = false,
|
adamc@879
|
1059 supportsNextval = true,
|
adamc@882
|
1060 supportsNestedPrepared = true,
|
adamc@890
|
1061 sqlPrefix = "",
|
adamc@1014
|
1062 supportsOctetLength = true,
|
adamc@1014
|
1063 trueString = "TRUE",
|
adamc@1196
|
1064 falseString = "FALSE",
|
adamc@1196
|
1065 onlyUnion = false,
|
adam@1777
|
1066 nestedRelops = true,
|
adam@1777
|
1067 windowFunctions = true}
|
adamc@874
|
1068
|
adamc@866
|
1069 val () = setDbms "postgres"
|
adamc@866
|
1070
|
adamc@866
|
1071 end
|