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

@@ -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= ;
 

extra/redis/authors.txt

@@ -1 +1,2 @@
 Bruno Deferrari
+Benjamin Pollack

extra/redis/command-writer/authors.txt

@@ -1 +1,2 @@
 Bruno Deferrari
+Benjamin Pollack

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" ] [
+{ "*3\r\n$6\r\nGETSET\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
-    [ "foo" "key" getset ] with-string-writer
+[ [ "foo" "key" getset ] with-string-writer ] unit-test
-] unit-test
 
-[ "MGET key1 key2 key3\r\n" ] [
+{ "*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
+[ [ { "key1" "key2" "key3" } mget ] with-string-writer ] unit-test
-] unit-test
 
-[ "SETNX key 3\r\nfoo\r\n" ] [
+{ "*3\r\n$5\r\nSETNX\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
-    [ "foo" "key" setnx ] with-string-writer
+[ [ "foo" "key" setnx ] with-string-writer ] unit-test
-] 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" ] [
+{ "*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
+[ [ "foo" "dstkey" "srckey" smove ] with-string-writer ] unit-test
-] 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" ] [
+{ "*3\r\n$9\r\nSISMEMBER\r\n$3\r\nkey\r\n$3\r\nfoo\r\n" }
-    [ "foo" "key" sismember ] with-string-writer
+[ [ "foo" "key" sismember ] with-string-writer ] unit-test
-] unit-test
 
-[ "SINTER key1 key2 key3\r\n" ] [
+{ "*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
+[ [ { "key1" "key2" "key3" } sinter ] with-string-writer ] unit-test
-] 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" ] [
+{ "*3\r\n$4\r\nHDEL\r\n$3\r\nkey\r\n$5\r\nfield\r\n" }
-    [ "field" "key" hdel ] with-string-writer
+[ [ "field" "key" hdel ] with-string-writer ] unit-test
-] unit-test
 
-[ "HEXISTS key field\r\n" ] [
+{ "*3\r\n$7\r\nHEXISTS\r\n$3\r\nkey\r\n$5\r\nfield\r\n" }
-    [ "field" "key" hexists ] with-string-writer
+[ [ "field" "key" hexists ] with-string-writer ] unit-test
-] unit-test
 
-[ "HGET key field\r\n" ] [
+{ "*3\r\n$4\r\nHGET\r\n$3\r\nkey\r\n$5\r\nfield\r\n" }
-    [ "field" "key" hget ] with-string-writer
+[ [ "field" "key" hget ] with-string-writer ] unit-test
-] unit-test
 
-[ "HGETALL key\r\n" ] [
+{ "*2\r\n$7\r\nHGETALL\r\n$3\r\nkey\r\n" }
-    [ "key" hgetall ] with-string-writer
+[ [ "key" hgetall ] with-string-writer ] unit-test
-] unit-test
 
-[ "HINCRBY key field 1\r\n" ] [
+{ "*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
+[ [ 1 "field" "key" hincrby ] with-string-writer ] unit-test
-] unit-test
 
-[ "HINCRBYFLOAT key field 1.0\r\n" ] [
+{ "*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
+[ [ 1.0 "field" "key" hincrbyfloat ] with-string-writer ] unit-test
-] 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

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
 
 <PRIVATE
 
-GENERIC: write-value-with-length ( value -- )
+GENERIC: write-resp ( value -- )
 
-M: string write-value-with-length
+M: string write-resp ( string -- )
-    [ length number>string write crlf ]
+    [ length ] keep "$%s\r\n%s\r\n" printf ;
-    [ write ] bi ;
 
-: space ( -- ) CHAR: space write1 ;
+M: integer write-resp ( integer -- )
+    ":%s\r\n" printf ;
 
-: write-key/value ( value key -- )
+M: sequence write-resp ( sequence -- )
-    write space
+    [ length "*%s\r\n" printf ] keep
-    write-value-with-length ;
+    [ write-resp ] each ;
 
-: write-key/integer ( integer key -- )
+: write-command ( sequence command -- )
-    write space
+    suffix reverse
-    number>string write ;
+    [ dup number? [ number>string ] when ] map
+    write-resp ;
 
 PRIVATE>
 
 #! Connection
-: quit ( -- ) "QUIT" write crlf ;
+: quit ( -- ) { "QUIT" } write-resp ;
-: ping ( -- ) "PING" write crlf ;
+: ping ( -- ) { "PING" } write-resp ;
-: auth ( password -- ) "AUTH " write write crlf ;
+: auth ( password -- ) 1array "AUTH" write-command ;
 
 #! String values
-: set ( value key -- ) "SET " write write-key/value crlf ;
+: set ( value key -- ) 2array "SET" write-command ;
-: get ( key -- ) "GET " write write crlf ;
+: get ( key -- ) 1array "GET" write-command ;
-: getset ( value key -- ) "GETSET " write write-key/value crlf ;
+: getset ( value key -- ) 2array "GETSET" write-command ;
-: mget ( keys -- ) "MGET " write " " join write crlf ;
+: mget ( keys -- ) reverse "MGET" write-command ;
-: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
+: setnx ( value key -- ) 2array "SETNX" write-command ;
-: incr ( key -- ) "INCR " write write crlf ;
+: incr ( key -- ) 1array "INCR" write-command ;
-: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
+: incrby ( integer key -- ) 2array "INCRBY" write-command ;
-: decr ( key -- ) "DECR " write write crlf ;
+: decr ( key -- ) 1array "DECR" write-command ;
-: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
+: decrby ( integer key -- ) 2array "DECRBY" write-command ;
-: exists ( key -- ) "EXISTS " write write crlf ;
+: exists ( key -- ) 1array "EXISTS" write-command ;
-: del ( key -- ) "DEL " write write crlf ;
+: del ( key -- ) 1array "DEL" write-command ;
-: type ( key -- ) "TYPE " write write crlf ;
+: type ( key -- ) 1array "TYPE" write-command ;
 
 #! Key space
-: keys ( pattern -- ) "KEYS " write write crlf ;
+: keys ( pattern -- ) 1array "KEYS" write-command ;
-: randomkey ( -- ) "RANDOMKEY" write crlf ;
+: randomkey ( -- ) { "RANDOMKEY" } write-resp ;
-: rename ( newkey key -- ) "RENAME " write write space write crlf ;
+: rename ( newkey key -- ) 2array "RENAME" write-command ;
-: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
+: renamenx ( newkey key -- ) 2array "RENAMENX" write-command ;
-: dbsize ( -- ) "DBSIZE" write crlf ;
+: dbsize ( -- ) { "DBSIZE" } write-resp ;
-: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
+: expire ( integer key -- ) 2array "EXPIRE" write-command ;
 
 #! Lists
-: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
+: rpush ( value key -- ) 2array "RPUSH" write-command ;
-: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
+: lpush ( value key -- ) 2array "LPUSH" write-command ;
-: llen ( key -- ) "LLEN " write write crlf ;
+: 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 ;
+    [ swap ] dip 3array "LTRIM" write-command ;
-: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
+: lindex ( integer key -- ) 2array "LINDEX" write-command ;
-: lset ( value index key -- )
+: lset ( value index key -- ) 3array "LSET" write-command ;
-    "LSET " write write-key/integer space write-value-with-length crlf ;
+: lrem ( value amount key -- ) 3array "LREM" write-command ;
-: lrem ( value amount key -- )
+: lpop ( key -- ) 1array "LPOP" write-command ;
-    "LREM " write write-key/integer space write-value-with-length crlf ;
+: rpop ( key -- ) 1array "RPOP" write-command ;
-: lpop ( key -- ) "LPOP " write write crlf ;
-: rpop ( key -- ) "RPOP " write write crlf ;
 
 #! Sets
-: sadd ( member key -- )
+: sadd ( member key -- ) 2array "SADD" write-command ;
-    "SADD " write write space write-value-with-length crlf ;
+: srem  ( member key -- ) 2array "SREM" write-command ;
-: srem  ( member key -- )
-    "SREM " write write space write-value-with-length crlf ;
 : smove ( member newkey key -- )
-    "SMOVE " write write space write space write-value-with-length crlf ;
+    3array "SMOVE" write-command ;
-: scard ( key -- ) "SCARD " write write crlf ;
+: scard ( key -- ) 1array "SCARD" write-command ;
 : sismember ( member key -- )
-    "SISMEMBER " write write space write-value-with-length crlf ;
+    2array "SISMEMBER" write-command ;
-: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+: sinter ( keys -- ) reverse "SINTER" write-command ;
 : sinterstore ( keys destkey -- )
-    "SINTERSTORE " write write space " " join write crlf ;
+    [ reverse ] dip suffix "SINTERSTORE" write-command ;
-: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+: sunion ( keys -- ) reverse "SUNION" write-command ;
 : sunionstore ( keys destkey -- )
-    "SUNIONSTORE " write write " " join space write crlf ;
+    [ reverse ] dip suffix "SUNIONSTORE" write-command ;
-: smembers ( key -- ) "SMEMBERS " write write crlf ;
+: smembers ( key -- ) 1array "SMEMBERS" write-command ;
 
 #! Hashes
-: hdel ( field key -- ) "HDEL " write write space write crlf ;
+: hdel ( field key -- ) 2array "HDEL" write-command ;
-: hexists ( field key -- ) "HEXISTS " write write space write crlf ;
+: hexists ( field key -- ) 2array "HEXISTS" write-command ;
-: hget ( field key -- ) "HGET " write write space write crlf ;
+: hget ( field key -- ) 2array "HGET" write-command ;
-: hgetall ( key -- ) "HGETALL " write write crlf ;
+: 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 ;
+    3array "HINCRBYFLOAT" write-command ;
-: hkeys ( key -- ) "HKEYS " write write crlf ;
+: hkeys ( key -- ) 1array "HKEYS" write-command ;
-: hlen ( key -- ) "HLEN " write write crlf ;
+: hlen ( key -- ) 1array "HLEN" write-command ;
-: hmget ( seq key  -- )
+: hmget ( seq key  -- ) prefix reverse "HMGET" write-command ;
-    "HMGET " write write space " " join write crlf ;
 : hmset ( assoc key -- )
-    "HMSET " write write space
+    [
-    >alist [ " " join ] map " " join write crlf ;
+        >alist concat reverse
-: hset ( value field key -- ) "HSET " write write space write
+    ] dip suffix "HMSET" write-command ;
-    space write crlf ;
+: hset ( value field key -- ) 3array "HSET" write-command ;
-: hsetnx ( value field key -- ) "HSETNX " write write space
+: hsetnx ( value field key -- )
-    write space write crlf ;
+    3array "HSETNX" write-command ;
-: hvals ( key -- ) "HVALS " write write crlf ;
+: hvals ( key -- ) 1array "HVALS" write-command ;
 
 #! Multiple db
-: select ( integer -- ) "SELECT " write number>string write crlf ;
+: select ( integer -- ) 1array "SELECT" write-command ;
-: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
+: move ( integer key -- ) 2array "MOVE" write-command ;
-: flushdb ( -- ) "FLUSHDB" write crlf ;
+: flushdb ( -- ) { "FLUSHDB" } write-resp ;
-: flushall ( -- ) "FLUSHALL" write crlf ;
+: flushall ( -- ) { "FLUSHALL" } write-resp ;
 
 #! Sorting
 ! sort
 
 #! Persistence control
-: save ( -- ) "SAVE" write crlf ;
+: save ( -- ) { "SAVE" } write-resp ;
-: bgsave ( -- ) "BGSAVE" write crlf ;
+: bgsave ( -- ) { "BGSAVE" } write-resp ;
-: lastsave ( -- ) "LASTSAVE" write crlf ;
+: lastsave ( -- ) { "LASTSAVE" } write-resp ;
-: shutdown ( -- ) "SHUTDOWN" write crlf ;
+: shutdown ( -- ) { "SHUTDOWN" } write-resp ;
 
 #! Remote server control
-: info ( -- ) "INFO" write crlf ;
+: info ( -- ) { "INFO" } write-resp ;
-: monitor ( -- ) "MONITOR" write crlf ;
+: monitor ( -- ) { "MONITOR" } write-resp ;

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
+    <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

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
+redis.command-writer redis.response-parser io.encodings.utf8 ;
-io.encodings.8-bit.latin1 ;
 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-flushdb ( -- ) flushdb flush check-response ;
-: redis-flushall ( -- response ) flushall flush read-response ;
+: redis-flushall ( -- ) flushall flush check-response ;
 
 #! Sorting
 ! sort
 
 #! Persistence control
-: redis-save ( -- response ) save flush read-response ;
+: redis-save ( -- ) save flush check-response ;
-: redis-bgsave ( -- response ) bgsave flush read-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

extra/redis/response-parser/authors.txt

@@ -1 +1,2 @@
 Bruno Deferrari
+Benjamin Pollack

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 ;
+
+: <redis-response> ( message -- redis-response )
+    redis-response boa ;
+
 <PRIVATE
 
-: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
+: read-bulk ( n -- bytes )
-: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
+    dup 0 < [ drop f ] [ read 2 read drop ] if ;
 : read-multi-bulk ( n -- seq/f )
-    dup 0 < [ drop f ] [
+    dup 0 <
-        iota [ drop (read-multi-bulk) ] map
+    [ drop f ]
-    ] if ;
+    [ [ read-response ] replicate ] if ;
 
-: handle-response ( string -- string ) ; ! TODO
+: handle-response ( string -- string )
-: handle-error ( string -- string ) ; ! TODO
+    <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 ;