Mercurial > urweb

annotate src/postgres.sml @ 1289:3b22c3c67f35

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