diff options
-rw-r--r-- | TODO | 6 | ||||
-rw-r--r-- | benchmarks/run.scm | 127 | ||||
-rwxr-xr-x | build-postgresql | 23 | ||||
-rw-r--r-- | feature-tests/connectdb-params.c | 7 | ||||
-rw-r--r-- | feature-tests/diag-query-position.c | 7 | ||||
-rw-r--r-- | feature-tests/diag-schema-info.c | 10 | ||||
-rw-r--r-- | feature-tests/escape-identifier.c | 6 | ||||
-rw-r--r-- | postgresql.egg | 18 | ||||
-rw-r--r-- | postgresql.release-info | 3 | ||||
-rw-r--r-- | postgresql.scm | 1360 | ||||
-rw-r--r-- | tests/run.scm | 949 |
11 files changed, 2516 insertions, 0 deletions
@@ -0,0 +1,6 @@ +- Add Batch (pipeline) API support (http://blog.2ndquadrant.com/postgresql-latency-pipelining-batching/) +- Add LISTEN/NOTIFY support +- Add support for range types +- Add large object support +- Add namespace support for types? + diff --git a/benchmarks/run.scm b/benchmarks/run.scm new file mode 100644 index 0000000..2994710 --- /dev/null +++ b/benchmarks/run.scm @@ -0,0 +1,127 @@ +(import postgresql (chicken string) (chicken format) srfi-13) + +(define conn (connect '((dbname . test)))) +(define raw-conn (connect '((dbname . test)) '() '())) + +(print "--- Connecting/disconnecting ---") +(print "Full connection") +(time (do ((i 0 (add1 i))) + ((= i 1000)) + (disconnect (connect '((dbname . test)))))) + +(print "Raw connection") +(time (do ((i 0 (add1 i))) + ((= i 1000)) + (disconnect (connect '((dbname . test)) '() '())))) + +(let ((str (make-string 1000 #\x))) + (newline) + (print "--- Quotation ---") + (print "Escaping many strings") + (time (do ((i 0 (add1 i))) + ((= i 100000)) + (escape-string conn str))) + + (print "Quoting many identifiers") + (time (do ((i 0 (add1 i))) + ((= i 100000)) + (quote-identifier conn str))) + + (print "Escaping many byteas") + (time (do ((i 0 (add1 i))) + ((= i 100000)) + (escape-bytea conn str))) + + (print "Unescaping many byteas") + (let ((bytea (escape-bytea conn str))) + (time (do ((i 0 (add1 i))) + ((= i 100000)) + (unescape-bytea bytea))))) + +(begin (newline) + (print "--- Reading data ---") + (print "Raw query with no result processing (postgres/libpq benchmark)") + (time (query conn "SELECT generate_series(0, 100000)")) + + (newline) + (print "Fetching all values, no type conversion (string)") + (time (row-for-each (lambda (values) #f) + (query raw-conn "SELECT generate_series(0, 1000000)::text"))) + (print "Fetching all values, with type conversion (string)") + (time (row-for-each (lambda (values) #f) + (query conn "SELECT generate_series(0, 1000000)::text"))) + + (newline) + (print "Fetching all values, no type conversion (integer)") + (time (row-for-each (lambda (values) #f) + (query raw-conn "SELECT generate_series(0, 1000000)"))) + (print "Fetching all values, with type conversion (integer)") + (time (row-for-each (lambda (values) #f) + (query conn "SELECT generate_series(0, 1000000)"))) + + (newline) + (print "COPY TO") + (time (copy-query-for-each (lambda (values) #f) + raw-conn "COPY (SELECT generate_series(0, 1000000)) TO STDOUT"))) + +(begin (newline) + (print "--- Inserting data ---") + (query raw-conn "CREATE TEMPORARY TABLE foo (bar int)") + (print "INSERT in a loop, no type conversion") + (time (do ((i 0 (add1 i))) + ((= i 65535)) + (query raw-conn "INSERT INTO foo VALUES ($1)" (->string i)))) + (query raw-conn "TRUNCATE foo") + + (query conn "CREATE TEMPORARY TABLE foo (bar int)") + (print "INSERT in a loop, with type conversion") + (time (do ((i 0 (add1 i))) + ((= i 65535)) + (query conn "INSERT INTO foo VALUES ($1)" i))) + (query conn "TRUNCATE foo") + + (newline) + + (print "Parameterized INSERT statement, no type conversion") + (time (do ((i 0 (add1 i)) + (values '() (cons (->string i) values)) + (values-string '() (cons (sprintf "($~A)" (add1 i)) values-string))) + ((= i 65535) + (query* raw-conn (sprintf "INSERT INTO foo VALUES ~A" + (string-join values-string ",")) + values)))) + (query raw-conn "TRUNCATE foo") + + (print "Parameterized INSERT statement, with type conversion") + (time (do ((i 0 (add1 i)) + (values '() (cons i values)) + (values-string '() (cons (sprintf "($~A)" (add1 i)) values-string))) + ((= i 65535) + (query* conn (sprintf "INSERT INTO foo VALUES ~A" + (string-join values-string ",")) + values)))) + (query conn "TRUNCATE foo") + + (newline) + + (print "Unparameterized INSERT statement") + (time (do ((i 0 (add1 i)) + (values-string '() (cons (sprintf "(~A)" i) values-string))) + ((= i 65535) + (query raw-conn (sprintf "INSERT INTO foo VALUES ~A" + (string-join values-string ",")))))) + (query raw-conn "TRUNCATE foo") + + (newline) + (print "COPY FROM") + (time (call-with-output-copy-query + (lambda (p) + (do ((i 0 (add1 i))) + ((= i 65535)) + (display i p) + (newline p))) + raw-conn "COPY foo (bar) FROM STDIN")) + (query raw-conn "TRUNCATE foo")) + +(disconnect raw-conn) +(disconnect conn) diff --git a/build-postgresql b/build-postgresql new file mode 100755 index 0000000..fb15976 --- /dev/null +++ b/build-postgresql @@ -0,0 +1,23 @@ +# -*- sh -*- + +# Determine if pkg-config exists and knows about libpq, otherwise +# fall back on pg_config to determine compiler and linker flags. +if pkg-config --exists libpq >/dev/null 2>/dev/null; then + CFLAGS="`pkg-config --cflags libpq`" + LDFLAGS="`pkg-config --libs libpq`" +else + CFLAGS="-I`pg_config --includedir`" + LDFLAGS="-L`pg_config --libdir` -Wl,-rpath `pg_config --libdir` -lpq" +fi + +known_features="escape-identifier connectdb-params diag-query-position diag-schema-info" + +feature_flags="" +for feature in $known_features; do + if "$CHICKEN_CSC" -C "$CFLAGS" -L "$LDFLAGS" "feature-tests/$feature.c" >/dev/null 2>/dev/null; then + feature_flags="$feature_flags -Dhas-$feature" + fi + rm -f feature-tests/$feature.o feature-tests/$feature +done + +"$CHICKEN_CSC" $feature_flags -C "$CFLAGS" -L "$LDFLAGS" "$@" diff --git a/feature-tests/connectdb-params.c b/feature-tests/connectdb-params.c new file mode 100644 index 0000000..d79a2e0 --- /dev/null +++ b/feature-tests/connectdb-params.c @@ -0,0 +1,7 @@ +#include <libpq-fe.h> +int main(void) +{ + const char *kw[] = {"a", NULL}; + const char *val[] = {"b", NULL}; + return PQconnectdbParams(kw, val, 0) != NULL; +} diff --git a/feature-tests/diag-query-position.c b/feature-tests/diag-query-position.c new file mode 100644 index 0000000..8feb629 --- /dev/null +++ b/feature-tests/diag-query-position.c @@ -0,0 +1,7 @@ +#include <libpq-fe.h> +int main(void) +{ + int foo = PG_DIAG_INTERNAL_QUERY; + int bar = PG_DIAG_INTERNAL_POSITION; + return foo + bar; +} diff --git a/feature-tests/diag-schema-info.c b/feature-tests/diag-schema-info.c new file mode 100644 index 0000000..e64e990 --- /dev/null +++ b/feature-tests/diag-schema-info.c @@ -0,0 +1,10 @@ +#include <libpq-fe.h> +int main(void) +{ + int s = PG_DIAG_SCHEMA_NAME; + int t = PG_DIAG_TABLE_NAME; + int col = PG_DIAG_COLUMN_NAME; + int d = PG_DIAG_DATATYPE_NAME; + int con = PG_DIAG_CONSTRAINT_NAME; + return s + t + col + d + con; +} diff --git a/feature-tests/escape-identifier.c b/feature-tests/escape-identifier.c new file mode 100644 index 0000000..8188cbf --- /dev/null +++ b/feature-tests/escape-identifier.c @@ -0,0 +1,6 @@ +#include <libpq-fe.h> +int main(void) +{ + PGconn *conn = NULL; /* Bork */ + return PQescapeIdentifier(conn, "test", 4) != NULL; +} diff --git a/postgresql.egg b/postgresql.egg new file mode 100644 index 0000000..3848b3e --- /dev/null +++ b/postgresql.egg @@ -0,0 +1,18 @@ +;;; postgresql.meta -*- Scheme -*- + +((synopsis "Bindings for PostgreSQL's C-api") + (category db) + (version 4.0.0) + (author "Johannes Groedem") + (maintainer "Peter Bex") + (license "BSD") + (dependencies sql-null srfi-1 srfi-18 srfi-13 srfi-69) + (test-dependencies test) + (foreign-dependencies libpq) ;; Or libpq-dev? Highly OS-dependent! + (components (extension postgresql + (custom-build "build-postgresql") + (source-dependencies + "feature-tests/connectdb-params.c" + "feature-tests/escape-identifier.c" + "feature-tests/diag-query-position.c" + "feature-tests/diag-schema-info.c")))) diff --git a/postgresql.release-info b/postgresql.release-info new file mode 100644 index 0000000..57d33b4 --- /dev/null +++ b/postgresql.release-info @@ -0,0 +1,3 @@ +(repo git "https://code.more-magic.net/chicken-postgresql") +(uri targz "https://code.more-magic.net/chicken-postgresql/snapshot/chicken-postgresql-{egg-release}.tar.gz") +(release "4.0.0") diff --git a/postgresql.scm b/postgresql.scm new file mode 100644 index 0000000..3f1baf4 --- /dev/null +++ b/postgresql.scm @@ -0,0 +1,1360 @@ +;;; Bindings to the PostgreSQL C library +;; +;; Copyright (C) 2008-2014 Peter Bex +;; Copyright (C) 2004 Johannes Gr�dem <johs@copyleft.no> +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +(module postgresql + (type-parsers update-type-parsers! default-type-parsers + char-parser bool-parser bytea-parser numeric-parser + make-array-parser make-composite-parser + scheme-value->db-value type-unparsers update-type-unparsers! + default-type-unparsers bool-unparser vector-unparser list-unparser + + connect reset-connection disconnect connection? connected? + + query query* with-transaction in-transaction? + + result? clear-result! row-count column-count + column-index column-name column-names column-format + column-type column-type-modifier table-oid table-column-index + value-at row-values row-alist column-values affected-rows inserted-oid + + invalid-oid + + escape-string escape-bytea unescape-bytea quote-identifier + + put-copy-data put-copy-end get-copy-data + + row-fold row-fold* row-fold-right row-fold-right* + row-for-each row-for-each* row-map row-map* + column-fold column-fold* column-fold-right column-fold-right* + column-for-each column-for-each* column-map column-map* + copy-query-fold copy-query*-fold copy-query-fold-right copy-query*-fold-right + copy-query-for-each copy-query*-for-each copy-query-map copy-query*-map + call-with-output-copy-query call-with-output-copy-query* + with-output-to-copy-query with-output-to-copy-query*) + + (import scheme + (chicken base) + (chicken foreign) + (chicken string) + (chicken port) + (chicken memory) + (chicken condition) + (chicken format) + (chicken gc) + (chicken blob) + srfi-1 + srfi-4 + srfi-13 + srfi-18 + srfi-69 + sql-null) + +(import-for-syntax (chicken string)) + +(foreign-declare "#include <libpq-fe.h>") + +(define-foreign-type pg-polling-status (enum "PostgresPollingStatusType")) +(define-foreign-variable PGRES_POLLING_FAILED pg-polling-status) +(define-foreign-variable PGRES_POLLING_READING pg-polling-status) +(define-foreign-variable PGRES_POLLING_WRITING pg-polling-status) +(define-foreign-variable PGRES_POLLING_OK pg-polling-status) + +(define-foreign-type pg-exec-status (enum "ExecStatusType")) +(define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status) +(define-foreign-variable PGRES_COMMAND_OK pg-exec-status) +(define-foreign-variable PGRES_TUPLES_OK pg-exec-status) +(define-foreign-variable PGRES_COPY_OUT pg-exec-status) +(define-foreign-variable PGRES_COPY_IN pg-exec-status) +(define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status) +(define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status) +(define-foreign-variable PGRES_FATAL_ERROR pg-exec-status) + +(define-foreign-type pgconn* (c-pointer "PGconn")) + +(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string))) +(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*)) +(define PQresetStart (foreign-lambda bool PQresetStart pgconn*)) +(define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*)) +(define PQfinish (foreign-lambda void PQfinish pgconn*)) +(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*))) +(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*))) + +;(define-foreign-type oid "Oid") +(define-foreign-type oid unsigned-int) + +(define invalid-oid (foreign-value "InvalidOid" oid)) + +(define PQisBusy (foreign-lambda bool PQisBusy pgconn*)) +(define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*)) + +(define-foreign-type pgresult* (c-pointer "PGresult")) + +(define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*)) +(define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*))) +(define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*))) +(define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int)) + +(define PQclear (foreign-lambda void PQclear pgresult*)) +(define PQnfields (foreign-lambda int PQnfields (const pgresult*))) +(define PQntuples (foreign-lambda int PQntuples (const pgresult*))) +(define PQfname (foreign-lambda c-string PQfname (const pgresult*) int)) +(define PQfnumber (foreign-lambda int PQfnumber (const pgresult*) (const c-string))) +(define PQftable (foreign-lambda oid PQftable (const pgresult*) int)) +(define PQftablecol (foreign-lambda int PQftablecol (const pgresult*) int)) +(define PQfformat (foreign-lambda int PQfformat (const pgresult*) int)) +(define PQftype (foreign-lambda oid PQftype (const pgresult*) int)) +(define PQfmod (foreign-lambda int PQfmod (const pgresult*) int)) +(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int)) +(define PQgetlength (foreign-lambda int PQgetlength (const pgresult*) int int)) +(define PQgetvalue-ptr (foreign-lambda (c-pointer char) PQgetvalue (const pgresult*) int int)) +(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*)) +(define PQoidValue (foreign-lambda oid PQoidValue pgresult*)) + +(define PQputCopyData (foreign-lambda int PQputCopyData pgconn* scheme-pointer int)) +(define PQputCopyEnd (foreign-lambda int PQputCopyEnd pgconn* (const c-string))) +(define PQgetCopyData (foreign-lambda int PQgetCopyData pgconn* (c-pointer (c-pointer char)) bool)) + +(define memcpy (foreign-lambda c-pointer "C_memcpy" scheme-pointer c-pointer size_t)) + +(define (srfi-4-vector? x) ; Copied from ##sys#srfi-4-vector? from 4.8.3 + (and (##core#inline "C_blockp" x) + (##sys#generic-structure? x) + (memq (##sys#slot x 0) + '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)))) + +;; TODO: Create a real callback system? +(foreign-declare "static void nullNoticeReceiver(void *arg, const PGresult *res){ }") + +(define-syntax define-foreign-int + (er-macro-transformer + (lambda (e r c) + ;; cannot rename define-foreign-variable; it's a really special form + `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e)))))) + +(define-syntax define-pgdiag-constants + (syntax-rules () + ((_ (?condition ?constant0 ...) ?more ...) + (begin (cond-expand + (?condition (define-foreign-int ?constant0) ...) + (else (define ?constant0 #f) ...)) + (define-pgdiag-constants ?more ...))) + ((_ ?constant0 ?more ...) + (begin (define-foreign-int ?constant0) + (define-pgdiag-constants ?more ...))) + ((_) (void)))) + +(define-pgdiag-constants + PG_DIAG_SEVERITY PG_DIAG_SQLSTATE PG_DIAG_CONTEXT PG_DIAG_MESSAGE_PRIMARY + PG_DIAG_MESSAGE_DETAIL PG_DIAG_MESSAGE_HINT PG_DIAG_STATEMENT_POSITION + PG_DIAG_SOURCE_FILE PG_DIAG_SOURCE_LINE PG_DIAG_SOURCE_FUNCTION + + (has-diag-query-position + PG_DIAG_INTERNAL_QUERY PG_DIAG_INTERNAL_POSITION) + + (has-diag-schema-info + PG_DIAG_SCHEMA_NAME PG_DIAG_TABLE_NAME PG_DIAG_COLUMN_NAME + PG_DIAG_DATATYPE_NAME PG_DIAG_CONSTRAINT_NAME)) + +;; Helper procedure for lists (TODO: use ANY instead of IN with an array?) +(define (in-list len) + (string-intersperse + (list-tabulate len (lambda (p) (conc "$" (add1 p)))) ",")) + +(define (postgresql-error subtype loc message . args) + (signal (apply make-pg-condition subtype loc message args))) + +(define (make-pg-condition subtype loc message . args) + (make-composite-condition + (make-property-condition + 'exn 'location loc 'message message 'arguments args) + (make-property-condition 'postgresql) + (if (condition? subtype) subtype (make-property-condition subtype)))) + +;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Type parsers +;;;;;;;;;;;;;;;;;;;;;;;; + +(define (char-parser str) (string-ref str 0)) + +(define (bool-parser str) (string=? str "t")) + +(define (numeric-parser str) + (or (string->number str) + (postgresql-error 'parse 'numeric-parser "Unable to parse number" str))) + +(define (bytea-parser str) + (unescape-bytea str)) + +;; Here be dragons +(define (make-array-parser element-parser #!optional (delim #\,)) + (define (parse str) + (if (string-ci=? "NULL" str) + (sql-null) + (element-parser str))) + (lambda (str) + (let loop ((chars (let ignore-bounds ((chars (string->list str))) + (if (char=? (car chars) #\{) + chars + (ignore-bounds (cdr chars))))) + (result (list))) + (if (null? chars) + (car result) ; Should contain only one vector + (case (car chars) + ((#\{) (receive (value rest-chars) + (loop (cdr chars) (list)) + (loop rest-chars (cons value result)))) + ((#\}) (values (list->vector (reverse! result)) (cdr chars))) + ((#\") (let consume-string ((chars (cdr chars)) + (consumed (list))) + (case (car chars) + ((#\\) (consume-string ; Don't interpret, just add it + (cddr chars) (cons (cadr chars) consumed))) + ((#\") (loop (cdr chars) + (cons (element-parser + (reverse-list->string consumed)) + result))) + (else (consume-string (cdr chars) + (cons (car chars) consumed)))))) + ((#\tab #\newline #\space) (loop (cdr chars) result)) + (else + (if (char=? (car chars) delim) + (loop (cdr chars) result) + (let consume-string ((chars chars) + (consumed (list))) + (cond + ((char=? (car chars) delim) + (loop (cdr chars) + (cons (parse (reverse-list->string consumed)) + result))) + ((or (char=? (car chars) #\}) + (char=? (car chars) #\})) + (loop chars + (cons (parse (reverse-list->string consumed)) + result))) + (else (consume-string (cdr chars) + (cons (car chars) consumed)))))))))))) + +(define (make-composite-parser element-parsers) + (define (parse str element-parser) + (if (string=? "" str) + (sql-null) + (element-parser str))) + (lambda (str) + (let loop ((chars (cdr (string->list (string-trim str)))) ; skip leading ( + (maybe-null? #t) + (result (list)) + (parsers element-parsers)) + (case (car chars) + ((#\)) (reverse! (if maybe-null? + (cons (sql-null) result) + result))) + ((#\") (let consume-string ((chars (cdr chars)) + (consumed (list))) + (case (car chars) + ((#\\) (consume-string ; Don't interpret, just add it + (cddr chars) (cons (cadr chars) consumed))) + ((#\") (if (char=? #\" (cadr chars)) ; double escapes + (consume-string (cddr chars) + (cons #\" consumed)) + (let skip-spaces ((chars (cdr chars))) + (case (car chars) + ((#\space #\newline #\tab) + (skip-spaces (cdr chars))) + ((#\,) + (loop (cdr chars) + #t + (cons ((car parsers) + (reverse-list->string consumed)) + result) + (cdr parsers))) + ((#\)) (loop chars + #f + (cons ((car parsers) + (reverse-list->string consumed)) + result) + (cdr parsers))) + (else + (postgresql-error + 'parse 'make-composite-parser + "Bogus trailing characters" str)))))) + (else (consume-string (cdr chars) + (cons (car chars) consumed)))))) + (else (let consume-string ((chars chars) + (consumed (list))) + (case (car chars) + ((#\,) (loop (cdr chars) + #t + (cons (parse (reverse-list->string consumed) + (car parsers)) + result) + (cdr parsers))) + ;; Nothing should precede this one + ((#\)) (loop chars + #f + (cons (parse (reverse-list->string consumed) + (car parsers)) + result) + (cdr parsers))) + (else (consume-string (cdr chars) + (cons (car chars) consumed)))))))))) + +;; Array parsers and composite parsers are automatically cached when such +;; a value is requested. +(define default-type-parsers + (make-parameter + `(("text" . ,identity) + ("bytea" . ,bytea-parser) + ("char" . ,char-parser) + ("bpchar" . ,identity) + ("bool" . ,bool-parser) + ("int8" . ,numeric-parser) + ("int4" . ,numeric-parser) + ("int2" . ,numeric-parser) + ("float4" . ,numeric-parser) + ("float8" . ,numeric-parser) + ("numeric" . ,numeric-parser) + ("oid" . ,numeric-parser) + ;; Nasty hack, or clever hack? :) + ("record" . ,(make-composite-parser (circular-list identity)))))) + +;;;;;;;;;;;;;;;;;;;;;;; +;;;; Type unparsers +;;;;;;;;;;;;;;;;;;;;;;; + +(define (scheme-value->db-value conn value) + (cond ((find (lambda (parse?) + ((car parse?) value)) + (pg-connection-type-unparsers conn)) => + (lambda (parse) + ((cdr parse) conn value))) + (else value))) + +(define (bool-unparser conn b) + (if b "TRUE" "FALSE")) + +(define (vector-unparser conn v) + (let loop ((result (list)) + (pos 0) + (len (vector-length v))) + (if (= pos len) + (string-append "{" (string-intersperse (reverse! result) ",") "}") + (let* ((value (vector-ref v pos)) + (unparsed-value (scheme-value->db-value conn value)) + (serialized (cond + ((sql-null? unparsed-value) "NULL") + ((not (string? unparsed-value)) + (postgresql-error + 'unparse 'vector-unparser + "Param value is not string" unparsed-value)) + ((vector? value) unparsed-value) ;; don't quote! + (else + (sprintf "\"~A\"" + (string-translate* + unparsed-value + '(("\\" . "\\\\") ("\"" . "\\\"")))))))) + (loop (cons serialized result) (add1 pos) len))))) + +(define (list-unparser conn l) + (let loop ((result (list)) + (items l)) + (if (null? items) + (string-append "(" (string-intersperse (reverse! result) ",") ")") + (let* ((unparsed-value (scheme-value->db-value conn (car items))) + (serialized (cond + ((sql-null? unparsed-value) "") + ((not (string? unparsed-value)) + (postgresql-error + 'unparse 'list-unparser + "Param value is not string" unparsed-value)) + (else + (sprintf "\"~A\"" + (string-translate* + unparsed-value + '(("\\" . "\\\\") ("\"" . "\\\"")))))))) + (loop (cons serialized result) (cdr items)))))) + +(define default-type-unparsers + (make-parameter + `((,string? . ,(lambda (conn s) s)) + (,u8vector? . ,(lambda (conn v) (u8vector->blob/shared v))) + (,char? . ,(lambda (conn c) (string c))) + (,boolean? . ,bool-unparser) + (,number? . ,(lambda (conn n) (number->string n))) + (,vector? . ,vector-unparser) + (,pair? . ,list-unparser)))) + +;; Retrieve type-oids from PostgreSQL: +(define (update-type-parsers! conn #!optional new-type-parsers) + (let ((type-parsers (or new-type-parsers (pg-connection-type-parsers conn))) + (ht (make-hash-table)) + (result '())) + (pg-connection-oid-parsers-set! conn ht) + (pg-connection-type-parsers-set! conn type-parsers) + (unless (null? type-parsers) ; empty IN () clause is not allowed + (row-for-each* + (lambda (oid typname) + (and-let* ((procedure (assoc typname type-parsers))) + (hash-table-set! ht (string->number oid) (cdr procedure)))) + (query* conn + (sprintf + "SELECT oid, typname FROM pg_type WHERE typname IN (~A)" + (in-list (length type-parsers))) + (map car type-parsers) raw: #t))))) + +(define (update-type-unparsers! conn new-type-unparsers) + (pg-connection-type-unparsers-set! conn new-type-unparsers)) + +;;;;;;;;;;;;;;;;;;;; +;;;; Connections +;;;;;;;;;;;;;;;;;;;; + +(define-record pg-connection + ptr type-parsers oid-parsers type-unparsers transaction-depth) +(define connection? pg-connection?) +(define type-parsers pg-connection-type-parsers) +(define type-unparsers pg-connection-type-unparsers) + +(define (connected? conn) (not (not (pg-connection-ptr conn)))) + +(define (pgsql-connection->fd conn) + ((foreign-lambda int PQsocket pgconn*) (pg-connection-ptr conn))) + +(define (wait-for-connection! conn poll-function) + (let ((conn-fd (pgsql-connection->fd conn)) + (conn-ptr (pg-connection-ptr conn))) + (let loop ((result (poll-function conn-ptr))) + (cond ((= result PGRES_POLLING_OK) (void)) + ((= result PGRES_POLLING_FAILED) + (let ((message (PQerrorMessage conn-ptr))) + (disconnect conn) + (postgresql-error + 'connect 'connect + (conc "Polling Postgres database failed: " message) conn))) + ((member result (list PGRES_POLLING_WRITING PGRES_POLLING_READING)) + (thread-wait-for-i/o! conn-fd (if (= PGRES_POLLING_READING result) + #:input + #:output)) + (loop (poll-function conn-ptr))) + (else + (postgresql-error + 'internal 'connect + (conc "Internal error! Unknown status code: " result) conn)))))) + +(cond-expand + ((not has-connectdb-params) + (define (alist->connection-spec alist) + (string-join + (map (lambda (subspec) + (sprintf "~A='~A'" + (car subspec) ;; this had better not contain [ =\'] + (string-translate* (->string (cdr subspec)) + '(("\\" . "\\\\") ("'" . "\\'"))))) + alist)))) + (else)) + +(define (connect-start spec) + (if (string? spec) + (PQconnectStart spec) + (cond-expand + (has-connectdb-params + (let ((len (length spec))) + ((foreign-lambda* pgconn* ((scheme-object cons) (scheme-pointer keybuf) + (scheme-pointer valbuf) (int len)) + "const char **key = (const char **)keybuf;" + "const char **val = (const char **)valbuf;" + "int i;" + "for (i=0; i < len; ++i,cons=C_u_i_cdr(cons)) {" + " C_word kvpair = C_u_i_car(cons);" + " key[i] = C_c_string(C_u_i_car(kvpair));" + " val[i] = C_c_string(C_u_i_cdr(kvpair));" + "}" + "key[len] = NULL;" + "val[len] = NULL;" + "C_return(PQconnectStartParams(key, val, 0));") + (map (lambda (x) (cons (string-append (->string (car x)) "\x00") + (string-append (->string (cdr x)) "\x00"))) spec) + (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int))) + (make-blob (* (add1 len) (foreign-value "sizeof(char *)" int))) + len))) + (else (PQconnectStart (alist->connection-spec spec)))))) + +(define (connect #!optional (conn-spec '()) + (type-parsers (default-type-parsers)) + (type-unparsers (default-type-unparsers))) + (let ((conn-ptr (connect-start conn-spec))) + (cond + ((not conn-ptr) + (postgresql-error + 'internal 'connect + "Unable to allocate a Postgres connection structure" conn-spec)) + ((= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr)) + (let ((message (PQerrorMessage conn-ptr))) + (PQfinish conn-ptr) + (postgresql-error + 'connect 'connect + (conc "Connection to Postgres database failed: " message) conn-spec))) + (else + (let ((conn (make-pg-connection conn-ptr type-parsers + (make-hash-table) type-unparsers 0))) + ;; We don't want libpq to piss in our stderr stream + ((foreign-lambda* void ((pgconn* conn)) + "PQsetNoticeReceiver(conn, nullNoticeReceiver, NULL);") conn-ptr) + (wait-for-connection! conn PQconnectPoll) + (set-finalizer! conn disconnect) + ;; Retrieve type-information from PostgreSQL metadata for use by + ;; the various value-parsers. + (update-type-parsers! conn) + conn))))) + +(define (reset-connection connection) + (let ((conn-ptr (pg-connection-ptr connection))) + (if (PQresetStart conn-ptr) ;; Update oid-parsers? + (wait-for-connection! connection PQresetPoll) + (let ((error-message (PQerrorMessage conn-ptr))) + (disconnect connection) + (postgresql-error + 'connect 'reset-connection + (conc "Reset of connection failed: " error-message) connection))))) + +(define (disconnect connection) + (and-let* ((conn-ptr (pg-connection-ptr connection))) + (pg-connection-ptr-set! connection #f) + (pg-connection-type-parsers-set! connection #f) + (pg-connection-oid-parsers-set! connection #f) + (PQfinish conn-ptr)) + (void)) + +;;;;;;;;;;;;;;; +;;;; Results +;;;;;;;;;;;;;;; + +(define-record pg-result ptr value-parsers) +(define result? pg-result?) + +(define (clear-result! result) + (and-let* ((result-ptr (pg-result-ptr result))) + (pg-result-ptr-set! result #f) + (PQclear result-ptr))) + +(define (row-count result) + (PQntuples (pg-result-ptr result))) + +(define (column-count result) + (PQnfields (pg-result-ptr result))) + +;; Helper procedures for bounds checking; so we can distinguish between +;; out of bounds and nonexistant columns, and signal it. +(define (check-column-index! result index location) + (when (>= index (column-count result)) + (postgresql-error + 'bounds location + (sprintf "Result column ~A out of bounds" index) result index))) + +(define (check-row-index! result index location) + (when (>= index (row-count result)) + (postgresql-error + 'bounds location + (sprintf "Result row ~A out of bounds" index) result index))) + +(define (column-name result index) + (check-column-index! result index 'column-name) + (string->symbol (PQfname (pg-result-ptr result) index))) + +(define (column-names result) + (let ((ptr (pg-result-ptr result))) + (let loop ((names '()) + (column (column-count result))) + (if (= column 0) + names + (loop (cons (string->symbol (PQfname ptr (sub1 column))) names) + (sub1 column)))))) + +(define (column-index result name) + (let ((idx (PQfnumber (pg-result-ptr result) (symbol->string name)))) + (and (>= idx 0) idx))) + +(define (table-oid result index) + (check-column-index! result index 'table-oid) + (let ((oid (PQftable (pg-result-ptr result) index))) + (and (not (= oid invalid-oid)) oid))) + +;; Fixes the off-by-1 unexpectedness in libpq/the protocol to make it more +;; consistent with the rest of Scheme. However, this is inconsistent with +;; almost all other PostgreSQL interfaces... +(define (table-column-index result index) + (check-column-index! result index 'table-column-index) + (let ((idx (PQftablecol (pg-result-ptr result) index))) + (and (> idx 0) (sub1 idx)))) + +(define format-table + '((0 . text) (1 . binary))) + +(define (format->symbol format) + (or (alist-ref format format-table eq?) + (postgresql-error 'type 'format->symbol "Unknown format" format))) + +(define (symbol->format symbol) + (or (and-let* ((res (rassoc symbol format-table eq?))) + (car res)) + (postgresql-error 'type 'format->symbol "Unknown format" symbol))) + +(define (column-format result index) + (check-column-index! result index 'column-format) + (format->symbol (PQfformat (pg-result-ptr result) index))) + +(define (column-type result index) + (check-column-index! result index 'column-type) + (PQftype (pg-result-ptr result) index)) + +;; This is really not super-useful as it requires intimate knowledge +;; about the internal implementations of types in PostgreSQL. +(define (column-type-modifier result index) + (check-column-index! result index 'column-type) + (let ((mod (PQfmod (pg-result-ptr result) index))) + (and (>= mod 0) mod))) + +;; Unchecked version, for speed +(define (value-at* result column row raw) + (let ((ptr (pg-result-ptr result))) + (if (PQgetisnull ptr row column) + (sql-null) + (let* ((len (PQgetlength ptr row column)) + (fmt (PQfformat ptr column)) + (value (case fmt + ((0) (make-string len)) + ((1) (make-blob len)) + (else (postgresql-error + 'internal 'value-at + (conc "Unknown column format type: " fmt) + result column row raw))))) + (memcpy value (PQgetvalue-ptr ptr row column) len) + (if (or raw (blob? value)) + value + ((vector-ref (pg-result-value-parsers result) column) value)))))) + +(define (value-at result #!optional (column 0) (row 0) #!key raw) + (check-row-index! result row 'value) + (check-column-index! result column 'value) + (value-at* result column row raw)) + +(define (row-values* result row column-count raw) + (let loop ((list '()) + (column column-count)) + (if (= column 0) + list + (loop (cons (value-at* result (sub1 column) row raw) list) + (sub1 column))))) + +(define (row-values result #!optional (row 0) #!key raw) + (check-row-index! result row 'row) + (row-values* result row (column-count result) raw)) + +(define (column-values* result column row-count raw) + (let loop ((list '()) + (row row-count)) + (if (= row 0) + list + (loop (cons (value-at* result column (sub1 row) raw) list) + (sub1 row))))) + +(define (column-values result #!optional (column 0) #!key raw) + (check-column-index! result column 'column) + (column-values* result column (row-count result) raw)) + +;; (define (row-alist result #!optional (row 0) #!key raw) +;; (map cons (column-names result) (row-values result row raw: raw))) +(define (row-alist result #!optional (row 0) #!key raw) + (check-row-index! result row 'row-alist) + (let loop ((alist '()) + (column (column-count result))) + (if (= column 0) + alist + (loop (cons (cons (string->symbol + (PQfname (pg-result-ptr result) (sub1 column))) + (value-at* result (sub1 column) row raw)) alist) + (sub1 column))))) + +;;; TODO: Do we want/need PQnparams and PQparamtype bindings? + +(define (affected-rows result) + (string->number (PQcmdTuples (pg-result-ptr result)))) + +(define (inserted-oid result) + (let ((oid (PQoidValue (pg-result-ptr result)))) + (and (not (= oid invalid-oid)) oid))) + + +;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Query procedures +;;;;;;;;;;;;;;;;;;;;;;;; + +;; Buffer all available input, yielding if nothing is available: +(define (buffer-available-input! conn) + (let ((conn-ptr (pg-connection-ptr conn)) + (conn-fd (pgsql-connection->fd conn))) + (let loop () + (if (PQconsumeInput conn-ptr) + (when (PQisBusy conn-ptr) + (thread-wait-for-i/o! conn-fd #:input) + (loop)) + (postgresql-error + 'i/o 'buffer-available-input! + (conc "Error reading reply from server: " (PQerrorMessage conn-ptr)) + conn))))) + +;; Here be more dragons +(define (resolve-unknown-types! conn oids) + (unless (null? oids) + (let* ((parsers (pg-connection-oid-parsers conn)) + (q (conc "SELECT t.oid, t.typtype, t.typelem, t.typdelim, " + " t.typbasetype, t.typarray, a.attrelid, a.atttypid " + "FROM pg_type t " + " LEFT JOIN pg_attribute a " + " ON t.typrelid = a.attrelid AND a.attnum > 0 " + "WHERE t.oid IN (~A) " + "ORDER BY COALESCE(t.typrelid,-1) ASC, a.attnum ASC")) + (result (query* conn (sprintf q (in-list (length oids))) + (map number->string oids) raw: #t)) + (count (row-count result))) + (let dissect-types ((unknown-oids (list)) + (pos 0) + (domains (list)) + (arrays (list)) + (classes (list)) + (last-class 0)) + (cond + ((>= pos count) ; Done scanning rows? + ;; Keep going until all oids are resolved + (resolve-unknown-types! conn unknown-oids) + ;; Postprocessing step: resolve all nested types + (for-each (lambda (d) + (and-let* ((p (hash-table-ref/default parsers (cdr d) #f))) + (hash-table-set! parsers (car d) p))) + domains) + (for-each (lambda (a) + (and-let* ((p (hash-table-ref/default parsers (cddr a) #f))) + (hash-table-set! parsers (car a) + (make-array-parser p (cadr a))))) + arrays) + (for-each + (lambda (c) + (and-let* ((p-list + (fold + (lambda (att l) + (and-let* ((l) + (p (hash-table-ref/default parsers att #f))) + (cons p l))) + '() + (cdr c)))) + (hash-table-set! parsers (car c) + (make-composite-parser p-list)))) + classes)) + ((not (string=? (value-at* result 4 pos #f) "0")) ; Domain type? + (let* ((basetype-oid (string->number (value-at* result 4 pos #f))) + (parser (hash-table-ref/default parsers basetype-oid #f)) + (oid (string->number (value-at* result 0 pos #f)))) + (dissect-types (if parser + unknown-oids + (cons basetype-oid unknown-oids)) + (add1 pos) (cons (cons oid basetype-oid) domains) + arrays classes last-class))) + ((string=? (value-at* result 5 pos #f) "0") ; Array value? + (let* ((elem (string->number (value-at* result 2 pos #f))) + (delim (string-ref (value-at* result 3 pos #f) 0)) + (parser (hash-table-ref/default parsers elem #f)) + (oid (string->number (value-at* result 0 pos #f)))) + (dissect-types (if parser + unknown-oids + (cons elem unknown-oids)) + (add1 pos) domains + (cons (cons oid (cons delim elem)) arrays) + classes last-class))) + ((string=? (value-at* result 1 pos #f) "c") ; Class? (i.e., table or type) + (let* ((classid (string->number (value-at* result 6 pos #f))) + (attrid (string->number (value-at* result 7 pos #f))) + (parser (hash-table-ref/default parsers attrid #f))) + (dissect-types (if parser + unknown-oids + (cons attrid unknown-oids)) + (add1 pos) domains arrays + ;; Keep oid at the front of the list, insert this + ;; attr after it, before the other attrs, if any. + (if (= last-class classid) + (cons (cons (caar classes) + (cons attrid (cdar classes))) + (cdr classes)) + (cons (cons (string->number + (value-at* result 0 pos #f)) + (list attrid)) classes)) + classid))) + (else + (dissect-types unknown-oids (add1 pos) + domains arrays classes last-class))))))) + +(define (make-value-parsers conn pqresult #!key raw) + (let* ((nfields (PQnfields pqresult)) + (parsers (make-vector nfields)) + (ht (pg-connection-oid-parsers conn))) + (let loop ((col 0) + (unknowns (list))) + (if (= col nfields) + (begin + (resolve-unknown-types! conn (map cdr unknowns)) + (for-each (lambda (unknown) + (let* ((col (car unknown)) + (oid (cdr unknown)) + (parser (hash-table-ref/default ht oid identity))) + (vector-set! parsers col parser))) + unknowns) + parsers) + (let* ((oid (PQftype pqresult col)) + (parser (if raw identity (hash-table-ref/default ht oid #f)))) + (vector-set! parsers col parser) + (loop (add1 col) (if parser + unknowns + (cons (cons col oid) unknowns)))))))) + +;; Collect the result pointers from the last query. +;; +;; A pgresult represents an entire resultset and is always read into memory +;; all at once. +(define (get-last-result conn #!key raw) + (buffer-available-input! conn) + (let* ((conn-ptr (pg-connection-ptr conn)) + ;; Read out all remaining results (including the current one). + ;; TODO: Is this really needed? libpq does it (in pqExecFinish), + ;; but ostensibly only to concatenate the error messages for + ;; each query. OTOH, maybe we want to do that, too. + (clean-results! (lambda (result) + (let loop ((result result)) + (when result + (PQclear result) + (loop (PQgetResult conn-ptr)))))) + (result (PQgetResult conn-ptr)) + (status (PQresultStatus result))) + (cond + ((not result) (postgresql-error + 'internal 'get-last-result + "Internal error! No result object available from server" + conn)) + ((member status (list PGRES_BAD_RESPONSE PGRES_FATAL_ERROR + PGRES_NONFATAL_ERROR)) + (let* ((error-field (lambda (f) (and f (PQresultErrorField result f)))) + (error-field/int (lambda (f) + (and-let* ((value (error-field f))) + (string->number value)))) + (sqlstate (error-field PG_DIAG_SQLSTATE)) + (maybe-severity (error-field PG_DIAG_SEVERITY)) + (condition + (make-pg-condition + (make-property-condition + 'query + 'severity (and maybe-severity + (string->symbol + (string-downcase maybe-severity))) + 'error-class (and sqlstate (string-take sqlstate 2)) + 'error-code sqlstate + 'message-primary (error-field PG_DIAG_MESSAGE_PRIMARY) + 'message-detail (error-field PG_DIAG_MESSAGE_DETAIL) + 'message-hint (error-field PG_DIAG_MESSAGE_HINT) + 'statement-position (error-field/int PG_DIAG_STATEMENT_POSITION) + 'context (error-field PG_DIAG_CONTEXT) + 'source-file (error-field PG_DIAG_SOURCE_FILE) + 'source-line (error-field/int PG_DIAG_SOURCE_LINE) + 'source-function (error-field PG_DIAG_SOURCE_FUNCTION) + 'internal-query (error-field PG_DIAG_INTERNAL_QUERY) + 'internal-position (error-field/int PG_DIAG_INTERNAL_POSITION) + 'schema-name (error-field PG_DIAG_SCHEMA_NAME) + 'table-name (error-field PG_DIAG_TABLE_NAME) + 'column-name (error-field PG_DIAG_COLUMN_NAME) + 'datatype-name (error-field PG_DIAG_DATATYPE_NAME) + 'constraint-name (error-field PG_DIAG_CONSTRAINT_NAME)) + 'get-last-result + (PQresultErrorMessage result)))) + (clean-results! result) + (signal condition))) + ((member status (list PGRES_COPY_OUT PGRES_COPY_IN)) + ;; These are weird; A COPY puts the connection in "copy mode". + ;; As long as it's in "copy mode", pqgetresult will return the + ;; same result every time you call it, so don't try to call + ;; clean-results! + (let ((result-obj (make-pg-result result #f))) + (set-finalizer! result-obj clear-result!) + result-obj)) + ((member status (list PGRES_EMPTY_QUERY PGRES_COMMAND_OK PGRES_TUPLES_OK)) + (let ((result-obj (make-pg-result result #f))) + (set-finalizer! result-obj clear-result!) + (let ((trailing-result (PQgetResult conn-ptr))) + (when trailing-result + (clean-results! trailing-result) + (postgresql-error 'internal 'get-last-result + (conc "Internal error! Unexpected extra " + "results after first query result") + conn))) + (pg-result-value-parsers-set! + result-obj (make-value-parsers conn result raw: raw)) + result-obj)) + (else + (postgresql-error 'internal 'get-last-result + (conc "Internal error! Unknown status code: " status) + conn))))) + +(define (query conn query . params) + (query* conn query params)) + +(define (query* conn query #!optional (params '()) #!key (format 'text) raw) + (let* ((params ;; Check all params and ensure they are proper pairs + (map (lambda (p) + (let ((obj (if raw p (scheme-value->db-value conn p)))) + (cond ((string? obj) ; Convert to ASCIIZ + (let* ((len (##sys#size obj)) + (res (string-append obj "\x00"))) + (vector 0 len res))) + ((blob? obj) + (vector 1 (##sys#size obj) obj)) + ((sql-null? obj) #f) + (else (postgresql-error + 'type 'query* + (sprintf "Param value is not string, sql-null or blob: ~S" p) + conn query params format))))) + params)) + ;; It's a shame we need to traverse params twice (and again in C)... + (len (length params)) + (send-query + (foreign-lambda* + bool ((pgconn* conn) (nonnull-c-string query) + (bool is_prepped) (int num) (scheme-object params) + (scheme-pointer valsbuf) (scheme-pointer lensbuf) + (scheme-pointer fmtsbuf) (int rfmt)) + "int i = 0, *lens = (int *)lensbuf, *fmts = (int *)fmtsbuf;" + "const char **vals = (const char **)valsbuf;" + "C_word obj, cons;" + "for (i=0,cons=params; i < num; ++i,cons=C_u_i_cdr(cons)) {" + " obj = C_u_i_car(cons);" + " if (obj == C_SCHEME_FALSE) {" + " fmts[i] = lens[i] = 0;" + " vals[i] = NULL;" + " } else {" + " fmts[i] = C_unfix(C_block_item(obj, 0));" + " lens[i] = C_unfix(C_block_item(obj, 1));" + " vals[i] = C_c_string(C_block_item(obj, 2));" + " }" + "}" + "if (is_prepped)" + " C_return(PQsendQueryPrepared((PGconn *)conn, query, num," + " vals, lens, fmts, rfmt));" + "else" + " C_return(PQsendQueryParams((PGconn *)conn, query, num, NULL," + " vals, lens, fmts, rfmt));")) + (query-as-string (if (symbol? query) (symbol->string query) query))) + ;; XXX: What if we're using a newer protocol version? Then this error is + ;; well-meaning but completely wrong... Unfortunately the error message + ;; returned by the server if we exceed this limit is even more confusing. + (cond ((> len 65535) + (postgresql-error + 'domain 'query* + (sprintf "Too many bind parameters (PG protocol supports up to 65535, but got ~A). Try using the COPY support, or escaping the data and sending it as a big string." len) + conn query params format)) + ((send-query (pg-connection-ptr conn) query-as-string (symbol? query) + len params + ;; We allocate here instead of in C to keep things simple + (make-blob (* len (foreign-value "sizeof(char *)" int))) + (make-blob (* len (foreign-value "sizeof(int)" int))) + (make-blob (* len (foreign-value "sizeof(int)" int))) + (symbol->format format)) + (get-last-result conn raw: raw)) + (else (postgresql-error 'i/o 'query* + (conc "Unable to send query to server: " + (PQerrorMessage (pg-connection-ptr conn))) + conn query params format))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Transaction management +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (with-transaction conn thunk #!key isolation access) + (let* ((old-depth (pg-connection-transaction-depth conn)) + (isolation (and isolation + (case isolation + ((read-committed) "ISOLATION LEVEL READ COMMITTED") + ((serializable) "ISOLATION LEVEL SERIALIZABLE") + (else (postgresql-error + 'type 'with-transaction + "Unknown isolation level" isolation))))) + (access (and access + (case access + ((read/write) "READ WRITE") + ((read-only) "READ ONLY") + (else (postgresql-error + 'type 'with-transaction + "Unknown access mode" access))))) + (characteristics (conc (or isolation "") " " (or access ""))) + (rollback! + (lambda () + (if (zero? old-depth) + (query conn "ROLLBACK") + ;; We do not *need* to give savepoints unique names, + ;; but it aids debugging and we know the depth anyway. + (query conn (conc "ROLLBACK TO SAVEPOINT s_" old-depth))))) + (commit! + (lambda () + (if (zero? old-depth) + (query conn "COMMIT") + (query conn (conc "RELEASE SAVEPOINT s_" old-depth)))))) + (when (and isolation (not (zero? old-depth))) + (postgresql-error + 'domain 'with-transaction + "Can't set isolation level in nested transactions" isolation)) + (if (zero? old-depth) + (query conn (conc "BEGIN " characteristics)) + (begin (query conn (conc "SAVEPOINT s_" old-depth)) + ;; XXX: This should probably be SET LOCAL instead of SET + ;; (which is implicitly the same as SET SESSION), but I + ;; can't come up with a testcase that fails with this and + ;; succeeds with SET LOCAL, so keep it around for now. + (when access + (query conn (conc "SET TRANSACTION " characteristics))))) + (pg-connection-transaction-depth-set! conn (add1 old-depth)) + ;; TODO: Add a warning mechanism (using dynamic-wind) for when the + ;; user tries to jump into/out of transactions with continuations? + (handle-exceptions exn + (begin + (pg-connection-transaction-depth-set! conn old-depth) + (rollback!) + (raise exn)) + (let ((res (thunk))) + (pg-connection-transaction-depth-set! conn old-depth) + (if res (commit!) (rollback!)) + res)))) + +(define (in-transaction? conn) + (> (pg-connection-transaction-depth conn) 0)) + +;;;;;;;;;;;;;;;;;;;; +;;;; COPY support +;;;;;;;;;;;;;;;;;;;; + +(define (put-copy-data conn data) + (let* ((data (cond + ((or (string? data) (blob? data)) data) + ((srfi-4-vector? data) (##sys#slot data 1)) + (else (postgresql-error + 'type 'put-copy-data + "Expected a blob, string or srfi-4 vector" conn data)))) + (len (##sys#size data)) + (conn-ptr (pg-connection-ptr conn)) + (conn-fd (pgsql-connection->fd conn))) + (let loop ((res (PQputCopyData conn-ptr data len))) + (cond + ((= res 0) + (thread-wait-for-i/o! conn-fd #:output) + (loop (PQputCopyData conn-ptr data len))) + ((= res 1) (void)) + ((= res -1) + (postgresql-error + 'i/o 'put-copy-data + (conc "Error putting COPY data: " (PQerrorMessage conn-ptr)) conn)) + (else (postgresql-error + 'internal 'put-copy-data + (conc "Internal error! Unexpected return value: " res) conn)))))) + +(define (put-copy-end conn #!optional error-message) + (let ((conn-ptr (pg-connection-ptr conn)) + (conn-fd (pgsql-connection->fd conn))) + (let loop ((res (PQputCopyEnd conn-ptr error-message))) + (cond + ((= res 0) + (thread-wait-for-i/o! conn-fd #:output) + (loop (PQputCopyEnd conn-ptr error-message))) + ((= res 1) (get-last-result conn)) + ((= res -1) + (postgresql-error + 'i/o 'put-copy-end + (conc "Error ending put COPY data: " (PQerrorMessage conn-ptr)) + conn error-message)) + (else + (postgresql-error + 'internal 'put-copy-end + (conc "Internal error! Unexpected return value: " res) conn)))))) + +(define (get-copy-data conn #!key (format 'text)) + (let ((conn-ptr (pg-connection-ptr conn))) + (let loop () + (let-location ((buf c-pointer)) + (let ((res (PQgetCopyData conn-ptr (location buf) #t))) + (cond + ((> res 0) + (let ((value (case format + ((text) (make-string res)) + ((binary) (make-blob res)) + (else (postgresql-error + 'internal 'get-copy-data + (conc "Unknown column format type: " format) + conn))))) + (memcpy value buf res) + (free buf) + value)) + ((= res 0) + (buffer-available-input! conn) + (loop)) + ((= res -1) + (get-last-result conn)) + ((= res -2) + (postgresql-error + 'i/o 'get-copy-data + (conc "Error getting COPY data: " (PQerrorMessage conn-ptr)) conn)) + (else (postgresql-error + 'internal 'get-copy-data + (conc "Internal error! Unexpected return value: " res) + conn)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Value escaping and quotation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (escape-string conn str) + (define %escape-string-conn + (foreign-lambda size_t PQescapeStringConn + pgconn* scheme-pointer scheme-pointer size_t (c-pointer bool))) + (let-location ((err bool)) + (let* ((strlen (string-length str)) + (buflen (add1 (* strlen 2))) + (buffer (make-string buflen)) + (conn-ptr (pg-connection-ptr conn)) + (size (%escape-string-conn conn-ptr buffer str strlen (location err)))) + (cond (err (postgresql-error 'internal 'escape-string + (conc "String escaping failed. " + (PQerrorMessage conn-ptr)) conn str)) + ((= size buflen) buffer) + (else (##sys#substring buffer 0 size)))))) + +(define (quote-identifier conn str) + (cond-expand + (has-escape-identifier + (define %escape-ident + (foreign-lambda c-string* PQescapeIdentifier pgconn* scheme-pointer size_t)) + (or (%escape-ident (pg-connection-ptr conn) str (string-length str)) + (postgresql-error 'internal 'quote-identifier + (conc "Identifier escaping failed: " + (PQerrorMessage (pg-connection-ptr conn))) + conn str))) + (else (postgresql-error 'unsupported-version 'quote-identifier + (conc "Please upgrade your PostgreSQL to 9.0 or later " + "in order to be able to use quote-identifier!") + conn str)))) + +(define (escape-bytea conn obj) + (define %escape-bytea-conn + (foreign-lambda (c-pointer unsigned-char) PQescapeByteaConn + pgconn* scheme-pointer size_t (c-pointer size_t))) + (let-location ((allocated size_t)) + (let* ((data (cond ((or (string? obj) (blob? obj)) obj) + ((srfi-4-vector? obj) (##sys#slot obj 1)) + (else (postgresql-error + 'type 'escape-bytea + "Expected string, blob or srfi-4 vector" obj)))) + (conn-ptr (pg-connection-ptr conn)) + (buf (%escape-bytea-conn + conn-ptr data (##sys#size data) (location allocated)))) + (if buf + (let* ((string-length (sub1 allocated)) + (result-string (make-string string-length))) + (memcpy result-string buf string-length) + (free buf) + result-string) + (postgresql-error + 'internal 'escape-bytea + (conc "Byte array escaping failed: " (PQerrorMessage conn-ptr)) + conn obj))))) + +(define (unescape-bytea str) + (define %unescape-bytea + (foreign-lambda (c-pointer unsigned-char) PQunescapeBytea c-string (c-pointer size_t))) + (let-location ((blob-length size_t)) + (let ((buf (%unescape-bytea str (location blob-length)))) + (if buf + (let ((result-blob (make-blob blob-length))) + (memcpy result-blob buf blob-length) + (free buf) + (blob->u8vector/shared result-blob)) + (postgresql-error 'internal 'unescape-bytea + "Byte array unescaping failed (out of memory?)" str))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; High-level interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (make-result-fold item-count sub-item-count extract-item) + (lambda (kons knil result) + (let ((items (item-count result)) + (sub-items (sub-item-count result))) + (let loop ((seed knil) + (item 0)) + (if (= item items) + seed + (loop (kons (extract-item result item sub-items #f) seed) (add1 item))))))) + +(define row-fold (make-result-fold row-count column-count row-values*)) +(define (row-fold* kons knil result) + (row-fold (lambda (values seed) + (apply kons (append values (list seed)))) knil result)) + +(define column-fold (make-result-fold column-count row-count column-values*)) +(define (column-fold* kons knil result) + (column-fold (lambda (values seed) + (apply kons (append values (list seed)))) knil result)) + + +(define (make-result-fold-right item-count sub-item-count extract-item) + (lambda (kons knil result) + (let ((sub-items (sub-item-count result))) + (let loop ((seed knil) + (item (item-count result))) + (if (= item 0) + seed + (loop (kons (extract-item result (sub1 item) sub-items #f) seed) (sub1 item))))))) + +(define row-fold-right (make-result-fold-right row-count column-count row-values*)) +(define (row-fold-right* kons knil result) + (row-fold-right (lambda (values seed) + (apply kons (append values (list seed)))) knil result)) + +(define column-fold-right (make-result-fold-right column-count row-count column-values*)) +(define (column-fold-right* kons knil result) + (column-fold-right (lambda (values seed) + (apply kons (append values (list seed)))) knil result)) + + +(define (row-for-each proc result) + (row-fold (lambda (values seed) (proc values)) #f result) + (void)) +(define (row-for-each* proc result) + (row-fold (lambda (values seed) (apply proc values)) #f result) + (void)) + +(define (column-for-each proc result) + (column-fold (lambda (values seed) (proc values)) #f result) + (void)) +(define (column-for-each* proc result) + (column-fold (lambda (values seed) (apply proc values)) #f result) + (void)) + +;; Like regular Scheme map, the order in which the procedure is applied is +;; undefined. We make good use of that by traversing the resultset from +;; the end back to the beginning, thereby avoiding a reverse! on the result. +(define (row-map proc res) + (row-fold-right (lambda (row lst) (cons (proc row) lst)) '() res)) +(define (row-map* proc res) + (row-fold-right (lambda (row lst) (cons (apply proc row) lst)) '() res)) +(define (column-map proc res) + (column-fold-right (lambda (col lst) (cons (proc col) lst)) '() res)) +(define (column-map* proc res) + (column-fold-right (lambda (col lst) (cons (apply proc col) lst)) '() res)) + +(define (result-format result) + (if (and result ((foreign-lambda bool PQbinaryTuples pgresult*) + (pg-result-ptr result))) + 'binary 'text)) + +(define (copy-query*-fold kons knil conn query + #!optional (params '()) #!key (format 'text) raw) + (let* ((result (query* conn query params format: format raw: raw)) + (data-format (result-format result))) + (handle-exceptions exn + (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup))) + (let loop ((data (get-copy-data conn format: data-format)) + (seed knil)) + (if (result? data) + seed + ;; Explicit ordering; data could be _very_ big, allow one to be GCed + (let ((next (kons data seed))) + (loop (get-copy-data conn format: data-format) next))))))) + +(define (copy-query-fold kons knil conn query . params) + (copy-query*-fold kons knil conn query params)) + + +;; This is slow and memory-intensive if data is big. Provided for completeness +(define (copy-query*-fold-right kons knil conn query + #!optional (params '()) #!key (format 'text) raw) + (let* ((result (query* conn query params format: format raw: raw)) + (data-format (result-format result))) + (handle-exceptions exn + (let cleanup () (if (result? (get-copy-data conn)) (raise exn) (cleanup))) + (let loop ((data (get-copy-data conn format: data-format))) + (if (result? data) + knil + (kons data (loop (get-copy-data conn format: data-format)))))))) + +(define (copy-query-fold-right kons knil conn query . params) + (copy-query*-fold-right kons knil conn query params)) + + +(define (copy-query*-map proc conn query + #!optional (params '()) #!key (format 'text) raw) + (reverse! (copy-query*-fold (lambda (data seed) (cons (proc data) seed)) + '() conn query params format: format raw: raw))) + +(define (copy-query-map proc conn query . params) + (copy-query*-map proc conn query params)) + + +(define (copy-query*-for-each proc conn query + #!optional (params '()) #!key (format 'text) raw) + (copy-query*-fold (lambda (data seed) (proc data)) + #f conn query params format: format raw: raw) + (void)) + +(define (copy-query-for-each proc conn query . params) + (copy-query*-for-each proc conn query params)) + +;; A bit of a weird name but consistent +(define (call-with-output-copy-query* + proc conn query #!optional (params '()) #!key (format 'text) raw) + (query* conn query params format: format raw: raw) + (let* ((closed? #f) + (output-port (make-output-port + (lambda (data) (put-copy-data conn data)) + (lambda () (put-copy-end conn) (set! closed? #t))))) + (handle-exceptions exn + (if closed? + (raise exn) + (handle-exceptions _ + (raise exn) + ;; Previously written data will be discarded to guarantee atomicity + (put-copy-end conn "Chicken PostgreSQL egg -- forcing error"))) + (call-with-values (lambda () (proc output-port)) + (lambda args + (unless closed? (put-copy-end conn)) + (apply values args)))))) + +(define (call-with-output-copy-query proc conn query . params) + (call-with-output-copy-query* proc conn query params)) + +(define (with-output-to-copy-query* + thunk conn query #!optional (params '()) #!key (format 'text) raw) + (call-with-output-copy-query* (lambda (x) (with-output-to-port x thunk)) + conn query params format: format raw: raw)) + +(define (with-output-to-copy-query thunk conn query . params) + (with-output-to-copy-query* thunk conn query params)) + +) diff --git a/tests/run.scm b/tests/run.scm new file mode 100644 index 0000000..0469929 --- /dev/null +++ b/tests/run.scm @@ -0,0 +1,949 @@ +(import (chicken blob) + (chicken condition) + (chicken string) + test + postgresql + sql-null + srfi-4) + +(define-syntax test-error* + (syntax-rules () + ((_ ?msg (?error-type ...) ?expr) + (let-syntax ((expression: + (syntax-rules () + ((_ ?expr) + (condition-case (begin ?expr "<no error thrown>") + ((?error-type ...) '(?error-type ...)) + (exn () (##sys#slot exn 1))))))) + (test ?msg '(?error-type ...) (expression: ?expr)))) + ((_ ?msg ?error-type ?expr) + (test-error* ?msg (?error-type) ?expr)) + ((_ ?error-type ?expr) + (test-error* (sprintf "~S" '?expr) ?error-type ?expr)))) + +;; Perform a quick sanity check before running the actual tests +(condition-case (disconnect (connect '((dbname . test)))) + (exn (exn postgresql connect) + (print "Could not connect to server. Please ensure that the UNIX " + "user running these tests is allowed to connect to a database " + "with the name \"test\". Error from Postgres:") + (print ((condition-property-accessor 'exn 'message) exn)) + (test-exit))) + +(test-begin "postgresql") + +(test-group "connection management" + (test "connect returns a connected connection" + '(#t #t) + (let* ((conn (connect '((dbname . test)))) + (isconn (connection? conn)) + (connected (connected? conn))) + (disconnect conn) + (list isconn connected))) + (test "disconnect causes connection to be disconnected" + '(#t #f) + (let ((conn (connect '((dbname . test))))) + (disconnect conn) + (list (connection? conn) (connected? conn)))) + (test-error "cannot connect with invalid credentials" + (connect '((dbname . does-not-exist) + (username . nobody)))) + (test-error "disconnect invalidates the connection" + (let ((conn (connect '((dbname . test))))) + (disconnect conn) + (reset-connection conn))) + ;; It would be nice if we could test some more error cases here but + ;; that's hard to do + ) + +;; From now on, just keep using the same connection +(define conn (connect '((dbname . test)))) + +;; In the tests, we assume that the client lib is at least equal to +;; the server's version. +(define-values (major-version minor-version micro-version) + (apply values + (map string->number + (string-split + (value-at (query conn "SHOW server_version")) ".")))) + +(test-group "low-level interface" + (test-assert "query returns result" + (result? (query conn "SELECT 1"))) + (test "Correct row count" + 2 + (row-count (query conn "SELECT 1 UNION SELECT 2"))) + (test "Correct column count" + 4 + (column-count (query conn "SELECT 1, 2, 3, 4"))) + (test "Correct column name" + 'one + (column-name + (query conn "SELECT 1 AS one, 2 AS two") 0)) + (test "Correct column names" + '(one two) + (column-names + (query conn "SELECT 1 AS one, 2 AS two"))) + (test-error* "Condition for nonexistant column index" + (exn postgresql bounds) + (column-name + (query conn "SELECT 1 AS one, 2 AS two") 3)) + (test "Not false for nameless column" + #f ;; Could check for ?column?, but that's a bit too specific + (not (column-name + (query conn "SELECT 1, 2") 0))) + ;; Maybe add a few tests here for case folding/noncase folding variants? + ;; Perhaps column-index-ci vs column-index? That would be + ;; misleading though, since column-index-ci isn't really ci, + ;; it will not match columns that are explicitly uppercased in the query. + (test "Correct column index" + 0 + (column-index + (query conn "SELECT 1 AS one, 2 AS two") 'one)) + (test "False column index for nonexistant column name" + #f + (column-index + (query conn "SELECT 1 AS one, 2 AS two") 'foo)) + (test "False oid for virtual table" + #f + (table-oid + (query conn "SELECT 1 AS one, 2 AS two") 0)) + (test-assert "Number for nonvirtual table" + (number? + (table-oid + (query conn "SELECT typlen FROM pg_type") 0))) + + (test-error* "Condition for column index out of bounds" + (exn postgresql bounds) + (table-oid + (query conn "SELECT typname FROM pg_type") 1)) + (test "Table column number for real table" + 0 + (table-column-index + (query conn "SELECT typname FROM pg_type") 0)) + (test "Column format is text for normal data" + 'text + (column-format + (query conn "SELECT 'hello'") 0)) + + (test "Column format is binary for forced binary data" + 'binary + (column-format + (query* conn "SELECT 1" '() format: 'binary) 0)) + + (test "Column type OID ok" + 23 ;; from catalog/pg_type.h + (column-type + (query conn "SELECT 1::int4") 0)) + (test "Column modifier false" + #f + (column-type-modifier + (query conn "SELECT 1") 0)) + (test "Column modifier for bit ok" + 2 + (column-type-modifier + (query conn "SELECT '10'::bit(2)") 0)) + (test "Result value string for strings" + "test" + (value-at (query conn "SELECT 'test'"))) + (test "Result value string for 'name' type (with no custom parser)" + "test" + (value-at (query conn "SELECT 'test'::name"))) + (test "Result row values" + '("one" "two") + (row-values + (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0)) + (test "Result row values for second row" + '("three" "four") + (row-values + (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 1)) + (test "Result row alist" + '((a . "one") (b . "two")) + (row-alist + (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 0)) + (test "Result row alist for second row" + '((a . "three") (b . "four")) + (row-alist + (query conn "SELECT 'one' AS a, 'two' AS b UNION SELECT 'three', 'four'") 1)) + (test "Result column values" + '("one" "three") + (column-values + (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 0)) + (test "Result column values for second column" + '("two" "four") + (column-values + (query conn "SELECT 'one', 'two' UNION SELECT 'three', 'four'") 1)) + (test "Result value number for numbers" + 1 + (value-at (query conn "SELECT 1"))) + (test "Result value string for raw numbers" + "1" + (value-at (query conn "SELECT 1") 0 0 raw: #t)) + ;; We are using two levels of escaping here because the ::bytea cast + ;; performs another string interpretation. Yes, this is kinda confusing... + (test "Result value for null-terminated byte array" + (blob->u8vector (string->blob "h\x00ello")) + (value-at (query conn "SELECT E'h\\\\000ello'::bytea"))) + + (test "Result value for raw null-terminated byte array" + (if (>= major-version 9) + "\\x6800656c6c6f" + "h\\000ello") + (value-at (query conn "SELECT E'h\\\\000ello'::bytea") 0 0 raw: #t)) + + (test "Result value blob for binary string" + (string->blob "hello") + (value-at (query* conn "SELECT 'hello'" '() format: 'binary))) + + (test "Result value blob for binary integer" + (u8vector->blob (u8vector 0 0 0 1)) + (value-at (query* conn "SELECT 1::int4" '() format: 'binary))) + + (test "Result value for binary string with NUL bytes" + (string->blob "h\x00ello") + (value-at (query* conn "SELECT E'h\\\\000ello'::bytea" '() format: 'binary))) + + (test "Result value for array of integers" + `#(1 ,(sql-null) 3) ;; Not sure if comparing sql-null is kosher + (value-at (query conn "SELECT array[1, null, 3]"))) + + (test "Result value for nested array of ints" + `#(#(1 ,(sql-null) 3) + #(4 5 ,(sql-null))) ;; Not sure if comparing sql-null is kosher + (value-at + (query conn "SELECT array[array[1, null, 3], array[4, 5, NULL]]"))) + + (test "Result value for array of strings" + `#("a" ,(sql-null) "c") ;; Not sure if comparing sql-null is kosher + (value-at (query conn "SELECT array['a', null, 'c']"))) + + (test "Result value for nested array of strings" + `#(#("a" ,(sql-null) "c") + #("NULL" "e" ,(sql-null))) ;; Not sure if comparing sql-null is kosher + (value-at (query conn "SELECT array[array['a', null, 'c'], array['NULL', 'e', NULL]]"))) + + (test "Result value at row 0, column 1" + 2 + (value-at (query conn "SELECT 1, 2 UNION SELECT 3, 4") 1 0)) + (test "Result value at row 1, column 0" + 3 + (value-at (query conn "SELECT 1, 2 UNION SELECT 3, 4") 0 1)) + (test-assert "Result value sql-null for NULL" + (sql-null? (value-at (query conn "SELECT NULL")))) + (test-error* "Result value error for out of bounds row" + (exn postgresql bounds) + (value-at (query conn "SELECT NULL") 0 1)) + (test-error* "Result value error for out of bounds column" + (exn postgresql bounds) + (value-at (query conn "SELECT NULL") 1 0)) + + (query conn "PREPARE foo (int) AS (SELECT 1, 2, $1)") + (test-assert "query with prepared statement name returns result" + (result? (query conn 'foo 3))) + (test "result value ok for query with prepared statement name" + '(1 2 3) + (row-values (query conn 'foo 3))) + (test-error* "condition for missing parameter names" + (exn postgresql query) + (query conn 'foo)) + + (query conn "BEGIN") + (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP") + (test "Number of affected rows 1 with INSERT" + 1 + (affected-rows + (query conn "INSERT INTO foo (bar) VALUES (1);"))) + (query conn "COMMIT") + + (query conn "BEGIN") + (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP") + (query conn "INSERT INTO foo (bar) VALUES (100);") + (query conn "INSERT INTO foo (bar) VALUES (101);") + (test "Number of affected rows 2 with UPDATE of two rows" + 2 + (affected-rows + (query conn "UPDATE foo SET bar=102;"))) + (query conn "COMMIT") + + (test "Inserted OID false on SELECT" + #f + (inserted-oid + (query conn "SELECT 1"))) + + (query conn "BEGIN") + (query conn "CREATE TEMP TABLE foo ( bar integer ) ON COMMIT DROP") + (test "Inserted OID false on OID-less table" + #f + (inserted-oid + (query conn "INSERT INTO foo (bar) VALUES (1);"))) + (query conn "COMMIT") + + (query conn "BEGIN") + (query conn "CREATE TEMP TABLE foo ( bar integer ) WITH (OIDS=true) ON COMMIT DROP") + (test-assert "Inserted OID number on table with OID" + (number? + (inserted-oid + (query conn "INSERT INTO foo (bar) VALUES (1)")))) + (query conn "COMMIT") + + (test "regular parameters" + "hi" + (value-at (query conn "SELECT $1::text" "hi") 0 0)) + (test-assert "NULL parameters" + (sql-null? (value-at + (query conn "SELECT $1::text" (sql-null)) 0 0))) + (test "blob parameters" + "hi" + (value-at (query conn "SELECT $1::text" (string->blob "hi")) 0 0)) + (test "boolean parameters" + '(#t #f) + (row-values (query conn "SELECT $1::bool, $2::bool" #t #f))) + (test "integer array parameters" + `(#(1 2) #(,(sql-null) 4)) + (row-values (query conn "SELECT $1::int[], $2::int[]" + `#(1 2) `#(,(sql-null) 4)))) + (test "nested integer array parameters" + `(#(#(1 2) #(,(sql-null) 4))) + (row-values (query conn "SELECT $1::int[][]" + `#(#(1 2) #(,(sql-null) 4))))) + (test "string array parameters (including 'null')" + `(#("a" "b") #(,(sql-null) "null")) + (row-values (query conn "SELECT $1::text[], $2::text[]" + `#("a" "b") `#(,(sql-null) "null")))) + (test "string array parameters with meta-characters" + `(#("a\\b" "c\"d") #("{" "}")) + (row-values (query conn "SELECT $1::text[], $2::text[]" + '#("a\\b" "c\"d") '#("{" "}")))) + (test "nested string array parameters" + `(#(#("a" "b") #(,(sql-null) "null"))) + (row-values (query conn "SELECT $1::text[][]" + `#(#("a" "b") #(,(sql-null) "null"))))) + (test "array bounds are ignored" + `#(#(#(1 2 3) #(4 5 6))) + (value-at + (query conn + "SELECT '[1:1][-2:-1][3:5]={{{1,2,3},{4,5,6}}}'::int[] AS f1"))) + + ;; Basic domains seem to return just their base type + (query conn "BEGIN") + (query conn "CREATE DOMAIN mydom AS integer CHECK (VALUE > 2)") + (test "basic domains" + 3 + (value-at (query conn "SELECT $1::mydom" 3))) + (query conn "ROLLBACK") + + (query conn "BEGIN") + (query conn "CREATE TYPE foo AS ( a integer, b text )") + (test "basic composite type" + `(1 "one") + (value-at (query conn "SELECT $1::foo" `(1 "one")))) + (test "composite type with meta-characters" + `(123 "\\backslash\"quote") + (value-at (query conn "SELECT $1::foo" `(123 "\\backslash\"quote")))) + (query conn "CREATE TYPE bar AS ( x foo, y integer )") + (test "Nested composite type" + `((2 "two") 3) + (value-at (query conn "SELECT $1::bar" `((2 "two") 3)))) + (query conn "CREATE DOMAIN mydom AS integer CHECK (VALUE > 1)") + (query conn "CREATE TYPE qux AS ( i integer, d mydom )") + (test "Composite type containing domain value" + `(1 2) + (value-at (query conn "SELECT $1::qux" `(1 2)))) + (query conn "ROLLBACK") + + (test "anonymous composite type ('record')" + '("one" "two") + (value-at (query conn "SELECT ROW('one', 'two')"))) + + (test "anonymous composite type ('record') with NULL" + `("one" ,(sql-null)) + (value-at (query conn "SELECT ROW('one', NULL)"))) + + ;; ROW() is indistinguishable from ROW(NULL). The latter is more likely + ;; to occur than the former, so let's ensure that's how it's interpreted + ;; See also http://archives.postgresql.org/pgsql-hackers/2004-06/msg00159.php + (test "anonymous composite type ('record') with just one NULL" + `(,(sql-null)) + (value-at (query conn "SELECT ROW(NULL)")))) + +(test-group "escaping and quotation" + (test-group "with standards conforming strings off" + (query conn "SET standard_conforming_strings='off'") + (test "String is escaped correctly" + "it''s \"this\" \\\\ safe!" + (escape-string conn "it's \"this\" \\ safe!")) + (test "Small string is escaped correctly" + "foo" + (escape-string conn "foo")) + (test "Bytea is escaped correctly (u8vector)" + (if (>= major-version 9) + "\\\\x576800617427730a75703f" + "Wh\\\\000at''s\\\\012up?") + (escape-bytea conn (blob->u8vector (string->blob "Wh\x00at's\nup?")))) + (test "Bytea is unescaped correctly (blob)" + (blob->u8vector (string->blob "What's\nup? ")) + ;; The extra quote is dropped here because it wouldn't be returned + ;; by pgsql either. + (unescape-bytea "What's\\012up?\\ ")) + (test "Identifier is escaped and quoted correctly" + ;; Backslashes have no special meaning in identifiers, + ;; standards conforming strings or no + "\"it's \"\"this\"\" \\ safe!\"" + (quote-identifier conn "it's \"this\" \\ safe!"))) + (test-group "with standards conforming strings on" + (query conn "SET standard_conforming_strings='on'") + (test "String is escaped correctly" + "it''s \"this\" \\ safe!" + (escape-string conn "it's \"this\" \\ safe!")) + (test "Bytea is escaped correctly" + (if (>= major-version 9) + "\\x576800617427730a75703f" + "Wh\\000at''s\\012up?") + (escape-bytea conn "Wh\x00at's\nup?")) + (test "Bytea is unescaped correctly" + (blob->u8vector (string->blob "What's\nup? ")) + ;; The extra quote is dropped here because it wouldn't be returned + ;; by pgsql either. + (unescape-bytea "What's\\012up?\\ ")) + (test "Identifier is escaped and quoted correctly" + ;; Backslashes have no special meaning in identifiers, + ;; standards conforming strings or no + "\"it's \"\"this\"\" \\ safe!\"" + (quote-identifier conn "it's \"this\" \\ safe!")))) + +(test-group "query error handling" + (test-group "basic info: position and code" + (handle-exceptions exn + (begin (test "Class of real query error is available and set to expected value" + "42" + ((condition-property-accessor 'query 'error-class) exn)) + (test "Code of real query error is available and set to expected value" + "42P01" ; undefined_table + ((condition-property-accessor 'query 'error-code) exn)) + ;; We can't set locale w/o superuser rights, so we'll + ;; have to make do with an incomplete severity check. + (test-assert "Severity of real query error is a symbol" + (symbol? ((condition-property-accessor + 'query 'severity) exn))) + (test "Statement position in real query error is correct" + 15 + ((condition-property-accessor + 'query 'statement-position) exn))) + (query conn "SELECT 1 FROM nonexistant_table") + (error "query call didn't fail"))) + (test-group "message and code" + (handle-exceptions exn + (begin (test "Error class is available and set to expected value" + "42" + ((condition-property-accessor 'query 'error-class) exn)) + (test "Error code is available and set to expected value" + "42P16" + ((condition-property-accessor 'query 'error-code) exn)) + ;; We can't set locale w/o superuser rights, so we'll + ;; have to make do with some neutered checks. + (test-assert "Severity is a symbol" + (symbol? ((condition-property-accessor + 'query 'severity) exn))) + (test "Message primary is set to the expected value" + "testing, 1, 2, 3." + ((condition-property-accessor 'query 'message-primary) exn)) + (test "Detail is set to the expected value" + "this is a test" + ((condition-property-accessor 'query 'message-detail) exn)) + (test "Hint is set to the expected value" + "try again" + ((condition-property-accessor 'query 'message-hint) exn)) + ;; XXX These two may be too version-specific + (test "source function is set to the correct value" + "exec_stmt_raise" + ((condition-property-accessor 'query 'source-function) exn)) + (test "source file is set to the the correct value" + "pl_exec.c" + ((condition-property-accessor 'query 'source-file) exn)) + (test-assert "source line is available and a number" + (number? ((condition-property-accessor + 'query 'source-line) exn)))) + (query conn (conc "CREATE OR REPLACE FUNCTION cause_error() " + "RETURNS void AS $$\n" + " BEGIN\n" + " RAISE invalid_table_definition \n" + " USING MESSAGE = 'testing, 1, 2, 3.', \n" + " DETAIL = 'this is a test', \n" + " HINT = 'try again';\n" + " END;\n" + "$$ LANGUAGE plpgsql")) + (value-at (query conn "SELECT cause_error()")) + (error "query call didn't fail"))) + (when (or (> major-version 9) (and (= major-version 9) (>= minor-version 3))) + (test-group "schema information" + (query conn "BEGIN") + (query conn (conc "CREATE DOMAIN posint AS int" + " CONSTRAINT must_be_positive CHECK (VALUE > 0)")) + (query conn (conc "CREATE TEMP TABLE foo (bar posint) ON COMMIT DROP")) + (handle-exceptions exn + (begin (test-assert "Schema name is set" ; It is pg_temp_2 + ((condition-property-accessor + 'query 'schema-name) exn)) + (test "Data type name is correct" + "posint" + ((condition-property-accessor 'query 'datatype-name) exn)) + (test "Constraint name is correct" + "must_be_positive" + ((condition-property-accessor 'query 'constraint-name) exn))) + (query conn "INSERT INTO foo (bar) VALUES (-1)") + (error "query call didn't fail")) + (query conn "ROLLBACK") + (query conn "BEGIN") + (query conn (conc "CREATE TEMP TABLE foo (bar int NOT NULL) " + "ON COMMIT DROP")) + (handle-exceptions exn + (begin (test-assert "Schema name is set" ; It is pg_temp_2 + ((condition-property-accessor + 'query 'schema-name) exn)) + (test "Table name is correct" + "foo" + ((condition-property-accessor 'query 'table-name) exn)) + (test "Column name is correct" + "bar" + ((condition-property-accessor 'query 'column-name) exn))) + (query conn "INSERT INTO foo (bar) VALUES (NULL)") + (error "query call didn't fail")) + (query conn "ROLLBACK")))) + +(test-group "COPY support" + (query conn "CREATE TEMP TABLE copy_table ( nr integer, s text )") + (test-group "low-level interface" + (test-error* "Cannot put copy data while no COPY in progress" + (exn postgresql i/o) + (put-copy-data conn "whatever")) + (query conn "COPY copy_table (s, nr) FROM STDIN") + (test-error* "Cannot initiate new query while waiting for COPY input" + (exn postgresql i/o) + (query conn "SELECT 1")) + (put-copy-data conn "one\t1\n") + (test-error* "Cannot initiate new query while COPY data in progress" + (exn postgresql i/o) + (query conn "SELECT 1")) + (put-copy-data conn "two\t2") + (put-copy-end conn) + (let ((res (query conn "SELECT * FROM copy_table"))) + (test "Simple copy from STDIN works" + '((1 "one") + (2 "two")) + (list (row-values res 0) (row-values res 1)))) + (test-error* "Cannot get copy data while no COPY in progress" + (exn postgresql i/o) + (get-copy-data conn)) + (query conn "COPY copy_table (s, nr) TO STDOUT") + (test-error* "Cannot initiate new query while waiting for COPY output" + (exn postgresql i/o) + (query conn "SELECT 1")) + (test "Simple copy to STDOUT works, first record" + "one\t1\n" + (get-copy-data conn)) + (test-error* "Cannot initiate new query while reading COPY data" + (exn postgresql i/o) + (query conn "SELECT 1")) + (test "Simple copy to STDOUT works, second record" + "two\t2\n" + (get-copy-data conn)) + (test-assert "EOF is marked by a result object" + (result? (get-copy-data conn)))) + (test-group "high-level interface" + (test "Mapping" + '(("one" "1") + ("two" "2")) + (copy-query-map string-split conn "COPY copy_table (s, nr) TO STDOUT")) + (test "Error while mapping gets connection out of COPY state" + "okay" + (handle-exceptions exn + (value-at (query conn "SELECT 'okay'")) + (copy-query-map (lambda _ (error "blah")) + conn "COPY copy_table (s, nr) TO STDOUT"))) + (test "Fold" + '(("one" "1") + ("two" "2")) + (reverse + (copy-query-fold + (lambda (data result) + (cons (string-split data) result)) + '() conn "COPY copy_table (s, nr) TO STDOUT"))) + (test "Error while folding gets connection out of COPY state" + "okay" + (handle-exceptions exn + (value-at (query conn "SELECT 'okay'")) + (copy-query-fold (lambda _ (error "blah")) + '() conn "COPY copy_table (s, nr) TO STDOUT"))) + (test "Fold-right" + '(("one" "1") + ("two" "2")) + (copy-query-fold-right + (lambda (data result) + (cons (string-split data) result)) + '() conn "COPY copy_table (s, nr) TO STDOUT")) + (test "Error while folding right gets connection out of COPY state" + "okay" + (handle-exceptions exn + (value-at (query conn "SELECT 'okay'")) + (copy-query-fold-right (lambda _ (error "blah")) + '() conn "COPY copy_table (s, nr) TO STDOUT"))) + (test "For-each" + '(("one" "1") + ("two" "2")) + (let ((res '())) + (copy-query-for-each (lambda (x) + (set! res (cons (string-split x) res))) + conn "COPY copy_table (s, nr) TO STDOUT") + (reverse res))) + (test "Error during for-each gets connection out of COPY state" + "okay" + (handle-exceptions exn + (value-at (query conn "SELECT 'okay'")) + (copy-query-for-each (lambda (x) (error "blah")) + conn "COPY copy_table (s, nr) TO STDOUT"))) + (query conn "TRUNCATE copy_table") + (with-output-to-copy-query (lambda () + (print "first\t1") + (print "second\t2")) + conn "COPY copy_table (s, nr) FROM STDIN") + (test "Port interface inserted data correctly" + '(("first" 1) + ("second" 2)) + (let ((res (query conn "SELECT s, nr FROM copy_table"))) + (list (row-values res 0) (row-values res 1)))) + (query conn "TRUNCATE copy_table") + (handle-exceptions _ + (void) + (with-output-to-copy-query (lambda () + (print "first\t1") + (print "second\t2") + (error "blah")) + conn "COPY copy_table (s, nr) FROM STDIN")) + (test "Error inside with-output-to-copy caused abort of insert" + 0 (value-at (query conn "SELECT COUNT(*) FROM copy_table"))))) + +(test-group "type parsers" + (test "Integer parsed correctly" + 1234 + (numeric-parser "1234")) + (test "Float parsed correctly" + 123.456 + (numeric-parser "123.456")) + (test-error* "Non-integer is an error" + (exn postgresql parse) + (numeric-parser "not an integer")) + (test "Boolean true parsed correctly" + #t + (bool-parser "t")) + (test "Boolean false parsed correctly" + #f + (bool-parser "f")) + (test "Byte array parsed correctly" + (blob->u8vector/shared (string->blob "abc\x01\x02\xffdef")) + (bytea-parser "abc\\001\\002\\377def")) + (test "Char parser" + #\x + (char-parser "x"))) + +(test-group "type unparsers" + (test "Boolean true unparsed correctly" + "TRUE" + (bool-unparser conn #t)) + (test "Boolean false unparsed correctly" + "FALSE" + (bool-unparser conn #f))) + +(test-group "high-level interface" + (test "row-fold" + '(("one" 2) + ("three" 4)) + (reverse + (row-fold + cons '() + (query conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" + "one" 2)))) + (test "column-fold" + '(("one" "three") + (2 4)) + (reverse + (column-fold + cons '() + (query conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" + "one" 2)))) + (test "row-fold-right" + '(("one" 2) + ("three" 4)) + (row-fold-right + cons '() + (query conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" + "one" 2))) + (test "column-fold-right" + '(("one" "three") + (2 4)) + (column-fold-right + cons '() + (query conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" + "one" 2))) + (test "row-for-each" + '(("one" 2) + ("three" 4)) + (let ((res '())) + (row-for-each + (lambda (row) (set! res (cons row res))) + (query + conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)) + (reverse res))) + (test "column-for-each" + '(("one" "three") + (2 4)) + (let ((res '())) + (column-for-each + (lambda (col) (set! res (cons col res))) + (query + conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)) + (reverse res))) + (test "row-map" + '(("one" 2) + ("three" 4)) + (row-map + identity + (query conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2))) + (test "column-map" + '(("one" "three") + (2 4)) + (column-map + identity + (query conn + "SELECT $1::text, $2::integer UNION SELECT 'three', 4" "one" 2)))) + +(test-group "transactions" + (query conn "CREATE TEMP TABLE foo ( bar integer )") + + (test-group "simple transactions" + (test "Transaction inactive" + #f + (in-transaction? conn)) + (test "Transaction active" + #t + (with-transaction conn + (lambda () (in-transaction? conn)))) + (test "Successful transaction" + '(1) + (and + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)"))) + (column-values (query conn "SELECT * FROM foo")))) + + (query conn "TRUNCATE foo") + + (test "Unsuccessful transaction" + #f + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + #f))) + + (test "Empty table after unsuccessful transaction" + '() + (column-values (query conn "SELECT * FROM foo"))) + + (handle-exceptions exn + (void) + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + (error "oops!")))) + + (test "Exception during transaction causes reset" + '() + (column-values (query conn "SELECT * FROM foo")))) + + (test-group "nested transactions" + (test "Successful transaction" + '(1 2) + (and + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (2)"))))) + (column-values (query conn "SELECT * FROM foo")))) + + (query conn "TRUNCATE foo") + + (test "Unsuccessful main transaction" + '() + (and + (not + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (2)"))) + #f))) + (column-values (query conn "SELECT * FROM foo")))) + + (test "Unsuccessful subtransaction" + '(1) + (and + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (2)") + #f)) + #t)) + (column-values (query conn "SELECT * FROM foo")))) + + (query conn "TRUNCATE foo") + + ;; Test that errors do not kill the transaction. Apparently + ;; aborting transactions on errors is a psql(1) "feature", not a + ;; libpq one. + (test "Unsuccessful subtransaction with bad query" + '(1 2) + (and + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + (handle-exceptions exn + #t + (with-transaction + conn (lambda () + (query conn "INVALID QUERY")))) + (query conn "INSERT INTO foo (bar) VALUES (2)"))) + (column-values (query conn "SELECT * FROM foo")))) + + (query conn "TRUNCATE foo") + + (test "Multiple subtransactions" + '(1 3) + (and + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (1)") + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (2)") + #f)) + (with-transaction + conn (lambda () + (query conn "INSERT INTO foo (bar) VALUES (3)"))))) + (column-values (query conn "SELECT * FROM foo"))))) + + ;; Very annoying; read-only transactions can write to temporary tables, + ;; so we have to create a REAL table here. + (query conn "CREATE TABLE chicken_pgsql_test (bar int)") + ;; We'd better make damn sure it gets dropped again. + (on-exit (lambda () (query conn "DROP TABLE chicken_pgsql_test"))) + + (test-group "transaction access mode" + (test "Writes with explicit read/write access mode work" + '(1) + (with-transaction + conn (lambda () + (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (1)") + (column-values + (query conn "SELECT * FROM chicken_pgsql_test"))) + access: 'read/write)) + + (test "Reads with read-only access mode work" + '(1) + (with-transaction + conn (lambda () + (column-values + (query conn "SELECT * FROM chicken_pgsql_test"))) + access: 'read-only)) + + (test-error* "Writes with read-only access cause errors" + (exn postgresql query) + (with-transaction + conn (lambda () + (query conn (conc "INSERT INTO chicken_pgsql_test (bar)" + "VALUES (1)"))) + access: 'read-only)) + + (test "Switching read-write to read-only works" + '(1 2) + (with-transaction + conn (lambda () + (with-transaction + conn (lambda () + (query conn "SELECT * FROM chicken_pgsql_test")) + access: 'read-only) + (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (2)") + (column-values (query conn "SELECT * FROM chicken_pgsql_test"))) + access: 'read/write)) + + (test "Switching read-write to read-only works with rollback" + '(1 2 3) + (with-transaction + conn (lambda () + (handle-exceptions exn + (void) + (with-transaction + conn (lambda () + (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (3)")) + access: 'read-only)) + (query conn "INSERT INTO chicken_pgsql_test (bar) VALUES (3)") + (column-values (query conn "SELECT * FROM chicken_pgsql_test"))) + access: 'read/write)) + + (test-error* "Switching read-only to read-write causes error" + (exn postgresql query) + (with-transaction + conn (lambda () + (query conn "SELECT * FROM chicken_pgsql_test") + (with-transaction + conn (lambda () + (query conn + (conc "INSERT INTO chicken_pgsql_test (bar)" + "VALUES (2)"))) + access: 'read/write) + (column-values (query conn "SELECT * FROM chicken_pgsql_test"))) + access: 'read-only)) + + ;; Run these "concurrent" tests with a second connection + (let ((conn2 (connect '((dbname . test))))) + (test "Read committed transaction does see concurrent changes" + '(1 2 3 4) + (with-transaction + conn (lambda () + ;; MUST perform a query, since only after the first + ;; query will the isolation take effect. + (query conn "SELECT * FROM chicken_pgsql_test") + (query conn2 (conc "INSERT INTO chicken_pgsql_test (bar) " + "VALUES (4)")) + (column-values + (query conn "SELECT * FROM chicken_pgsql_test"))) + isolation: 'read-committed)) + + (test "Serializable transaction doesn't see concurrent changes" + '(1 2 3 4) + (with-transaction + conn (lambda () + ;; MUST perform a query, since only after the first + ;; query will the isolation take effect. + (query conn "SELECT * FROM chicken_pgsql_test") + (query conn2 (conc "INSERT INTO chicken_pgsql_test (bar) " + "VALUES (5)")) + (column-values + (query conn "SELECT * FROM chicken_pgsql_test"))) + isolation: 'serializable)) + (disconnect conn2))) + ) + +(test-end) + +(test-exit) |