redis/redis.carp

(load "git@github.com:carpentry-org/socket@0.1.1")

(deftype RESP
  (Null [])
  (Str [String])
  (Err [String])
  (Integer [Int])
  (Arr [(Array (Box RESP))])
)

(defmodule RESP
  (use-all Array Maybe Pattern Result)

  (hidden c)
  (private c)
  (def c (prn &@&(Arr [(Box.init (Null))])))

  (defn str [r]
    (match @r
      (Null) @"$-1\r\n"
      (Str s) (fmt "$%d\r\n%s\r\n" (String.length &s) &s)
      (Err s) (fmt "-%s\r\n" &s)
      (Integer i) (fmt ":%d\r\n" i)
      (Arr a)
        (let-do [parts [(fmt "*%d\r\n" (Array.length &a))]]
          (for [i 0 (Array.length &a)]
            (Array.push-back! &parts (str (Box.peek (Array.unsafe-nth &a i)))))
          (String.concat &parts))))

  (hidden decode-one)
  (private decode-one)
  (defn decode-one [s pos]
    (if (>= pos (String.length s))
      (Success (Pair.init (Null) pos))
      (case (String.char-at s pos)
        \+ (let [rest-start (+ pos 1)
                 idx (String.index-of-from s \return rest-start)]
             (if (= idx -1)
               (Error @"Malformed simple string")
               (Success (Pair.init
                 (Str (String.slice s rest-start idx))
                 (+ idx 2)))))
        \- (let [rest-start (+ pos 1)
                 idx (String.index-of-from s \return rest-start)]
             (if (= idx -1)
               (Error @"Malformed error string")
               (Success (Pair.init
                 (Err (String.slice s rest-start idx))
                 (+ idx 2)))))
        \: (let [rest-start (+ pos 1)
                 idx (String.index-of-from s \return rest-start)]
             (if (= idx -1)
               (Error @"Malformed integer")
               (match (Int.from-string &(String.slice s rest-start idx))
                 (Maybe.Nothing) (Error @"Could not parse integer in result.")
                 (Maybe.Just n) (Success (Pair.init
                   (Integer n)
                   (+ idx 2))))))
        \$ (let [rest-start (+ pos 1)
                 idx (String.index-of-from s \return rest-start)]
             (if (= idx -1)
               (Error @"Malformed bulk string")
               (match (Int.from-string &(String.slice s rest-start idx))
                 (Maybe.Nothing) (Error @"Error decoding bulk string: does not start with length!")
                 (Maybe.Just len)
                   (if (= len -1)
                     (Success (Pair.init (Null) (+ idx 2)))
                     (let [data-start (+ idx 2)]
                       (Success (Pair.init
                         (Str (String.slice s data-start (+ data-start len)))
                         (+ data-start (+ len 2)))))))))
        \* (let [rest-start (+ pos 1)
                 idx (String.index-of-from s \return rest-start)]
             (if (= idx -1)
               (Error @"Malformed array")
               (match (Int.from-string &(String.slice s rest-start idx))
                 (Maybe.Nothing) (Error @"Error decoding array: does not start with length!")
                 (Maybe.Just len)
                   (if (= len -1)
                     (Success (Pair.init (Null) (+ idx 2)))
                     (if (= len 0)
                       (Success (Pair.init (Arr []) (+ idx 2)))
                       (let-do [cur (+ idx 2)
                                a (Array.allocate len)
                                err @""]
                         (for [i 0 len]
                           (match (decode-one s cur)
                             (Result.Error e) (do (set! err e) (break))
                             (Result.Success p)
                               (do
                                 (aset-uninitialized! &a i (Box.init @(Pair.a &p)))
                                 (set! cur @(Pair.b &p)))))
                         (if (= &err "")
                           (Success (Pair.init (Arr a) cur))
                           (Error err))))))))
        (Error (fmt "Malformed RESP data: got %s" &(String.slice s pos (+ pos 1)))))))

  (doc from-string "converts a RESP string into a `RESP` data structure.")
  (defn from-string [s]
    (if (empty? s)
      (Success (Null))
      (match (decode-one s 0)
        (Result.Error e) (Error e)
        (Result.Success p) (Success @(Pair.a &p)))))

  (definterface to-redis (Fn [a] RESP))
)

(defmodule String
  (defn to-redis [s] (RESP.Str s))
  (implements to-redis String.to-redis)
)

(defmodule Int
  (defn to-redis [s] (RESP.Integer s))
  (implements to-redis Int.to-redis)
)

(deftype Redis [
  sock TcpStream
])

(defmodule Redis
  (use-all Array Result)

  (doc open-on "opens the connection to Redis on port `port`.")
  (defn open-on [host port]
    (match (TcpStream.connect host port)
      (Result.Success s) (Success (init s))
      (Result.Error e) (Error (fmt "Couldn’t connect to %s:%d: %s" host port &e))))

  (doc open "opens the connection to Redis on port 6379.

For variable port numbers please check out [`open-on`](#open-on).")
  (defn open [host] (open-on host 6379))

  (doc read "reads a `RESP` object from Redis.")
  (defn read [r]
    (match (the (Result String String) (TcpStream.read (sock r)))
      (Result.Success s) (RESP.from-string &s)
      (Result.Error e) (Error e)))

  (doc send "sends the command `cmd` with the arguments `args` to Redis.")
  (defn send [r cmd args]
    (let [cmd-parts (copy-map &(fn [x] (Box.init (to-redis @x))) &(Pattern.split #" " &cmd))
          msg (str &(RESP.Arr (concat &[cmd-parts (copy-map &(fn [x] (Box.init @x)) args)])))]
      (ignore (TcpStream.send (sock r) &msg))))

  (doc close "closes the connection to Redis.")
  (defn close [r] (TcpStream.close @(sock &r)))
)

(defndynamic rtreat- [s]
  (let [i (String.index-of s \-)]
    (if (= i -1)
      s
      (String.concat [(String.prefix s i) " " (rtreat- (String.suffix s (+ i 1)))]))))

(defndynamic rconv- [args]
  (if (= (length args) 0)
    (array)
    (cons (list 'to-redis (car args)) (rconv- (cdr args)))))

(defmacro defredis [cmd :rest args]
  (eval
    (list 'defmodule 'Redis
      (list 'doc cmd (String.concat [
        "is a wrapper around the `" (rtreat- (Symbol.str cmd)) "` Redis command.

It takes the same arguments as the [Redis command](https://redis.io/commands/"
(Symbol.str cmd) ")."
      ]))
      (list 'defn cmd (collect-into (cons 'r args) array)
        (list 'do
          (list 'Redis.send 'r (list 'copy (rtreat- (Symbol.str cmd))) (list 'ref (rconv- args)))
          '(Redis.read r))))))

; these commands were scraped from redis.io on the 9th of Feb 2020

(defredis append key value)
(defredis auth password)
(defredis bgrewriteaof)
(defredis bgsave)
(defredis bitcount key)
(defredis bitfield key)
(defredis bitop operation destkey key)
(defredis bitpos key bit)
(defredis blpop key timeout)
(defredis brpop key timeout)
(defredis brpoplpush source destination timeout)
(defredis bzpopmin key timeout)
(defredis bzpopmax key timeout)
(defredis client-id)
(defredis client-kill)
(defredis client-list)
(defredis client-getname)
(defredis client-pause timeout)
(defredis client-reply)
(defredis client-setname connection-name)
(defredis client-unblock client-id)
(defredis cluster-addslots slot)
(defredis cluster-bumpepoch)
(defredis cluster-count-failure-reports node-id)
(defredis cluster-countkeysinslot slot)
(defredis cluster-delslots slot)
(defredis cluster-failover)
(defredis cluster-flushslots)
(defredis cluster-forget node-id)
(defredis cluster-getkeysinslot slot count)
(defredis cluster-info)
(defredis cluster-keyslot key)
(defredis cluster-meet ip port)
(defredis cluster-myid)
(defredis cluster-nodes)
(defredis cluster-replicate node-id)
(defredis cluster-reset)
(defredis cluster-saveconfig)
(defredis cluster-set-config-epoch config-epoch)
(defredis cluster-setslot slot)
(defredis cluster-slaves node-id)
(defredis cluster-replicas node-id)
(defredis cluster-slots)
(defredis command)
(defredis command-count)
(defredis command-getkeys)
(defredis command-info command-name)
(defredis config-get parameter)
(defredis config-rewrite)
(defredis config-set parameter value)
(defredis config-resetstat)
(defredis dbsize)
(defredis debug-object key)
(defredis debug-segfault)
(defredis decr key)
(defredis decrby key decrement)
(defredis del key)
(defredis discard)
(defredis dump key)
(defredis echo message)
(defredis eval script numkeys key)
(defredis evalsha sha1 numkeys key)
(defredis exec)
(defredis exists key)
(defredis expire key seconds)
(defredis expireat key timestamp)
(defredis flushall)
(defredis flushdb)
(defredis geoadd key longitude latitude member)
(defredis geohash key member)
(defredis geopos key member)
(defredis geodist key member1 member2)
(defredis georadius key longitude latitude radius)
(defredis georadiusbymember key member radius)
(defredis get key)
(defredis getbit key offset)
(defredis getrange key start end)
(defredis getset key value)
(defredis hdel key field)
(defredis hexists key field)
(defredis hget key field)
(defredis hgetall key)
(defredis hincrby key field increment)
(defredis hincrbyfloat key field increment)
(defredis hkeys key)
(defredis hlen key)
(defredis hmget key field)
(defredis hmset key field value)
(defredis hset key field value)
(defredis hsetnx key field value)
(defredis hstrlen key field)
(defredis hvals key)
(defredis incr key)
(defredis incrby key increment)
(defredis incrbyfloat key increment)
(defredis info)
(defredis lolwut)
(defredis keys pattern)
(defredis lastsave)
(defredis lindex key index)
(defredis linsert key w pivot element)
(defredis llen key)
(defredis lpop key)
(defredis lpush key element)
(defredis lpushx key element)
(defredis lrange key start stop)
(defredis lrem key count element)
(defredis lset key index element)
(defredis ltrim key start stop)
(defredis memory-doctor)
(defredis memory-help)
(defredis memory-malloc-stats)
(defredis memory-purge)
(defredis memory-stats)
(defredis memory-usage key)
(defredis mget key)
(defredis migrate host port key destination-db timeout)
(defredis module-list)
(defredis module-load path)
(defredis module-unload name)
(defredis monitor)
(defredis move key db)
(defredis mset key value)
(defredis msetnx key value)
(defredis multi)
(defredis object subcommand)
(defredis persist key)
(defredis pexpire key milliseconds)
(defredis pexpireat key milliseconds-timestamp)
(defredis pfadd key element)
(defredis pfcount key)
(defredis pfmerge destkey sourcekey)
(defredis ping)
(defredis psetex key milliseconds value)
(defredis psubscribe pattern)
(defredis pubsub subcommand)
(defredis pttl key)
(defredis publish channel message)
(defredis punsubscribe)
(defredis quit)
(defredis randomkey)
(defredis readonly)
(defredis readwrite)
(defredis rename key newkey)
(defredis renamenx key newkey)
(defredis restore key ttl serialized-value)
(defredis role)
(defredis rpop key)
(defredis rpoplpush source destination)
(defredis rpush key element)
(defredis rpushx key element)
(defredis sadd key member)
(defredis save)
(defredis scard key)
(defredis script-debug mode)
(defredis script-exists sha1)
(defredis script-flush)
(defredis script-kill)
(defredis script-load script)
(defredis sdiff key)
(defredis sdiffstore destination key)
(defredis select index)
(defredis set key value)
(defredis setbit key offset value)
(defredis setex key seconds value)
(defredis setnx key value)
(defredis setrange key offset value)
(defredis shutdown)
(defredis sinter key)
(defredis sinterstore destination key)
(defredis sismember key member)
(defredis slaveof host port)
(defredis replicaof host port)
(defredis slowlog subcommand)
(defredis smembers key)
(defredis smove source destination member)
(defredis sort key)
(defredis spop key)
(defredis srandmember key)
(defredis srem key member)
(defredis strlen key)
(defredis subscribe channel)
(defredis sunion key)
(defredis sunionstore destination key)
(defredis swapdb index1 index2)
(defredis sync)
(defredis psync replicationid offset)
(defredis time)
(defredis touch key)
(defredis ttl key)
(defredis type key)
(defredis unsubscribe)
(defredis unlink key)
(defredis unwatch)
(defredis wait numreplicas timeout)
(defredis watch key)
(defredis zadd key)
(defredis zcard key)
(defredis zcount key min max)
(defredis zincrby key increment member)
(defredis zinterstore destination numkeys key)
(defredis zlexcount key min max)
(defredis zpopmax key)
(defredis zpopmin key)
(defredis zrange key start stop)
(defredis zrangebylex key min max)
(defredis zrevrangebylex key max min)
(defredis zrangebyscore key min max)
(defredis zrank key member)
(defredis zrem key member)
(defredis zremrangebylex key min max)
(defredis zremrangebyrank key start stop)
(defredis zremrangebyscore key min max)
(defredis zrevrange key start stop)
(defredis zrevrangebyscore key max min)
(defredis zrevrank key member)
(defredis zscore key member)
(defredis zunionstore destination numkeys key)
(defredis scan cursor)
(defredis sscan key cursor)
(defredis hscan key cursor)
(defredis zscan key cursor)
(defredis xinfo)
(defredis xadd key ID field value)
(defredis xtrim key MAXLEN count)
(defredis xdel key ID)
(defredis xrange key start end)
(defredis xrevrange key end start)
(defredis xlen key)
(defredis xread)
(defredis xgroup)
(defredis xreadgroup GROUP group consumer)
(defredis xack key group ID)
(defredis xclaim key group consumer min-idle-time ID)
(defredis xpending key group)
(defredis latency-doctor)
(defredis latency-graph event)
(defredis latency-history event)
(defredis latency-latest)
(defredis latency-reset)
(defredis latency-help)

; commands added in Redis 6.0

(defredis acl-cat)
(defredis acl-deluser username)
(defredis acl-genpass)
(defredis acl-getuser username)
(defredis acl-list)
(defredis acl-load)
(defredis acl-log)
(defredis acl-save)
(defredis acl-setuser username rule)
(defredis acl-users)
(defredis acl-whoami)
(defredis client-caching mode)
(defredis client-getredir)
(defredis client-tracking mode)
(defredis client-trackinginfo)
(defredis hello)
(defredis reset)
(defredis lpos key element)

; commands added in Redis 6.2

(defredis copy source destination)
(defredis getdel key)
(defredis getex key)
(defredis lmove source destination wherefrom whereto)
(defredis blmove source destination wherefrom whereto timeout)
(defredis smismember key member)
(defredis zmscore key member)
(defredis zdiff numkeys key)
(defredis zdiffstore destination numkeys key)
(defredis zunion numkeys key)
(defredis zinter numkeys key)
(defredis zrangestore dst src min max)
(defredis zrandmember key)
(defredis hrandfield key)
(defredis geosearch key)
(defredis geosearchstore destination source)
(defredis xautoclaim key group consumer min-idle-time start)
(defredis xgroup-createconsumer key groupname consumername)
(defredis xgroup-delconsumer key groupname consumername)

; commands added in Redis 7.0

(defredis function-load library-code)
(defredis function-delete library-name)
(defredis function-dump)
(defredis function-restore serialized-value)
(defredis function-list)
(defredis function-stats)
(defredis function-flush)
(defredis fcall function numkeys)
(defredis fcall_ro function numkeys)
(defredis eval_ro script numkeys key)
(defredis evalsha_ro sha1 numkeys key)
(defredis sort_ro key)
(defredis lmpop numkeys key)
(defredis blmpop timeout numkeys key)
(defredis zmpop numkeys key)
(defredis bzmpop timeout numkeys key)
(defredis zintercard numkeys key)
(defredis sintercard numkeys key)
(defredis expiretime key)
(defredis pexpiretime key)
(defredis lcs key1 key2)
(defredis cluster-shards)
(defredis cluster-links)
(defredis cluster-addslotsrange slot)
(defredis cluster-delslotsrange slot)
(defredis client-no-evict mode)
(defredis ssubscribe channel)
(defredis sunsubscribe)
(defredis spublish channel message)
(defredis command-docs command-name)
(defredis command-list)
(defredis latency-histogram)
(defredis module-loadex path)

; commands added in Redis 7.2

(defredis client-setinfo attr value)
(defredis client-no-touch mode)
(defredis waitaof numlocal numreplicas timeout)

(doc Redis "is a wrapper around Redis connections. It supports opening a
connection using [`open`](#open) or [`open-on`](#open-on), reading from and
sending to the connection (using [`read`](#read) and [`send`](#send),
respectively), and contains thin wrappers around all Redis commands through 7.2.

```
(match (Redis.open \"127.0.0.1\")
  (Result.Success r)
    (do
      (println* &(Redis.set &r @\"key\" @\"val\"))
      (println* &(Redis.get &r @\"key\"))
      (println* &(Redis.lrange &r @\"list\" @\"0\" @\"-1\"))
      (Redis.close r))
  (Result.Error err) (IO.errorln &err))
```")
(doc RESP "is a wrapper around the [Redis Serialization
Protocol](https://redis.io/topics/protocol). You can create all types,
stringify the built types into strings using [`str`](#str), and decode from
the string protocol using [`from-string`](#from-string). Arrays are fully
supported, including nested arrays.

```
; decoding
(RESP.from-string \"+OK\\r\\n\")       ; => (Success (Str @\"OK\"))
(RESP.from-string \":42\\r\\n\")       ; => (Success (Integer 42))
(RESP.from-string \"$-1\\r\\n\")       ; => (Success (Null))

; encoding
(str &(RESP.Str @\"hi\"))             ; => \"$2\\r\\nhi\\r\\n\"
(str &(RESP.Integer 42))            ; => \":42\\r\\n\"

; pattern matching on responses
(match (Redis.get &r @\"key\")
  (Result.Success resp)
    (match resp
      (RESP.Str s) (println* \"got: \" &s)
      (RESP.Null) (println* \"not found\")
      (RESP.Arr items) (println* \"array of \" &(Int.str (Array.length &items)))
      _ (println* \"other\"))
  (Result.Error e) (println* \"error: \" &e))
```

If you want your types to be supported when encoding, you’ll have to implement
the interface `to-redis`, the signature of which is `(Fn [a] RESP))`.")