;;; redis.rkt ;;; ;;; Implements an interface to the redis persistent key-value ;;; database. Communicates with the database through its TCP ;;; interface. #lang racket (require racket/date) (define-struct connection (in out cust)) (define (connect) (let ([cust (make-custodian)]) (parameterize ([current-custodian cust]) (let-values ([(in out) (tcp-connect "localhost" 6379)]) (make-connection in out cust))))) (define current-connection (make-parameter (connect))) (define (disconnect!) (define conn (current-connection)) (with-handlers ([exn:fail:network? void]) (close-output-port (connection-out conn))) (with-handlers ([exn:fail:network? void]) (close-input-port (connection-in conn)))) (define send-command (lambda commands (define out (connection-out (current-connection))) (fprintf out "*~a\r\n" (length commands)) (for-each (lambda (command) (fprintf out "$~a\r\n~a\r\n" (bytes-length (string->bytes/utf-8 command)) command)) commands) (flush-output out))) (define-struct exn:redis (message)) (define (read-reply) (define in (connection-in (current-connection))) (match (read-bytes 1 in) [#"-" (read-line in 'return-linefeed)] [#"+" (read-line in 'return-linefeed)] [#"$" (read-bulk-reply in)] [#"*" (read-multi-bulk-reply in)] [#":" (string->number (read-line in 'return-linefeed))] [_ (raise (make-exn:redis (format "invalid control character: ~a" (read-byte in))))])) (define (read-bulk-reply in) (flush-output) (let ([length (string->number (read-line in 'return-linefeed))]) (match length [-1 'nil] [_ (begin0 (read-bytes length in) (read-line in 'return-linefeed))]))) (define (read-multi-bulk-reply in) (let ([length (string->number (read-line in 'return-linefeed))]) (flush-output) (build-list length (lambda (_) (read-reply))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; COMMANDS (define (ping) (send-command "PING") (read-reply)) ;; Connection handling (define (quit) (send-command "QUIT") (disconnect!)) (define (auth) (send-command "AUTH") (read-reply)) ;; Commands operating on all value types (define (exists? key) (send-command "EXISTS" key) (match (read-reply) [1 #t] [0 #f])) (define del! (lambda keys (apply send-command `("DEL" ,@keys)) (read-reply))) (define (type key) (send-command "TYPE" key) (string->symbol (read-reply))) (define (keys pattern) (send-command "KEYS" pattern) (read-reply)) (define (randomkey) (send-command "RANDOMKEY") (read-reply)) (define (rename! oldkey newkey) (send-command "RENAME" oldkey newkey) (read-reply)) (define (renamenx! oldkey newkey) (send-command "RENAME" oldkey newkey) (match (read-reply) [1 #t] [0 #f])) (define (dbsize) (send-command "DBSIZE") (read-reply)) (define (expire! key seconds) (send-command "EXPIRE" key seconds) (read-reply)) (define (expireat! key date) (send-command "EXPIREAT" key (date->seconds date)) (read-reply)) (define (ttl key) (send-command "TTL" key) (read-reply)) (define (select key) (send-command "SELECT" key) (read-reply)) (define (move key dbindex) (send-command "MOVE" key dbindex) (read-reply)) (define (flushdb) (send-command "FLUSHDB") (read-reply)) (define (flushall) (send-command "FLUSHALL") (read-reply)) (define (set key value) (send-command "SET" key value) (read-reply)) (define (get key) (send-command "GET" key) (read-reply)) (define (getset key value) (send-command "GETSET" key value) (read-reply)) (define mget (lambda keys (apply send-command `("MGET" ,@keys) (read-reply)))) (define (incrby key n) (send-command "INCRBY" key n) (read-reply)) ;; Hash commands (define (hset key field value) (send-command "HSET" key field value) (read-reply)) (define (hget key field) (send-command "HGET" key field) (read-reply)) (define (hgetall key) (send-command "HGETALL" key) (read-reply)) (define (hincrby key field num) (send-command "HINCRBY" key field num) (read-reply)) (define (hincrbyfloat key field num) (send-command "HINCRBYFLOAT" key field num) (read-reply)) (define (hkeys key) (send-command "HKEYS" key) (read-reply)) (define (hvals key) (send-command "HVALS" key) (read-reply)) (provide (all-defined-out))