path: root/tests/run.scm

(import (chicken blob)
        (chicken condition)
        (chicken string)
        test
        postgresql
        sql-null
        srfi-4
        srfi-18)

(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)
  (let ((versions (map string->number
                       (string-split
                        (value-at (query conn "SHOW server_version")) "."))))
    ;; NOTE: Sometimes there are two, sometimes three values.
    ;; We don't really care about the "micro" version here,
    ;; so just return the first two and treat them as major/minor.
    (values (car versions) (cadr versions))))

(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 "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);")))
  (test "Table column number for real table"
        0
        (table-column-index
         (query conn "SELECT bar FROM foo") 0))
  (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")
  
  ;; Since Postgres 12, WITH OIDS is not supported anymore
  (when (< major-version 12)
    (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)))
)


;; This testing code is pretty hairy
(test-group "LISTEN/NOTIFY"
  (let ((received-channel #f)
        (received-pid #f)
        (received-message #f)
        (pid1 (value-at (query conn "SELECT pg_backend_pid()"))))

    (define (reset-received-values!)
      (set! received-channel #f)
      (set! received-pid #f)
      (set! received-message #f))

    (query conn "LISTEN \"testing channel\"")
    (query conn "LISTEN \"unused channel\"")

    (set-notify-handler! conn (lambda (channel pid message)
                                (set! received-channel channel)
                                (set! received-pid pid)
                                (set! received-message message)))

    (query conn "NOTIFY \"testing channel\", 'this is a test'")

    (test "Notification handler is immediately invoked for own connection"
          `("testing channel" ,pid1 "this is a test")
          (list received-channel pid1 received-message))

    (reset-received-values!)

    (let* ((conn2 (connect '((dbname . test))))
           (pid2 (value-at (query conn2 "SELECT pg_backend_pid()"))))
      (query conn2 "NOTIFY \"testing channel\", 'another test'")

      (test "Notification handler for connection 1 is not invoked when notifying from connection 2"
            `(#f #f #f)
            (list received-channel received-pid received-message))

      (query conn "SELECT 1")
      (test "Notification handler is invoked after performing next query"
            `("testing channel" ,pid2 "another test")
            (list received-channel received-pid received-message))

      (reset-received-values!)

      ;; This sucks, we have to do this from another thread
      (thread-start!
       (lambda ()
         (thread-sleep! 0.1)
         (query conn2 "NOTIFY \"testing channel\", 'hi'")))

      (test "Waiting manually for a short while does nothing yet"
            `(#f #f #f)
            (begin (wait-for-notifications! conn 1)
                   (list received-channel received-pid received-message)))

      (test "Waiting long enough returns the notification"
            `("testing channel" ,pid2 "hi")
            (begin (wait-for-notifications! conn 5000)
                   (list received-channel received-pid received-message)))

      (reset-received-values!)

      ;; And once more
      (thread-start!
       (lambda ()
         (thread-sleep! 0.01)
         (query conn2 "NOTIFY \"testing channel\", 'also hi'")))

      (test "Waiting without timeout returns the notification"
            `("testing channel" ,pid2 "also hi")
            (begin (wait-for-notifications! conn #f)
                   (list received-channel received-pid received-message))))))

(test-end)

(test-exit)