base.ss
#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
(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)) 

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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")))

(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)
                        ))
 (current-handle (parameter/c handle?))
 (connect (->* (symbol?)
               ()
               #:rest (listof any/c)
               handle?))
 (disconnect (-> handle? any))
 (prepare (-> handle? symbol? string? any))
 (query (-> handle? (or/c symbol? string?) (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))
 )