#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBI.plt
;;
;; database interface abstraction.  Inspired by Perl DBI.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; base.plt - holds the basic structures of database interface
;; yc 9/8/2009 - first version
;; yc 11/4/2009 - adding effect structure...
;; yc 11/5/2009 - making the args for (query handle stmt args) to be optional

(require (planet bzlib/base)
         )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; driver
(define-struct driver (connect disconnect query prepare begin commit rollback))

(define-struct handle (driver conn query (trans #:mutable))) 

(define-struct prepared (query inner))

(define-struct phq (query converted args) #:prefab)

(define-struct active-record (handle id)) 

;; mysql.ss has the best side-effect structures...
#|
(define-struct (side-effect query-result)
  (affected-rows
   insert-id
   server-status
   warning-count
   message))
;;|#
(define-struct effect (rows insert-id status warning-count message error))

(define (result-set-or-effect->result-set rs)
  (define (helper v) 
    (if (not v) 
        null 
        v))
  (cond ((effect? rs) 
         (list (list "affected rows" "insert id" "status" 
                     "warning count" "message" "error")
               (map helper (list (effect-rows rs)
                                 (effect-insert-id rs)
                                 (effect-status rs)
                                 (effect-warning-count rs)
                                 (effect-message rs)
                                 (effect-error rs)))))
          (else rs)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; current-handle
;; is there a fake handle???
(define (false-driver . args)
  (error 'false-driver! "this is not a true DBI driver - please instantiate one"))

(define current-handle (make-parameter
                        (make-handle (make-driver false-driver
                                                  false-driver
                                                  false-driver
                                                  false-driver
                                                  false-driver
                                                  false-driver
                                                  false-driver)
                                     #f
                                     #f
                                     0)))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; drivers
;; registry for all loaded drivers - identified by name
(define drivers (make-immutable-hash-registry))

(define (connect key . args)
  (if-it (registry-ref drivers key)
         (apply (driver-connect it) it args)
         (error 'connect "Unknown driver ~a" key)))

(define (disconnect handle)
  ((driver-disconnect (handle-driver handle)) handle))

(define (query handle stmt (args '()))
  ((driver-query (handle-driver handle)) handle stmt args))

;; (trace query)

(define (prepare handle key stmt)
  ((driver-prepare (handle-driver handle)) handle key stmt))

(define (begin-trans handle)
  ((driver-begin (handle-driver handle)) handle))

(define (commit handle)
  ((driver-commit (handle-driver handle)) handle))

(define (rollback handle)
  ((driver-rollback (handle-driver handle)) handle))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(define (default-begin handle)
  (when (= (handle-trans handle) 0)
    (query handle "begin"))
  (set-handle-trans! handle (add1 (handle-trans handle))))

(define (default-commit handle)
  (when (> (handle-trans handle) 0)
    (set-handle-trans! handle (sub1 (handle-trans handle))))
  (when (= (handle-trans handle) 0)
    (query handle "commit")))

(define (default-rollback handle)
  (when (> (handle-trans handle) 0)
    (set-handle-trans! handle (sub1 (handle-trans handle))))
  (when (= (handle-trans handle) 0)
    (query handle "rollback")))

(define dbi-statement/c path-string?)

(define dbi-key/statement/c (or/c symbol? dbi-statement/c))

(provide/contract
 (struct driver ((connect procedure?)
                 (disconnect procedure?)
                 (query procedure?)
                 (prepare procedure?)
                 (begin procedure?)
                 (commit procedure?)
                 (rollback procedure?)))
 (drivers registry?)
 (struct handle ((driver driver?)
                 (conn any/c)
                 (query (or/c false/c registry?))
                 (trans exact-nonnegative-integer?)))
 (struct phq ((query string?) (converted string?) (args (listof symbol?))))
 (struct prepared ((query phq?)
                   (inner any/c)))
 (struct active-record ((handle (or/c false/c handle?))
                        (id any/c)
                        ))
 (struct effect ((rows (or/c false/c exact-nonnegative-integer?))
                 (insert-id (or/c false/c exact-nonnegative-integer?))
                 (status any/c) 
                 (warning-count any/c)
                 (message any/c)
                 (error any/c)))
 (result-set-or-effect->result-set (-> any/c any))
 (current-handle (parameter/c handle?))
 (connect (->* (symbol?)
               ()
               #:rest (listof any/c)
               handle?))
 (disconnect (-> handle? any))
 (prepare (-> handle? dbi-key/statement/c dbi-statement/c any))
 (query (->* (handle? dbi-key/statement/c) 
             ((listof any/c)) 
             any))
 (begin-trans (-> handle? any))
 (commit (-> handle? any))
 (rollback (-> handle? any))
 (default-begin (-> handle? any))
 (default-commit (-> handle? any))
 (default-rollback (-> handle? any))
 )

(provide dbi-statement/c dbi-key/statement/c)