(use test postgresql sql-null srfi-4)

;; These tests assume that the current UNIX user has access to a database
;; named 'test'.  The tests will fail otherwise.

(test-group "connection management"
  (test-assert "connect returns a connection"
               (let* ((conn (connect '((dbname . test))))
                      (isconn (connection? conn)))
                 (disconnect conn)
                 isconn))
  (test-error "cannot connect with invalid credentials"
              (connect '((dbname . does-not-exist)
                         (username . nobody))))
  (test-assert "reset-connection returns a connection"
               (let* ((conn (connect '((dbname . test))))
                      (isconn (connection? conn)))
                 (reset-connection conn)
                 (disconnect conn)
                 isconn))
  (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))))

(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"
              (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"
              (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 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"
        "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 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"
              (value-at (query conn "SELECT NULL") 0 1))
  (test-error "Result value error for out of bounds column"
              (value-at (query conn "SELECT NULL") 1 0))
  (test "Number of affected rows false with SELECT"
        #f
        (affected-rows
         (query conn "SELECT 1")))

  (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-group "value escaping"
  (test "String is escaped correctly"
        "What''s up?"
        (escape-string conn "What's up?"))
  (test "Bytea is escaped correctly"
        "Wh\\\\000at''s\\\\012up?"
        (escape-bytea conn "Wh\x00at's\nup?"))
  (test "Bytea is unescaped correctly"
        "What's\nup?"
        ;; The extra quote is dropped here because it wouldn't be returned
        ;; by pgsql either.
        (unescape-bytea "What's\\012up?")))

(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"
                (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"
                (query conn "SELECT 1"))
    (put-copy-data conn "one\t1\n")
    (test-error "Cannot initiate new query while COPY data in progress"
                (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"
                (get-copy-data conn))
    (query conn "COPY copy_table (s, nr) TO STDOUT")
    (test-error "Cannot initiate new query while waiting for COPY output"
                (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"
                (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-map string-split
                    conn (query 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-map (lambda _ (error "blah"))
                      conn (query conn "COPY copy_table (s, nr) TO STDOUT"))))
    (test "Fold"
          '(("one" "1")
            ("two" "2"))
          (reverse
           (copy-fold
            (lambda (data result)
              (cons (string-split data) result))
            '() conn (query 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-fold (lambda _ (error "blah"))
                       '() conn
                       (query conn "COPY copy_table (s, nr) TO STDOUT"))))
    (test "Fold-right"
          '(("one" "1")
            ("two" "2"))
          (copy-fold-right
           (lambda (data result)
             (cons (string-split data) result))
           '() conn (query 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-fold-right (lambda _ (error "blah"))
                             '() conn
                             (query conn "COPY copy_table (s, nr) TO STDOUT"))))
    (test "For-each"
          '(("one" "1")
            ("two" "2"))
          (let ((res '()))
            (copy-for-each (lambda (x) (set! res (cons (string-split x) res)))
                           conn (query 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-for-each
             (lambda (x) (error "blah"))
             conn (query conn "COPY copy_table (s, nr) TO STDOUT"))))
    (query conn "TRUNCATE copy_table")
    (with-output-to-copy (lambda ()
                           (print "first\t1")
                           (print "second\t2"))
                         conn
                         (query 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 (lambda ()
                             (print "first\t1")
                             (print "second\t2")
                             (error "blah"))
                           conn
                           (query 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"
              (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 #t))
  (test "Boolean false unparsed correctly"
        "FALSE"
        (bool-unparser #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")))))
  )