| 1 | ;;; Bindings to the PostgreSQL C library |
|---|
| 2 | ;; |
|---|
| 3 | ;; Copyright (C) 2008-2009 Peter Bex |
|---|
| 4 | ;; Copyright (C) 2004 Johannes Grødem <johs@copyleft.no> |
|---|
| 5 | ;; Redistribution and use in source and binary forms, with or without |
|---|
| 6 | ;; modification, is permitted. |
|---|
| 7 | ;; |
|---|
| 8 | ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS |
|---|
| 9 | ;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED |
|---|
| 10 | ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|---|
| 11 | ;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE |
|---|
| 12 | ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR |
|---|
| 13 | ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT |
|---|
| 14 | ;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR |
|---|
| 15 | ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
|---|
| 16 | ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
|---|
| 17 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE |
|---|
| 18 | ;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|---|
| 19 | ;; DAMAGE. |
|---|
| 20 | |
|---|
| 21 | (module postgresql |
|---|
| 22 | (update-type-parsers! default-type-parsers |
|---|
| 23 | char-parser bool-parser bytea-parser numeric-parser |
|---|
| 24 | update-type-unparsers! default-type-unparsers |
|---|
| 25 | bool-unparser |
|---|
| 26 | |
|---|
| 27 | connect reset-connection disconnect connection? |
|---|
| 28 | |
|---|
| 29 | exec-simple-queries exec-query |
|---|
| 30 | |
|---|
| 31 | result? clear-result! result-row-count result-column-count |
|---|
| 32 | result-column-index result-column result-column-format |
|---|
| 33 | result-column-type result-column-type-modifier result-columns |
|---|
| 34 | result-table-oid result-table-column-index |
|---|
| 35 | result-value result-values result-alist result-affected-rows |
|---|
| 36 | result-inserted-oid invalid-oid |
|---|
| 37 | |
|---|
| 38 | escape-string escape-bytea unescape-bytea |
|---|
| 39 | |
|---|
| 40 | query-fold query-fold* query-for-each query-for-each*) |
|---|
| 41 | |
|---|
| 42 | (import chicken scheme foreign) |
|---|
| 43 | |
|---|
| 44 | (require-extension srfi-1 srfi-4 srfi-13 srfi-18 srfi-69 |
|---|
| 45 | extras data-structures sql-null) |
|---|
| 46 | |
|---|
| 47 | (foreign-declare "#include <libpq-fe.h>") |
|---|
| 48 | |
|---|
| 49 | (define-foreign-type pg-polling-status (enum "PostgresPollingStatusType")) |
|---|
| 50 | (define-foreign-variable PGRES_POLLING_FAILED pg-polling-status) |
|---|
| 51 | (define-foreign-variable PGRES_POLLING_READING pg-polling-status) |
|---|
| 52 | (define-foreign-variable PGRES_POLLING_WRITING pg-polling-status) |
|---|
| 53 | (define-foreign-variable PGRES_POLLING_OK pg-polling-status) |
|---|
| 54 | |
|---|
| 55 | (define-foreign-type pg-exec-status (enum "ExecStatusType")) |
|---|
| 56 | (define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status) |
|---|
| 57 | (define-foreign-variable PGRES_COMMAND_OK pg-exec-status) |
|---|
| 58 | (define-foreign-variable PGRES_TUPLES_OK pg-exec-status) |
|---|
| 59 | (define-foreign-variable PGRES_COPY_OUT pg-exec-status) |
|---|
| 60 | (define-foreign-variable PGRES_COPY_IN pg-exec-status) |
|---|
| 61 | (define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status) |
|---|
| 62 | (define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status) |
|---|
| 63 | (define-foreign-variable PGRES_FATAL_ERROR pg-exec-status) |
|---|
| 64 | |
|---|
| 65 | ;(define-foreign-type pgconn* (c-pointer "PGconn")) |
|---|
| 66 | (define-foreign-type pgconn* c-pointer) |
|---|
| 67 | |
|---|
| 68 | (define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string))) |
|---|
| 69 | (define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*)) |
|---|
| 70 | (define PQresetStart (foreign-lambda bool PQresetStart pgconn*)) |
|---|
| 71 | (define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*)) |
|---|
| 72 | (define PQfinish (foreign-lambda void PQfinish pgconn*)) |
|---|
| 73 | (define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*))) |
|---|
| 74 | (define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*))) |
|---|
| 75 | |
|---|
| 76 | ;(define-foreign-type oid "Oid") |
|---|
| 77 | (define-foreign-type oid unsigned-int) |
|---|
| 78 | |
|---|
| 79 | (define invalid-oid (foreign-value "InvalidOid" oid)) |
|---|
| 80 | |
|---|
| 81 | (define PQisBusy (foreign-lambda bool PQisBusy pgconn*)) |
|---|
| 82 | (define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*)) |
|---|
| 83 | |
|---|
| 84 | (define-foreign-type pgresult* (c-pointer "PGresult")) |
|---|
| 85 | |
|---|
| 86 | (define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*)) |
|---|
| 87 | (define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*))) |
|---|
| 88 | (define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*))) |
|---|
| 89 | (define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int)) |
|---|
| 90 | |
|---|
| 91 | (define PQclear (foreign-lambda void PQclear pgresult*)) |
|---|
| 92 | (define PQntuples (foreign-lambda int PQntuples (const pgresult*))) |
|---|
| 93 | (define PQnfields (foreign-lambda int PQnfields (const pgresult*))) |
|---|
| 94 | (define PQfname (foreign-lambda c-string PQfname (const pgresult*) int)) |
|---|
| 95 | (define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string))) |
|---|
| 96 | (define PQftable (foreign-lambda oid PQftable (const pgresult*) int)) |
|---|
| 97 | (define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int)) |
|---|
| 98 | (define PQfformat (foreign-lambda int PQfformat (const pgresult*) int)) |
|---|
| 99 | (define PQftype (foreign-lambda oid PQftype (const pgresult*) int)) |
|---|
| 100 | (define PQfmod (foreign-lambda int PQfmod (const pgresult*) int)) |
|---|
| 101 | (define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int)) |
|---|
| 102 | (define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*)) |
|---|
| 103 | (define PQoidValue (foreign-lambda oid PQoidValue pgresult*)) |
|---|
| 104 | |
|---|
| 105 | ;; TODO: Create a real callback system? |
|---|
| 106 | (foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }") |
|---|
| 107 | |
|---|
| 108 | (define-syntax define-foreign-int |
|---|
| 109 | (er-macro-transformer |
|---|
| 110 | (lambda (e r c) |
|---|
| 111 | ;; cannot rename define-foreign-variable; it's a really special form |
|---|
| 112 | `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e)))))) |
|---|
| 113 | |
|---|
| 114 | (define-foreign-int PG_DIAG_SEVERITY) |
|---|
| 115 | (define-foreign-int PG_DIAG_SQLSTATE) |
|---|
| 116 | (define-foreign-int PG_DIAG_MESSAGE_PRIMARY) |
|---|
| 117 | (define-foreign-int PG_DIAG_MESSAGE_DETAIL) |
|---|
| 118 | (define-foreign-int PG_DIAG_MESSAGE_HINT) |
|---|
| 119 | (define-foreign-int PG_DIAG_STATEMENT_POSITION) |
|---|
| 120 | (define-foreign-int PG_DIAG_CONTEXT) |
|---|
| 121 | (define-foreign-int PG_DIAG_SOURCE_FILE) |
|---|
| 122 | (define-foreign-int PG_DIAG_SOURCE_LINE) |
|---|
| 123 | (define-foreign-int PG_DIAG_SOURCE_FUNCTION) |
|---|
| 124 | |
|---|
| 125 | (define (postgresql-error loc message . args) |
|---|
| 126 | (signal (make-pg-condition loc message args: args))) |
|---|
| 127 | |
|---|
| 128 | (define (make-pg-condition loc message #!key (args '()) severity |
|---|
| 129 | error-class error-code message-detail |
|---|
| 130 | message-hint statement-position context |
|---|
| 131 | source-file source-line |
|---|
| 132 | source-function) |
|---|
| 133 | (make-composite-condition |
|---|
| 134 | (make-property-condition |
|---|
| 135 | 'exn 'location loc 'message message 'arguments args) |
|---|
| 136 | (make-property-condition |
|---|
| 137 | 'postgresql 'severity severity 'error-class error-class |
|---|
| 138 | 'error-code error-code 'message-detail message-detail |
|---|
| 139 | 'message-hint message-hint 'statement-position statement-position |
|---|
| 140 | 'context context 'source-file source-file 'source-line source-line |
|---|
| 141 | ;; Might break not-terribly-old versions of postgresql |
|---|
| 142 | ;;'internal-position internal-position 'internal-query internal-query |
|---|
| 143 | 'source-function source-function))) |
|---|
| 144 | |
|---|
| 145 | ;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 146 | ;;;; Type parsers |
|---|
| 147 | ;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 148 | |
|---|
| 149 | (define (char-parser str) (string-ref str 0)) |
|---|
| 150 | |
|---|
| 151 | (define (bool-parser str) (string=? str "t")) |
|---|
| 152 | |
|---|
| 153 | (define (abstime-parser str) str) |
|---|
| 154 | |
|---|
| 155 | (define (reltime-parser str) str) |
|---|
| 156 | |
|---|
| 157 | (define (parse-format-string s) |
|---|
| 158 | (let-syntax ((push! (syntax-rules () |
|---|
| 159 | ((_ value place) |
|---|
| 160 | (set! place (cons value place)))))) |
|---|
| 161 | (do ([i 0 (+ i 1)] |
|---|
| 162 | [ranges (list)] |
|---|
| 163 | [cur-range (list)] |
|---|
| 164 | [len (string-length s)]) |
|---|
| 165 | ([= i len] |
|---|
| 166 | (when (not (null? cur-range)) |
|---|
| 167 | (push! (cons (- i (length cur-range)) i) |
|---|
| 168 | ranges)) |
|---|
| 169 | (reverse! ranges)) |
|---|
| 170 | (let ([char (string-ref s i)]) |
|---|
| 171 | (cond ([and (or (null? cur-range) |
|---|
| 172 | (char=? char (car cur-range))) |
|---|
| 173 | (char-alphabetic? char)] |
|---|
| 174 | (push! char cur-range)) |
|---|
| 175 | ([and (not (null? cur-range)) |
|---|
| 176 | (not (char=? char (car cur-range)))] |
|---|
| 177 | (push! (cons (- i (length cur-range)) i) |
|---|
| 178 | ranges) |
|---|
| 179 | (set! cur-range |
|---|
| 180 | (if (char-alphabetic? char) |
|---|
| 181 | (list char) |
|---|
| 182 | (list))))))))) |
|---|
| 183 | |
|---|
| 184 | (define-syntax define-time-parser |
|---|
| 185 | (syntax-rules () |
|---|
| 186 | ((_ name format-string) |
|---|
| 187 | (define name |
|---|
| 188 | (let ((format-ranges (parse-format-string format-string))) |
|---|
| 189 | (lambda (str) |
|---|
| 190 | (apply |
|---|
| 191 | vector |
|---|
| 192 | (map (lambda (range) |
|---|
| 193 | (if (> (cdr range) (string-length str)) |
|---|
| 194 | 0 |
|---|
| 195 | (string->number |
|---|
| 196 | (substring str (car range) (cdr range))))) |
|---|
| 197 | format-ranges)))))))) |
|---|
| 198 | |
|---|
| 199 | (define-time-parser date-parser "YYYY-MM-DD") |
|---|
| 200 | (define-time-parser timestamp-parser "YYYY-MM-DD hh:mm:ss.ssssss") |
|---|
| 201 | (define-time-parser timestamp/tz-parser "YYYY-MM-DD hh:mm:ss.sssssszzz") |
|---|
| 202 | (define-time-parser time-parser "hh:mm:ss.ssssss") |
|---|
| 203 | |
|---|
| 204 | (define (numeric-parser str) |
|---|
| 205 | (or (string->number str) |
|---|
| 206 | (postgresql-error 'numeric-parser "Unable to parse number" str))) |
|---|
| 207 | |
|---|
| 208 | (define (bytea-parser str) |
|---|
| 209 | (blob->u8vector/shared (string->blob (unescape-bytea str)))) |
|---|
| 210 | |
|---|
| 211 | (define default-type-parsers |
|---|
| 212 | (make-parameter |
|---|
| 213 | `(("text" . ,identity) |
|---|
| 214 | ("bytea" . ,bytea-parser) |
|---|
| 215 | ("char" . ,char-parser) |
|---|
| 216 | ("bpchar" . ,identity) |
|---|
| 217 | ("bool" . ,bool-parser) |
|---|
| 218 | ("int8" . ,numeric-parser) |
|---|
| 219 | ("int4" . ,numeric-parser) |
|---|
| 220 | ("int2" . ,numeric-parser) |
|---|
| 221 | ("float4" . ,numeric-parser) |
|---|
| 222 | ("float8" . ,numeric-parser) |
|---|
| 223 | ("abstime" . ,abstime-parser) |
|---|
| 224 | ("reltime" . ,reltime-parser) |
|---|
| 225 | ("date" . ,date-parser) |
|---|
| 226 | ("time" . ,time-parser) |
|---|
| 227 | ("timestamp" . ,timestamp-parser) |
|---|
| 228 | ("timestamptz" . ,timestamp/tz-parser) |
|---|
| 229 | ("numeric" . ,numeric-parser) |
|---|
| 230 | ("oid" . ,numeric-parser)))) |
|---|
| 231 | |
|---|
| 232 | ;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 233 | ;;;; Type unparsers |
|---|
| 234 | ;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 235 | |
|---|
| 236 | (define (bool-unparser b) |
|---|
| 237 | (if b "TRUE" "FALSE")) |
|---|
| 238 | |
|---|
| 239 | (define default-type-unparsers |
|---|
| 240 | (make-parameter |
|---|
| 241 | `((,string? . ,identity) |
|---|
| 242 | (,u8vector? . ,u8vector->blob/shared) |
|---|
| 243 | (,char? . ,string) |
|---|
| 244 | (,boolean? . ,bool-unparser) |
|---|
| 245 | (,number? . ,number->string) |
|---|
| 246 | #;(,vector? . ,vector-unparser)))) |
|---|
| 247 | |
|---|
| 248 | ;; Retrieve type-oids from PostgreSQL: |
|---|
| 249 | (define (update-type-parsers! conn #!optional new-type-parsers) |
|---|
| 250 | (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn))) |
|---|
| 251 | (ht (make-hash-table)) |
|---|
| 252 | (result '())) |
|---|
| 253 | ;; Set the parsers now, so that we will be retrieving raw data |
|---|
| 254 | (pg-connection-oid-parsers-set! conn ht) |
|---|
| 255 | (pg-connection-type-parsers-set! conn type-parsers) |
|---|
| 256 | (unless (null? type-parsers) ; empty IN () clause is not allowed |
|---|
| 257 | (query-for-each* |
|---|
| 258 | (lambda (oid typname) |
|---|
| 259 | (and-let* ((procedure (assoc typname type-parsers))) |
|---|
| 260 | (hash-table-set! ht (string->number oid) (cdr procedure)))) |
|---|
| 261 | conn |
|---|
| 262 | (conc "SELECT oid, typname FROM pg_type WHERE typname IN " |
|---|
| 263 | "('" (string-intersperse |
|---|
| 264 | (map (lambda (p) (escape-string conn (car p))) |
|---|
| 265 | type-parsers) "', '") "')"))))) |
|---|
| 266 | |
|---|
| 267 | (define (update-type-unparsers! conn new-type-unparsers) |
|---|
| 268 | (pg-connection-type-unparsers-set! conn new-type-unparsers)) |
|---|
| 269 | |
|---|
| 270 | ;;;;;;;;;;;;;;;;;;;; |
|---|
| 271 | ;;;; Connections |
|---|
| 272 | ;;;;;;;;;;;;;;;;;;;; |
|---|
| 273 | |
|---|
| 274 | (define-record pg-connection ptr type-parsers oid-parsers type-unparsers) |
|---|
| 275 | (define connection? pg-connection?) |
|---|
| 276 | |
|---|
| 277 | (define (pgsql-connection->fd conn) |
|---|
| 278 | ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn))) |
|---|
| 279 | |
|---|
| 280 | ;; TODO: Add timeout code |
|---|
| 281 | (define (wait-for-connection! conn poll-function) |
|---|
| 282 | (let ((conn-fd (pgsql-connection->fd conn)) |
|---|
| 283 | (conn-ptr (pg-connection-ptr conn))) |
|---|
| 284 | (let loop ((result (poll-function conn-ptr))) |
|---|
| 285 | (cond ((= result PGRES_POLLING_OK) (void)) |
|---|
| 286 | ((= result PGRES_POLLING_FAILED) |
|---|
| 287 | (let ((error-message (PQerrorMessage conn-ptr))) |
|---|
| 288 | (disconnect conn) |
|---|
| 289 | (postgresql-error 'connect |
|---|
| 290 | (conc "Polling Postgres database failed. " |
|---|
| 291 | error-message)))) |
|---|
| 292 | ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING)) |
|---|
| 293 | (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result) |
|---|
| 294 | #:output |
|---|
| 295 | #:input)) |
|---|
| 296 | (loop (poll-function conn-ptr))) |
|---|
| 297 | (else |
|---|
| 298 | (postgresql-error 'connect (conc "Unknown status code!"))))))) |
|---|
| 299 | |
|---|
| 300 | (define (alist->connection-spec alist) |
|---|
| 301 | (string-join |
|---|
| 302 | (map (lambda (subspec) |
|---|
| 303 | (sprintf "~A='~A'" |
|---|
| 304 | (car subspec) ;; this had better not contain [ =\'] |
|---|
| 305 | (string-translate* (->string (cdr subspec)) |
|---|
| 306 | '(("\\" . "\\\\") ("'" . "\\'"))))) |
|---|
| 307 | alist))) |
|---|
| 308 | |
|---|
| 309 | (define (connect connection-spec |
|---|
| 310 | #!optional |
|---|
| 311 | (type-parsers (default-type-parsers)) |
|---|
| 312 | (type-unparsers (default-type-unparsers))) |
|---|
| 313 | (let* ((connection-spec (if (string? connection-spec) |
|---|
| 314 | connection-spec |
|---|
| 315 | (alist->connection-spec connection-spec))) |
|---|
| 316 | (conn-ptr (PQconnectStart connection-spec))) |
|---|
| 317 | (cond |
|---|
| 318 | ((not conn-ptr) |
|---|
| 319 | (postgresql-error 'connect |
|---|
| 320 | "Unable to allocate a Postgres connection structure." |
|---|
| 321 | connection-spec)) |
|---|
| 322 | ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr)) |
|---|
| 323 | (let ((error-message (PQerrorMessage conn-ptr))) |
|---|
| 324 | (PQfinish conn-ptr) |
|---|
| 325 | (postgresql-error 'connect |
|---|
| 326 | (conc "Connection to Postgres database failed: " |
|---|
| 327 | error-message) |
|---|
| 328 | connection-spec))) |
|---|
| 329 | (else |
|---|
| 330 | (let ((conn (make-pg-connection conn-ptr type-parsers |
|---|
| 331 | (make-hash-table) type-unparsers))) |
|---|
| 332 | ;; We don't want libpq to piss in our stderr stream |
|---|
| 333 | ((foreign-lambda* void ((pgconn* conn)) |
|---|
| 334 | "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr) |
|---|
| 335 | (wait-for-connection! conn PQconnectPoll) |
|---|
| 336 | (set-finalizer! conn disconnect) |
|---|
| 337 | ;; Retrieve type-information from PostgreSQL metadata for use by |
|---|
| 338 | ;; the various value-parsers. |
|---|
| 339 | (update-type-parsers! conn) |
|---|
| 340 | conn))))) |
|---|
| 341 | |
|---|
| 342 | (define (reset-connection connection) |
|---|
| 343 | (let ((conn-ptr (pg-connection-ptr connection))) |
|---|
| 344 | (if (PQresetStart conn-ptr) ;; Update oid-parsers? |
|---|
| 345 | (wait-for-connection! connection PQresetPoll) |
|---|
| 346 | (let ((error-message (PQerrorMessage conn-ptr))) |
|---|
| 347 | (disconnect connection) |
|---|
| 348 | (postgresql-error 'reset-connection |
|---|
| 349 | (conc "Reset of connection failed " error-message) |
|---|
| 350 | connection))))) |
|---|
| 351 | |
|---|
| 352 | (define (disconnect connection) |
|---|
| 353 | (and-let* ((conn-ptr (pg-connection-ptr connection))) |
|---|
| 354 | (pg-connection-ptr-set! connection #f) |
|---|
| 355 | (pg-connection-type-parsers-set! connection #f) |
|---|
| 356 | (pg-connection-oid-parsers-set! connection #f) |
|---|
| 357 | (PQfinish conn-ptr)) |
|---|
| 358 | (void)) |
|---|
| 359 | |
|---|
| 360 | ;;;;;;;;;;;;;;; |
|---|
| 361 | ;;;; Results |
|---|
| 362 | ;;;;;;;;;;;;;;; |
|---|
| 363 | |
|---|
| 364 | (define-record pg-result ptr value-parsers) |
|---|
| 365 | (define result? pg-result?) |
|---|
| 366 | |
|---|
| 367 | (define (clear-result! result) |
|---|
| 368 | (and-let* ((result-ptr (pg-result-ptr result))) |
|---|
| 369 | (pg-result-ptr-set! result #f) |
|---|
| 370 | (PQclear result-ptr))) |
|---|
| 371 | |
|---|
| 372 | (define (result-row-count result) |
|---|
| 373 | (PQntuples (pg-result-ptr result))) |
|---|
| 374 | |
|---|
| 375 | (define (result-column-count result) |
|---|
| 376 | (PQnfields (pg-result-ptr result))) |
|---|
| 377 | |
|---|
| 378 | ;; Helper procedures for bounds checking; so we can distinguish between |
|---|
| 379 | ;; out of bounds and nonexistant columns, and signal it. |
|---|
| 380 | (define (check-result-column-index! result index location) |
|---|
| 381 | (when (>= index (result-column-count result)) |
|---|
| 382 | (postgresql-error |
|---|
| 383 | location (sprintf "Result column ~A out of bounds" index) result index))) |
|---|
| 384 | |
|---|
| 385 | (define (check-result-row-index! result index location) |
|---|
| 386 | (when (>= index (result-row-count result)) |
|---|
| 387 | (postgresql-error |
|---|
| 388 | location (sprintf "Result row ~A out of bounds" index) result index))) |
|---|
| 389 | |
|---|
| 390 | (define (result-column result index) |
|---|
| 391 | (check-result-column-index! result index 'result-column) |
|---|
| 392 | (string->symbol (PQfname (pg-result-ptr result) index))) |
|---|
| 393 | |
|---|
| 394 | (define (result-columns result) |
|---|
| 395 | (let loop ((ptr (pg-result-ptr result)) |
|---|
| 396 | (row '()) |
|---|
| 397 | (idx (result-column-count result))) |
|---|
| 398 | (if (= idx 0) |
|---|
| 399 | row |
|---|
| 400 | (loop ptr (cons (string->symbol |
|---|
| 401 | (PQfname ptr (sub1 idx))) row) (sub1 idx))))) |
|---|
| 402 | |
|---|
| 403 | (define (result-column-index result name) |
|---|
| 404 | (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name)))) |
|---|
| 405 | (and (>= idx 0) idx))) |
|---|
| 406 | |
|---|
| 407 | (define (result-table-oid result index) |
|---|
| 408 | (check-result-column-index! result index 'result-table-oid) |
|---|
| 409 | (let ((oid (PQftable (pg-result-ptr result) index))) |
|---|
| 410 | (and (not (= oid invalid-oid)) oid))) |
|---|
| 411 | |
|---|
| 412 | ;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more |
|---|
| 413 | ;; consistent with the rest of Scheme. However, this is inconsistent with |
|---|
| 414 | ;; almost all other PostgreSQL interfaces... |
|---|
| 415 | (define (result-table-column-index result index) |
|---|
| 416 | (check-result-column-index! result index 'result-table-column-index) |
|---|
| 417 | (let ((idx (PQftablecol (pg-result-ptr result) index))) |
|---|
| 418 | (and (> idx 0) (sub1 idx)))) |
|---|
| 419 | |
|---|
| 420 | (define format-table |
|---|
| 421 | '((0 . text) (1 . binary))) |
|---|
| 422 | |
|---|
| 423 | (define (format->symbol format) |
|---|
| 424 | (or (alist-ref format format-table eq?) |
|---|
| 425 | (postgresql-error 'format->symbol "Unknown format" format))) |
|---|
| 426 | |
|---|
| 427 | (define (symbol->format symbol) |
|---|
| 428 | (or (and-let* ((res (rassoc symbol format-table eq?))) |
|---|
| 429 | (car res)) |
|---|
| 430 | (postgresql-error 'format->symbol "Unknown format" symbol))) |
|---|
| 431 | |
|---|
| 432 | (define (result-column-format result index) |
|---|
| 433 | (check-result-column-index! result index 'result-column-format) |
|---|
| 434 | (format->symbol (PQfformat (pg-result-ptr result) index))) |
|---|
| 435 | |
|---|
| 436 | (define (result-column-type result index) |
|---|
| 437 | (check-result-column-index! result index 'result-column-type) |
|---|
| 438 | (PQftype (pg-result-ptr result) index)) |
|---|
| 439 | |
|---|
| 440 | ;; This is really not super-useful as it requires intimate knowledge |
|---|
| 441 | ;; about the internal implementations of types in PostgreSQL. |
|---|
| 442 | (define (result-column-type-modifier result index) |
|---|
| 443 | (check-result-column-index! result index 'result-column-type) |
|---|
| 444 | (let ((mod (PQfmod (pg-result-ptr result) index))) |
|---|
| 445 | (and (>= mod 0) mod))) |
|---|
| 446 | |
|---|
| 447 | ;; Unchecked version, for speed |
|---|
| 448 | (define (result-value* result row column #!key raw) |
|---|
| 449 | (if (PQgetisnull (pg-result-ptr result) row column) |
|---|
| 450 | (sql-null) |
|---|
| 451 | (let ((value ((foreign-safe-lambda* |
|---|
| 452 | scheme-object ((c-pointer res) (int row) (int col)) |
|---|
| 453 | "C_word fin, *str; char *val; int len;" |
|---|
| 454 | "len = PQgetlength(res, row, col);" |
|---|
| 455 | "str = C_alloc(C_bytestowords(len + sizeof(C_header)));" |
|---|
| 456 | "val = PQgetvalue(res, row, col);" |
|---|
| 457 | "fin = C_string(&str, len, val);" |
|---|
| 458 | "if (PQfformat(res, col) == 1) /* binary? */" |
|---|
| 459 | " C_string_to_bytevector(fin);" |
|---|
| 460 | "C_return(fin);") |
|---|
| 461 | (pg-result-ptr result) row column))) |
|---|
| 462 | (if (or raw (blob? value)) |
|---|
| 463 | value |
|---|
| 464 | ((vector-ref (pg-result-value-parsers result) column) value))))) |
|---|
| 465 | |
|---|
| 466 | (define (result-value result row column #!key raw) |
|---|
| 467 | (check-result-row-index! result row 'result-value) |
|---|
| 468 | (check-result-column-index! result column 'result-value) |
|---|
| 469 | (result-value* result row column raw: raw)) |
|---|
| 470 | |
|---|
| 471 | (define (result-values result row #!key raw) |
|---|
| 472 | (check-result-row-index! result row 'result-list) |
|---|
| 473 | (let loop ((list '()) |
|---|
| 474 | (column (result-column-count result))) |
|---|
| 475 | (if (= column 0) |
|---|
| 476 | list |
|---|
| 477 | (loop (cons (result-value* result row (sub1 column) raw: raw) list) |
|---|
| 478 | (sub1 column))))) |
|---|
| 479 | |
|---|
| 480 | ;; (define (result-alist result row) |
|---|
| 481 | ;; (map cons (result-columns result row) (result-values result row))) |
|---|
| 482 | (define (result-alist result row) |
|---|
| 483 | (check-result-row-index! result row 'result-alist) |
|---|
| 484 | (let loop ((alist '()) |
|---|
| 485 | (column (result-column-count result))) |
|---|
| 486 | (if (= column 0) |
|---|
| 487 | alist |
|---|
| 488 | (loop (cons (cons (PQfname (pg-result-ptr result) column) |
|---|
| 489 | (result-value* result row (sub1 column))) alist) |
|---|
| 490 | (sub1 column))))) |
|---|
| 491 | |
|---|
| 492 | ;;; TODO: Do we want/need PQnparams and PQparamtype bindings? |
|---|
| 493 | |
|---|
| 494 | (define (result-affected-rows result) |
|---|
| 495 | (string->number (PQcmdTuples (pg-result-ptr result)))) |
|---|
| 496 | |
|---|
| 497 | (define (result-inserted-oid result) |
|---|
| 498 | (let ((oid (PQoidValue (pg-result-ptr result)))) |
|---|
| 499 | (and (not (= oid invalid-oid)) oid))) |
|---|
| 500 | |
|---|
| 501 | |
|---|
| 502 | ;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 503 | ;;;; Query procedures |
|---|
| 504 | ;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 505 | |
|---|
| 506 | ;; Buffer all available input, yielding if nothing is available: |
|---|
| 507 | (define (buffer-available-input! conn) |
|---|
| 508 | (let ((conn-ptr (pg-connection-ptr conn)) |
|---|
| 509 | (conn-fd (pgsql-connection->fd conn))) |
|---|
| 510 | (let loop () |
|---|
| 511 | (if (PQconsumeInput conn-ptr) |
|---|
| 512 | (when (PQisBusy conn-ptr) |
|---|
| 513 | (thread-wait-for-i/o! conn-fd #:input) |
|---|
| 514 | (loop)) |
|---|
| 515 | (postgresql-error 'buffer-available-input! |
|---|
| 516 | (conc "Error reading reply from server. " |
|---|
| 517 | (PQerrorMessage conn-ptr)) |
|---|
| 518 | conn-ptr))))) |
|---|
| 519 | |
|---|
| 520 | (define (make-value-parsers conn pqresult) |
|---|
| 521 | (let ((nfields (PQnfields pqresult))) |
|---|
| 522 | (do ([col 0 (+ col 1)] |
|---|
| 523 | [parsers (make-vector nfields)]) |
|---|
| 524 | ([= col nfields] parsers) |
|---|
| 525 | (vector-set! parsers col |
|---|
| 526 | (hash-table-ref (pg-connection-oid-parsers conn) |
|---|
| 527 | (PQftype pqresult col) |
|---|
| 528 | (lambda () identity)))))) |
|---|
| 529 | |
|---|
| 530 | ;; Collect the result pointers from the last query. |
|---|
| 531 | ;; |
|---|
| 532 | ;; A pgresult represents an entire resultset and is always read into memory |
|---|
| 533 | ;; all at once. |
|---|
| 534 | (define (collect-results conn) |
|---|
| 535 | (buffer-available-input! conn) |
|---|
| 536 | (let loop ((results (list))) |
|---|
| 537 | (let* ((conn-ptr (pg-connection-ptr conn)) |
|---|
| 538 | (result (PQgetResult conn-ptr))) |
|---|
| 539 | (if result |
|---|
| 540 | (cond |
|---|
| 541 | ((member (PQresultStatus result) (list PGRES_BAD_RESPONSE |
|---|
| 542 | PGRES_FATAL_ERROR)) |
|---|
| 543 | (let* ((msg (string-trim-right (PQresultErrorMessage result))) |
|---|
| 544 | (get-error-field (lambda (diag) |
|---|
| 545 | (PQresultErrorField result diag))) |
|---|
| 546 | (sqlstate (get-error-field PG_DIAG_SQLSTATE)) |
|---|
| 547 | (maybe-severity (get-error-field PG_DIAG_SEVERITY)) |
|---|
| 548 | (maybe-statement-position |
|---|
| 549 | (get-error-field PG_DIAG_STATEMENT_POSITION)) |
|---|
| 550 | (condition |
|---|
| 551 | (make-pg-condition |
|---|
| 552 | 'collect-results |
|---|
| 553 | (conc "PQgetResult: " msg) |
|---|
| 554 | args: (list conn) |
|---|
| 555 | severity: (and maybe-severity |
|---|
| 556 | (string->symbol |
|---|
| 557 | (string-downcase maybe-severity))) |
|---|
| 558 | error-class: (and sqlstate (string-take sqlstate 2)) |
|---|
| 559 | error-code: sqlstate |
|---|
| 560 | message-detail: (get-error-field PG_DIAG_MESSAGE_DETAIL) |
|---|
| 561 | message-hint: (get-error-field PG_DIAG_MESSAGE_HINT) |
|---|
| 562 | statement-position: (and maybe-statement-position |
|---|
| 563 | (string->number |
|---|
| 564 | maybe-statement-position)) |
|---|
| 565 | context: (get-error-field PG_DIAG_CONTEXT) |
|---|
| 566 | source-file: (get-error-field PG_DIAG_SOURCE_FILE) |
|---|
| 567 | source-line: (get-error-field PG_DIAG_SOURCE_LINE) |
|---|
| 568 | source-function: (get-error-field PG_DIAG_SOURCE_FUNCTION)))) |
|---|
| 569 | ;; Read out all remaining results (including the current one). |
|---|
| 570 | ;; TODO: Is this really needed? libpq does it (in pqExecFinish), |
|---|
| 571 | ;; but ostensibly only to concatenate the error messages for |
|---|
| 572 | ;; each query. OTOH, maybe we want to do that, too. |
|---|
| 573 | (let clean-results! ((result result)) |
|---|
| 574 | (when result |
|---|
| 575 | (PQclear result) |
|---|
| 576 | (clean-results! (PQgetResult (pg-connection-ptr conn))))) |
|---|
| 577 | (signal condition))) |
|---|
| 578 | (else |
|---|
| 579 | (let ((result-obj (make-pg-result result |
|---|
| 580 | (make-value-parsers conn result)))) |
|---|
| 581 | (set-finalizer! result-obj clear-result!) |
|---|
| 582 | (loop (cons result-obj results))))) |
|---|
| 583 | (reverse! results))))) |
|---|
| 584 | |
|---|
| 585 | (define (exec-simple-queries conn query) |
|---|
| 586 | (if ((foreign-lambda bool PQsendQuery pgconn* (const c-string)) |
|---|
| 587 | (pg-connection-ptr conn) query) |
|---|
| 588 | (collect-results conn) |
|---|
| 589 | (postgresql-error 'exec-simple-queries |
|---|
| 590 | (conc "Unable to send query to server. " |
|---|
| 591 | (PQerrorMessage (pg-connection-ptr conn))) |
|---|
| 592 | conn query))) |
|---|
| 593 | |
|---|
| 594 | (define (exec-query conn query #!optional (params '()) #!key (format 'text) raw) |
|---|
| 595 | (let* ((unparsers (pg-connection-type-unparsers conn)) |
|---|
| 596 | (unparse (lambda (x) |
|---|
| 597 | (cond ((find (lambda (parse?) |
|---|
| 598 | ((car parse?) x)) |
|---|
| 599 | unparsers) => (lambda (parse) |
|---|
| 600 | ((cdr parse) x))) |
|---|
| 601 | (else x)))) |
|---|
| 602 | (params ;; Check all params and ensure they are proper pairs |
|---|
| 603 | (map ;; See if this can be moved into C |
|---|
| 604 | (lambda (p) |
|---|
| 605 | (let ((obj (if raw p (unparse p)))) |
|---|
| 606 | (when (and (not (string? obj)) |
|---|
| 607 | (not (blob? obj)) |
|---|
| 608 | (not (sql-null? obj))) |
|---|
| 609 | (postgresql-error |
|---|
| 610 | 'exec-query |
|---|
| 611 | (sprintf "Param value is not a string, sql-null or blob: ~S" p) |
|---|
| 612 | conn query params format)) |
|---|
| 613 | (if (sql-null? obj) #f obj))) params)) |
|---|
| 614 | (send-query |
|---|
| 615 | (foreign-lambda* |
|---|
| 616 | bool ((pgconn* conn) (nonnull-c-string query) |
|---|
| 617 | (int num) (scheme-object params) (int resfmt)) |
|---|
| 618 | "int res = 0, i = 0, *lens = NULL;" |
|---|
| 619 | "char **vals = NULL;" |
|---|
| 620 | "int *fmts = NULL;" |
|---|
| 621 | "C_word obj, cons;" |
|---|
| 622 | "if (num > 0) {" |
|---|
| 623 | " vals = C_malloc(num * sizeof(char *));" |
|---|
| 624 | " lens = C_malloc(num * sizeof(int));" |
|---|
| 625 | " fmts = C_malloc(num * sizeof(int));" |
|---|
| 626 | "}" |
|---|
| 627 | "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {" |
|---|
| 628 | " obj = C_u_i_car(cons);" |
|---|
| 629 | " if (obj == C_SCHEME_FALSE) {" |
|---|
| 630 | " fmts[i] = 0; /* don't care */" |
|---|
| 631 | " lens[i] = 0;" |
|---|
| 632 | " vals[i] = NULL;" |
|---|
| 633 | " } else if (C_header_bits(obj) == C_BYTEVECTOR_TYPE) {" |
|---|
| 634 | " fmts[i] = 1; /* binary */" |
|---|
| 635 | " lens[i] = C_header_size(obj);" |
|---|
| 636 | " vals[i] = C_c_string(obj);" |
|---|
| 637 | " } else {" |
|---|
| 638 | " /* text needs to be copied; it expects ASCIIZ */" |
|---|
| 639 | " fmts[i] = 0; /* text */" |
|---|
| 640 | " lens[i] = C_header_size(obj);" |
|---|
| 641 | " vals[i] = malloc(lens[i] + 1);" |
|---|
| 642 | " memcpy(vals[i], C_c_string(obj), lens[i]);" |
|---|
| 643 | " vals[i][lens[i]] = '\\0';" |
|---|
| 644 | " }" |
|---|
| 645 | "}" |
|---|
| 646 | "res = PQsendQueryParams(conn, query, num, NULL," |
|---|
| 647 | " vals, lens, fmts, resfmt);" |
|---|
| 648 | "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {" |
|---|
| 649 | " obj = C_u_i_car(cons);" |
|---|
| 650 | " if (!C_immediatep(obj) && C_header_bits(obj) == C_STRING_TYPE)" |
|---|
| 651 | " free(vals[i]); /* Clear copied strings only */" |
|---|
| 652 | "}" |
|---|
| 653 | "if (num > 0) {" |
|---|
| 654 | " free(fmts);" |
|---|
| 655 | " free(lens);" |
|---|
| 656 | " free(vals);" |
|---|
| 657 | "}" |
|---|
| 658 | "C_return(res);"))) |
|---|
| 659 | (if (send-query (pg-connection-ptr conn) query |
|---|
| 660 | (length params) params (symbol->format format)) |
|---|
| 661 | (car (collect-results conn)) ;; assumed to always return one result... |
|---|
| 662 | (postgresql-error 'exec-query |
|---|
| 663 | (conc "Unable to send query to server. " |
|---|
| 664 | (PQerrorMessage (pg-connection-ptr conn))) |
|---|
| 665 | conn query params format)))) |
|---|
| 666 | |
|---|
| 667 | ;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 668 | ;;;; Value escaping |
|---|
| 669 | ;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 670 | |
|---|
| 671 | (define (escape-string conn str) |
|---|
| 672 | (define %escape-string-conn |
|---|
| 673 | ;; This could be more efficient by copying straight into a Scheme object. |
|---|
| 674 | ;; Now it's being copied by PQescapeStringConn, and Chicken copies it again. |
|---|
| 675 | ;; This can allocate up to twice as much memory than the string actually |
|---|
| 676 | ;; uses; in extreme cases this could be a problem. |
|---|
| 677 | (foreign-lambda* c-string* ((pointer conn) (c-string from) (int fromlen)) |
|---|
| 678 | "int err = 0; char *to;" |
|---|
| 679 | "to = malloc(sizeof(char) * (fromlen * 2 + 1));" |
|---|
| 680 | "PQescapeStringConn(conn, to, from, fromlen, &err);" |
|---|
| 681 | "if (err) {" |
|---|
| 682 | " free(to);" |
|---|
| 683 | " C_return(NULL);" |
|---|
| 684 | "}" |
|---|
| 685 | "C_return(to);" |
|---|
| 686 | )) |
|---|
| 687 | (or (%escape-string-conn conn str (string-length str)) |
|---|
| 688 | (postgresql-error 'escape-string |
|---|
| 689 | (conc "String escaping failed. " |
|---|
| 690 | (PQerrorMessage conn)) conn str))) |
|---|
| 691 | |
|---|
| 692 | (define (escape-bytea conn str) |
|---|
| 693 | (define %escape-bytea-conn |
|---|
| 694 | ;; This must copy because libpq returns a malloced ptr... |
|---|
| 695 | (foreign-safe-lambda* scheme-object ((pointer conn) |
|---|
| 696 | ;; not copied/NUL interpreted: |
|---|
| 697 | ((const unsigned-c-string*) from) |
|---|
| 698 | (int fromlen)) |
|---|
| 699 | "size_t tolen=0; C_word res, *fin; unsigned char *esc;" |
|---|
| 700 | "esc = PQescapeByteaConn(conn, from, (size_t)fromlen, &tolen);" |
|---|
| 701 | "if (esc == NULL)" |
|---|
| 702 | " C_return(C_SCHEME_FALSE);" |
|---|
| 703 | "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));" |
|---|
| 704 | "/* tolen includes the resulting NUL byte */" |
|---|
| 705 | "res = C_string(&fin, tolen - 1, (char *)esc);" |
|---|
| 706 | "PQfreemem(esc);" |
|---|
| 707 | "C_return(res);" |
|---|
| 708 | )) |
|---|
| 709 | (or (%escape-bytea-conn conn str (string-length str)) |
|---|
| 710 | (postgresql-error 'escape-bytea |
|---|
| 711 | (conc "Byte array escaping failed. " |
|---|
| 712 | (PQerrorMessage conn)) conn str))) |
|---|
| 713 | |
|---|
| 714 | (define (unescape-bytea str) |
|---|
| 715 | (define %unescape-bytea |
|---|
| 716 | ;; This must copy because libpq returns a malloced ptr... |
|---|
| 717 | (foreign-safe-lambda* scheme-object (((const unsigned-c-string*) from)) |
|---|
| 718 | "size_t tolen=0; C_word res, *fin; unsigned char *unesc;" |
|---|
| 719 | "unesc = PQunescapeBytea(from, &tolen);" |
|---|
| 720 | "if (unesc == NULL)" |
|---|
| 721 | " C_return(C_SCHEME_FALSE);" |
|---|
| 722 | "fin = C_alloc(C_bytestowords(tolen + sizeof(C_header)));" |
|---|
| 723 | "res = C_string(&fin, tolen, (char *)unesc);" |
|---|
| 724 | "PQfreemem(unesc);" |
|---|
| 725 | "C_return(res);" |
|---|
| 726 | )) |
|---|
| 727 | (or (%unescape-bytea str) |
|---|
| 728 | (postgresql-error 'unescape-bytea |
|---|
| 729 | "Byte array unescaping failed (out of memory?)" str))) |
|---|
| 730 | |
|---|
| 731 | |
|---|
| 732 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 733 | ;;;; High-level interface |
|---|
| 734 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 735 | |
|---|
| 736 | (define (query-fold kons knil conn query #!optional (params '())) |
|---|
| 737 | (let* ((result (exec-query conn query params)) |
|---|
| 738 | (rows (result-row-count result))) |
|---|
| 739 | (let loop ((seed knil) |
|---|
| 740 | (row 0)) |
|---|
| 741 | (if (= row rows) |
|---|
| 742 | seed |
|---|
| 743 | (loop (kons (result-values result row) seed) (add1 row)))))) |
|---|
| 744 | |
|---|
| 745 | (define (query-fold* kons knil conn query #!optional (params '())) |
|---|
| 746 | (query-fold (lambda (values seed) (apply kons (append values (list seed)))) |
|---|
| 747 | knil conn query params)) |
|---|
| 748 | |
|---|
| 749 | (define (query-for-each proc conn query #!optional (params '())) |
|---|
| 750 | (query-fold (lambda (values seed) (proc values)) #f conn query params) |
|---|
| 751 | (void)) |
|---|
| 752 | |
|---|
| 753 | (define (query-for-each* proc conn query #!optional (params '())) |
|---|
| 754 | (query-fold (lambda (values seed) (apply proc values)) #f conn query params) |
|---|
| 755 | (void)) |
|---|
| 756 | |
|---|
| 757 | ) |
|---|
