;; This file is part of SQLite3 for CHICKEN
;; Copyright (c) 2005-2018, Thomas Chust <chust@web.de>.  All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;;   Redistributions of source code must retain the above copyright notice,
;;   this list of conditions and the following disclaimer. Redistributions in
;;   binary form must reproduce the above copyright notice, this list of
;;   conditions and the following disclaimer in the documentation and/or
;;   other materials provided with the distribution. Neither the name of the
;;   author nor the names of its contributors may be used to endorse or
;;   promote products derived from this software without specific prior
;;   written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(import
  scheme
  (chicken blob)
  (srfi 1)
  (srfi 13)
  (srfi 69)
  test
  sql-null
  sqlite3)

;;; Some utilities

(define-syntax with-database
  (syntax-rules ()
    [(with-database [db path . finalize-statements?]
        body ...)
      (let ([db #f])
        (dynamic-wind
          (lambda ()
            (set! db (open-database path)))
          (lambda ()
            body ...)
          (lambda ()
            (and-let* ([d db])
              (set! db #f)
              (finalize! d . finalize-statements?)))))]))

(define-syntax with-database+statement
  (syntax-rules ()
    [(with-database+statement ([db path] [stmt sql])
        body ...)
      (with-database [db path]
        (call-with-temporary-statements
          (lambda (stmt)
            body ...)
          db sql))]))

(enable-shared-cache! #t)

;;; The tests

(test-group "SQLite3 bindings"

  (test-assert "library version"
    (string-prefix? "3." (database-version)))

  (test-group "SQL completeness checks"

    (test-assert "complete SQL"
      (sql-complete? "SELECT 42;"))

    (test-assert "incomplete SQL"
      (not (sql-complete? "SELECT -- just a comment")))

    )

  (test-group "statement management"

    (test "basic lifecycle"
      '(" -- tail" #t #f)
      (with-database [db ":memory:"]
        (let-values ([(stmt tail) (prepare db "SELECT 42; -- tail")])
          (dynamic-wind
            void
            (lambda ()
              (let* ([s0 (step! stmt)]
                     [s1 (step! stmt)])
                (list tail s0 s1)))
            (lambda ()
              (and-let* ([s stmt])
                (set! stmt #f)
                (finalize! s)))))))

    (test-assert "unfinalized statement detection"
      (let ([db (open-database ":memory:")])
        (condition-case
          (begin
            (prepare db "SELECT 23;")
            (finalize! db #f)
            #f)
          [(exn sqlite3)
            (finalize! db #t)
            #t])))

    (test-assert "automatic statement finalization"
      (with-database [db ":memory:" #t]
        (prepare db "SELECT 23;")
        #t))

    (test-error "SQL error detection"
      (with-database [db ":memory:"]
        (execute db "DISTIM A DOSH;")))

    (test-assert "repair"
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (id INTEGER PRIMARY KEY);")
        (call-with-temporary-statements
          (lambda (stmt)
            (execute db "ALTER TABLE Foo ADD COLUMN blurb TEXT;")
            (not (step! stmt)))
          db "SELECT * FROM Foo;")))

    (test "column count"
      3
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT 1, 2, 3;"])
        (column-count stmt)))

    (test "column name"
      '("foo" "bar")
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo(foo);")
        (call-with-temporary-statements
          (lambda (stmt)
            (list
              (column-name stmt 0)
              (column-name stmt 1)))
          db "SELECT foo, 42 AS bar FROM Foo;")))

    (test "column declared type"
      '("INTEGER" "TEXT")
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (id INTEGER PRIMARY KEY, data TEXT);")
        (call-with-temporary-statements
          (lambda (stmt)
            (list
              (column-declared-type stmt 0)
              (column-declared-type stmt 1)))
          db "SELECT id, data FROM Foo;")))

    (test "column type"
      '(integer text)
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (id INTEGER PRIMARY KEY, data TEXT);")
        (update db "INSERT INTO Foo (data) VALUES (?);" "Hallo Welt!")
        (call-with-temporary-statements
          (lambda (stmt)
            (step! stmt)
            (list
              (column-type stmt 0)
              (column-type stmt 1)))
          db "SELECT id, data FROM Foo;")))

    (test "inserting fixnums and bignums"
      '(10000000 10000000000)
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (id INTEGER PRIMARY KEY, data INTEGER);")
        (update db "INSERT INTO Foo (data) VALUES (?);" 10000000) ; fixnum
        (update db "INSERT INTO Foo (data) VALUES (?);" 10000000000) ; bignum
        (map-row identity db "SELECT data FROM Foo;")))

    (test "parameter count"
      3
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT :a, :b, :c;"])
        (bind-parameter-count stmt)))

    (test "parameter name"
      '(":foo" #f)
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT ?, :foo, ?;"])
        (list
          (bind-parameter-name stmt 1)
          (bind-parameter-name stmt 2))))

    (test "parameter index"
      '(1 #f)
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT ?, :foo, ?;"])
        (list
          (bind-parameter-index stmt ":foo")
          (bind-parameter-index stmt ":bar"))))

    )

  (test-group "simple statement interface"

    (let ([data (list 42 3.5 "hallo" (string->blob "welt"))])
      (test "data invariance"
        data
        (with-database+statement ([db ":memory:"]
                                  [stmt "SELECT ?;"])
          (map (cut first-result stmt <>) data))))

    (test "boolean invariance"
      '(#t #f)
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Bool (id INTEGER PRIMARY KEY, v BOOL);")
        (call-with-temporary-statements
          (lambda (ins)
            (for-each (cut execute ins <> <>) (iota 2) '(#t #f)))
          db "INSERT INTO Bool (id, v) VALUES (?, ?);")
        (call-with-temporary-statements
          (lambda (get)
            (map (cut first-result get <>) (iota 2)))
          db "SELECT v FROM Bool WHERE id = ?;")))

    (test-assert "null invariance"
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT ?;"])
        (sql-null? (first-result stmt (sql-null)))))

    (test "single value retrieval"
      "value"
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT 'value';"])
        (first-result stmt)))

    (test "single row retrieval"
      '(1 2 3)
      (with-database+statement ([db ":memory:"]
                                [stmt "SELECT 1, 2, 3;"])
        (first-row stmt)))

    (test-error "missing data detection"
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (foo);")
        (first-result db "SELECT * FROM Foo;")))

    (test "folding rows"
      42
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (v);")
        (call-with-temporary-statements
          (lambda (ins)
            (for-each (cut execute ins <>) '(23 19)))
          db "INSERT INTO Foo (v) VALUES (?);")
        (fold-row + 0 db "SELECT v FROM Foo;")))

    (test "mapping rows"
      '(2 4 6)
      (with-database [db ":memory:"]
        (execute db "CREATE TABLE Foo (v);")
        (call-with-temporary-statements
          (lambda (ins)
            (for-each (cut execute ins <>) '(1 2 3)))
          db "INSERT INTO Foo (v) VALUES (?);")
        (map-row (cut * 2 <>) db "SELECT v FROM Foo ORDER BY v ASC;")))

    (test "iterating over rows"
      '(#t #t #f #f)
      (let ([tab (make-hash-table)])
        (with-database [db ":memory:"]
          (execute db "CREATE TABLE Foo (v);")
          (call-with-temporary-statements
            (lambda (ins)
              (for-each (cut execute ins <>) '(1 2 3)))
            db "INSERT INTO Foo (v) VALUES (?);")
          (for-each-row (cut hash-table-set! tab <> #t) db "SELECT v FROM Foo;"))
        (map (cut hash-table-ref tab <> (lambda () #f)) '(1 2 5 7))))

    (test "change counting"
      '(0 1 1 2)
      (with-database [db ":memory:"]
        (let* ([c0 (update db "CREATE TABLE Foo (foo);")]
               [c1 (update db "INSERT INTO Foo (foo) VALUES (?);" 42)]
               [c2 (update db "UPDATE Foo SET foo = 2 * foo WHERE foo > ?;" 23)]
               [c3 (change-count db #t)])
          (list c0 c1 c2 c3))))

    (test "named parameters"
      42
      (with-database [db ":memory:"]
        (first-result db "SELECT ? * (:foo + :bar);" bar: 9 foo: 12 2)))

    (test-error "bad named parameter detection"
      (with-database [db ":memory:"]
        (first-result db "SELECT ? * (:foo + :bar);" 5 foo: 10 baz: 32)))

    (test-error "bad parameter count detection"
      (with-database [db ":memory:"]
        (first-result db "SELECT ? * (:foo + :bar);" foo: 10 bar: 12)))

    )

  (test-group "user defined functions"

    (test "collation sequences"
      '("bar" "foo" "qux")
      (with-database [db ":memory:"]
        (define-collation db "second_char"
          (lambda (a b)
            (-
              (char->integer (string-ref a 1))
              (char->integer (string-ref b 1)))))

        (execute db "CREATE TABLE Foo (v);")
        (call-with-temporary-statements
          (lambda (ins)
            (map (cut execute ins <>) '("foo" "qux" "bar")))
          db "INSERT INTO Foo (v) VALUES (?);")

        (map-row values db "SELECT v FROM Foo ORDER BY v COLLATE second_char;")))

    (test "simple functions"
      "It works!"
      (with-database [db ":memory:"]
        (define-function db "foo" 1
          (cut string-append "It " <> "!"))
        (first-result db "SELECT foo(?);" "works")))

    (test "aggregate functions"
      262144
      (with-database [db ":memory:"]
        (define-function db "expt" 1
          (lambda (s v) (expt v s)) 1)

        (execute db "CREATE TABLE Foo (v);")
        (call-with-temporary-statements
          (lambda (ins)
            (for-each (cut execute ins <>) (iota 5)))
          db "INSERT INTO Foo (v) VALUES (?);")

        (first-result db "SELECT expt(v) FROM Foo;")))

    )

  )

(print "Database memory still used: " (database-memory-used))
(print "Database memory high water mark: " (database-memory-highwater))

(test-exit)

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;