#lang scheme/base
(require (planet bzlib/base)
)
(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))
(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)))
(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))
(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))
)