driver.ss
#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DBD-MEMCACHED - DBI interface to memcached in both single & multi-instance mode.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; driver.ss - bindings to DBI
;; yc 9/23/2009 - first version
(require (planet bzlib/base) 
         (planet bzlib/dbi)
         "memcached.ss"
         "dht.ss")

(define (m-connect driver host port)
  (make-handle driver (memcached-connect host port) (make-immutable-hash-registry) 0))

(define (m-disconnect handle)
  (memcached-disconnect (handle-conn handle)))

(define (m-prepare handle stmt)
  (void)) 

(define (make-query set! add! replace! append! prepend! cas! get gets delete! incr! decr! flush-all!)
  (lambda (handle stmt (args '()))
    (let ((client (handle-conn handle)))
      (case stmt 
        ((set! add! replace! append! prepend!)
         (let/assert! ((key (assoc/cdr 'key args))
                       (value (assoc/cdr 'value args))
                       (flags (assoc/cdr 'flags args 0))
                       (exp-time (assoc/cdr 'exp-time args 0)))
                      ((case stmt
                         ((set!) set!)
                         ((add!) add!)
                         ((replace!) replace!)
                         ((append!) append!)
                         ((prepend!) prepend!))
                       client key value 
                       #:exp-time exp-time #:flags flags 
                       #:noreply? (assoc/cdr 'noreply? args))))
        ((cas!)
         (let/assert! ((key (assoc/cdr 'key args))
                       (value (assoc/cdr 'value args))
                       (cas (assoc/cdr 'cas args))
                       (flags (assoc/cdr 'flags args 0))
                       (exp-time (assoc/cdr 'exp-time args 0)))
                      (cas! client key value cas
                                      #:exp-time exp-time #:flags flags #:noreply? (assoc/cdr 'noreply? args))))
        ((get gets)
         (cons (list "key" "value" "flags" "cas")
               (apply (case stmt
                        ((get) get)
                        ((gets) gets))
                      client (map cdr (filter (lambda (kv)
                                                (equal? (car kv) 'key))
                                              args)))))
        ((delete!)
         (let/assert! ((key (assoc/cdr 'key args))
                       (delay (assoc/cdr 'delay args 0)))
                      (delete! client key delay (assoc/cdr 'noreply? args))))
        ((incr! decr!)
         (let/assert! ((key (assoc/cdr 'key args))
                       (value (assoc/cdr 'value args)))
                      ((case stmt
                         ((incr!) incr!)
                         ((decr!) decr!))
                       client key value (assoc/cdr 'noreply? args))))
        ((flush-all!) 
         (let/assert! ((delay (assoc/cdr 'key args 10)))
                      (flush-all! client delay (assoc/cdr 'noreply? args))))
        (else
         (error 'query "invalid stmt: ~a" stmt))))))

(define m-query 
  (make-query memcached-set!
              memcached-add!
              memcached-replace!
              memcached-append!
              memcached-prepend!
              memcached-cas!
              memcached-get
              memcached-gets
              memcached-delete!
              memcached-incr!
              memcached-decr!
              memcached-flush-all!))

(define (no-begin handle) (void))

(define (no-commit handle) (void))

(define (no-rollback handle) (void))

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


(define (dht-connect driver host . rest)
  (make-handle driver (apply memcached/dht-connect (cons host rest)) (make-immutable-hash-registry) 0))

(define (dht-disconnect handle)
  (memcached/dht-disconnect (handle-conn handle)))

(define (dht-prepare handle stmt)
  (void)) 

(define dht-query 
  (make-query memcached/dht-set!
              memcached/dht-add!
              memcached/dht-replace!
              memcached/dht-append!
              memcached/dht-prepend!
              memcached/dht-cas!
              memcached/dht-get
              memcached/dht-gets
              memcached/dht-delete!
              memcached/dht-incr!
              memcached/dht-decr!
              memcached/dht-flush-all!))

(registry-set! drivers 'memcached/dht
               (make-driver dht-connect
                            dht-disconnect
                            dht-query
                            dht-prepare
                            no-begin
                            no-commit
                            no-rollback))