Mercurial > urweb

annotate src/postgres.sml @ 2176:d2a98983f502

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of support for surviving database-server restarts, for Postgres
author Adam Chlipala <adam@chlipala.net>
date Sat, 17 Oct 2015 10:49:25 -0400
parents 661b531f55bd
children 00cf8214c2e3
rev   line source
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