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