adam@2177
|
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
|
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 = '"
|
adam@2199
|
281 ^ sl ^ "' AND relkind = 'S' AND pg_catalog.pg_table_is_visible(oid)"
|
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@2177
|
523 string "uw_error(ctx, BOUNDED_RETRY, ",
|
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@2177
|
615 fun queryCommon {loc, query, cols, doCols} =
|
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@2177
|
622 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2176
|
623 newline,
|
adam@2177
|
624 string "uw_error(ctx, FATAL, \"Can't allocate query result; database server may be down.\");",
|
adam@2176
|
625 newline],
|
adam@2176
|
626 string "}",
|
adamc@867
|
627 newline,
|
adamc@867
|
628 newline,
|
adamc@867
|
629
|
adamc@867
|
630 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@867
|
631 newline,
|
adam@1918
|
632 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
|
adam@1918
|
633 box [newline,
|
adam@1918
|
634 string "PQclear(res);",
|
adam@1918
|
635 newline,
|
adam@1918
|
636 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
|
adam@1918
|
637 newline],
|
adam@1918
|
638 string "}",
|
adam@1918
|
639 newline,
|
adam@1918
|
640 string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
|
adam@1918
|
641 box [newline,
|
adam@1918
|
642 string "PQclear(res);",
|
adam@1918
|
643 newline,
|
adam@1918
|
644 string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
|
adam@1918
|
645 newline],
|
adam@1918
|
646 string "}",
|
adam@1918
|
647 newline,
|
adam@1918
|
648 string "PQclear(res);",
|
adamc@867
|
649 newline,
|
adamc@867
|
650 string "uw_error(ctx, FATAL, \"",
|
adamc@867
|
651 string (ErrorMsg.spanToString loc),
|
adamc@867
|
652 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@867
|
653 query,
|
adamc@867
|
654 string ", PQerrorMessage(conn));",
|
adamc@867
|
655 newline],
|
adamc@867
|
656 string "}",
|
adamc@867
|
657 newline,
|
adamc@867
|
658 newline,
|
adamc@867
|
659
|
adamc@867
|
660 string "if (PQnfields(res) != ",
|
adamc@873
|
661 string (Int.toString (length cols)),
|
adamc@867
|
662 string ") {",
|
adamc@867
|
663 newline,
|
adamc@867
|
664 box [string "int nf = PQnfields(res);",
|
adamc@867
|
665 newline,
|
adamc@867
|
666 string "PQclear(res);",
|
adamc@867
|
667 newline,
|
adamc@867
|
668 string "uw_error(ctx, FATAL, \"",
|
adamc@867
|
669 string (ErrorMsg.spanToString loc),
|
adamc@867
|
670 string ": Query returned %d columns instead of ",
|
adamc@873
|
671 string (Int.toString (length cols)),
|
adamc@867
|
672 string ":\\n%s\\n%s\", nf, ",
|
adamc@867
|
673 query,
|
adamc@867
|
674 string ", PQerrorMessage(conn));",
|
adamc@867
|
675 newline],
|
adamc@867
|
676 string "}",
|
adamc@867
|
677 newline,
|
adamc@867
|
678 newline,
|
adamc@867
|
679
|
adamc@867
|
680 string "uw_end_region(ctx);",
|
adamc@867
|
681 newline,
|
adamc@867
|
682 string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);",
|
adamc@867
|
683 newline,
|
adamc@867
|
684 string "n = PQntuples(res);",
|
adamc@867
|
685 newline,
|
adamc@867
|
686 string "for (i = 0; i < n; ++i) {",
|
adamc@867
|
687 newline,
|
adamc@867
|
688 doCols p_getcol,
|
adamc@867
|
689 string "}",
|
adamc@867
|
690 newline,
|
adamc@867
|
691 newline,
|
adamc@867
|
692 string "uw_pop_cleanup(ctx);",
|
adam@1682
|
693 newline]
|
adamc@867
|
694
|
adamc@873
|
695 fun query {loc, cols, doCols} =
|
adam@2177
|
696 box [string "PGconn *conn = uw_get_db(ctx);",
|
adam@2177
|
697 newline,
|
adam@2177
|
698 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
|
adam@2177
|
699 newline,
|
adam@2177
|
700 newline,
|
adam@2177
|
701 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}]
|
adamc@867
|
702
|
adamc@867
|
703 fun p_ensql t e =
|
adamc@867
|
704 case t of
|
adamc@867
|
705 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
|
adamc@867
|
706 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
|
adamc@867
|
707 | String => e
|
adamc@1011
|
708 | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"]
|
adamc@867
|
709 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
|
adam@1364
|
710 | Time => box [string "uw_Basis_ensqlTime(ctx, ", e, string ")"]
|
adamc@867
|
711 | Blob => box [e, string ".data"]
|
adamc@867
|
712 | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
|
adamc@867
|
713 | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
|
adamc@867
|
714 | Nullable String => e
|
adamc@867
|
715 | Nullable t => box [string "(",
|
adamc@867
|
716 e,
|
adamc@867
|
717 string " == NULL ? NULL : ",
|
adamc@867
|
718 p_ensql t (box [string "(*", e, string ")"]),
|
adamc@867
|
719 string ")"]
|
adamc@867
|
720
|
adam@1431
|
721 fun makeParams inputs =
|
adam@1431
|
722 box [string "static const int paramFormats[] = { ",
|
adamc@867
|
723 p_list_sep (box [string ",", space])
|
adamc@867
|
724 (fn t => if isBlob t then string "1" else string "0") inputs,
|
adamc@867
|
725 string " };",
|
adamc@867
|
726 newline,
|
adam@1431
|
727 if List.exists isBlob inputs then
|
adam@1650
|
728 box [string "int *paramLengths = uw_malloc(ctx, ",
|
adam@1431
|
729 string (Int.toString (length inputs)),
|
adam@1431
|
730 string " * sizeof(int));",
|
adam@1431
|
731 newline,
|
adam@1431
|
732 p_list_sepi (box [])
|
adam@1431
|
733 (fn i => fn t =>
|
adam@1431
|
734 box [string "paramLengths[",
|
adam@1431
|
735 string (Int.toString i),
|
adam@1431
|
736 string "] = ",
|
adam@1431
|
737 case t of
|
adam@1431
|
738 Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
|
adam@1431
|
739 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
|
adam@1431
|
740 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
|
adam@1431
|
741 | _ => string "0",
|
adam@1431
|
742 string ";",
|
adam@1431
|
743 newline]) inputs,
|
adam@1431
|
744 newline]
|
adam@1431
|
745 else
|
adam@1431
|
746 box [string "const int *paramLengths = paramFormats;",
|
adam@1431
|
747 newline],
|
adam@1431
|
748
|
adam@1431
|
749 string "const char **paramValues = uw_malloc(ctx, ",
|
adam@1431
|
750 string (Int.toString (length inputs)),
|
adam@1431
|
751 string " * sizeof(char*));",
|
adamc@867
|
752 newline,
|
adam@1431
|
753 p_list_sepi (box [])
|
adam@1431
|
754 (fn i => fn t => box [string "paramValues[",
|
adam@1431
|
755 string (Int.toString i),
|
adam@1431
|
756 string "] = ",
|
adam@1431
|
757 p_ensql t (box [string "arg",
|
adam@1431
|
758 string (Int.toString (i + 1))]),
|
adam@1431
|
759 string ";",
|
adam@1431
|
760 newline])
|
adamc@867
|
761 inputs,
|
adam@1431
|
762 newline]
|
adam@1431
|
763
|
adam@1431
|
764 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} =
|
adam@2177
|
765 box [string "PGconn *conn = uw_get_db(ctx);",
|
adam@2177
|
766 newline,
|
adam@1431
|
767
|
adam@2177
|
768 makeParams inputs,
|
adam@2177
|
769
|
adam@2177
|
770 newline,
|
adam@2177
|
771 string "PGresult *res = ",
|
adam@2177
|
772 if #persistent (Settings.currentProtocol ()) then
|
adam@2177
|
773 box [string "PQexecPrepared(conn, \"uw",
|
adam@2177
|
774 string (Int.toString id),
|
adam@2177
|
775 string "\", ",
|
adam@2177
|
776 string (Int.toString (length inputs)),
|
adam@2177
|
777 string ", paramValues, paramLengths, paramFormats, 0);"]
|
adam@2177
|
778 else
|
adam@2177
|
779 box [string "PQexecParams(conn, \"",
|
adam@2177
|
780 string (Prim.toCString query),
|
adam@2177
|
781 string "\", ",
|
adam@2177
|
782 string (Int.toString (length inputs)),
|
adam@2177
|
783 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
|
adam@2177
|
784 newline,
|
adam@2177
|
785 newline,
|
adam@2177
|
786 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
|
adam@2177
|
787 string (Prim.toCString query),
|
adam@2177
|
788 string "\""]}]
|
adam@2177
|
789
|
adam@2177
|
790 fun dmlCommon {loc, dml, mode} =
|
adam@2176
|
791 box [string "if (res == NULL) {",
|
adam@2176
|
792 box [newline,
|
adam@2177
|
793 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2176
|
794 newline,
|
adam@2177
|
795 string "uw_error(ctx, FATAL, \"Can't allocate DML result; database server may be down.\");",
|
adam@2176
|
796 newline],
|
adam@2176
|
797 string "}",
|
adamc@868
|
798 newline,
|
adamc@868
|
799 newline,
|
adamc@868
|
800
|
adamc@868
|
801 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adamc@868
|
802 newline,
|
adamc@868
|
803 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
|
adamc@868
|
804 box [newline,
|
adamc@868
|
805 string "PQclear(res);",
|
adamc@868
|
806 newline,
|
adamc@868
|
807 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
|
adamc@868
|
808 newline],
|
adamc@868
|
809 string "}",
|
adamc@868
|
810 newline,
|
adam@1550
|
811 string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {",
|
adam@1550
|
812 box [newline,
|
adam@1550
|
813 string "PQclear(res);",
|
adam@1550
|
814 newline,
|
adam@1550
|
815 string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");",
|
adam@1550
|
816 newline],
|
adam@1550
|
817 string "}",
|
adam@1550
|
818 newline,
|
adam@1293
|
819 case mode of
|
adam@1918
|
820 Settings.Error => box [string "PQclear(res);",
|
adam@1293
|
821 newline,
|
adam@1293
|
822 string "uw_error(ctx, FATAL, \"",
|
adam@1293
|
823 string (ErrorMsg.spanToString loc),
|
adam@1918
|
824 string ": DML failed:\\n%s\\n%s\", ",
|
adam@1293
|
825 dml,
|
adam@1918
|
826 string ", PQerrorMessage(conn));"]
|
adam@1295
|
827 | Settings.None => box [string "uw_set_error_message(ctx, PQerrorMessage(conn));",
|
adam@1295
|
828 newline,
|
adam@1295
|
829 newline,
|
adam@1295
|
830
|
adam@1295
|
831 string "res = PQexec(conn, \"ROLLBACK TO s\");",
|
adam@1295
|
832 newline,
|
adam@2176
|
833 string "if (res == NULL) {",
|
adam@2176
|
834 box [newline,
|
adam@2177
|
835 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2177
|
836 newline,
|
adam@2177
|
837 string "uw_error(ctx, FATAL, \"Can't allocate DML ROLLBACK result; database server may be down.\");",
|
adam@2176
|
838 newline],
|
adam@2176
|
839 string "}",
|
adam@1295
|
840 newline,
|
adam@1295
|
841 newline,
|
adam@1295
|
842
|
adam@1295
|
843 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adam@1295
|
844 newline,
|
adam@1295
|
845 box [string "PQclear(res);",
|
adam@1295
|
846 newline,
|
adam@1295
|
847 string "uw_error(ctx, FATAL, \"",
|
adam@1295
|
848 string (ErrorMsg.spanToString loc),
|
adam@1295
|
849 string ": ROLLBACK TO failed:\\n%s\\n%s\", ",
|
adam@1295
|
850 dml,
|
adam@1295
|
851 string ", PQerrorMessage(conn));",
|
adam@1295
|
852 newline,
|
adam@1295
|
853 string "}"],
|
adam@1295
|
854 newline,
|
adam@1295
|
855
|
adam@1295
|
856 string "PQclear(res);",
|
adam@1295
|
857 newline],
|
adamc@868
|
858 newline],
|
adamc@868
|
859 string "}",
|
adamc@868
|
860
|
adam@1295
|
861 case mode of
|
adam@1295
|
862 Error => box [newline,
|
adam@1295
|
863 newline,
|
adam@1295
|
864 string "PQclear(res);",
|
adam@1295
|
865 newline]
|
adam@1295
|
866 | None => box[string " else {",
|
adam@1295
|
867 newline,
|
adam@1295
|
868 box [string "PQclear(res);",
|
adam@1295
|
869 newline,
|
adam@1295
|
870 string "res = PQexec(conn, \"RELEASE s\");",
|
adam@1295
|
871 newline,
|
adam@2177
|
872 string "if (res == NULL) {",
|
adam@2177
|
873 box [newline,
|
adam@2177
|
874 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2177
|
875 newline,
|
adam@2177
|
876 string "uw_error(ctx, FATAL, \"Can't allocate DML RELEASE result; database server may be down.\");",
|
adam@2177
|
877 newline],
|
adam@2177
|
878 string "}",
|
adam@1295
|
879 newline,
|
adam@1295
|
880 newline,
|
adam@1295
|
881
|
adam@1295
|
882 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adam@1295
|
883 newline,
|
adam@1295
|
884 box [string "PQclear(res);",
|
adam@1295
|
885 newline,
|
adam@1295
|
886 string "uw_error(ctx, FATAL, \"",
|
adam@1295
|
887 string (ErrorMsg.spanToString loc),
|
adam@1295
|
888 string ": RELEASE failed:\\n%s\\n%s\", ",
|
adam@1295
|
889 dml,
|
adam@1295
|
890 string ", PQerrorMessage(conn));",
|
adam@1295
|
891 newline],
|
adam@1295
|
892 string "}",
|
adam@1295
|
893 newline,
|
adam@1295
|
894 string "PQclear(res);",
|
adam@1295
|
895 newline],
|
adam@1295
|
896 string "}",
|
adam@1295
|
897 newline]]
|
adam@1295
|
898
|
adam@1295
|
899 fun makeSavepoint mode =
|
adam@1295
|
900 case mode of
|
adam@1295
|
901 Error => box []
|
adam@1295
|
902 | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");",
|
adam@1295
|
903 newline,
|
adam@2177
|
904 string "if (res == NULL) {",
|
adam@2177
|
905 box [newline,
|
adam@2177
|
906 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2177
|
907 newline,
|
adam@2177
|
908 string "uw_error(ctx, FATAL, \"Can't allocate DML SAVEPOINT result; database server may be down.\");",
|
adam@2177
|
909 newline],
|
adam@2177
|
910 string "}",
|
adam@1295
|
911 newline,
|
adam@1295
|
912 newline,
|
adam@1295
|
913 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
|
adam@1295
|
914 box [newline,
|
adam@1295
|
915 string "PQclear(res);",
|
adam@1295
|
916 newline,
|
adam@1295
|
917 string "uw_error(ctx, FATAL, \"Error creating SAVEPOINT\");",
|
adam@1295
|
918 newline],
|
adam@1295
|
919 string "}",
|
adam@1295
|
920 newline,
|
adam@1295
|
921 string "PQclear(res);",
|
adam@1295
|
922 newline,
|
adam@1295
|
923 newline]
|
adamc@868
|
924
|
adam@1293
|
925 fun dml (loc, mode) =
|
adam@2177
|
926 box [string "PGconn *conn = uw_get_db(ctx);",
|
adam@2177
|
927 newline,
|
adam@2177
|
928 string "PGresult *res;",
|
adam@2177
|
929 newline,
|
adam@1295
|
930
|
adam@2177
|
931 makeSavepoint mode,
|
adam@1295
|
932
|
adam@2177
|
933 string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
|
adam@2177
|
934 newline,
|
adam@2177
|
935 newline,
|
adam@2177
|
936 dmlCommon {loc = loc, dml = string "dml", mode = mode}]
|
adamc@868
|
937
|
adam@1293
|
938 fun dmlPrepared {loc, id, dml, inputs, mode} =
|
adam@2177
|
939 box [string "PGconn *conn = uw_get_db(ctx);",
|
adam@2177
|
940 newline,
|
adam@1431
|
941
|
adam@2177
|
942 makeParams inputs,
|
adam@1431
|
943
|
adam@2177
|
944 newline,
|
adam@2177
|
945 string "PGresult *res;",
|
adam@2177
|
946 newline,
|
adam@2177
|
947 newline,
|
adam@1295
|
948
|
adam@2177
|
949 makeSavepoint mode,
|
adam@1295
|
950
|
adam@2177
|
951 string "res = ",
|
adam@2177
|
952 if #persistent (Settings.currentProtocol ()) then
|
adam@2177
|
953 box [string "PQexecPrepared(conn, \"uw",
|
adam@2177
|
954 string (Int.toString id),
|
adam@2177
|
955 string "\", ",
|
adam@2177
|
956 string (Int.toString (length inputs)),
|
adam@2177
|
957 string ", paramValues, paramLengths, paramFormats, 0);"]
|
adam@2177
|
958 else
|
adam@2177
|
959 box [string "PQexecParams(conn, \"",
|
adam@2177
|
960 string (Prim.toCString dml),
|
adam@2177
|
961 string "\", ",
|
adam@2177
|
962 string (Int.toString (length inputs)),
|
adam@2177
|
963 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
|
adam@2177
|
964 newline,
|
adam@2177
|
965 newline,
|
adam@2177
|
966 dmlCommon {loc = loc, dml = box [string "\"",
|
adam@2177
|
967 string (Prim.toCString dml),
|
adam@2177
|
968 string "\""], mode = mode}]
|
adamc@868
|
969
|
adam@2177
|
970 fun nextvalCommon {loc, query} =
|
adam@2176
|
971 box [string "if (res == NULL) {",
|
adam@2176
|
972 box [newline,
|
adam@2177
|
973 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2176
|
974 newline,
|
adam@2177
|
975 string "uw_error(ctx, FATAL, \"Can't allocate NEXTVAL result; database server may be down.\");",
|
adam@2176
|
976 newline],
|
adam@2176
|
977 string "}",
|
adamc@869
|
978 newline,
|
adamc@869
|
979 newline,
|
adamc@869
|
980
|
adamc@869
|
981 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@869
|
982 newline,
|
adamc@869
|
983 box [string "PQclear(res);",
|
adamc@869
|
984 newline,
|
adamc@869
|
985 string "uw_error(ctx, FATAL, \"",
|
adamc@869
|
986 string (ErrorMsg.spanToString loc),
|
adamc@869
|
987 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@869
|
988 query,
|
adamc@869
|
989 string ", PQerrorMessage(conn));",
|
adamc@869
|
990 newline],
|
adamc@869
|
991 string "}",
|
adamc@869
|
992 newline,
|
adamc@869
|
993 newline,
|
adamc@869
|
994
|
adamc@869
|
995 string "n = PQntuples(res);",
|
adamc@869
|
996 newline,
|
adamc@869
|
997 string "if (n != 1) {",
|
adamc@869
|
998 newline,
|
adamc@869
|
999 box [string "PQclear(res);",
|
adamc@869
|
1000 newline,
|
adamc@869
|
1001 string "uw_error(ctx, FATAL, \"",
|
adamc@869
|
1002 string (ErrorMsg.spanToString loc),
|
adamc@869
|
1003 string ": Wrong number of result rows:\\n%s\\n%s\", ",
|
adamc@869
|
1004 query,
|
adamc@869
|
1005 string ", PQerrorMessage(conn));",
|
adamc@869
|
1006 newline],
|
adamc@869
|
1007 string "}",
|
adamc@869
|
1008 newline,
|
adamc@869
|
1009 newline,
|
adamc@869
|
1010
|
adamc@869
|
1011 string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));",
|
adamc@869
|
1012 newline,
|
adamc@869
|
1013 string "PQclear(res);",
|
adamc@869
|
1014 newline]
|
adamc@869
|
1015
|
adamc@878
|
1016 open Cjr
|
adamc@878
|
1017
|
adamc@878
|
1018 fun nextval {loc, seqE, seqName} =
|
adamc@878
|
1019 let
|
adamc@878
|
1020 val query = case seqName of
|
adamc@878
|
1021 SOME s =>
|
adamc@879
|
1022 string ("\"SELECT NEXTVAL('" ^ s ^ "')\"")
|
adamc@878
|
1023 | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ",
|
adamc@878
|
1024 seqE,
|
adamc@878
|
1025 string ", \"')\"))"]
|
adamc@878
|
1026 in
|
adamc@878
|
1027 box [string "char *query = ",
|
adamc@878
|
1028 query,
|
adamc@878
|
1029 string ";",
|
adamc@878
|
1030 newline,
|
adamc@878
|
1031 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@878
|
1032 newline,
|
adam@2177
|
1033 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
|
adamc@878
|
1034 newline,
|
adamc@878
|
1035 newline,
|
adam@2177
|
1036 nextvalCommon {loc = loc, query = string "query"}]
|
adamc@878
|
1037 end
|
adamc@869
|
1038
|
adamc@869
|
1039 fun nextvalPrepared {loc, id, query} =
|
adam@2177
|
1040 box [string "PGconn *conn = uw_get_db(ctx);",
|
adam@2177
|
1041 newline,
|
adam@2177
|
1042 newline,
|
adam@2177
|
1043 string "PGresult *res = ",
|
adam@2177
|
1044 if #persistent (Settings.currentProtocol ()) then
|
adam@2177
|
1045 box [string "PQexecPrepared(conn, \"uw",
|
adam@2177
|
1046 string (Int.toString id),
|
adam@2177
|
1047 string "\", 0, NULL, NULL, NULL, 0);"]
|
adam@2177
|
1048 else
|
adam@2177
|
1049 box [string "PQexecParams(conn, \"",
|
adam@2177
|
1050 string (Prim.toCString query),
|
adam@2177
|
1051 string "\", 0, NULL, NULL, NULL, NULL, 0);"],
|
adam@2177
|
1052 newline,
|
adam@2177
|
1053 newline,
|
adam@2177
|
1054 nextvalCommon {loc = loc, query = box [string "\"",
|
adam@2177
|
1055 string (Prim.toCString query),
|
adam@2177
|
1056 string "\""]}]
|
adamc@869
|
1057
|
adam@2177
|
1058 fun setvalCommon {loc, query} =
|
adam@2176
|
1059 box [string "if (res == NULL) {",
|
adam@2176
|
1060 box [newline,
|
adam@2177
|
1061 string "uw_try_reconnecting_and_restarting(ctx);",
|
adam@2176
|
1062 newline,
|
adam@2177
|
1063 string "uw_error(ctx, FATAL, \"Can't allocate SETVAL result; database server may be down.\");",
|
adam@2176
|
1064 newline],
|
adam@2176
|
1065 string "}",
|
adamc@1073
|
1066 newline,
|
adamc@1073
|
1067 newline,
|
adamc@1073
|
1068
|
adamc@1073
|
1069 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
|
adamc@1073
|
1070 newline,
|
adamc@1073
|
1071 box [string "PQclear(res);",
|
adamc@1073
|
1072 newline,
|
adamc@1073
|
1073 string "uw_error(ctx, FATAL, \"",
|
adamc@1073
|
1074 string (ErrorMsg.spanToString loc),
|
adamc@1073
|
1075 string ": Query failed:\\n%s\\n%s\", ",
|
adamc@1073
|
1076 query,
|
adamc@1073
|
1077 string ", PQerrorMessage(conn));",
|
adamc@1073
|
1078 newline],
|
adamc@1073
|
1079 string "}",
|
adamc@1073
|
1080 newline,
|
adamc@1073
|
1081 newline,
|
adamc@1073
|
1082
|
adamc@1073
|
1083 string "PQclear(res);",
|
adamc@1073
|
1084 newline]
|
adamc@1073
|
1085
|
adamc@1073
|
1086 fun setval {loc, seqE, count} =
|
adamc@1073
|
1087 let
|
adamc@1073
|
1088 val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ",
|
adamc@1073
|
1089 seqE,
|
adamc@1073
|
1090 string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ",
|
adamc@1073
|
1091 count,
|
adamc@1073
|
1092 string "), \")\"))))"]
|
adamc@1073
|
1093 in
|
adamc@1073
|
1094 box [string "char *query = ",
|
adamc@1073
|
1095 query,
|
adamc@1073
|
1096 string ";",
|
adamc@1073
|
1097 newline,
|
adamc@1073
|
1098 string "PGconn *conn = uw_get_db(ctx);",
|
adamc@1073
|
1099 newline,
|
adam@2177
|
1100 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
|
adamc@1073
|
1101 newline,
|
adamc@1073
|
1102 newline,
|
adam@2177
|
1103 setvalCommon {loc = loc, query = string "query"}]
|
adamc@1073
|
1104 end
|
adamc@1073
|
1105
|
adamc@874
|
1106 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
|
adamc@874
|
1107 | #"\\" => "\\\\"
|
adamc@874
|
1108 | ch =>
|
adamc@874
|
1109 if Char.isPrint ch then
|
adamc@874
|
1110 str ch
|
adamc@874
|
1111 else
|
adamc@874
|
1112 "\\" ^ StringCvt.padLeft #"0" 3
|
adamc@874
|
1113 (Int.fmt StringCvt.OCT (ord ch)))
|
adam@1656
|
1114 (Prim.toCString s) ^ "'::text"
|
adamc@874
|
1115
|
adamc@874
|
1116 fun p_cast (s, t) = s ^ "::" ^ p_sql_type t
|
adamc@874
|
1117
|
adamc@874
|
1118 fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t)
|
adamc@874
|
1119
|
adamc@866
|
1120 val () = addDbms {name = "postgres",
|
adam@1682
|
1121 randomFunction = "RANDOM",
|
adam@1464
|
1122 header = Config.pgheader,
|
adamc@866
|
1123 link = "-lpq",
|
adamc@873
|
1124 p_sql_type = p_sql_type,
|
adamc@867
|
1125 init = init,
|
adamc@867
|
1126 query = query,
|
adamc@868
|
1127 queryPrepared = queryPrepared,
|
adamc@868
|
1128 dml = dml,
|
adamc@869
|
1129 dmlPrepared = dmlPrepared,
|
adamc@869
|
1130 nextval = nextval,
|
adamc@874
|
1131 nextvalPrepared = nextvalPrepared,
|
adamc@1073
|
1132 setval = setval,
|
adamc@874
|
1133 sqlifyString = sqlifyString,
|
adamc@874
|
1134 p_cast = p_cast,
|
adamc@874
|
1135 p_blank = p_blank,
|
adamc@877
|
1136 supportsDeleteAs = true,
|
adamc@886
|
1137 supportsUpdateAs = true,
|
adamc@877
|
1138 createSequence = fn s => "CREATE SEQUENCE " ^ s,
|
adamc@878
|
1139 textKeysNeedLengths = false,
|
adamc@879
|
1140 supportsNextval = true,
|
adamc@882
|
1141 supportsNestedPrepared = true,
|
adamc@890
|
1142 sqlPrefix = "",
|
adamc@1014
|
1143 supportsOctetLength = true,
|
adamc@1014
|
1144 trueString = "TRUE",
|
adamc@1196
|
1145 falseString = "FALSE",
|
adamc@1196
|
1146 onlyUnion = false,
|
adam@1777
|
1147 nestedRelops = true,
|
adam@1777
|
1148 windowFunctions = true}
|
adamc@874
|
1149
|
adamc@866
|
1150 val () = setDbms "postgres"
|
adamc@866
|
1151
|
adamc@866
|
1152 end
|