├── README.md ├── info.rkt ├── bytes-utils.rkt ├── main.rkt ├── test-utils.rkt ├── redis-cmds.rkt ├── redis.rkt └── redis-tests.rkt /README.md: -------------------------------------------------------------------------------- 1 | redis 2 | ===== 3 | 4 | A redis client for Racket. 5 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define deps '("base" 3 | "data-lib" 4 | "rackunit-lib")) 5 | -------------------------------------------------------------------------------- /bytes-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define o compose) 6 | (define number->bytes (o string->bytes/utf-8 number->string)) 7 | (define symbol->bytes (o string->bytes/utf-8 symbol->string)) 8 | (define bytes->number (o string->number bytes->string/utf-8)) 9 | (define bytes->symbol (o string->symbol bytes->string/utf-8)) 10 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "redis.rkt" 3 | (except-in "redis-cmds.rkt" 4 | defcmd defcmds defcmd/chknil defcmds/chknil defcmd/ok defcmds/ok 5 | defcmd/01 defcmds/01 6 | GET/as) 7 | (only-in "bytes-utils.rkt" bytes->symbol bytes->number)) 8 | (provide (all-from-out "redis.rkt") 9 | (all-from-out "redis-cmds.rkt") 10 | (all-from-out "bytes-utils.rkt")) -------------------------------------------------------------------------------- /test-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "redis.rkt" "redis-cmds.rkt") 3 | (require rackunit) 4 | (provide (all-defined-out)) 5 | 6 | (define-syntax-rule (test tst ...) 7 | (parameterize ([current-redis-connection (make-connection-pool)]) 8 | (let* ([keys (KEYS "*")] 9 | [old (map (lambda (x) (DUMP x)) keys)]) 10 | (for-each (lambda (x) (check-equal? (DEL x) 1)) keys) 11 | tst ... 12 | (for-each (lambda (k v) (DEL k) (RESTORE k 0 v)) keys old)) 13 | (kill-connection-pool (current-redis-connection)))) 14 | 15 | (define-syntax-rule (check-redis-exn e) 16 | (check-exn exn:fail:redis? (lambda () e))) 17 | 18 | (define-syntax-rule (check-set-equal? e (x ...)) 19 | (check-equal? (list->set e) (set x ...))) 20 | 21 | (define-syntax-rule (check-void? e) (check-equal? e (void))) 22 | -------------------------------------------------------------------------------- /redis-cmds.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "redis.rkt" 3 | "bytes-utils.rkt") 4 | (require (for-syntax syntax/parse)) 5 | (require data/heap) 6 | 7 | ; functions for specific redis commands 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;; TODO 12 | ;; [o] 2013-09-25: SUBSCRIBE cmd should return (async?) channel? 13 | ;; [o] 2013-09-23: define macro that defines defcmd and defcmds at same time 14 | ;; [o] 2013-09-23: define macro that defines all GET/SET variants 15 | 16 | (define-syntax (defcmd stx) 17 | (syntax-parse stx 18 | [(_ CMD (~optional (~seq #:return fn)) (~optional (~seq #:no-reply nr))) 19 | #:with res #`(apply #,(if (attribute nr) 20 | #'(if nr send-cmd/no-reply send-cmd) 21 | #'send-cmd) 22 | #:rconn rconn 'CMD args) 23 | #`(define (CMD #:rconn [rconn (current-redis-connection)] . args) 24 | #,(if (attribute fn) #'(fn res) #'res))])) 25 | (define-syntax-rule (defcmds c ...) (begin (defcmd c) ...)) 26 | (define-syntax-rule (defcmd/nr c) (defcmd c #:no-reply #t)) 27 | (define-syntax-rule (defcmds/nr c ...) (begin (defcmd/nr c) ...)) 28 | (define-syntax-rule (defcmd/chknil c) 29 | (defcmd c #:return (lambda (reply) (and (not (eq? #\null reply)) reply)))) 30 | (define-syntax-rule (defcmds/chknil c ...) (begin (defcmd/chknil c) ...)) 31 | (define-syntax-rule (defcmd/ok c) 32 | (defcmd c #:return (lambda (reply) (or (string=? "OK" reply) (string=? "QUEUED" reply))))) 33 | (define-syntax-rule (defcmds/ok c ...) (begin (defcmd/ok c) ...)) 34 | (define-syntax-rule (defcmd/01 c) 35 | (defcmd c #:return (lambda(reply) (not (and (number? reply) (zero? reply)))))) 36 | (define-syntax-rule (defcmds/01 c ...) (begin (defcmd/01 c) ...)) 37 | 38 | ;; basic operations, ie get and set 39 | (defcmds APPEND DEL GETSET MGET SETRANGE STRLEN) 40 | (defcmds/01 EXISTS MSETNX RENAMENX) 41 | (defcmds/chknil GET GETRANGE RANDOMKEY) 42 | (defcmd SET #:return (lambda (reply) (and (not (eq? #\null reply))))) 43 | (defcmds/ok MSET RENAME) 44 | ;; SETNX, SETEX, PSETEX: deprecated? use SET + options instead 45 | 46 | ;; converts bytestring from GET according to conv function 47 | (define (GET/as #:rconn [rconn (current-redis-connection)] key 48 | #:conv [conv identity]) 49 | (define reply (GET #:rconn rconn key)) 50 | (and reply (conv reply))) 51 | ;; returns value of key as string (errors if not valid string) 52 | (define (GET/str #:rconn [rconn (current-redis-connection)] key) 53 | (GET/as #:rconn rconn key #:conv bytes->string/utf-8)) 54 | (define (GET/num #:rconn [rconn (current-redis-connection)] key) 55 | (GET/as #:rconn rconn key #:conv bytes->number)) 56 | (define (GETRANGE/str #:rconn [rconn (current-redis-connection)] key start end) 57 | (define reply (GETRANGE #:rconn rconn key start end)) 58 | (and reply (bytes->string/utf-8 reply))) 59 | (define (SET/list #:rconn [rconn (current-redis-connection)] key lst) 60 | (DEL #:rconn rconn key) 61 | (for/last ([x lst]) (RPUSH #:rconn rconn key x))) 62 | (define (POP/list #:rconn [rconn (current-redis-connection)] key 63 | #:map-fn [f identity]) 64 | (let loop ([x (LPOP #:rconn rconn key)]) 65 | (if x (cons (f x) (loop (LPOP #:rconn rconn key))) null))) 66 | (define (GET/list #:rconn [rconn (current-redis-connection)] key 67 | #:map-fn [f identity]) 68 | (let loop ([n (sub1 (LLEN #:rconn rconn key))] [lst null]) 69 | (if (< n 0) lst 70 | (let ([x (LINDEX key n)]) 71 | (if x (loop (sub1 n) (cons (f x) lst)) (loop (sub1 n) lst)))))) 72 | (define (GET/set #:rconn [rconn (current-redis-connection)] key 73 | #:map-fn [f identity]) 74 | (list->set (map f (SMEMBERS #:rconn rconn key)))) 75 | (define (SET/set #:rconn [rconn (current-redis-connection)] k xs) 76 | (DEL #:rconn rconn k) 77 | (for ([x (in-set xs)]) (SADD #:rconn rconn k x))) 78 | (define (GET/hash #:rconn [rconn (current-redis-connection)] key 79 | #:map-key [fkey identity] #:map-val [fval identity]) 80 | (let loop ([lst (HGETALL #:rconn rconn key)] [h (hash)]) 81 | (if (null? lst) h 82 | (loop (cddr lst) (hash-set h (fkey (car lst)) (fval (cadr lst))))))) 83 | (define (SET/hash #:rconn [conn (current-redis-connection)] key h) 84 | (define rconn (or conn (connect))) 85 | (parameterize ([current-redis-connection rconn]) 86 | (do-MULTI 87 | (DEL key) 88 | (for ([(k v) (in-hash h)]) (send-cmd 'HSET key k v)))) 89 | (unless conn (disconnect rconn))) 90 | (define (SET/heap #:rconn [rconn (current-redis-connection)] key h) 91 | (for ([(k v) (in-hash h)]) (ZADD #:rconn rconn key v k))) 92 | (define (GET/heap #:rconn [rconn (current-redis-connection)] key 93 | #:map-fn [f identity] #:map-score [fsco identity]) 94 | (define hp (make-heap (λ (x y) (<= (car x) (car y))))) 95 | (let loop ([lst (ZRANGE key 0 -1 'WITHSCORES)]) 96 | (unless (null? lst) 97 | (heap-add! hp (cons (fsco (cadr lst)) (f (car lst)))) 98 | (loop (cddr lst)))) 99 | hp) 100 | 101 | 102 | 103 | 104 | ;; DUMP and RESTORE 105 | (defcmd/chknil DUMP) 106 | ;; if key to restore exists: (error) ERR Target key name is busy. 107 | (defcmd RESTORE) 108 | 109 | ;; GETBIT,SETBIT,BITCOUNT,BITOP 110 | ;; val = 0 or 1 111 | (defcmds SETBIT GETBIT BITCOUNT) 112 | 113 | ;; BITOP 114 | (define-syntax-rule (defcmd/bitop OP) 115 | (define (OP #:rconn [rconn (current-redis-connection)] dest . keys) 116 | (apply send-cmd #:rconn rconn "BITOP" 'OP dest keys))) 117 | (define-syntax-rule (defcmds/bitop op ...) (begin (defcmd/bitop op) ...)) 118 | 119 | (defcmds/bitop AND OR XOR NOT) 120 | 121 | (defcmds LPUSH LPUSHX LRANGE LLEN LREM 122 | RPUSH RPUSHX) 123 | (defcmds/chknil LINDEX LPOP RPOP RPOPLPUSH BLPOP BRPOP BRPOPLPUSH) 124 | (defcmd LINSERT #:return (lambda (reply) (and (not (= -1 reply)) reply))) 125 | (defcmds/ok LSET LTRIM) 126 | 127 | ;; hashes 128 | (defcmds HDEL HGETALL HINCRBY HINCRBYFLOAT HMGET HVALS) 129 | (defcmd/ok HMSET) 130 | (defcmds/01 HSET HEXISTS HSETNX) 131 | (defcmds/chknil HGET) 132 | (define (HGET/str #:rconn [rconn (current-redis-connection)] key field) 133 | (define reply (HGET #:rconn rconn key field)) 134 | (and reply (bytes->string/utf-8 reply))) 135 | 136 | ;; sets 137 | (defcmds SADD SCARD SDIFF SDIFFSTORE SINTER SINTERSTORE SMEMBERS SREM 138 | SUNION SUNIONSTORE) 139 | (defcmds/01 SISMEMBER SMOVE) 140 | (defcmds/chknil SPOP SRANDMEMBER) 141 | 142 | ;; ordered sets 143 | (defcmds ZADD ZCARD ZCOUNT ZINCRBY ZINTERSTORE ZRANGE ZRANGEBYSCORE 144 | ZREM ZREMRANGEBYRANK ZREMRANGEBYSCORE ZREVRANGE ZREVRANGEBYSCORE 145 | ZUNIONSTORE) 146 | (defcmds/chknil ZRANK ZREVRANK ZSCORE) 147 | 148 | ;; in/decrementing 149 | (defcmds DECR DECRBY INCR INCRBY INCRBYFLOAT HKEYS HLEN) 150 | 151 | ;; expiring 152 | (defcmds/01 EXPIRE EXPIREAT PERSIST PEXPIRE PEXPIREAT) 153 | (defcmd TTL #:return (lambda (res) (and (not (negative? res)) res))) 154 | (defcmd PTTL #:return (lambda (res) (and (not (negative? res)) res))) 155 | 156 | ;; MULTI cmds 157 | (defcmds/ok MULTI DISCARD WATCH UNWATCH) 158 | (defcmds/chknil EXEC) 159 | (define-syntax-rule (do-MULTI c ...) (begin (MULTI) c ... (EXEC))) 160 | ;; DISCARD EXEC MULTI WATCH UNWATCH 161 | 162 | ;; pubsub 163 | ; (defcmd PUBSUB) ; only available in redis >= v2.8 164 | (defcmds/nr SUBSCRIBE UNSUBSCRIBE PSUBSCRIBE PUNSUBSCRIBE) 165 | (defcmd PUBLISH) 166 | 167 | ;; administrative commands 168 | ;; BGREWRITEAOF BGSAVE INFO LASTSAVE MIGRATE MONITOR MOVE SAVE SHUTDOWN 169 | ;; SLAVEOF SLOWLOG SYNC 170 | ;; CLIENT: KILL LIST GETNAME SETNAME 171 | ;; CONFIG: GET REWRITE SET RESETSTAT 172 | ;; DEBUG: OBJECT SEGFAULT 173 | 174 | (defcmds DBSIZE ECHO FLUSHALL FLUSHDB KEYS PING TIME TYPE) 175 | (defcmds/ok AUTH QUIT SELECT) 176 | 177 | ;; LUA scripting 178 | ;; EVAL EVALSHA 179 | ;; SCRIPT: EXISTS FLUSH KILL LOAD -------------------------------------------------------------------------------- /redis.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; redis bindings for racket 4 | 5 | ; based on protocol decribed here: http://redis.io/topics/protocol 6 | 7 | ;; TODO: 8 | ;; [x] 2013-09-25: make redis-specific exn 9 | ;; DONE: 2013-09-26 10 | ;; [x] 2013-09-25: dont automatically set rconn parameter on connect 11 | ;; - makes it hard to use parameterize with (connect) 12 | ;; DONE: 2013-09-26 13 | 14 | (require "bytes-utils.rkt" 15 | racket/tcp 16 | racket/match 17 | racket/async-channel 18 | racket/contract) 19 | (provide connect disconnect send-cmd send-cmd/no-reply current-redis-connection 20 | exn:fail:redis? get-reply get-reply-evt with-redis-connection 21 | redis-connection? make-connection-pool kill-connection-pool) 22 | 23 | ;; connect/disconnect --------------------------------------------------------- 24 | (struct redis-connection ()) 25 | (struct redis-connection-single redis-connection 26 | (in out pool [owner #:mutable])) 27 | (struct redis-connection-pool redis-connection 28 | (host port [dead? #:mutable] key=>conn 29 | idle-conns fresh-conn-sema manager-thread)) 30 | 31 | (define current-redis-connection (make-parameter #f)) 32 | 33 | (struct exn:fail:redis exn:fail ()) 34 | 35 | (define-syntax-rule (redis-error msg) 36 | (raise (exn:fail:redis (string-append "redis ERROR: " msg) 37 | (current-continuation-marks)))) 38 | 39 | ;; Construct a redis-connection-pool that will lease at most max-connections 40 | ;; to client threads and will maintain at most max-idle unleased connections. 41 | ;; 42 | ;; A connection pool will lease a connection to a client thread when (connect) 43 | ;; is called on the pool. Further calls to (connect) on the same connection pool 44 | ;; and in the same thread, with no intervening calls to (disconnect), will 45 | ;; produce the same connection. No other thread will be able to use the 46 | ;; connection until it is returned to the pool. 47 | ;; 48 | ;; Leased connections are explicitly returned to the pool of available 49 | ;; connections when (disconnect) is called on the connection pool whence 50 | ;; the connection was leased or on the leased connection itself. Leased 51 | ;; connections are also returned to the pool when the leasing thread dies. 52 | ;; 53 | ;; Calling any command on a connection that is not leased to the current thread 54 | ;; will raise an exception. Attepting to lease a connection when there are no 55 | ;; available connections in the pool will block until a connection is available. 56 | ;; 57 | ;; A connection pool can be killed with kill-connection-pool. Killing a 58 | ;; connection pool causes it to lease no further connections, close all idle 59 | ;; connections, and immediately close any connection that is returned to the 60 | ;; pool. Attempting to lease from a dead connection pool will result in an 61 | ;; exception. Threads that were blocked on leasing a connection from a 62 | ;; connection pool that was killed will block forever. 63 | (define/contract 64 | (make-connection-pool #:host [host "127.0.0.1"] 65 | #:port [port 6379] 66 | #:max-connections [max-conn 100] 67 | #:max-idle [max-idle 10]) 68 | (->* () (#:host 69 | string? 70 | #:port 71 | exact-nonnegative-integer? 72 | #:max-connections 73 | exact-nonnegative-integer? 74 | #:max-idle 75 | exact-nonnegative-integer?) 76 | redis-connection-pool?) 77 | (define idle-return-chan (make-async-channel max-idle)) 78 | (define key=>conn (make-hasheq)) 79 | (define fresh-conn-sema (make-semaphore max-conn)) 80 | (define (release-conn thd.conn dead?) 81 | (match-define (cons thd conn) thd.conn) 82 | (set-redis-connection-single-owner! conn (current-thread)) 83 | (hash-remove! key=>conn thd) 84 | (if dead? 85 | (disconnect conn) 86 | (begin 87 | ;; Reset state of returned connection. 88 | (send-cmd/no-reply #:rconn conn "UNSUBSCRIBE") 89 | (send-cmd/no-reply #:rconn conn "UNWATCH") 90 | (send-cmd/no-reply #:rconn conn "ECHO" #"i-am-reset") 91 | (let loop () 92 | (unless (equal? (get-reply (redis-connection-single-in conn)) #"i-am-reset") 93 | (loop))) 94 | (unless (sync/timeout 0 (async-channel-put-evt idle-return-chan conn)) 95 | (disconnect conn) 96 | (semaphore-post fresh-conn-sema)))) 97 | (set-redis-connection-single-owner! conn #f)) 98 | (define pool 99 | (redis-connection-pool 100 | host port #f key=>conn idle-return-chan fresh-conn-sema 101 | (thread 102 | (lambda() 103 | (let loop () 104 | (sync 105 | (handle-evt 106 | (apply choice-evt 107 | (map (lambda(thd.conn) (wrap-evt (thread-dead-evt (car thd.conn)) (lambda(_) thd.conn))) 108 | (hash->list key=>conn))) 109 | (lambda(thd.conn) 110 | (when (redis-connection-single-owner (cdr thd.conn)) 111 | (release-conn thd.conn (redis-connection-pool-dead? pool))) 112 | (loop))) 113 | (handle-evt 114 | (thread-receive-evt) 115 | (lambda(_) 116 | (match (thread-receive) 117 | ['die 118 | (set-redis-connection-pool-dead?! pool #t) 119 | (let dis-loop () 120 | (let ([maybe-idle-conn (async-channel-try-get idle-return-chan)]) 121 | (when maybe-idle-conn 122 | (disconnect maybe-idle-conn) 123 | (dis-loop)))) 124 | (loop)] 125 | ['new (loop)] 126 | [thd.conn 127 | (release-conn thd.conn (redis-connection-pool-dead? pool)) 128 | (loop)]))))))))) 129 | pool) 130 | 131 | (define (kill-connection-pool pool) 132 | (thread-send (redis-connection-pool-manager-thread pool) 'die)) 133 | 134 | (define (connection-pool-lease pool) 135 | (when (redis-connection-pool-dead? pool) 136 | (redis-error "Attempted to lease connection from dead connection pool.")) 137 | (or (hash-ref (redis-connection-pool-key=>conn pool) (current-thread) #f) 138 | (let ([conn 139 | (or (async-channel-try-get (redis-connection-pool-idle-conns pool)) 140 | (sync (redis-connection-pool-idle-conns pool) 141 | (wrap-evt (redis-connection-pool-fresh-conn-sema pool) 142 | (lambda(_) 143 | (real-connect (redis-connection-pool-host pool) 144 | (redis-connection-pool-port pool) 145 | pool)))))]) 146 | (hash-set! (redis-connection-pool-key=>conn pool) (current-thread) conn) 147 | (set-redis-connection-single-owner! conn (current-thread)) 148 | (thread-send (redis-connection-pool-manager-thread pool) 'new) 149 | conn))) 150 | 151 | (define (connection-pool-return pool conn) 152 | (unless (eq? (current-thread) (redis-connection-single-owner conn)) 153 | (redis-error "Attempted to disconnect leased connection when not owner.")) 154 | ;; prevent double-return 155 | (set-redis-connection-single-owner! conn #f) 156 | (thread-send (redis-connection-pool-manager-thread pool) 157 | (cons (current-thread) conn))) 158 | 159 | (define/contract (connect #:host [host "127.0.0.1"] #:port [port 6379]) 160 | (->* () (#:host string? #:port exact-nonnegative-integer?) redis-connection?) 161 | (let ([rconn (current-redis-connection)]) 162 | (if (and (redis-connection-pool? rconn) 163 | (string=? (redis-connection-pool-host rconn) host) 164 | (= (redis-connection-pool-port rconn) port)) 165 | (connection-pool-lease rconn) 166 | (real-connect host port #f)))) 167 | 168 | (define (real-connect host port pool) 169 | (let-values ([(in out) (tcp-connect host port)]) 170 | (redis-connection-single in out pool (current-thread)))) 171 | 172 | (define/contract (disconnect [rconn (current-redis-connection)]) 173 | (->* () (redis-connection?) void?) 174 | (match rconn 175 | [#f (redis-error "Can't disconnect when not connected to server.")] 176 | [(redis-connection-single _ _ (? redis-connection-pool? pool) _) 177 | (disconnect pool)] 178 | [(redis-connection-single in out _ _) 179 | (send-cmd #:rconn rconn "QUIT") 180 | (close-input-port in) (close-output-port out)] 181 | [(redis-connection-pool _ _ _ key=>conn _ _ _) 182 | (let ([maybe-connection (hash-ref key=>conn (current-thread) #f)]) 183 | (when (and maybe-connection (eq? (current-thread) (redis-connection-single-owner maybe-connection))) 184 | (connection-pool-return rconn maybe-connection)))])) 185 | 186 | (define-syntax-rule (with-redis-connection e0 e ...) 187 | (let ([rconn (connect)]) 188 | (parameterize ([current-redis-connection rconn]) 189 | (dynamic-wind 190 | (lambda() (void)) 191 | (lambda() e0 e ...) 192 | (lambda() (disconnect)))))) 193 | 194 | ;; send cmd/recv reply -------------------------------------------------------- 195 | (define CRLF #"\r\n") 196 | 197 | (define (send-cmd/no-reply #:rconn [conn (current-redis-connection)] cmd . args) 198 | (define rconn (if (redis-connection-single? conn) conn (connect))) 199 | (match-define (redis-connection-single in out _ owner) rconn) 200 | (unless (eq? (current-thread) owner) 201 | (redis-error "Attempted to use redis connection in thread other than owner.")) 202 | (write-bytes (mk-request cmd args) out) 203 | (flush-output out)) 204 | 205 | (define (send-cmd #:rconn [conn (current-redis-connection)] cmd . args) 206 | (define rconn (if (redis-connection-single? conn) conn (connect))) 207 | (match-define (redis-connection-single in out _ owner) rconn) 208 | (unless (eq? (current-thread) owner) 209 | (redis-error "Attempted to use redis connection in thread other than owner.")) 210 | (write-bytes (mk-request cmd args) out) 211 | (flush-output out) 212 | ;; must catch and re-throw here to display offending cmd and args 213 | (with-handlers ([exn:fail? 214 | (lambda (x) 215 | (redis-error (format "~a\nCMD: ~a\nARGS: ~a\n" 216 | (exn-message x) cmd args)))]) 217 | (begin0 (get-reply in) (unless conn (disconnect rconn))))) 218 | 219 | (define (mk-request cmd args) 220 | (bytes-append 221 | (string->bytes/utf-8 222 | (string-append "*" (number->string (add1 (length args))) "\r\n")) 223 | (arg->bytes cmd) 224 | (apply bytes-append (map arg->bytes args)))) 225 | 226 | (define (arg->bytes val) 227 | (define bs 228 | (cond [(bytes? val) val] 229 | [(string? val) (string->bytes/utf-8 val)] 230 | [(number? val) (number->bytes val)] 231 | [(symbol? val) (symbol->bytes val)] 232 | [else (error 'send "invalid argument: ~v\n" val)])) 233 | (bytes-append #"$" (number->bytes (bytes-length bs)) CRLF bs CRLF)) 234 | 235 | ;; cmd and args are used for error reporting 236 | (define (get-reply [in (redis-connection-single-in (current-redis-connection))]) 237 | (define byte1 (read-char in)) 238 | (define reply1 (read-line in 'return-linefeed)) 239 | (match byte1 240 | [#\+ reply1] ; Status reply 241 | [#\- (error 'redis-reply reply1)] ; Error reply 242 | [#\: (string->number reply1)] ; Integer reply 243 | [#\$ (let ([numbytes (string->number reply1)]) ; Bulk reply 244 | (if (= numbytes -1) #\null 245 | (begin0 246 | (read-bytes numbytes in) 247 | (read-line in 'return-linefeed))))] 248 | [#\* (let ([numreplies (string->number reply1)]) ; Multi-bulk reply 249 | (if (= numreplies -1) #\null 250 | (for/list ([n (in-range numreplies)]) (get-reply in))))])) 251 | 252 | (define (get-reply-evt [in (redis-connection-single-in (current-redis-connection))]) 253 | (wrap-evt in (lambda(_) (get-reply in)))) 254 | -------------------------------------------------------------------------------- /redis-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "redis.rkt" "redis-cmds.rkt" 3 | "bytes-utils.rkt" "test-utils.rkt") 4 | (require rackunit data/heap racket/async-channel ffi/unsafe/custodian) 5 | 6 | (module+ main (displayln "Run tests with \"raco test redis-tests.rkt\".")) 7 | 8 | (module+ test 9 | 10 | (printf 11 | (~a "\n" 12 | "*WARNING*: Interrupting these tests will result in data loss.\n" 13 | " Running these tests (temporarily) deletes keys from the db. The keys " 14 | "are restored when the tests conclude but if the tests are interrupted, " 15 | "the keys won't get restored, meaning you'll lose data. The current " 16 | "keys are saved to disk before testing begins so if the tests get " 17 | "interrupted, you should manually restore the keys from disk.\n" 18 | " The tests also change the redis parameters \"dir\" and " 19 | "\"dbfilename\". The current parameters are similarly saved before the " 20 | "tests begin and restored at the end of the tests. The tests try to " 21 | "restore these parameters if the tests are interrupted, but I don't " 22 | "know how well this works, so in the event of early termination, you " 23 | "should check that the parameters were actually restored.\n\n" 24 | "Continue with the tests? (enter 'y' to continue): ")) 25 | 26 | (define y (read)) 27 | 28 | (when (eq? 'y y) 29 | 30 | ;; save keys to disk 31 | (newline) 32 | (printf "Saving keys to disk ..........\n") 33 | (send-cmd 'save) 34 | 35 | ;; need to organize custodians so I still have a connection 36 | ;; to the redis db, to restore parameters in case of shutdown 37 | (define restore-cust (make-custodian)) 38 | (define redis-conn-cust (make-custodian restore-cust)) 39 | (define shutdown-rconn 40 | (parameterize ([current-custodian redis-conn-cust]) (connect))) 41 | 42 | (define rdb-dir 43 | (bytes->string/utf-8 (second (send-cmd 'config 'get 'dir)))) 44 | (define rdb-file 45 | (bytes->string/utf-8 (second (send-cmd 'config 'get 'dbfilename)))) 46 | (newline) 47 | (printf "Saving current parameters: ..........\n") 48 | (printf "current \"dir\": ~a\n" rdb-dir) 49 | (printf "current \"dbfilename\": ~a\n" rdb-file) 50 | ;; /var/lib/redis/6379/dump.rdb 51 | (define rdb-path (build-path rdb-dir rdb-file)) 52 | 53 | ;; restore old params in case of premature exit 54 | (define dir+file (list rdb-dir rdb-file)) 55 | (define cust-reg 56 | (register-custodian-shutdown dir+file 57 | (λ (dir+file) 58 | (define dir (first dir+file)) 59 | (define file (second dir+file)) 60 | (printf "Premature exit. Restoring old parameters: ..........\n") 61 | (printf "- restoring \"dir\" to: ~a\n" dir) 62 | (send-cmd #:rconn shutdown-rconn 'config 'set 'dir dir) 63 | (printf "- restoring \"dbfilename\" to: ~a\n" file) 64 | (send-cmd #:rconn shutdown-rconn 'config 'set 'dbfilename file)) 65 | restore-cust #:at-exit? #t)) 66 | 67 | (define current-dir (path->string (current-directory))) 68 | (define tmp-rdb-file "tmp.rdb") 69 | (define backup-path (build-path current-dir (~a rdb-file ".bak"))) 70 | 71 | (newline) 72 | ;; backup rdb file 73 | (printf "Backing up rdb file: ..........\n- from: ~a\n- to: ~a\n" 74 | rdb-path backup-path) 75 | (copy-file rdb-path backup-path #t) 76 | 77 | (newline) 78 | ;; set tmp rdb file 79 | (printf "Setting tmp dir: ~a\n" current-dir) 80 | (send-cmd 'config 'set 'dir current-dir) 81 | (printf "Setting tmp rdb file: ~a\n" tmp-rdb-file) 82 | (send-cmd 'config 'set 'dbfilename tmp-rdb-file) 83 | 84 | ;; do tests 85 | (newline) 86 | (printf "Running tests ..........\n") 87 | 88 | ;; disconnected exn 89 | (check-true (SET "x" 100)) ;; should auto-connect 90 | (check-redis-exn (disconnect)) 91 | 92 | ; test GET, SET, EXISTS, DEL, APPEND, etc 93 | (test 94 | (check-true (SET "x" 100)) 95 | (check-equal? (GET/str "x") "100") 96 | (check-true (EXISTS "x")) 97 | (check-equal? (APPEND "x" "World") 8) 98 | (check-equal? (GET/str "x") "100World") 99 | (check-true (SET "y" "hello")) 100 | (check-equal? (GET/str "y") "hello") 101 | (check-equal? (GETSET "y" "world") #"hello") 102 | (check-equal? (GET/str "y") "world") 103 | (check-equal? (MGET "x" "y") (list #"100World" #"world")) 104 | (check-true (SET "z" "This is a string")) 105 | (check-equal? (GETRANGE "z" 0 3) #"This") 106 | (check-equal? (GETRANGE "z" -3 -1) #"ing") 107 | (check-equal? (GETRANGE "z" 0 -1) #"This is a string") 108 | (check-equal? (GETRANGE/str "z" 10 100) "string") 109 | (check-equal? (DEL "x" "y" "z") 3) 110 | (check-true (MSETNX "k1" "Hello" "k2" "there")) 111 | (check-false (MSETNX "k2" "there" "k3" "world")) 112 | (check-equal? (MGET "k1" "k2" "k3") (list #"Hello" #"there" #\null)) 113 | ;; setrange 114 | (check-true (SET 'key1 "Hello World")) 115 | (check-equal? (SETRANGE 'key1 6 "Redis") 11) 116 | (check-equal? (GET/str 'key1) "Hello Redis") 117 | (check-equal? (SETRANGE 'key2 6 "Redis") 11) 118 | (check-equal? (GET 'key2) #"\0\0\0\0\0\0Redis")) 119 | 120 | ; test SET options 121 | (test 122 | (check-true (SET "z" "red" "EX" 1)) 123 | (check-equal? (GET/str "z") "red") 124 | (sleep 1.5) 125 | (check-false (GET/str "z")) 126 | (check-equal? (do-MULTI (SET "z" "blue" "PX" 1) 127 | (GET "z") "blue") 128 | (list "OK" #"blue")) 129 | (sleep .1) 130 | (check-false (GET/str "z")) 131 | (check-false (EXISTS "z")) 132 | (check-false (SET "z" "black" "XX")) 133 | (check-false (EXISTS "z")) 134 | (check-true (SET "z" "yellow" "NX")) 135 | (check-equal? (GET/str "z") "yellow") 136 | (check-true (SET "z" "white" "XX")) 137 | (check-equal? (GET/str "z") "white")) 138 | 139 | ;; test SETBIT,GETBIT, BITCOUNT 140 | (test 141 | (check-true (SET "pin" "foobar")) 142 | (check-equal? (BITCOUNT "pin") 26) 143 | (check-equal? (BITCOUNT "pin" 0 0) 4) 144 | (check-equal? (BITCOUNT "pin" 1 1) 6) 145 | (check-equal? (SETBIT "pan" 7 1) 0) 146 | (check-equal? (BITCOUNT "pan") 1) 147 | (check-equal? (SETBIT "pan" 7 0) 1) 148 | (check-equal? (GETBIT "pan" 7) 0) 149 | (check-equal? (GET "pan") #"\0") 150 | (check-equal? (SETBIT "pon" 4 1) 0) 151 | (check-equal? (GET "pon") #"\b")) 152 | 153 | ;; test BITOP 154 | (test 155 | (check-true (SET "hip" "foobar")) 156 | (check-true (SET "hop" "abcdef")) 157 | (check-equal? (AND "hep" "hip" "hop") 6) 158 | (check-equal? (GET/str "hep") "`bc`ab") 159 | (check-equal? (DEL "hip" "hop") 2) 160 | (check-equal? (SETBIT "hip" 0 1) 0) 161 | (check-equal? (SETBIT "hop" 0 0) 0) 162 | (check-equal? (AND "hep" "hip" "hop") 1) 163 | (check-equal? (GETBIT "hep" 0) 0) 164 | (check-equal? (OR "hep" "hip" "hop") 1) 165 | (check-equal? (GETBIT "hep" 0) 1) 166 | (check-equal? (NOT "hep" "hop") 1) 167 | (check-equal? (GETBIT "hep" 0) 1) 168 | (check-equal? (XOR "hep" "hip" "hop") 1) 169 | (check-equal? (GETBIT "hep" 0) 1) 170 | (check-equal? (SETBIT "hop" 0 1) 0) 171 | (check-equal? (XOR "hep" "hip" "hop") 1) 172 | (check-equal? (GETBIT "hep" 0) 0)) 173 | 174 | ;; test list commands 175 | (test 176 | (check-equal? (LPUSH "lst" "world") 1) 177 | (check-equal? (LPUSHX "lst" "hello") 2) 178 | (check-equal? (LRANGE "lst" 0 -1) (list #"hello" #"world")) 179 | (check-equal? (LPUSHX "lst-non-exist" "Hello") 0) 180 | (check-equal? (LRANGE "lst-non-exist" 0 -1) null) 181 | 182 | (check-equal? (DEL "lst") 1) 183 | 184 | ;; LINDEX test 185 | (check-equal? (LPUSH "lst" "World") 1) 186 | (check-equal? (LPUSH "lst" "Hello") 2) 187 | (check-equal? (LINDEX "lst" 0) #"Hello") 188 | (check-equal? (LINDEX "lst" -1) #"World") 189 | (check-false (LINDEX "lst" 3)) 190 | 191 | (check-equal? (DEL "lst") 1) 192 | 193 | ;; LINSERT test 194 | (check-equal? (RPUSH "lst" "Hello") 1) 195 | (check-equal? (RPUSHX "lst" "World") 2) 196 | (check-equal? (RPUSHX "lst-non-exist" "asdf") 0) 197 | (check-false (LINSERT "lst" 'BEFORE "Worl" "There")) 198 | (check-equal? (LINSERT "lst" 'BEFORE "World" "There") 3) 199 | (check-equal? (LRANGE "lst" 0 -1) (list #"Hello" #"There" #"World")) 200 | (check-equal? (LLEN "lst") 3) 201 | (check-false (RPOPLPUSH "lst-non-exist" "lst2")) 202 | (check-equal? (RPOPLPUSH "lst" "lst2") #"World") 203 | (check-equal? (LRANGE "lst" 0 -1) (list #"Hello" #"There")) 204 | (check-equal? (LRANGE "lst2" 0 -1) (list #"World")) 205 | 206 | (check-equal? (DEL "lst") 1) 207 | 208 | ;; L/RPOP test 209 | (check-equal? (RPUSH "lst" "one") 1) 210 | (check-equal? (RPUSH "lst" "two") 2) 211 | (check-equal? (RPUSH "lst" "three") 3) 212 | (check-equal? (LPOP "lst") #"one") 213 | (check-equal? (LRANGE "lst" 0 -1) (list #"two" #"three")) 214 | (check-equal? (RPOP "lst") #"three") 215 | (check-equal? (LRANGE "lst" 0 -1) (list #"two")) 216 | 217 | (check-equal? (DEL "lst") 1) 218 | 219 | ;; LREM test 220 | (check-equal? (RPUSH "lst" "hello") 1) 221 | (check-equal? (RPUSH "lst" "hello") 2) 222 | (check-equal? (RPUSH "lst" "foo") 3) 223 | (check-equal? (RPUSH "lst" "hello") 4) 224 | (check-equal? (LREM "lst" -2 "hello") 2) 225 | (check-equal? (LRANGE "lst" 0 -1) (list #"hello" #"foo")) 226 | 227 | (check-equal? (DEL "lst") 1) 228 | 229 | ;; LSET test 230 | (check-equal? (RPUSH "lst" "one") 1) 231 | (check-equal? (RPUSH "lst" "two") 2) 232 | (check-equal? (RPUSH "lst" "three") 3) 233 | (check-true (LSET "lst" 0 "four")) 234 | (check-true (LSET "lst" -2 "five")) 235 | (check-equal? (LRANGE "lst" 0 -1) (list #"four" #"five" #"three")) 236 | (check-redis-exn (LSET "lst" 4 "six")) 237 | (check-true (LTRIM "lst" 1 -1)) 238 | (check-equal? (LRANGE "lst" 0 -1) (list #"five" #"three")) 239 | 240 | ;; blocking pop 241 | (check-equal? (DEL "lst" "lst2") 2) 242 | 243 | (check-equal? (RPUSH "lst" 'a 'b 'c) 3) 244 | (check-equal? (BLPOP "lst" "lst2" 0) (list #"lst" #"a")) 245 | (check-equal? (BRPOPLPUSH "lst" "lst2" 0) #"c") 246 | (check-equal? (BRPOP "lst" "lst2" 0) (list #"lst" #"b")) 247 | (check-equal? (BRPOP "lst" "lst2" 0) (list #"lst2" #"c")) 248 | (check-false (BLPOP "lst-non-exist" 1)) 249 | (check-false (BRPOP "lst-non-exist" 1)) 250 | (check-false (BRPOPLPUSH "lst-non-exist" "lst" 1)) 251 | 252 | (define achan (make-async-channel)) 253 | ;; #f = make new single connection, instead of using pool 254 | (parameterize ([current-redis-connection #f]) 255 | (thread (lambda () (async-channel-put achan (BRPOP "lst" 0))))) 256 | (check-equal? (RPUSH "lst" "aaa") 1) 257 | (check-equal? (async-channel-get achan) (list #"lst" #"aaa")) 258 | (parameterize ([current-redis-connection #f]) 259 | (thread (lambda () (async-channel-put achan (BLPOP "lst" 0))))) 260 | (check-equal? (RPUSH "lst" "bbb") 1) 261 | (check-equal? (async-channel-get achan) (list #"lst" #"bbb")) 262 | (parameterize ([current-redis-connection #f]) 263 | (thread (lambda () (async-channel-put achan (BRPOPLPUSH "lst" "lst2" 0))))) 264 | (check-equal? (RPUSH "lst" "ccc") 1) 265 | (check-equal? (async-channel-get achan) #"ccc") 266 | ) 267 | 268 | (test 269 | (check-equal? (SET/list "lst" (list 1 2 3)) 3) 270 | (check-equal? (GET/list "lst") (list #"1" #"2" #"3")) 271 | (check-equal? (POP/list "lst") (list #"1" #"2" #"3")) 272 | (SET/hash "hsh" (hash 'a 10 'b 20 'c 30)) 273 | (check-equal? (GET/hash "hsh" #:map-key bytes->symbol 274 | #:map-val bytes->number) 275 | (hash 'a 10 'b 20 'c 30)) 276 | (SET/set "s" (set 1 2 3 4 5)) 277 | (check-equal? (GET/set "s" #:map-fn bytes->number) (set 1 2 3 4 5)) 278 | (SET/heap "hp" (hash 'a 30 'b 10 'c 20)) 279 | (check-equal? (heap->vector 280 | (GET/heap "hp" #:map-fn bytes->symbol 281 | #:map-score bytes->number)) 282 | (let ([h (make-heap (lambda (x y) (<= (car x) (car y))))]) 283 | (heap-add-all! h '((30 . a) (10 . b) (20 . c))) 284 | (heap->vector h))) 285 | ) 286 | 287 | ;; in/decrementing 288 | (test 289 | (check-true (SET "i" 10)) 290 | (check-equal? (INCR "i") 11) 291 | (check-equal? (GET/num "i") 11) 292 | (check-equal? (INCRBY "i" 5) 16) 293 | (check-equal? (GET/num "i") 16) 294 | (check-equal? (INCRBYFLOAT "i" 0.5) #"16.5") 295 | (check-equal? (GET/num "i") 16.5) 296 | (check-redis-exn (DECR "i")) ;; not int 297 | (check-equal? (DECR "j") -1) 298 | (check-equal? (DECRBY "j" 2) -3) 299 | (check-equal? (GETSET "i" 0) #"16.5") 300 | (check-equal? (GET/num "i") 0)) 301 | 302 | ;; flush/expire 303 | (test 304 | (check-true (MSET "x" 10 "y" 11 "z" 12)) 305 | (check-true (EXISTS "x")) 306 | (check-true (EXISTS "y")) 307 | (check-true (EXISTS "z")) 308 | (FLUSHALL) 309 | (check-false (EXISTS "x")) 310 | (check-false (EXISTS "y")) 311 | (check-false (EXISTS "z")) 312 | (check-true (MSET "x" 10 "y" 11 "z" 12)) 313 | (check-true (EXISTS "x")) 314 | (check-true (EXISTS "y")) 315 | (check-true (EXISTS "z")) 316 | (FLUSHDB) 317 | (check-false (EXISTS "x")) 318 | (check-false (EXISTS "y")) 319 | (check-false (EXISTS "z")) 320 | 321 | ;; expire 322 | (check-false (EXPIRE "x" 1)) 323 | (check-false (EXPIREAT "x" 1)) 324 | (check-true (MSET "x" 10 "y" 11 "z" 12)) 325 | (check-true (EXPIRE "x" 2)) 326 | (check-equal? (TTL "x") 2) 327 | (sleep 2) 328 | (check-false (EXISTS "x")) 329 | (check-true (EXPIRE "y" 1)) 330 | (check-true (PERSIST 'y)) 331 | (sleep 1) 332 | (check-true (EXISTS "y")) 333 | (check-equal? (GET/num 'y) 11) 334 | (check-true (PEXPIRE 'y 100)) 335 | (check-true (let ([x (PTTL 'y)]) (or (= x 100) (= x 99) (= x 98)))) 336 | (sleep .11) 337 | (check-false (EXISTS 'y)) 338 | (check-false (PEXPIREAT 'y 100)) 339 | (check-false (TTL "non-exist")) ; nonexisting, -2 340 | (check-false (TTL "y"))) ; no TTL, -1 341 | 342 | ;; hashes 343 | (test 344 | (check-true (HSET "h" 'field1 "foo")) ; #t means new field 345 | (check-true (HEXISTS "h" 'field1)) 346 | (check-equal? (HGET "h" 'field1) #"foo") 347 | (check-equal? (HGET/str "h" 'field1) "foo") 348 | (check-false (HEXISTS "h" 'field2)) 349 | (check-false (HGET "h" 'field2)) 350 | (check-false (HSET "h" 'field1 "bar")) ; #f means field exists 351 | (check-equal? (HGET/str "h" 'field1) "bar") 352 | (check-true (HSET "h" 'field2 "world")) 353 | (check-equal? (HKEYS "h") (list #"field1" #"field2")) 354 | (check-equal? (HKEYS "h2") null) 355 | (check-equal? (HGETALL "h") (list #"field1" #"bar" #"field2" #"world")) 356 | (check-equal? (HLEN "h") 2) 357 | (check-equal? (HLEN "h2") 0) 358 | (check-equal? (HDEL "h" 'field1) 1) 359 | (check-equal? (HDEL "h" 'field1) 0) 360 | (check-true (HSET "h" 'num 5)) 361 | (check-equal? (HINCRBY "h" 'num 1) 6) 362 | (check-equal? (HINCRBY "h" 'num -1) 5) 363 | (check-equal? (HINCRBY "h" 'num -10) -5) 364 | (check-equal? (HINCRBYFLOAT "h" 'num .1) #"-4.9") 365 | (check-false (HSET "h" 'num "5.0e3")) 366 | (check-equal? (HINCRBYFLOAT "h" 'num "2.0e2") #"5200") 367 | (check-equal? (HMGET "h" 'field1 'field2 'num) 368 | (list #\null #"world" #"5200")) 369 | (check-true (HMSET "h" 'field1 "Hello" 'field2 "World")) 370 | (check-equal? (HMGET "h" 'field1 'field2) (list #"Hello" #"World")) 371 | (check-false (HSETNX "h" 'field1 "hall")) 372 | (check-true (HSET "h" 'field3 "hall")) 373 | (check-equal? (HGET/str "h" 'field3) "hall") 374 | (check-equal? (HVALS "h") (list #"World" #"5200" #"Hello" #"hall"))) 375 | 376 | ;; KEYS testing 377 | (test 378 | (check-true (MSET "one" 1 "two" 2 "three" 3 "four" 4)) 379 | (define keyso (KEYS "*o*")) 380 | (check-equal? #"one" (car (member #"one" keyso))) 381 | (check-equal? #"two" (car (member #"two" keyso))) 382 | (check-equal? #"four" (car (member #"four" keyso))) 383 | (check-equal? (KEYS "t??") (list #"two")) 384 | (define keys* (KEYS "*")) 385 | (check-equal? #"one" (car (member #"one" keys*))) 386 | (check-equal? #"two" (car (member #"two" keys*))) 387 | (check-equal? #"three" (car (member #"three" keys*))) 388 | (check-equal? #"four" (car (member #"four" keys*)))) 389 | 390 | ;; MULTI 391 | (test 392 | (check-equal? (do-MULTI (INCR "foo") (INCR "bar")) (list 1 1)) 393 | ;; check exn 394 | (check-redis-exn (do-MULTI (SET "a" 3) (LPOP "a"))) 395 | ;; check discard 396 | (check-true (SET 'foo 1)) 397 | (check-true (MULTI)) 398 | (check-equal? (INCR 'foo) "QUEUED") 399 | (check-true (DISCARD)) 400 | (check-equal? (GET/num 'foo) 1) 401 | ;; WATCH: no abort 402 | (check-true (WATCH 'foo)) 403 | (check-equal? (do-MULTI (SET 'foo 10)) (list "OK")) 404 | (check-equal? (GET/num 'foo) 10) 405 | ;; WATCH: abort 406 | (check-true (WATCH 'foo)) 407 | (check-equal? (INCR 'foo) 11) 408 | (check-false (do-MULTI (SET 'foo 10))) 409 | (check-equal? (GET/num 'foo) 11) 410 | ;; WATCH/UNWATCH 411 | (check-true (WATCH 'foo)) 412 | (check-true (UNWATCH)) 413 | (check-equal? (INCR 'foo) 12) 414 | (check-equal? (do-MULTI (SET 'foo 10)) (list "OK")) 415 | (check-equal? (GET/num 'foo) 10)) 416 | 417 | ;; pub/sub 418 | (test 419 | ;; sub/unsub 420 | (parameterize ([current-redis-connection #f]) ; drop the pool 421 | (parameterize ([current-redis-connection (connect)]) ; single 422 | (check-void? (SUBSCRIBE 'foo 'bar)) 423 | (check-equal? (get-reply) (list #"subscribe" #"foo" 1)) 424 | (check-equal? (get-reply) (list #"subscribe" #"bar" 2)) 425 | (check-void? (PSUBSCRIBE "news.*")) 426 | (check-equal? (get-reply) (list #"psubscribe" #"news.*" 3)) 427 | (define achan (make-async-channel)) 428 | (thread (lambda () (async-channel-put achan (get-reply)))) 429 | (parameterize ([current-redis-connection (connect)]) 430 | (PUBLISH 'foo "Hello")) ; publish with new connection 431 | (check-equal? (async-channel-get achan) (list #"message" #"foo" #"Hello")) 432 | (parameterize ([current-redis-connection (connect)]) 433 | (PUBLISH 'foo "Kello")) ; publish with new connection 434 | (check-equal? (sync (get-reply-evt)) (list #"message" #"foo" #"Kello")) 435 | ;; test for the bug fixed by m4burns, where a SUBSCRIBE 436 | ;; followed by a get-reply can accidentally read a message from another 437 | ;; subscribe instead of the SUBSCRIBE cmd reply msg 438 | (parameterize ([current-redis-connection (connect)]) 439 | (PUBLISH 'foo "Jello")) ; publish with new connection 440 | (check-void? (SUBSCRIBE 'goo)) 441 | (check-equal? (get-reply) (list #"message" #"foo" #"Jello")) 442 | (check-equal? (get-reply) (list #"subscribe" #"goo" 4)) 443 | ;; test unsubscribe 444 | (check-void? (UNSUBSCRIBE 'foo)) 445 | (check-equal? (get-reply) (list #"unsubscribe" #"foo" 3)) 446 | (check-void? (UNSUBSCRIBE)) 447 | (check-equal? (get-reply) (list #"unsubscribe" #"goo" 2)) 448 | (check-equal? (get-reply) (list #"unsubscribe" #"bar" 1)) 449 | ;; psub/punsub 450 | ;; (check-equal? (PSUBSCRIBE "news.*") (list #"psubscribe" #"news.*" 1)) 451 | (thread (lambda () (async-channel-put achan (get-reply)))) 452 | (parameterize ([current-redis-connection (connect)]) 453 | (PUBLISH 'news.art "Pello")) 454 | (check-equal? (async-channel-get achan) 455 | (list #"pmessage" #"news.*" #"news.art" #"Pello")) 456 | (check-void? (PUNSUBSCRIBE "news.*")) 457 | (check-equal? (get-reply) (list #"punsubscribe" #"news.*" 0)) 458 | ;; PUBSUB cmd only available in redis version >= 2.8 459 | ))) 460 | 461 | ; random key 462 | (test 463 | (check-false (RANDOMKEY)) 464 | (SET 'x 100) 465 | (check-equal? (RANDOMKEY) #"x")) 466 | 467 | ; rename 468 | (test 469 | (check-redis-exn (RENAME 'key1 'key2)) 470 | (check-true (SET 'key1 "Hello")) 471 | (check-redis-exn (RENAME 'key1 'key1)) 472 | (check-true (RENAME 'key1 'key2)) 473 | (check-equal? (GET/str 'key2) "Hello") 474 | (check-redis-exn (RENAMENX 'key3 'key4)) 475 | (check-true (SET 'key3 "Dello")) 476 | (check-redis-exn (RENAMENX 'key3 'key3)) 477 | (check-false (RENAMENX 'key3 'key2)) 478 | (check-equal? (GET/str 'key2) "Hello") 479 | (check-true (RENAMENX 'key3 'key4)) 480 | (check-equal? (GET/str 'key4) "Dello")) 481 | 482 | ;; strlen 483 | (test 484 | (check-true (SET 'k "Hello World")) 485 | (check-equal? (STRLEN 'k) 11) 486 | (check-equal? (STRLEN 'non-exist) 0) 487 | (check-equal? (RPUSH 'lst 1) 1) 488 | (check-redis-exn (STRLEN 'lst))) 489 | 490 | ;; type 491 | (test 492 | (check-true (SET 'k:str "val")) 493 | (check-equal? (TYPE 'k:str) "string") 494 | (check-equal? (LPUSH 'k:lst "val") 1) 495 | (check-equal? (TYPE 'k:lst) "list") 496 | (check-true (HSET 'k:hash 'field1 "val")) 497 | (check-equal? (TYPE 'k:hash) "hash") 498 | (check-equal? (SADD 'k:set "val") 1) 499 | (check-equal? (TYPE 'k:set) "set")) 500 | 501 | ;; sets 502 | (test 503 | (check-true (SET 'not-set 1)) 504 | (check-redis-exn (SADD 'not-set 1)) 505 | (check-equal? (SADD 'myset "Hello") 1) 506 | (check-equal? (SADD 'myset "World") 1) 507 | (check-equal? (SADD 'myset "World") 0) 508 | (check-true (SISMEMBER 'myset "Hello")) 509 | (check-false (SISMEMBER 'myset "Dello")) 510 | (check-set-equal? (SMEMBERS 'myset) (#"Hello" #"World")) 511 | (check-equal? (SCARD 'myset) 2) 512 | (check-equal? (SADD 'myset "H" "E" "L" "L" "O") 4) 513 | (check-set-equal? (SMEMBERS 'myset)(#"Hello" #"World" #"H" #"E" #"L" #"O")) 514 | (check-equal? (SCARD 'myset) 6) 515 | (check-equal? (SADD 's1 #"A") 1) 516 | (check-equal? (list->set (SDIFF 'myset 's1)) (list->set (SMEMBERS 'myset))) 517 | (check-equal? (SADD 's2 #"H" #"E") 2) 518 | (check-set-equal? (SDIFF 'myset 's1 's2) (#"Hello" #"World" #"L" #"O")) 519 | (check-equal? (SDIFFSTORE 'destset 'myset 's1 's2) 4) 520 | (check-set-equal? (SMEMBERS 'destset) (#"Hello" #"World" #"L" #"O")) 521 | (check-set-equal? (SINTER 'myset 's1) ()) 522 | (check-set-equal? (SINTER 'myset 's2) (#"H" #"E")) 523 | (check-set-equal? (SINTER 'myset 's1 's2) ()) 524 | (check-equal? (SINTERSTORE 'destset 'myset 's2) 2) 525 | (check-set-equal? (SMEMBERS 'destset) (#"H" #"E")) 526 | (check-redis-exn (SMOVE 'not-set 'myset 1)) 527 | (check-redis-exn (SMOVE 'myset 'not-set 1)) 528 | (check-false (SMOVE 'myset 's1 "Dello")) 529 | (check-true (SMOVE 'myset 's1 "Hello")) 530 | (check-set-equal? (SMEMBERS 'myset) (#"World" #"H" #"E" #"L" #"O")) 531 | (check-set-equal? (SMEMBERS 's1) (#"Hello" #"A")) 532 | (check-true (let ([x (SRANDMEMBER 's1)]) 533 | (or (equal? x #"Hello") (equal? x #"A")))) 534 | (check-set-equal? (SRANDMEMBER 's1 2) (#"Hello" #"A")) 535 | (check-set-equal? (SRANDMEMBER 's1 3) (#"Hello" #"A")) 536 | (check-true (let ([xs (list->set (SRANDMEMBER 's1 -3))]) 537 | (or (equal? xs (set #"Hello" #"A")) 538 | (equal? xs (set #"A")) (equal? xs (set #"Hello"))))) 539 | (check-true (let ([x (SPOP 's1)]) 540 | (or (equal? x #"Hello") (equal? x #"A")))) 541 | (check-true (let ([x (SPOP 's1)]) 542 | (or (equal? x #"Hello") (equal? x #"A")))) 543 | (check-false (SPOP 's1)) 544 | (check-set-equal? (SRANDMEMBER 's1 1) ()) 545 | (check-redis-exn (SRANDMEMBER 'not-set 1)) 546 | (check-set-equal? (SRANDMEMBER 'non-exist 1) ()) 547 | (check-false (SRANDMEMBER 'non-exist)) 548 | (check-false (SPOP 'non-exist)) 549 | (check-equal? (SREM 'myset "World") 1) 550 | (check-equal? (SREM 'myset "World") 0) 551 | (check-equal? (SREM 'myset "H" "E" "L") 3) 552 | (check-set-equal? (SMEMBERS 'myset) (#"O")) 553 | (check-redis-exn (SREM 'not-set 1)) 554 | (check-equal? (SREM 'non-exist 1) 0) 555 | (check-set-equal? (SUNION 'myset 's2) (#"H" #"E" #"O")) 556 | (check-equal? (SUNIONSTORE 'destset 'myset 's2) 3) 557 | (check-set-equal? (SMEMBERS 'destset) (#"H" #"E" #"O"))) 558 | 559 | ;; sorted sets 560 | (test 561 | (check-true (SET 'not-zset 1)) 562 | (check-redis-exn (ZADD 'not-zset 1)) 563 | (check-equal? (ZADD 'zset 1 "one") 1) 564 | (check-equal? (ZCARD 'zset) 1) 565 | (check-equal? (ZADD 'zset 1 "uno") 1) 566 | (check-equal? (ZCARD 'zset) 2) 567 | (check-equal? (ZADD 'zset 2 "two") 1) 568 | (check-equal? (ZCARD 'zset) 3) 569 | (check-equal? (ZADD 'zset 3 "two") 0) 570 | (check-equal? (ZCARD 'zset) 3) 571 | (check-equal? (ZCARD 'non-exist) 0) 572 | (check-equal? (ZRANGE 'zset 0 -1 'WITHSCORES) 573 | (list #"one" #"1" #"uno" #"1" #"two" #"3")) 574 | (check-equal? (ZRANGE 'zset 0 -1) 575 | (list #"one" #"uno" #"two")) 576 | (check-equal? (ZREVRANGE 'zset 0 -1 'WITHSCORES) 577 | (list #"two" #"3" #"uno" #"1" #"one" #"1")) 578 | (check-equal? (ZREVRANGE 'zset 0 -1) 579 | (list #"two" #"uno" #"one")) 580 | (check-equal? (ZCOUNT 'zset "-inf" "+inf") 3) 581 | (check-equal? (ZCOUNT 'zset "(1" 3) 1) 582 | (check-equal? (ZINCRBY 'zset 4 "one") #"5") 583 | (check-equal? (ZRANGE 'zset 0 -1 'WITHSCORES) 584 | (list #"uno" #"1" #"two" #"3" #"one" #"5")) 585 | (check-equal? (ZADD 'zset2 1 "one" 2 "two" 3 "three") 3) 586 | (check-equal? (ZINTERSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3) 2) 587 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 588 | (list #"two" #"12" #"one" #"13")) 589 | (check-equal? (ZINTERSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3 590 | 'AGGREGATE 'SUM) 2) 591 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 592 | (list #"two" #"12" #"one" #"13")) 593 | (check-equal? (ZINTERSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3 594 | 'AGGREGATE 'MAX) 2) 595 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 596 | (list #"two" #"6" #"one" #"10")) 597 | (check-equal? (ZINTERSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3 598 | 'AGGREGATE 'MIN) 2) 599 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 600 | (list #"one" #"3" #"two" #"6")) 601 | (check-equal? (ZRANGEBYSCORE 'zset "-inf" "+inf") 602 | (list #"uno" #"two" #"one")) 603 | (check-equal? (ZRANGEBYSCORE 'zset "-inf" "+inf" 'WITHSCORES) 604 | (ZRANGE 'zset 0 -1 'WITHSCORES)) 605 | (check-equal? (ZRANGEBYSCORE 'zset "(1" "5") (list #"two" #"one")) 606 | (check-equal? (ZRANGEBYSCORE 'zset "(1" "5" 'LIMIT 0 1) (list #"two")) 607 | (check-equal? (ZRANGEBYSCORE 'zset "(1" "5" 'LIMIT 1 1) (list #"one")) 608 | (check-equal? (ZRANGEBYSCORE 'zset "(1" "5" 'LIMIT 2 1) (list)) 609 | (check-equal? (ZRANGEBYSCORE 'zset "(1" "(5") (list #"two")) 610 | (check-equal? (ZRANK 'zset "two") 1) 611 | (check-equal? (ZRANK 'zset "one") 2) 612 | (check-equal? (ZRANK 'zset "uno") 0) 613 | (check-false (ZRANK 'non-exist "two")) 614 | (check-false (ZRANK 'zset "five")) 615 | (check-equal? (ZREVRANK 'zset "two") 1) 616 | (check-equal? (ZREVRANK 'zset "one") 0) 617 | (check-equal? (ZREVRANK 'zset "uno") 2) 618 | (check-false (ZREVRANK 'non-exist "two")) 619 | (check-false (ZREVRANK 'zset "five")) 620 | (check-redis-exn (ZREM 'not-zset "one")) 621 | (check-equal? (ZREM 'zset "two") 1) 622 | (check-equal? (ZRANGE 'zset 0 -1 'WITHSCORES) 623 | (list #"uno" #"1" #"one" #"5")) 624 | (check-equal? (ZREMRANGEBYRANK 'zset 0 1) 2) 625 | (check-equal? (ZRANGE 'zset 0 -1 'withscores) null) 626 | (check-equal? (ZADD 'zset 1 "one") 1) 627 | (check-equal? (ZADD 'zset 2 "two") 1) 628 | (check-equal? (ZADD 'zset 3 "three") 1) 629 | (check-equal? (ZREMRANGEBYSCORE 'zset "-inf" "(2") 1) 630 | (check-equal? (ZRANGE 'zset 0 -1 'withscores) 631 | (list #"two" #"2" #"three" #"3")) 632 | (check-equal? (ZADD 'zset 1 "one") 1) 633 | (check-equal? (ZREVRANGEBYSCORE 'zset "3" "(1") (list #"three" #"two")) 634 | (check-equal? (ZREVRANGEBYSCORE 'zset "3" "(1" 'LIMIT 0 1) (list #"three")) 635 | (check-equal? (ZREVRANGEBYSCORE 'zset "3" "(1" 'LIMIT 1 1) (list #"two")) 636 | (check-equal? (ZREVRANGEBYSCORE 'zset "3" "(1" 'LIMIT 2 1) (list)) 637 | (check-equal? (ZREVRANGEBYSCORE 'zset "(3" "(1") (list #"two")) 638 | (check-equal? (ZSCORE 'zset "one") #"1") 639 | (check-false (ZSCORE 'zset "five")) 640 | (check-false (ZSCORE 'non-exist 1)) 641 | (check-equal? (ZADD 'zset 4 "four") 1) 642 | (check-equal? (ZUNIONSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3) 4) 643 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 644 | (list #"one" #"5" #"four" #"8" #"two" #"10" #"three" #"15")) 645 | (check-equal? (ZUNIONSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3 646 | 'AGGREGATE 'SUM) 4) 647 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 648 | (list #"one" #"5" #"four" #"8" #"two" #"10" #"three" #"15")) 649 | (check-equal? (ZUNIONSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3 650 | 'AGGREGATE 'MAX) 4) 651 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 652 | (list #"one" #"3" #"two" #"6" #"four" #"8" #"three" #"9")) 653 | (check-equal? (ZUNIONSTORE 'zdest 2 'zset 'zset2 'WEIGHTS 2 3 654 | 'AGGREGATE 'MIN) 4) 655 | (check-equal? (ZRANGE 'zdest 0 -1 'WITHSCORES) 656 | (list #"one" #"2" #"two" #"4" #"three" #"6" #"four" #"8"))) 657 | 658 | ;; misc 659 | (test 660 | (check-equal? (ECHO "Hello World!") #"Hello World!") 661 | (check-equal? (PING) "PONG") 662 | (check-equal? (length (TIME)) 2) 663 | (check-equal? (car (TIME)) (car (TIME)))) 664 | 665 | ;; restore old config parameters 666 | (newline) 667 | (printf "Tests done. Restoring old parameters: ..........\n") 668 | (printf "- restoring \"dir\" to: ~a\n" rdb-dir) 669 | (send-cmd 'config 'set 'dir rdb-dir) 670 | (printf "- restoring \"dbfilename\" to: ~a\n" rdb-file) 671 | (send-cmd 'config 'set 'dbfilename rdb-file) 672 | (unregister-custodian-shutdown dir+file cust-reg) 673 | )) 674 | --------------------------------------------------------------------------------