redis.carp

(load "git@github.com:carpentry-org/sockets@0.0.2")

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

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

  (hidden c)
  (private c)
  (def c (prn &@&[@""]))

  (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) (fmt "*%d\r\n%s" (Array.length &a) &(String.concat &a))))

  (hidden decode-bulk-string)
  (private decode-bulk-string)
  (defn decode-bulk-string [s]
    (if (starts-with? s "-1\r\n")
      (Success (Null))
      (let [splt (split #"\r\n" s)
            l (unsafe-first &splt)]
        (match (from-string l)
          (Nothing) (Error @"Error decoding bulk string: does not start with length!")
          (Just il)
            (Success (Str
              (String.prefix &(join "\r\n" &(suffix &splt 1)) il)))))))

  (hidden agg)
  (private agg)
  (defn agg [els len]
    (let-do [consumed 0
             clen 0]
      (for [i 0 len]
        (let [el (unsafe-nth els i)]
          (if (>= clen len)
            (break)
            (do
              (set! consumed (inc consumed))
              (set! clen (+ 2 (+ clen (String.length el))))))))
      consumed))

  (hidden decode-arr)
  (private decode-arr)
  (defn decode-arr [s]
    (if (starts-with? s "*0\r\n")
      (Success (Null))
      (let [splt (split #"\r\n" &(chomp s))
            sl (unsafe-first &splt)]
        (match (from-string sl)
          (Nothing)
            (Error @"Error decoding array: does not start with length!")
          (Just l)
            (let-do [a (Array.allocate l)
                     idx 0
                     err ""]
              (for [i 0 (- (length &splt) 1)]
                ; TODO: have nested structures
                (let-do [el (unsafe-nth &splt (+ i 1))]
                  (case (head el)
                    \$
                      (match (from-string &(tail el))
                        (Maybe.Nothing)
                          (aset-uninitialized! &a idx @"")
                        (Maybe.Just il)
                          (let-do [rest (suffix &splt (+ i 2))]
                            (aset-uninitialized! &a idx (String.prefix &(join "\r\n" &rest) il))
                            (set! i (+ i (agg &rest il)))))
                    \*
                      (do
                        (set! err "TODO: cannot deal with nested arrays")
                        (break))
                    (aset-uninitialized! &a idx (chomp el)))
                  (set! idx (inc idx))))
              (if (= err "")
                (Success (Arr a))
                (Error @err)))))))

  (doc from-string "converts a RESP string into a `RESP` data structure.")
  (defn from-string [s]
    (if (empty? s)
      (Success (Null))
      (case (head s)
        \+ (Success (Str @(unsafe-first &(split #"\r\n" &(tail s)))))
        \- (Success (Err @(unsafe-first &(split #"\r\n" &(tail s)))))
        \:
          (match (from-string (unsafe-first &(split #"\r\n" &(tail s))))
            (Maybe.Nothing)
              (Error @"Could not parse integer in result.")
            (Maybe.Just i)
              (Success (Integer i)))
        \$ (decode-bulk-string &(tail s))
        \* (decode-arr &(tail s))
        (Error (fmt "Malformed RESP data: got %s" s)))))

  (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 Socket
])

(defmodule Redis
  (use-all Array Result Socket)

  (doc open-on "opens the connection to Redis on port `port`.")
  (defn open-on [host port]
    (let [s (setup-client host port)]
      (if (valid? &s)
        (Success (init s))
        (Error (fmt "Couldn’t connect to %s:%d" host port)))))

  (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] (RESP.from-string &(Socket.read (sock r))))
  (doc send "sends the command `cmd` with the arguments `args` to Redis.")
  (defn send [r cmd args]
    (if (empty? args)
      (Socket.send (sock r) &(fmt "%s\r\n" &cmd))
      (Socket.send (sock r) &(str &(RESP.Arr (concat &[[(str &(to-redis cmd))] (copy-map &RESP.str args)]))))))

  (doc close "closes the connection to Redis.")
  (defn close [r] (Socket.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)
(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 (everything
else).")
(doc RESP "is a wrapper around the [Redis Serialization
Protocol](https://redis.io/topics/protocol). You can create all types—though
creating arrays is a little unsightly due to the absence of recursive types—,
stringify the built types into strings using [`str`](#str), and decoding from
the string protocol using [`from-string`](#from-string).

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))`.")