extra/redis/command-writer/command-writer.factor

   1 ! Copyright (C) 2009 Bruno Deferrari
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs formatting kernel math math.parser
   4 sequences strings make ;
   5 IN: redis.command-writer
   6
   7 <PRIVATE
   8
   9 GENERIC: write-resp ( value -- )
  10
  11 M: string write-resp ( string -- )
  12     [ length ] keep "$%s\r\n%s\r\n" printf ;
  13
  14 M: integer write-resp ( integer -- )
  15     ":%s\r\n" printf ;
  16
  17 M: sequence write-resp ( sequence -- )
  18     [ length "*%s\r\n" printf ] keep
  19     [ write-resp ] each ;
  20
  21 : write-command ( sequence command -- )
  22     suffix reverse
  23     [ dup number? [ number>string ] when ] map
  24     write-resp ;
  25
  26 : write-command-multi ( sequence command -- )
  27     prepend
  28     [ dup number? [ number>string ] when ] map
  29     write-resp ;
  30
  31 :: (script-eval) ( script keys args command -- )
  32     [ script , keys length , keys % args % ] { } make
  33     { command }
  34     write-command-multi ;
  35
  36 PRIVATE>
  37
  38 ! Connection
  39 : quit ( -- ) { "QUIT" } write-resp ;
  40 : ping ( -- ) { "PING" } write-resp ;
  41 : auth ( password -- ) 1array "AUTH" write-command ;
  42
  43 ! String values
  44 : set ( value key -- ) 2array "SET" write-command ;
  45 : get ( key -- ) 1array "GET" write-command ;
  46 : getset ( value key -- ) 2array "GETSET" write-command ;
  47 : mget ( keys -- ) reverse "MGET" write-command ;
  48 : setnx ( value key -- ) 2array "SETNX" write-command ;
  49 : incr ( key -- ) 1array "INCR" write-command ;
  50 : incrby ( integer key -- ) 2array "INCRBY" write-command ;
  51 : decr ( key -- ) 1array "DECR" write-command ;
  52 : decrby ( integer key -- ) 2array "DECRBY" write-command ;
  53 : exists ( key -- ) 1array "EXISTS" write-command ;
  54 : del ( key -- ) 1array "DEL" write-command ;
  55 : type ( key -- ) 1array "TYPE" write-command ;
  56
  57 ! Key space
  58 : keys ( pattern -- ) 1array "KEYS" write-command ;
  59 : randomkey ( -- ) { "RANDOMKEY" } write-resp ;
  60 : rename ( newkey key -- ) 2array "RENAME" write-command ;
  61 : renamenx ( newkey key -- ) 2array "RENAMENX" write-command ;
  62 : dbsize ( -- ) { "DBSIZE" } write-resp ;
  63 : expire ( integer key -- ) 2array "EXPIRE" write-command ;
  64
  65 ! Lists
  66 : rpush ( value key -- ) 2array "RPUSH" write-command ;
  67 : lpush ( value key -- ) 2array "LPUSH" write-command ;
  68 : llen ( key -- ) 1array "LLEN" write-command ;
  69 : lrange ( start end key -- )
  70     swapd 3array "LRANGE" write-command ;
  71 : ltrim ( start end key -- )
  72     swapd 3array "LTRIM" write-command ;
  73 : lindex ( integer key -- ) 2array "LINDEX" write-command ;
  74 : lset ( value index key -- ) 3array "LSET" write-command ;
  75 : lrem ( value amount key -- ) 3array "LREM" write-command ;
  76 : lpop ( key -- ) 1array "LPOP" write-command ;
  77 : rpop ( key -- ) 1array "RPOP" write-command ;
  78
  79 ! Sets
  80 : sadd ( member key -- ) 2array "SADD" write-command ;
  81 : srem  ( member key -- ) 2array "SREM" write-command ;
  82 : smove ( member newkey key -- )
  83     3array "SMOVE" write-command ;
  84 : scard ( key -- ) 1array "SCARD" write-command ;
  85 : sismember ( member key -- )
  86     2array "SISMEMBER" write-command ;
  87 : sinter ( keys -- ) reverse "SINTER" write-command ;
  88 : sinterstore ( keys destkey -- )
  89     [ reverse ] dip suffix "SINTERSTORE" write-command ;
  90 : sunion ( keys -- ) reverse "SUNION" write-command ;
  91 : sunionstore ( keys destkey -- )
  92     [ reverse ] dip suffix "SUNIONSTORE" write-command ;
  93 : smembers ( key -- ) 1array "SMEMBERS" write-command ;
  94
  95 ! Hashes
  96 : hdel ( field key -- ) 2array "HDEL" write-command ;
  97 : hexists ( field key -- ) 2array "HEXISTS" write-command ;
  98 : hget ( field key -- ) 2array "HGET" write-command ;
  99 : hgetall ( key -- ) 1array "HGETALL" write-command ;
 100 : hincrby ( integer field key -- )
 101     3array "HINCRBY" write-command ;
 102 : hincrbyfloat (  float field key -- )
 103     3array "HINCRBYFLOAT" write-command ;
 104 : hkeys ( key -- ) 1array "HKEYS" write-command ;
 105 : hlen ( key -- ) 1array "HLEN" write-command ;
 106 : hmget ( seq key  -- ) prefix reverse "HMGET" write-command ;
 107 : hmset ( assoc key -- )
 108     [
 109         >alist concat reverse
 110     ] dip suffix "HMSET" write-command ;
 111 : hset ( value field key -- ) 3array "HSET" write-command ;
 112 : hsetnx ( value field key -- )
 113     3array "HSETNX" write-command ;
 114 : hvals ( key -- ) 1array "HVALS" write-command ;
 115
 116 ! Multiple db
 117 : select ( integer -- ) 1array "SELECT" write-command ;
 118 : move ( integer key -- ) 2array "MOVE" write-command ;
 119 : swapdb ( old new -- ) 2array "SWAPDB" write-command ;
 120 : flushdb ( -- ) { "FLUSHDB" } write-resp ;
 121 : flushall ( -- ) { "FLUSHALL" } write-resp ;
 122
 123 ! Sorting
 124 ! sort
 125
 126 ! Persistence control
 127 : save ( -- ) { "SAVE" } write-resp ;
 128 : bgsave ( -- ) { "BGSAVE" } write-resp ;
 129 : lastsave ( -- ) { "LASTSAVE" } write-resp ;
 130 : shutdown ( -- ) { "SHUTDOWN" } write-resp ;
 131
 132 ! Remote server control
 133 : info ( -- ) { "INFO" } write-resp ;
 134 : monitor ( -- ) { "MONITOR" } write-resp ;
 135
 136 ! Lua
 137 : script-load ( script -- ) 1array { "SCRIPT" "LOAD" } write-command-multi ;
 138 : script-exists ( scripts -- ) { "SCRIPT" "EXISTS" } write-command-multi ;
 139 : script-flush ( -- ) { } { "SCRIPT" "FLUSH" } write-command-multi ;
 140 : script-kill ( -- ) { } { "SCRIPT" "KILL" } write-command-multi ;
 141 ! YES | SYNC | NO
 142 : script-debug ( debug -- ) 1array { "SCRIPT" "DEBUG" } write-command-multi ;
 143 : script-evalsha ( sha keys args -- ) "EVALSHA" (script-eval) ;
 144 : script-eval ( script keys args -- ) "EVAL" (script-eval) ;