newlisp-redis / redis.lsp

Full commit
;; @module redis
;; @description newLISP bindings for the Redis database ( )
;; @version 0.1
;; @author Nikhil Marathe <> 2010
;; @homepage @link
;; This module provides bindings to Redis. It communicates
;; with the Redis server and returns values in appropriate
;; lisp-y types.
;; @example
;; (setf 'redis (redis:connect))
;; (redis:ping redis)
;; => "+PONG"

(context 'redis)

(constant 'CRLF "\r\n")
(constant 'BUFSIZE 4096)

// transformed from redis-node-client + ping and quit
(constant 'inline-commands 
  '("auth" "bgsave" "dbsize" "decr" "decrby" "del"
    "exists" "expire" "flushall" "flushdb" "get" "incr" "incrby" "info"
    "keys" "lastsave" "lindex" "llen" "lpop" "lrange" "ltrim" "mget"
    "move" "ping" "quit" "randomkey" "rename" "renamenx" "rpop" "save" "scard" "sdiff"
    "sdiffstore" "select" "shutdown" "sinter" "sinterstore" "smembers"
    "spop" "srandmember" "sunion" "sunionstore" "ttl" "type"
    "zrange" "zrevrange" "zcard" "zrangebyscore"))

(define (make-inline-command command)
  (letex ((fname (sym command)) (cmd command))
        (define (fname r)
          (letn ( (args-as-strings (map (fn (x) (string x)) (args)))
                  (command-string (join (cons (upper-case cmd) args-as-strings) " ")) )
              (:query r (append command-string redis:CRLF))))))

(context MAIN)

;; @syntax (redis <host> <port>)
;; Creates a new connection to a Redis instance
;; @return a new connection object or nil on error
(define (redis:redis (host "localhost") (port 6379))
  (let (sock (net-connect host port))
    (if (nil? sock)
      (list redis sock ""))))

(define (redis:close r)
  (:quit r)
  (net-close (r 1) true))

(define (redis:query r command-str)
  (net-send (r 1) (append command-str redis:CRLF))
  (net-receive (r 1) buf redis:BUFSIZE)
  (write-buffer (r 2) buf)
  (:handle-reply r))

(define (redis:handle-reply r , reply)
  (while (> (length (r 2)) 0)
    (setf reply
        (case (first (r 2))
          ("+" (:handle-single-reply r))
          ("-" (:handle-error r))
          ("$" (:handle-bulk-reply r))
          ("*" (:handle-multi-bulk-reply r))
          (":" (:handle-integer-reply r))
          (true (:handle-unknown-reply r))))
    (setf (r 2) ((reply 1) (r 2)))
    (reply 0)))

(define (redis:handle-single-reply r)
  (letn ((trimm (chop (r 2) 2))
         (message (1 trimm)))
    (list message (length (r 2)))))

(define (redis:handle-bulk-reply r)
  (list (r 2) (length (r 2))))

(define (redis:handle-error r)
  (throw-error (1 (chop (r 2) 2))))

(define (redis:handle-integer-reply r)
  (let (num (int (1 (r 2)))) 
    (if (nil? num)
      (throw-error (append "Invalid integer reply:" (r 2)))
      (list (int num) (length (r 2))))))

(dolist (x redis:inline-commands)
  (redis:make-inline-command x))