#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBD-JSQLITE.plt
;;
;; DBD Wrapper over jaymccarty/sqlite.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sqlite.ss - defines and registers the jsqlite driver.
;; yc 9/9/2009 - first version
;; yc 9/30/2009 - now creates implicit stored procedure and no longer uses SQL escape
;;                added support for serializing date (but not deserializing it back to date)
;; yc 10/1/2009 - fix the return of the query, so it returns the last-insert-rowid for insert statement
;;                and the result set now contains the column names for select statements.
;; yc 11/4/2009 - added jsqlite/effect & jsqlite/effect-set drivers
;; yc 11/5/2009 - default jsqlite to jsqlite/effect

(require (prefix-in dbd: (planet jaymccarthy/sqlite:4:5))
         (planet bzlib/base)
         (planet bzlib/dbi)
         (prefix-in s: srfi/19)
         )

(define (sqlite-connect driver path . attrs)
  (let-values (((loader attrs)
                (filter-file-loader/attrs attrs)))
  (let ((handle (make-handle driver (dbd:open path)
                             (make-immutable-hash-registry)
                             0)))
      (load-files! handle (if (list? loader) loader
                              (list loader)))
      handle)))

(define (sqlite-disconnect handle)
  ;; we need to free all of the values from the hash-registry...
  (hash-for-each (registry-table (handle-query handle))
                 (lambda (key prepared)
                   (dbd:finalize (prepared-inner prepared))))
  (dbd:close (handle-conn handle)))

(define (sqlite-query handle stmt (args '()))
  (define (run! query stmt)
    (dbd:run stmt))
  (define (insert! query stmt)
    (run! query stmt)
    (dbd:last-insert-rowid (handle-conn handle)))
  (define (select query stmt)
    (cons (dbd:statement-names stmt) 
          (dbd:step* stmt)))
  (define (exec! query stmt) 
    (apply dbd:load-params stmt (map cell->sql-cell (phq-map-values query args)))
    (begin0 (cond ((regexp-match #px"^(?i:select)" (phq-query query))
                   (select query stmt))
                  ((regexp-match #px"^(?i:insert)" (phq-query query))
                   (insert! query stmt))
                  (else
                   (run! query stmt)))
            (dbd:reset stmt)))
  (if-it (registry-ref (handle-query handle) stmt) ;; yes it exists!!!...
         (convert-result
          (exec! (prepared-query it) (prepared-inner it)))
         (begin
           (sqlite-prepare handle stmt stmt)
           (sqlite-query handle stmt args))))

(define (sqlite-query/effect handle stmt (args '())) 
  (define (helper rs) 
    (if (or (null? rs) (pair? rs)) 
        rs
        (let ((conn (handle-conn handle)))
          (make-effect (dbd:changes-count conn)
                       (let ((id (dbd:last-insert-rowid conn))) 
                         (if (= 0 id) #f id))
                       #f 
                       #f 
                       (dbd:errmsg conn)
                       (let ((v (dbd:errmsg conn)))
                         (if (equal? v "not an error")
                             #f
                             v))))))
  (helper (sqlite-query handle stmt args)))


(define (sqlite-query/effect-set handle stmt (args '()))
  (result-set-or-effect->result-set (sqlite-query/effect handle stmt args)))

;; if the query stmt is a path or an input-port... we'll convert it over...
(define (sqlite-prepare handle key stmt)
  (let ((query (make-place-holder-query question-converter stmt)))
    (registry-set! (handle-query handle)
                   key
                   (make-prepared query
                                  (dbd:prepare (handle-conn handle) (phq-converted query))))))

(define (convert-result result)
  (cond ((null? result) (void)) 
        ((pair? result)
         (map (lambda (rec)
                (map sql-cell->cell (vector->list rec)))
              result))
        (else result)))

(define (sql-cell->cell cell)
  (cond ((eq? #f cell) '())
        (else cell)))

(define (cell->sql-cell cell)
  (cond ((null? cell) #f)
        ((s:date? cell)
         (s:date->string cell "~Y-~m-~d ~H:~M:~S~z"))
        ;; I forgot why I have this line below...
        ;; ((and (number? cell) (exact? cell))
        ;; (exact->inexact cell))
        (else cell)))

(registry-set! drivers 'jsqlite/pass-thru-effect
               (make-driver sqlite-connect
                            sqlite-disconnect
                            sqlite-query
                            sqlite-prepare
                            default-begin
                            default-commit
                            default-rollback))

(registry-set! drivers 'jsqlite/effect
               (make-driver sqlite-connect
                            sqlite-disconnect
                            sqlite-query/effect
                            sqlite-prepare
                            default-begin
                            default-commit
                            default-rollback))

(registry-set! drivers 'jsqlite/effect-set
               (make-driver sqlite-connect
                            sqlite-disconnect
                            sqlite-query/effect-set
                            sqlite-prepare
                            default-begin
                            default-commit
                            default-rollback))

(registry-set! drivers 'jsqlite (registry-ref drivers 'jsqlite/effect))