;;; -*- Mode: Scheme -*-

;;;; SQLite3 Interface

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; 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 names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.

(begin-c-stub "sqlite3")

(c-system-include "sqlite3.h")

(define-c-constant-enumeration sqlite3-status-code "int"
  (OK                   "SQLITE_OK")
  (ERROR                "SQLITE_ERROR")
  (INTERNAL             "SQLITE_INTERNAL")
  (PERMISSION           "SQLITE_PERM")
  (ABORT                "SQLITE_ABORT")
  (BUSY                 "SQLITE_BUSY")
  (LOCKED               "SQLITE_LOCKED")
  (NO-MEMORY            "SQLITE_NOMEM")
  (READ-ONLY            "SQLITE_READONLY")
  (INTERRUPT            "SQLITE_INTERRUPT")
  (I/O-ERROR            "SQLITE_IOERR")
  (CORRUPT              "SQLITE_CORRUPT")
  (NOT-FOUND            "SQLITE_NOTFOUND")
  (FULL                 "SQLITE_FULL")
  (CANT-OPEN            "SQLITE_CANTOPEN")
  (PROTOCOL             "SQLITE_PROTOCOL")
  (EMPTY                "SQLITE_EMPTY")
  (SCHEMA               "SQLITE_SCHEMA")
  (TOO-BIG              "SQLITE_TOOBIG")
  (CONSTRAINT           "SQLITE_CONSTRAINT")
  (MISMATCH             "SQLITE_MISMATCH")
  (NO-LARGE-FILES       "SQLITE_NOLFS")
  (AUTHORIZATION        "SQLITE_AUTH")
  (FORMAT               "SQLITE_FORMAT")
  (RANGE                "SQLITE_RANGE")
  (NOT-A-DATABASE       "SQLITE_NOTADB")
  (ROW                  "SQLITE_ROW")
  (DONE                 "SQLITE_DONE")
  )

;;;; Databases

(define-record-type <sqlite3-database>
    (%make-sqlite3-database descriptor)
    sqlite3-database?
  (descriptor sqlite3-database.descriptor set-sqlite3-database.descriptor!))

(define (make-sqlite3-database)
  (let* ((descriptor (make-sqlite3-descriptor))
         (database (%make-sqlite3-database descriptor)))
    (finalizer/add-object! sqlite3-database-finalizer database descriptor)
    database))

(define (sqlite3-close database)
  (finalizer/remove-object! sqlite3-database-finalizer database))

(define (call-with-sqlite3-database-descriptor database receiver)
  (let ((descriptor (sqlite3-database.descriptor database)))
    (if (not descriptor)
        (error "Closed SQLite3 database:" database))
    (with-object-referenced database
      (lambda ()
        (receiver descriptor)))))

(define (call-with-sqlite3-database-alien database receiver)
  (call-with-sqlite3-database-descriptor database
    (lambda (descriptor)
      (receiver (sqlite3-descriptor.alien descriptor)))))

(define (call-with-sqlite3-database-statement-finalizer database receiver)
  (call-with-sqlite3-database-descriptor database
    (lambda (descriptor)
      (receiver (sqlite3-descriptor.statement-finalizer descriptor)))))

(define-record-type <sqlite3-descriptor>
    (%make-sqlite3-descriptor alien statement-finalizer)
    sqlite3-descriptor?
  (alien sqlite3-descriptor.alien)
  (statement-finalizer sqlite3-descriptor.statement-finalizer))

(define (make-sqlite3-descriptor)
  (%make-sqlite3-descriptor (allocate-sqlite3-database-alien)
                            (make-sqlite3-statement-finalizer)))

(define-c (allocate-sqlite3-database-alien)
  (c-alien "sqlite3 *" "0"))

(define sqlite3-database-finalizer
  (make-default-finalizer
   (lambda (descriptor) (%sqlite3-close descriptor))
   (lambda (object) (sqlite3-database? object))
   (lambda (database descriptor)
     (set-sqlite3-database.descriptor! database descriptor))))

(define (%sqlite3-close descriptor)
  (finalizer/clear! (sqlite3-descriptor.statement-finalizer descriptor))
  (let* ((database-alien (sqlite3-descriptor.alien descriptor))
         (status-code (%%sqlite3-close database-alien)))
    (if (not (eqv? status-code (sqlite3-status-code OK)))
        (error "Error while closing SQLite3 database:"
               (%sqlite3-database-error-message database-alien)))))

(define-c (%%sqlite3-close (database-pointer (c-alien-pointer "sqlite3 *")))
  (c-declare "int status;")
  (c-begin
    "if ((*database_pointer) == 0)                      "
    "  status = SQLITE_OK;                              "
    "else                                               "
    "  {                                                "
    "    status = (sqlite3_close (*database_pointer));  "
    "    if (status == SQLITE_OK)                       "
    "      (*database_pointer) = 0;                     "
    "  }                                                "
    (c-sqlite3-status-code "status")))

(define (sqlite3-call-error database status-code procedure . arguments)
  (error (sqlite3-database-error-message database)
         status-code
         (cons procedure arguments)))

(define (sqlite3-database-error-message database)
  (call-with-sqlite3-database-alien database %sqlite3-database-error-message))

(define-c (%sqlite3-database-error-message (database (c-alien "sqlite3 *")))
  (c-copied-asciz-utf-8-string "sqlite3_errmsg (database)"))

(define (sqlite3-database-error-code database)
  (call-with-sqlite3-database-alien database %sqlite3-database-error-code))

(define-c (%sqlite3-database-error-code (database (c-alien "sqlite3 *")))
  (c-sqlite3-status-code "sqlite3_errcode (database)"))

(define (sqlite3-open pathname)
  (let* ((database (make-sqlite3-database))
         (status-code
          (call-with-sqlite3-database-alien database
            (lambda (database-alien)
              (%sqlite3-open pathname database-alien)))))
    (if (eqv? status-code (sqlite3-status-code OK))
        database
        (let ((message (sqlite3-database-error-message database)))
          (sqlite3-close database)
          (error "Error opening SQLite3 database:"
                 status-code message pathname)))))

(define-c (%sqlite3-open
           (pathname            c-immutable-asciz-utf-8-string)
           (database-pointer    (c-alien-pointer "sqlite3 *")))
  (c-sqlite3-status-code "sqlite3_open (pathname, database_pointer)"))

;;;; Statements (what should be called `queries')

(define-record-type <sqlite3-statement>
    (%make-sqlite3-statement database alien)
    sqlite3-statement?
  (database sqlite3-statement.database)
  (alien sqlite3-statement.alien set-sqlite3-statement.alien!))

(define (make-sqlite3-statement database)
  (let* ((alien (allocate-sqlite3-statement-alien))
         (statement
          (%make-sqlite3-statement database alien)))
    (call-with-sqlite3-database-statement-finalizer database
      (lambda (finalizer)
        (finalizer/add-object! finalizer statement alien)))
    statement))

(define (call-with-sqlite3-statement-alien statement receiver)
  (let ((alien (sqlite3-statement.alien statement)))
    (if (not alien)
        (error "Finalized SQLite3 statement:" statement))
    (with-object-referenced statement
      (lambda ()
        (receiver alien)))))

(define-c (allocate-sqlite3-statement-alien)
  (c-alien "sqlite3_stmt *" "0"))

(define (make-sqlite3-statement-finalizer)
  (make-default-finalizer
   (lambda (alien) (%sqlite3-finalize alien))
   (lambda (object) (sqlite3-statement? object))
   (lambda (statement alien) (set-sqlite3-statement.alien! statement alien))))

(define (%sqlite3-finalize alien)
  (let ((status-code (%%sqlite3-finalize alien)))
    (if (not (eqv? status-code (sqlite3-status-code OK)))
        (error "Error during finalization of SQLite3 statement:"
               status-code alien))))

(define-c (%%sqlite3-finalize
           (statement-pointer (c-alien-pointer "sqlite3_stmt *")))
  (c-declare "int status;")
  (c-begin
    "if ((*statement_pointer) == 0)                             "
    "  status = SQLITE_OK;                                      "
    "else                                                       "
    "  {                                                        "
    "    status = (sqlite3_finalize (*statement_pointer));      "
    "    if (status == SQLITE_OK)                               "
    "      (*statement_pointer) = 0;                            "
    "  }                                                        "
    (c-sqlite3-status-code "status")))

(define (sqlite3-prepare database sql-string)
  (let* ((statement (make-sqlite3-statement database))
         (status-code
          (call-with-sqlite3-database-alien database
            (lambda (database-alien)
              (call-with-sqlite3-statement-alien statement
                (lambda (statement-alien)
                  (%sqlite3-prepare database-alien
                                    sql-string
                                    statement-alien)))))))
    (if (eqv? status-code (sqlite3-status-code OK))
        statement
        (begin
          (call-with-sqlite3-database-statement-finalizer database
            (lambda (finalizer)
              (finalizer/remove-object! finalizer statement)))
          (error "Error preparing SQLlite3 statement:"
                 status-code database sql-string)))))

(define-c (%sqlite3-prepare
           (database            (c-alien "sqlite3 *"))
           (sql-string          c-immutable-asciz-utf-8-string)
           (statement-pointer   (c-alien-pointer "sqlite3_stmt *")))
  (c-declare "const char *t = 0;")
  (c-sqlite3-status-code
   "sqlite3_prepare_v2 (database, sql_string, (-1), statement_pointer, (&t))"))

(define (sqlite3-step statement)
  (let ((status-code
         (call-with-sqlite3-statement-alien statement %sqlite3-step)))
    (cond ((or (eqv? status-code (sqlite3-status-code OK))
               (eqv? status-code (sqlite3-status-code BUSY))
               (eqv? status-code (sqlite3-status-code DONE))
               (eqv? status-code (sqlite3-status-code ROW)))
           status-code)
          (else
           (sqlite3-call-error (sqlite3-statement.database statement)
                               status-code
                               'SQLITE3-STEP
                               statement)))))

(define-c (%sqlite3-step (statement (c-alien "sqlite3_stmt *")))
  (c-sqlite3-status-code "sqlite3_step (statement)"))

;;; This does not signal any error; SQLITE3-STEP will have done so.

(define (sqlite3-reset statement)
  (call-with-sqlite3-statement-alien statement %sqlite3-reset))

(define-c (%sqlite3-reset (statement (c-alien "sqlite3_stmt *")))
  (c-sqlite3-status-code "sqlite3_reset (statement)"))

(define (sqlite3-finalize statement)
  (call-with-sqlite3-database-statement-finalizer
      (sqlite3-statement.database statement)
    (lambda (finalizer)
      (finalizer/remove-object! finalizer statement))))

(define-c-constant-enumeration sqlite3-type "int"
  (INTEGER      "SQLITE_INTEGER")
  (FLOAT        "SQLITE_FLOAT")
  (BLOB         "SQLITE_BLOB")
  (NULL         "SQLITE_NULL")
  (TEXT         "SQLITE3_TEXT"))

(define-c-integral-conversion c-sqlite3-column "int")

(define (sqlite3-column-type statement column)
  (call-with-sqlite3-statement-alien statement
    (lambda (alien)
      (%sqlite3-column-type alien column))))

(define-c (%sqlite3-column-type (statement      (c-alien "sqlite3_stmt *"))
                                (column         c-sqlite3-column))
  (c-sqlite3-type "sqlite3_column_type (statement, column)"))

(define-record-type <sqlite3-blob>
    (make-sqlite3-blob alien bytes)
    sqlite3-blob?
  (alien sqlite3-blob.alien)
  (bytes sqlite3-blob.bytes))

;++ Do something with the blobs...

(define-c (%sqlite3-column-blob (statement      (c-alien "sqlite3_stmt *"))
                                (column         c-sqlite3-column))
  (c-declare "const void *blob = 0;     "   ; Order matters for the following
             "int bytes = 0;            ")  ; calls, due to SQLite3 silliness.
  (c-begin "blob = (sqlite3_column_blob (statement, column));"
           "bytes = (sqlite3_column_bytes (statement, column));"
           (c-values (c-alien "const void *" "blob")
                     (c-integral "int" "bytes")))
  make-sqlite3-blob)

(define (sqlite3-zero-column statement column caller value)
  (if (zero? value)
      (let* ((database (sqlite3-statement.database statement))
             (status-code (sqlite3-database-error-code database)))
        (if (eqv? status-code (sqlite3-status-code OK))
            value
            (sqlite3-call-error database status-code caller statement column)))
      value))

(define (sqlite3-column-integer statement column)
  (sqlite3-zero-column statement column 'SQLITE3-COLUMN-INTEGER
    (call-with-sqlite3-statement-alien statement
      (lambda (alien)
        (%sqlite3-column-integer alien column)))))

(define-c (%sqlite3-column-integer (statement   (c-alien "sqlite3_stmt *"))
                                   (column      c-sqlite3-column))
  (c-integral "int" "sqlite3_column_int (statement, column)"))

(define (sqlite3-column-floating-point statement column)
  (sqlite3-zero-column statement column 'SQLITE3-COLUMN-FLOATING-POINT
    (call-with-sqlite3-statement-alien statement
      (lambda (alien)
        (%sqlite3-column-floating-point alien column)))))

(define-c (%sqlite3-column-floating-point
           (statement   (c-alien "sqlite3_stmt *"))
           (column      c-sqlite3-column))
  (c-floating-point "double" "sqlite3_column_double (statement, column)"))

(define-c-callback sqlite3-exec-callback
    ("void *callback_env" "int columns" "char **values" "char **names")
    (=> c-boolean "int")
  ("callback_env"
   (c-integral "int" "columns")
   (c-array-elements->vector "char *" "values" "columns"
                             "value" (c-copied-asciz-utf-8-string "value"))
   (c-array-elements->vector "char *" "names" "columns"
                             "name" (c-copied-asciz-utf-8-string "name"))))

(define (sqlite3-exec database sql-string receiver)
  (let ((status-code
         (call-with-sqlite3-database-alien database
           (lambda (alien)
             (%sqlite3-exec alien sql-string receiver)))))
    (cond ((eqv? status-code (sqlite3-status-code OK))
           #f)
          ((eqv? status-code (sqlite3-status-code ABORT))
           #t)
          (else
           (sqlite3-call-error database status-code
                               'SQLITE3-EXEC database sql-string receiver)))))

(define-c-with-callbacks
    (%sqlite3-exec (database    (c-alien "sqlite3 *"))
                   (sql-string  c-immutable-asciz-utf-8-string)
                   (procedure
                    (c-local-callback sqlite3-exec-callback "callback_code"
                                      "void *" "callback_env")))
  (c-sqlite3-status-code
   "sqlite3_exec (database, sql_string, callback_code, callback_env, 0)"))

(end-c-stub)