Mercurial > urweb

annotate src/postgres.sml @ 2279:32a407902d3b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Rewrite LRU cache. Now uses one big hash table and is less buggy.
author Ziv Scully <ziv@mit.edu>
date Wed, 11 Nov 2015 20:01:48 -0500
parents 00cf8214c2e3
children 251dd276f45f
rev   line source
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 = '"
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@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