From 7b1876250b95a7e9529484fa8b2f03bacb475bd7 Mon Sep 17 00:00:00 2001 From: Benjamin Pollack Date: Fri, 2 May 2014 16:41:44 -0400 Subject: [PATCH] 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. --- extra/redis/assoc/assoc.factor | 4 +- extra/redis/authors.txt | 1 + extra/redis/command-writer/authors.txt | 1 + .../command-writer-tests.factor | 207 ++++++++++-------- .../command-writer/command-writer.factor | 167 +++++++------- extra/redis/redis-tests.factor | 70 ++++++ extra/redis/redis.factor | 27 ++- extra/redis/response-parser/authors.txt | 1 + .../response-parser/response-parser.factor | 28 ++- 9 files changed, 310 insertions(+), 196 deletions(-) create mode 100644 extra/redis/redis-tests.factor diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor index e8bdbbb935..868cf53b5d 100644 --- a/extra/redis/assoc/assoc.factor +++ b/extra/redis/assoc/assoc.factor @@ -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= ; diff --git a/extra/redis/authors.txt b/extra/redis/authors.txt index f4a8cb1dc2..2395bc30ac 100644 --- a/extra/redis/authors.txt +++ b/extra/redis/authors.txt @@ -1 +1,2 @@ Bruno Deferrari +Benjamin Pollack diff --git a/extra/redis/command-writer/authors.txt b/extra/redis/command-writer/authors.txt index f4a8cb1dc2..2395bc30ac 100644 --- a/extra/redis/command-writer/authors.txt +++ b/extra/redis/command-writer/authors.txt @@ -1 +1,2 @@ Bruno Deferrari +Benjamin Pollack diff --git a/extra/redis/command-writer/command-writer-tests.factor b/extra/redis/command-writer/command-writer-tests.factor index 1e3ef59ccd..8c3270c876 100644 --- a/extra/redis/command-writer/command-writer-tests.factor +++ b/extra/redis/command-writer/command-writer-tests.factor @@ -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 diff --git a/extra/redis/command-writer/command-writer.factor b/extra/redis/command-writer/command-writer.factor index 17e4c27c97..06a2cd92cb 100644 --- a/extra/redis/command-writer/command-writer.factor +++ b/extra/redis/command-writer/command-writer.factor @@ -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 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 ; diff --git a/extra/redis/redis-tests.factor b/extra/redis/redis-tests.factor new file mode 100644 index 0000000000..3d53953f06 --- /dev/null +++ b/extra/redis/redis-tests.factor @@ -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 + 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 diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor index 6de729468b..f1a2da9974 100644 --- a/extra/redis/redis.factor +++ b/extra/redis/redis.factor @@ -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 diff --git a/extra/redis/response-parser/authors.txt b/extra/redis/response-parser/authors.txt index f4a8cb1dc2..2395bc30ac 100644 --- a/extra/redis/response-parser/authors.txt +++ b/extra/redis/response-parser/authors.txt @@ -1 +1,2 @@ Bruno Deferrari +Benjamin Pollack diff --git a/extra/redis/response-parser/response-parser.factor b/extra/redis/response-parser/response-parser.factor index 3d92d553b0..5b4f0b3283 100644 --- a/extra/redis/response-parser/response-parser.factor +++ b/extra/redis/response-parser/response-parser.factor @@ -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 ; + +: ( message -- redis-response ) + redis-response boa ; + 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 ) + ; + +: 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 ; -- 2.34.1