#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBI.plt
;;
;; database interface abstraction.  Inspired by Perl DBI.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pool.ss - provides a database pool management interface.
;; yc 9/8/2009 - first version
(require (planet bzlib/base)
         (planet bzlib/thread)
         "base.ss"
         "app.ss"
         )

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pool.ss
;;
;; a simpler version of database pool... instead of having the master pool
;; thread managing the access, each thread will have its own database connection (app
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; consumed
(define-struct consumed (thd handle)
  #:property prop:evt
  (lambda (self)
    (wrap-evt (thread-dead-evt (consumed-thd self))
              (lambda (x) self))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; helper
;; the main procedure to manage pool & requests...
(define (helper pool busy queue call-args remaining)
  (receive/match busy 
                 ((list (? thread? thd) (list 'connect)) ;; a call...
                  (handle-connect thd pool busy queue call-args remaining))
                 ((list 'new-consumed new)
                  (helper pool (cons new busy) queue call-args remaining))
                 (sync
                  ((? consumed? freed) 
                   (handle-freed freed pool busy queue call-args remaining)))
                 ))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-connect
(define (handle-connect thd pool busy queue call-args remaining)
  (cond-it ((memf (lambda (consumed)
                    (eq? (consumed-thd consumed) thd))
                  busy)
            (thread-reply thd (consumed-handle (car it)))
            (helper pool busy queue call-args remaining))
           ((not (null? pool)) ;; we have free database connection...
            (thread-reply thd (car pool)) ;; now car pool is busy.
            (helper (cdr pool) (cons (make-consumed thd (car pool)) busy) queue call-args remaining))
           ((> remaining 0) ;; we have not reached maximum connections...
            (let ((handle (apply connect 'app #f call-args)))
              (thread-reply thd handle)
              (helper pool (cons (make-consumed thd handle) busy) queue call-args (sub1 remaining))))
           (else ;; we'll have to wait for a consumed connection become free...
            (helper pool busy (append queue (list thd)) call-args remaining))))
;; (trace handle-connect)

(define (reset-conn! conn)
  (app-cast (handle-conn conn) 'reset! (current-thread)))

(define (handle-freed freed pool busy queue call-args remaining)
  (let ((busy (remove freed busy))
        (conn (consumed-handle freed)))
    (reset-conn! conn) ;; ensure the conneciton is "reset"...
    (cond ((not (null? queue))
           (thread-reply (car queue) conn)
           (helper pool (cons (make-consumed (car queue) conn) busy)
                   (cdr queue) call-args remaining))
          (else
           ((current-log) 'bzl/sys/dbi/pool2 "connection freed")
           (helper (cons conn pool) busy queue call-args remaining)))))

(define (make-pool count args)
  (make-app (thread (lambda ()
                      (helper '() '() '() args count)))))

(define (pool-connect driver count . args)
  (make-handle driver
               (make-pool count args)
               #f
               0))

;; this should do a broadcast!!
(define (pool-disconnect handle)
  (void))

;; pool2 is special - the only query it takes is 'connect
(define (pool-query handle stmt args)
  (if (equal? stmt 'connect)
      (app-call (handle-conn handle) 'connect)
      (error 'pool2 "unsupported statement for pool2: ~a" stmt)))

;; this function would causes some issues... because it should do a "broadcast"!!
(define (pool-prepare handle key stmt)
  (error 'pool2 "prepare unsupported"))

(define (pool-begin handle)
  (error 'pool2 "begin-trans unsupported"))

(define (pool-commit handle)
  (error 'pool2 "commit unsupported"))

(define (pool-rollback handle)
  (error 'pool2 "rollback unsupported"))

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