#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBI.plt
;;
;; database interface abstraction.  Inspired by Perl DBI.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; app.ss - provide a kill-safe + erlang-style application interface to database handle.
;; yc 9/8/2009 - first version
(require "base.ss"
         "query.ss"
         (planet bzlib/thread)
         (planet bzlib/base)
         )

;; I do not need to specifically need a different handle...
;; what I need is to delegate all calls within to the inner object, which
;; is automatically handled in an app setting...

(define (worker conn cmd . args)
  (define (helper)
    (case cmd
      ((connect) connect)
      ((disconnect) disconnect)
      ((prepare) prepare)
      ((query) query)
      ((begin-trans) begin-trans)
      ((commit) commit)
      ((rollback) rollback)
      (else (error 'async-handle "unknown command ~a" cmd))))
  ;; (trace helper)
  (apply (helper) conn args))

;; (trace worker)

(define (call-worker thd args state)
  (cons (apply worker state args)
        state)) 
;; (trace call-worker)

(define (make-handler-app conn pool)
  (define (helper conn)
    (receive/match
     ((list (? thread? thd) args)
      (with-handlers ((exn?
                       (lambda (e)
                         (send-exn-to e thd)
                         (helper conn))))
        (let ((v (call-worker thd args conn)))
          (thread-reply thd (car v))
          (helper (cdr v)))))
     ((list (list (? thread? thd) args)) ;; cast mode...
      (with-handlers ((exn?
                       (lambda (e)
                         (send-exn-to e thd pool)
                         (helper conn))))
        (let ((v (call-worker thd args conn)))
          (thread-reply thd (car v) pool)
          (helper (cdr v)))))
     ;; in a pooled setting, this is called whenever the caller
     ;; thread died and we need to ensure there are no dandling
     ;; transactions...
     ((list (list 'reset! (? thread? thd))) 
      (while (> (handle-trans conn) 0)
        (rollback conn))
      (helper conn))
     ))
  (make-app (thread
             (lambda ()
               (helper conn)))))
;; (trace make-handler-app)

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the basic interface for app
(define (app-connect driver pool key . attrs)
  (make-handle driver 
               (make-handler-app (apply connect key attrs) pool)
               #f
               0))

(define (app-disconnect handle)
  (app-call (handle-conn handle) 'disconnect))

(define (app-prepare handle key stmt)
  (app-call (handle-conn handle) 'prepare key stmt))

(define (app-query handle stmt args)
  (app-call (handle-conn handle) 'query stmt args))

(define (app-begin handle)
  (app-call (handle-conn handle) 'begin-trans))
;; (trace app-begin)

(define (app-rollback handle)
  (app-call (handle-conn handle) 'rollback))
;; (trace app-rollback)

(define (app-commit handle)
  (app-call (handle-conn handle) 'commit))
;; (trace app-commit)

(registry-set! drivers 'app
               (make-driver app-connect
                            app-disconnect
                            app-query
                            app-prepare
                            app-begin
                            app-commit
                            app-rollback))