diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/run.scm | 949 |
1 files changed, 949 insertions, 0 deletions
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) |