Update redis vocabulary to use the modern protocol
The existing Redis vocabulary was using a very old and outdated version of the Redis protocol that couldn't even write values to a modern Redis install. This patch updates the library and tests to use the newer protocol, which should also work on Redis servers all the way back to Redis 1.2.db4
Benjamin Pollack
parent
0d4afd2f31
commit
7b1876250b
|
|
@ -11,11 +11,11 @@ M: redis assoc-size [ redis-dbsize ] with-redis ;
|
|||
|
||||
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= ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Bruno Deferrari
|
||||
Benjamin Pollack
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Bruno Deferrari
|
||||
Benjamin Pollack
|
||||
|
|
|
|||
|
|
@ -4,148 +4,171 @@ USING: tools.test redis.command-writer io.streams.string ;
|
|||
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"
|
||||
|
|
@ -153,7 +176,8 @@ IN: redis.command-writer.tests
|
|||
] 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"
|
||||
|
|
@ -161,7 +185,8 @@ IN: redis.command-writer.tests
|
|||
] 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"
|
||||
|
|
@ -170,31 +195,37 @@ IN: redis.command-writer.tests
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -1,126 +1,123 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,70 @@
|
|||
! 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
|
||||
|
|
@ -1,8 +1,7 @@
|
|||
! 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
|
||||
|
|
@ -11,7 +10,7 @@ IN: redis
|
|||
: 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 ;
|
||||
|
|
@ -25,7 +24,7 @@ IN: redis
|
|||
: 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 ;
|
||||
|
|
@ -37,9 +36,9 @@ IN: redis
|
|||
: 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 ;
|
||||
|
|
@ -66,25 +65,25 @@ IN: redis
|
|||
: 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 ;
|
||||
|
|
@ -99,7 +98,7 @@ CONSTANT: default-redis-port 6379
|
|||
redis new
|
||||
"127.0.0.1" >>host
|
||||
default-redis-port >>port
|
||||
latin1 >>encoding ;
|
||||
utf8 >>encoding ;
|
||||
|
||||
: redis-do-connect ( redis -- stream )
|
||||
[ host>> ] [ port>> ] [ encoding>> ] tri
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Bruno Deferrari
|
||||
Benjamin Pollack
|
||||
|
|
|
|||
|
|
@ -3,17 +3,28 @@
|
|||
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>
|
||||
|
||||
|
|
@ -25,3 +36,6 @@ PRIVATE>
|
|||
{ CHAR: * [ string>number read-multi-bulk ] }
|
||||
{ CHAR: - [ handle-error ] }
|
||||
} case ;
|
||||
|
||||
: check-response ( -- )
|
||||
read-response drop ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue