M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ;
-M: redis set-at [ redis-set drop ] with-redis ;
+M: redis set-at [ redis-set ] with-redis ;
M: redis delete-at [ redis-del drop ] with-redis ;
-M: redis clear-assoc [ redis-flushdb drop ] with-redis ;
+M: redis clear-assoc [ redis-flushdb ] with-redis ;
M: redis equal? assoc= ;
Bruno Deferrari
+Benjamin Pollack
Bruno Deferrari
+Benjamin Pollack
IN: redis.command-writer.tests
#! Connection
-[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test
+{ "*1\r\n$4\r\nQUIT\r\n" }
+[ [ quit ] with-string-writer ] unit-test
-[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test
+{ "*1\r\n$4\r\nPING\r\n" }
+[ [ ping ] with-string-writer ] unit-test
-[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nAUTH\r\n$8\r\npassword\r\n" }
+[ [ "password" auth ] with-string-writer ] unit-test
#! String values
-[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test
+{ "*3\r\n$3\r\nSET\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" set ] with-string-writer ] unit-test
-[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test
+{ "*2\r\n$3\r\nGET\r\n$3\r\nkey\r\n" }
+[ [ "key" get ] with-string-writer ] unit-test
-[ "GETSET key 3\r\nfoo\r\n" ] [
- [ "foo" "key" getset ] with-string-writer
-] unit-test
+{ "*3\r\n$6\r\nGETSET\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" getset ] with-string-writer ] unit-test
-[ "MGET key1 key2 key3\r\n" ] [
- [ { "key1" "key2" "key3" } mget ] with-string-writer
-] unit-test
+{ "*4\r\n$4\r\nMGET\r\n$4\r\nkey1\r\n$4\r\nkey2\r\n$4\r\nkey3\r\n" }
+[ [ { "key1" "key2" "key3" } mget ] with-string-writer ] unit-test
-[ "SETNX key 3\r\nfoo\r\n" ] [
- [ "foo" "key" setnx ] with-string-writer
-] unit-test
+{ "*3\r\n$5\r\nSETNX\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" setnx ] with-string-writer ] unit-test
-[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nINCR\r\n$3\r\nkey\r\n" }
+[ [ "key" incr ] with-string-writer ] unit-test
-[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test
+{ "*3\r\n$6\r\nINCRBY\r\n$3\r\nkey\r\n$1\r\n7\r\n" }
+[ [ 7 "key" incrby ] with-string-writer ] unit-test
-[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nDECR\r\n$3\r\nkey\r\n" }
+[ [ "key" decr ] with-string-writer ] unit-test
-[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test
+{ "*3\r\n$6\r\nDECRBY\r\n$3\r\nkey\r\n$1\r\n7\r\n" }
+[ [ 7 "key" decrby ] with-string-writer ] unit-test
-[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test
+{ "*2\r\n$6\r\nEXISTS\r\n$3\r\nkey\r\n" }
+[ [ "key" exists ] with-string-writer ] unit-test
-[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test
+{ "*2\r\n$3\r\nDEL\r\n$3\r\nkey\r\n" }
+[ [ "key" del ] with-string-writer ] unit-test
-[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nTYPE\r\n$3\r\nkey\r\n" }
+[ [ "key" type ] with-string-writer ] unit-test
#! Key space
-[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nKEYS\r\n$4\r\npat*\r\n" }
+[ [ "pat*" keys ] with-string-writer ] unit-test
-[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test
+{ "*1\r\n$9\r\nRANDOMKEY\r\n" }
+[ [ randomkey ] with-string-writer ] unit-test
-[ "RENAME key newkey\r\n" ] [
+{ "*3\r\n$6\r\nRENAME\r\n$3\r\nkey\r\n$6\r\nnewkey\r\n" }
+[
[ "newkey" "key" rename ] with-string-writer
] unit-test
-[ "RENAMENX key newkey\r\n" ] [
+{ "*3\r\n$8\r\nRENAMENX\r\n$3\r\nkey\r\n$6\r\nnewkey\r\n" }
+[
[ "newkey" "key" renamenx ] with-string-writer
] unit-test
-[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test
+{ "*1\r\n$6\r\nDBSIZE\r\n" }
+[ [ dbsize ] with-string-writer ] unit-test
-[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test
+{ "*3\r\n$6\r\nEXPIRE\r\n$3\r\nkey\r\n$1\r\n7\r\n" }
+[ [ 7 "key" expire ] with-string-writer ] unit-test
#! Lists
-[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test
+{ "*3\r\n$5\r\nRPUSH\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" rpush ] with-string-writer ] unit-test
-[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test
+{ "*3\r\n$5\r\nLPUSH\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" lpush ] with-string-writer ] unit-test
-[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nLLEN\r\n$3\r\nkey\r\n" }
+[ [ "key" llen ] with-string-writer ] unit-test
-[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test
+{ "*4\r\n$6\r\nLRANGE\r\n$3\r\nkey\r\n$1\r\n5\r\n$1\r\n9\r\n" }
+[ [ 5 9 "key" lrange ] with-string-writer ] unit-test
-[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
+{ "*4\r\n$5\r\nLTRIM\r\n$3\r\nkey\r\n$1\r\n5\r\n$1\r\n9\r\n" }
+[ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
-[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test
+{ "*3\r\n$6\r\nLINDEX\r\n$3\r\nkey\r\n$1\r\n7\r\n" }
+[ [ 7 "key" lindex ] with-string-writer ] unit-test
-[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
+{ "*4\r\n$4\r\nLSET\r\n$3\r\nkey\r\n$1\r\n0\r\n$3\r\nfoo\r\n" }
+[ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
-[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
+{ "*4\r\n$4\r\nLREM\r\n$3\r\nkey\r\n$1\r\n1\r\n$3\r\nfoo\r\n" }
+[ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
-[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nLPOP\r\n$3\r\nkey\r\n" }
+[ [ "key" lpop ] with-string-writer ] unit-test
-[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test
+{ "*2\r\n$4\r\nRPOP\r\n$3\r\nkey\r\n" }
+[ [ "key" rpop ] with-string-writer ] unit-test
#! Sets
-[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test
+{ "*3\r\n$4\r\nSADD\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" sadd ] with-string-writer ] unit-test
-[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test
+{ "*3\r\n$4\r\nSREM\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" srem ] with-string-writer ] unit-test
-[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [
- [ "foo" "dstkey" "srckey" smove ] with-string-writer
-] unit-test
+{ "*4\r\n$5\r\nSMOVE\r\n$6\r\nsrckey\r\n$6\r\ndstkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "dstkey" "srckey" smove ] with-string-writer ] unit-test
-[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test
+{ "*2\r\n$5\r\nSCARD\r\n$3\r\nkey\r\n" }
+[ [ "key" scard ] with-string-writer ] unit-test
-[ "SISMEMBER key 3\r\nfoo\r\n" ] [
- [ "foo" "key" sismember ] with-string-writer
-] unit-test
+{ "*3\r\n$9\r\nSISMEMBER\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
+[ [ "foo" "key" sismember ] with-string-writer ] unit-test
-[ "SINTER key1 key2 key3\r\n" ] [
- [ { "key1" "key2" "key3" } sinter ] with-string-writer
-] unit-test
+{ "*4\r\n$6\r\nSINTER\r\n$4\r\nkey1\r\n$4\r\nkey2\r\n$4\r\nkey3\r\n" }
+[ [ { "key1" "key2" "key3" } sinter ] with-string-writer ] unit-test
-[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [
+{ "*5\r\n$11\r\nSINTERSTORE\r\n$6\r\ndstkey\r\n$4\r\nkey1\r\n$4\r\nkey2\r\n$4\r\nkey3\r\n" }
+[
[ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer
] unit-test
-[ "SUNION key1 key2 key3\r\n" ] [
+{ "*4\r\n$6\r\nSUNION\r\n$4\r\nkey1\r\n$4\r\nkey2\r\n$4\r\nkey3\r\n" }
+[
[ { "key1" "key2" "key3" } sunion ] with-string-writer
] unit-test
-[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [
+{ "*5\r\n$11\r\nSUNIONSTORE\r\n$6\r\ndstkey\r\n$4\r\nkey1\r\n$4\r\nkey2\r\n$4\r\nkey3\r\n" } [
[ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer
] unit-test
-[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test
+{ "*2\r\n$8\r\nSMEMBERS\r\n$3\r\nkey\r\n" }
+[ [ "key" smembers ] with-string-writer ] unit-test
#! Hashes
-[ "HDEL key field\r\n" ] [
- [ "field" "key" hdel ] with-string-writer
-] unit-test
+{ "*3\r\n$4\r\nHDEL\r\n$3\r\nkey\r\n$5\r\nfield\r\n" }
+[ [ "field" "key" hdel ] with-string-writer ] unit-test
-[ "HEXISTS key field\r\n" ] [
- [ "field" "key" hexists ] with-string-writer
-] unit-test
+{ "*3\r\n$7\r\nHEXISTS\r\n$3\r\nkey\r\n$5\r\nfield\r\n" }
+[ [ "field" "key" hexists ] with-string-writer ] unit-test
-[ "HGET key field\r\n" ] [
- [ "field" "key" hget ] with-string-writer
-] unit-test
+{ "*3\r\n$4\r\nHGET\r\n$3\r\nkey\r\n$5\r\nfield\r\n" }
+[ [ "field" "key" hget ] with-string-writer ] unit-test
-[ "HGETALL key\r\n" ] [
- [ "key" hgetall ] with-string-writer
-] unit-test
+{ "*2\r\n$7\r\nHGETALL\r\n$3\r\nkey\r\n" }
+[ [ "key" hgetall ] with-string-writer ] unit-test
-[ "HINCRBY key field 1\r\n" ] [
- [ 1 "field" "key" hincrby ] with-string-writer
-] unit-test
+{ "*4\r\n$7\r\nHINCRBY\r\n$3\r\nkey\r\n$5\r\nfield\r\n$1\r\n1\r\n" }
+[ [ 1 "field" "key" hincrby ] with-string-writer ] unit-test
-[ "HINCRBYFLOAT key field 1.0\r\n" ] [
- [ 1.0 "field" "key" hincrbyfloat ] with-string-writer
-] unit-test
+{ "*4\r\n$12\r\nHINCRBYFLOAT\r\n$3\r\nkey\r\n$5\r\nfield\r\n$3\r\n1.0\r\n" }
+[ [ 1.0 "field" "key" hincrbyfloat ] with-string-writer ] unit-test
-[ "HKEYS key\r\n" ] [
+{ "*2\r\n$5\r\nHKEYS\r\n$3\r\nkey\r\n" } [
[ "key" hkeys ] with-string-writer
] unit-test
-[ "HLEN key\r\n" ] [
+{ "*2\r\n$4\r\nHLEN\r\n$3\r\nkey\r\n" } [
[ "key" hlen ] with-string-writer
] unit-test
-[ "HMGET key field1 field2\r\n" ] [
+{ "*4\r\n$5\r\nHMGET\r\n$3\r\nkey\r\n$6\r\nfield1\r\n$6\r\nfield2\r\n" }
+[
[
{ "field1" "field2" }
"key"
] with-string-writer
] unit-test
-[ "HMSET key field1 value1 field2 value2\r\n" ] [
+{ "*6\r\n$5\r\nHMSET\r\n$3\r\nkey\r\n$6\r\nfield1\r\n$6\r\nvalue1\r\n$6\r\nfield2\r\n$6\r\nvalue2\r\n" }
+[
[
{ { "field1" "value1" } { "field2" "value2" } }
"key"
] with-string-writer
] unit-test
-[ "HSET key field value\r\n" ] [
+{ "*4\r\n$4\r\nHSET\r\n$3\r\nkey\r\n$5\r\nfield\r\n$5\r\nvalue\r\n" }
+[
[
"value"
"field"
] with-string-writer
] unit-test
-[ "HSETNX key field value\r\n" ] [ [ "value" "field" "key" hsetnx ] with-string-writer ] unit-test
+{ "*4\r\n$6\r\nHSETNX\r\n$3\r\nkey\r\n$5\r\nfield\r\n$5\r\nvalue\r\n" }
+[ [ "value" "field" "key" hsetnx ] with-string-writer ] unit-test
-[ "HVALS key\r\n" ] [ [ "key" hvals ] with-string-writer ] unit-test
+{ "*2\r\n$5\r\nHVALS\r\n$3\r\nkey\r\n" }
+[ [ "key" hvals ] with-string-writer ] unit-test
#! Multiple db
-[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test
+{ "*2\r\n$6\r\nSELECT\r\n$1\r\n2\r\n" }
+[ [ 2 select ] with-string-writer ] unit-test
-[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test
+{ "*3\r\n$4\r\nMOVE\r\n$3\r\nkey\r\n$1\r\n2\r\n" }
+[ [ 2 "key" move ] with-string-writer ] unit-test
-[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test
+{ "*1\r\n$7\r\nFLUSHDB\r\n" }
+[ [ flushdb ] with-string-writer ] unit-test
-[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test
+{ "*1\r\n$8\r\nFLUSHALL\r\n" }
+[ [ flushall ] with-string-writer ] unit-test
#! Sorting
#! Persistence control
-[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test
+{ "*1\r\n$4\r\nSAVE\r\n" } [ [ save ] with-string-writer ] unit-test
-[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test
+{ "*1\r\n$6\r\nBGSAVE\r\n" } [ [ bgsave ] with-string-writer ] unit-test
-[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test
+{ "*1\r\n$8\r\nLASTSAVE\r\n" } [ [ lastsave ] with-string-writer ] unit-test
-[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test
+{ "*1\r\n$8\r\nSHUTDOWN\r\n" } [ [ shutdown ] with-string-writer ] unit-test
#! Remote server control
-[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test
+{ "*1\r\n$4\r\nINFO\r\n" } [ [ info ] with-string-writer ] unit-test
-[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test
+{ "*1\r\n$7\r\nMONITOR\r\n" } [ [ monitor ] with-string-writer ] unit-test
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io io.crlf kernel math.parser sequences strings interpolate locals ;
+USING: arrays assocs formatting io io.crlf kernel math
+math.parser sequences strings locals ;
IN: redis.command-writer
<PRIVATE
-GENERIC: write-value-with-length ( value -- )
+GENERIC: write-resp ( value -- )
-M: string write-value-with-length
- [ length number>string write crlf ]
- [ write ] bi ;
+M: string write-resp ( string -- )
+ [ length ] keep "$%s\r\n%s\r\n" printf ;
-: space ( -- ) CHAR: space write1 ;
+M: integer write-resp ( integer -- )
+ ":%s\r\n" printf ;
-: write-key/value ( value key -- )
- write space
- write-value-with-length ;
+M: sequence write-resp ( sequence -- )
+ [ length "*%s\r\n" printf ] keep
+ [ write-resp ] each ;
-: write-key/integer ( integer key -- )
- write space
- number>string write ;
+: write-command ( sequence command -- )
+ suffix reverse
+ [ dup number? [ number>string ] when ] map
+ write-resp ;
PRIVATE>
#! Connection
-: quit ( -- ) "QUIT" write crlf ;
-: ping ( -- ) "PING" write crlf ;
-: auth ( password -- ) "AUTH " write write crlf ;
+: quit ( -- ) { "QUIT" } write-resp ;
+: ping ( -- ) { "PING" } write-resp ;
+: auth ( password -- ) 1array "AUTH" write-command ;
#! String values
-: set ( value key -- ) "SET " write write-key/value crlf ;
-: get ( key -- ) "GET " write write crlf ;
-: getset ( value key -- ) "GETSET " write write-key/value crlf ;
-: mget ( keys -- ) "MGET " write " " join write crlf ;
-: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
-: incr ( key -- ) "INCR " write write crlf ;
-: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
-: decr ( key -- ) "DECR " write write crlf ;
-: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
-: exists ( key -- ) "EXISTS " write write crlf ;
-: del ( key -- ) "DEL " write write crlf ;
-: type ( key -- ) "TYPE " write write crlf ;
+: set ( value key -- ) 2array "SET" write-command ;
+: get ( key -- ) 1array "GET" write-command ;
+: getset ( value key -- ) 2array "GETSET" write-command ;
+: mget ( keys -- ) reverse "MGET" write-command ;
+: setnx ( value key -- ) 2array "SETNX" write-command ;
+: incr ( key -- ) 1array "INCR" write-command ;
+: incrby ( integer key -- ) 2array "INCRBY" write-command ;
+: decr ( key -- ) 1array "DECR" write-command ;
+: decrby ( integer key -- ) 2array "DECRBY" write-command ;
+: exists ( key -- ) 1array "EXISTS" write-command ;
+: del ( key -- ) 1array "DEL" write-command ;
+: type ( key -- ) 1array "TYPE" write-command ;
#! Key space
-: keys ( pattern -- ) "KEYS " write write crlf ;
-: randomkey ( -- ) "RANDOMKEY" write crlf ;
-: rename ( newkey key -- ) "RENAME " write write space write crlf ;
-: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
-: dbsize ( -- ) "DBSIZE" write crlf ;
-: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
+: keys ( pattern -- ) 1array "KEYS" write-command ;
+: randomkey ( -- ) { "RANDOMKEY" } write-resp ;
+: rename ( newkey key -- ) 2array "RENAME" write-command ;
+: renamenx ( newkey key -- ) 2array "RENAMENX" write-command ;
+: dbsize ( -- ) { "DBSIZE" } write-resp ;
+: expire ( integer key -- ) 2array "EXPIRE" write-command ;
#! Lists
-: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
-: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
-: llen ( key -- ) "LLEN " write write crlf ;
+: rpush ( value key -- ) 2array "RPUSH" write-command ;
+: lpush ( value key -- ) 2array "LPUSH" write-command ;
+: llen ( key -- ) 1array "LLEN" write-command ;
: lrange ( start end key -- )
- "LRANGE " write write [ space number>string write ] bi@ crlf ;
+ [ swap ] dip 3array "LRANGE" write-command ;
: ltrim ( start end key -- )
- "LTRIM " write write [ space number>string write ] bi@ crlf ;
-: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
-: lset ( value index key -- )
- "LSET " write write-key/integer space write-value-with-length crlf ;
-: lrem ( value amount key -- )
- "LREM " write write-key/integer space write-value-with-length crlf ;
-: lpop ( key -- ) "LPOP " write write crlf ;
-: rpop ( key -- ) "RPOP " write write crlf ;
+ [ swap ] dip 3array "LTRIM" write-command ;
+: lindex ( integer key -- ) 2array "LINDEX" write-command ;
+: lset ( value index key -- ) 3array "LSET" write-command ;
+: lrem ( value amount key -- ) 3array "LREM" write-command ;
+: lpop ( key -- ) 1array "LPOP" write-command ;
+: rpop ( key -- ) 1array "RPOP" write-command ;
#! Sets
-: sadd ( member key -- )
- "SADD " write write space write-value-with-length crlf ;
-: srem ( member key -- )
- "SREM " write write space write-value-with-length crlf ;
+: sadd ( member key -- ) 2array "SADD" write-command ;
+: srem ( member key -- ) 2array "SREM" write-command ;
: smove ( member newkey key -- )
- "SMOVE " write write space write space write-value-with-length crlf ;
-: scard ( key -- ) "SCARD " write write crlf ;
+ 3array "SMOVE" write-command ;
+: scard ( key -- ) 1array "SCARD" write-command ;
: sismember ( member key -- )
- "SISMEMBER " write write space write-value-with-length crlf ;
-: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+ 2array "SISMEMBER" write-command ;
+: sinter ( keys -- ) reverse "SINTER" write-command ;
: sinterstore ( keys destkey -- )
- "SINTERSTORE " write write space " " join write crlf ;
-: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+ [ reverse ] dip suffix "SINTERSTORE" write-command ;
+: sunion ( keys -- ) reverse "SUNION" write-command ;
: sunionstore ( keys destkey -- )
- "SUNIONSTORE " write write " " join space write crlf ;
-: smembers ( key -- ) "SMEMBERS " write write crlf ;
+ [ reverse ] dip suffix "SUNIONSTORE" write-command ;
+: smembers ( key -- ) 1array "SMEMBERS" write-command ;
#! Hashes
-: hdel ( field key -- ) "HDEL " write write space write crlf ;
-: hexists ( field key -- ) "HEXISTS " write write space write crlf ;
-: hget ( field key -- ) "HGET " write write space write crlf ;
-: hgetall ( key -- ) "HGETALL " write write crlf ;
+: hdel ( field key -- ) 2array "HDEL" write-command ;
+: hexists ( field key -- ) 2array "HEXISTS" write-command ;
+: hget ( field key -- ) 2array "HGET" write-command ;
+: hgetall ( key -- ) 1array "HGETALL" write-command ;
: hincrby ( integer field key -- )
- "HINCRBY " write write space write space number>string write crlf ;
+ 3array "HINCRBY" write-command ;
: hincrbyfloat ( float field key -- )
- "HINCRBYFLOAT " write write space write space number>string write crlf ;
-: hkeys ( key -- ) "HKEYS " write write crlf ;
-: hlen ( key -- ) "HLEN " write write crlf ;
-: hmget ( seq key -- )
- "HMGET " write write space " " join write crlf ;
-: hmset ( assoc key -- )
- "HMSET " write write space
- >alist [ " " join ] map " " join write crlf ;
-: hset ( value field key -- ) "HSET " write write space write
- space write crlf ;
-: hsetnx ( value field key -- ) "HSETNX " write write space
- write space write crlf ;
-: hvals ( key -- ) "HVALS " write write crlf ;
+ 3array "HINCRBYFLOAT" write-command ;
+: hkeys ( key -- ) 1array "HKEYS" write-command ;
+: hlen ( key -- ) 1array "HLEN" write-command ;
+: hmget ( seq key -- ) prefix reverse "HMGET" write-command ;
+: hmset ( assoc key -- )
+ [
+ >alist concat reverse
+ ] dip suffix "HMSET" write-command ;
+: hset ( value field key -- ) 3array "HSET" write-command ;
+: hsetnx ( value field key -- )
+ 3array "HSETNX" write-command ;
+: hvals ( key -- ) 1array "HVALS" write-command ;
#! Multiple db
-: select ( integer -- ) "SELECT " write number>string write crlf ;
-: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
-: flushdb ( -- ) "FLUSHDB" write crlf ;
-: flushall ( -- ) "FLUSHALL" write crlf ;
+: select ( integer -- ) 1array "SELECT" write-command ;
+: move ( integer key -- ) 2array "MOVE" write-command ;
+: flushdb ( -- ) { "FLUSHDB" } write-resp ;
+: flushall ( -- ) { "FLUSHALL" } write-resp ;
#! Sorting
! sort
#! Persistence control
-: save ( -- ) "SAVE" write crlf ;
-: bgsave ( -- ) "BGSAVE" write crlf ;
-: lastsave ( -- ) "LASTSAVE" write crlf ;
-: shutdown ( -- ) "SHUTDOWN" write crlf ;
+: save ( -- ) { "SAVE" } write-resp ;
+: bgsave ( -- ) { "BGSAVE" } write-resp ;
+: lastsave ( -- ) { "LASTSAVE" } write-resp ;
+: shutdown ( -- ) { "SHUTDOWN" } write-resp ;
#! Remote server control
-: info ( -- ) "INFO" write crlf ;
-: monitor ( -- ) "MONITOR" write crlf ;
+: info ( -- ) { "INFO" } write-resp ;
+: monitor ( -- ) { "MONITOR" } write-resp ;
--- /dev/null
+! Copyright (C) 2014 Benjamin Pollack
+! See http://factorcode.org/license.txt for BSD license
+
+USING: continuations kernel redis math math.parser sequences
+sorting tools.test ;
+
+QUALIFIED: redis
+
+IN: redis.tests
+
+: with-redis ( quot -- )
+ [ redis-flushdb ] prepose
+ <redis> swap redis:with-redis ; inline
+
+{ -1 } [ [ "foo" redis-decr ] with-redis ] unit-test
+
+{ 1 } [ [ "foo" redis-incr ] with-redis ] unit-test
+
+{ -2 } [
+ [ 2 "foo" redis-decrby ] with-redis
+] unit-test
+
+{ 2 } [ [ 2 "foo" redis-incrby ] with-redis ] unit-test
+
+{ "hello" } [
+ [
+ "hello" "foo" redis-set
+ "foo" redis-get
+ ] with-redis
+] unit-test
+
+{ { "aa" "ab" "ac" } } [
+ [
+ { "aa" "ab" "ac" "bd" } [ "hello" swap redis-set ] each
+ "a*" redis-keys natural-sort
+ ] with-redis
+] unit-test
+
+{ "hello" } [
+ [
+ "world" "hello" redis-set redis-randomkey
+ ] with-redis
+] unit-test
+
+{ { "3" "2" "1" } "1" "5" "3" } [
+ [
+ { 1 2 3 } [
+ number>string "list" redis-lpush drop
+ ] each
+ 0 -1 "list" redis-lrange
+ "5" 1 "list" redis-lset
+ 3 [ "list" redis-rpop ] times
+ ] with-redis
+] unit-test
+
+{ { "world" } "1" 2 } [
+ [
+ "1" "world" "hello" redis-hset drop
+ "hello" redis-hkeys
+ "world" "hello" redis-hget
+ 1 "world" "hello" redis-hincrby
+ ] with-redis
+] unit-test
+
+{ t } [
+ [
+ "world" "hello" redis-set
+ [ "hello" redis-incr ] [ drop t ] recover
+ ] with-redis
+] unit-test
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io io.sockets io.streams.duplex kernel
-redis.command-writer redis.response-parser splitting
-io.encodings.8-bit.latin1 ;
+redis.command-writer redis.response-parser io.encodings.utf8 ;
IN: redis
#! Connection
: redis-auth ( password -- response ) auth flush read-response ;
#! String values
-: redis-set ( value key -- response ) set flush read-response ;
+: redis-set ( value key -- ) set flush check-response ;
: redis-get ( key -- response ) get flush read-response ;
: redis-getset ( value key -- response ) getset flush read-response ;
: redis-mget ( keys -- response ) mget flush read-response ;
: redis-type ( key -- response ) type flush read-response ;
#! Key space
-: redis-keys ( pattern -- response ) keys flush read-response " " split ;
+: redis-keys ( pattern -- response ) keys flush read-response ;
: redis-randomkey ( -- response ) randomkey flush read-response ;
: redis-rename ( newkey key -- response ) rename flush read-response ;
: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
: redis-lpush ( value key -- response ) lpush flush read-response ;
: redis-llen ( key -- response ) llen flush read-response ;
: redis-lrange ( start end key -- response ) lrange flush read-response ;
-: redis-ltrim ( start end key -- response ) ltrim flush read-response ;
+: redis-ltrim ( start end key -- ) ltrim flush check-response ;
: redis-lindex ( integer key -- response ) lindex flush read-response ;
-: redis-lset ( value index key -- response ) lset flush read-response ;
+: redis-lset ( value index key -- ) lset flush check-response ;
: redis-lrem ( value amount key -- response ) lrem flush read-response ;
: redis-lpop ( key -- response ) lpop flush read-response ;
: redis-rpop ( key -- response ) rpop flush read-response ;
: redis-hkeys ( key -- response ) hkeys flush read-response ;
: redis-hlen ( key -- response ) hlen flush read-response ;
: redis-hmget ( seq key -- response ) hmget flush read-response ;
-: redis-hmset ( assoc key -- response ) hmset flush read-response ;
+: redis-hmset ( assoc key -- ) hmset flush check-response ;
: redis-hset ( value field key -- response ) hset flush read-response ;
: redis-hsetnx ( value field key -- response ) hsetnx flush read-response ;
: redis-hvals ( key -- response ) hvals flush read-response ;
#! Multiple db
-: redis-select ( integer -- response ) select flush read-response ;
+: redis-select ( integer -- ) select flush check-response ;
: redis-move ( integer key -- response ) move flush read-response ;
-: redis-flushdb ( -- response ) flushdb flush read-response ;
-: redis-flushall ( -- response ) flushall flush read-response ;
+: redis-flushdb ( -- ) flushdb flush check-response ;
+: redis-flushall ( -- ) flushall flush check-response ;
#! Sorting
! sort
#! Persistence control
-: redis-save ( -- response ) save flush read-response ;
-: redis-bgsave ( -- response ) bgsave flush read-response ;
+: redis-save ( -- ) save flush check-response ;
+: redis-bgsave ( -- ) bgsave flush check-response ;
: redis-lastsave ( -- response ) lastsave flush read-response ;
-: redis-shutdown ( -- response ) shutdown flush read-response ;
+: redis-shutdown ( -- ) shutdown flush check-response ;
#! Remote server control
: redis-info ( -- response ) info flush read-response ;
redis new
"127.0.0.1" >>host
default-redis-port >>port
- latin1 >>encoding ;
+ utf8 >>encoding ;
: redis-do-connect ( redis -- stream )
[ host>> ] [ port>> ] [ encoding>> ] tri
Bruno Deferrari
+Benjamin Pollack
USING: combinators io kernel math math.parser sequences ;
IN: redis.response-parser
+DEFER: read-response
+
+TUPLE: redis-response message ;
+ERROR: redis-error message ;
+
+: <redis-response> ( message -- redis-response )
+ redis-response boa ;
+
<PRIVATE
-: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
-: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
+: read-bulk ( n -- bytes )
+ dup 0 < [ drop f ] [ read 2 read drop ] if ;
: read-multi-bulk ( n -- seq/f )
- dup 0 < [ drop f ] [
- iota [ drop (read-multi-bulk) ] map
- ] if ;
+ dup 0 <
+ [ drop f ]
+ [ [ read-response ] replicate ] if ;
-: handle-response ( string -- string ) ; ! TODO
-: handle-error ( string -- string ) ; ! TODO
+: handle-response ( string -- string )
+ <redis-response> ;
+
+: handle-error ( string -- * )
+ redis-error ;
PRIVATE>
{ CHAR: * [ string>number read-multi-bulk ] }
{ CHAR: - [ handle-error ] }
} case ;
+
+: check-response ( -- )
+ read-response drop ;
projects / factor.git / commitdiff