#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBI.plt
;;
;; database interface abstraction.  Inspired by Perl DBI.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle.ss - provides high level database handling functions.
;; yc 9/8/2009 - first version
;; yc 10/1/2009 - ensure non recordset values do not cause query helper functions to error
;; yc 11/4/2009 - add run-script!
(require scheme/contract
         mzlib/trace
         "base.ss"
         (planet bzlib/base)
         (rename-in scheme/base (list identity*))
         scheme/file
         )
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic set of processing that'll handle the values...

;; headless
(define (headless recordset)
  (cond ((null? recordset) recordset)
        ((pair? recordset) (cdr recordset))
        (else '())))

;; (trace headless)

;; useful for active-record pattern.
(define (bind-handle handle proc)
  (lambda args
    (apply proc handle args))) 

(define (exec handle key (args '()))
  (query handle key args)) 

(define (rows handle key (args '()) (converter identity*))
  (map (lambda (args)
         (apply converter args))
       (headless (query handle key args))))

;; (trace rows)

(define (row handle key (args '())
             (converter identity*)
             (default (lambda ()
                        (error 'query "no result returned"))))
  (define (return)
    (if (procedure? default) (default)
        default)) 
  (let ((it (rows handle key args converter)))
    (if (null? it) (return)
        (car it))))
;; (trace row)

(define (row/false handle key (args '()) (converter identity*))
  (row handle key args converter #f))

(define (exists? handle key (args '()) (converter identity*))
  (row/false handle key args converter))

;; can a row return nothing???
;; a cell - we want to get a return of the value that we can make use of easily
;; 1 - we need the row to return safely... what's a good default value?
;; 2 - as there is no
(define (cell handle key (args '())
              (converter identity*)
              (default (lambda ()
                         (error 'cell "no result returned"))))
  (if-it (row handle key args converter #f)
         (car it)
         (if (procedure? default)
             (default)
             default)))

(define (cell/null handle key (args '()) (converter identity*))
  (cell handle key args converter '()))

(define (cell/false handle key (args '()) (converter identity*))
  (cell handle key args converter #f))

(define (run-script! handle path (args '())) 
  (define (path-helper path) 
    (regexp-split #px";" (file->string path)))
  (for-each (lambda (stmt) 
              (exec handle stmt args))
            (path-helper path)))

(provide/contract
 (exec (->* (handle? dbi-key/statement/c)
            ((listof any/c))
            any))
 (rows (->* (handle? dbi-key/statement/c)
            ((listof any/c) procedure?)
            any))
 (row (->* (handle? dbi-key/statement/c)
           ((listof any/c)
            procedure?
            any/c)
           any))
 (row/false (->* (handle? dbi-key/statement/c)
           ((listof any/c) procedure?)
           any))
 (exists? (->* (handle? dbi-key/statement/c)
               ((listof any/c) procedure?)
               any))
 (cell (->* (handle? dbi-key/statement/c)
            ((listof any/c) procedure?
             any/c)
            any))
 (cell/null (->* (handle? dbi-key/statement/c)
                 ((listof any/c) procedure?)
                 any))
 (cell/false (->* (handle? dbi-key/statement/c)
                  ((listof any/c) procedure?)
                  any))
 (run-script! (->* (handle? path-string?) 
                   ((listof any/c))
                   any))
 (bind-handle (-> handle? procedure? procedure?))
 )


;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; with-trans...
(define-syntax with-trans
  (syntax-rules ()
    ((_ (handle h2 ...) exp ... exp2)
     (with-handlers ((exn?
                      (lambda (e)
                        (rollback handle)
                        (rollback h2) ...
                        (raise e))))
       (begin-trans handle)
       (begin-trans h2) ...
       exp ...
       (begin0
           exp2
         (commit handle)
         (commit h2) ...)))
    ))

(provide with-trans)