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