{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Redis.Internal
  ( Error (..),
    Handler (..),
    Query (..),
    cmds,
    map,
    map2,
    map3,
    sequence,
    query,
    transaction,
    -- internal tools
    traceQuery,
    maybesToDict,
    keysTouchedByQuery,
  )
where

import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Database.Redis
import qualified Dict
import qualified GHC.Stack as Stack
import qualified List
import qualified Log.RedisCommands as RedisCommands
import NriPrelude hiding (map, map2, map3)
import qualified Platform
import qualified Set
import qualified Text
import qualified Tuple
import qualified Prelude

-- | Redis Errors, scoped by where they originate.
data Error
  = RedisError Text
  | ConnectionLost
  | DecodingError Text
  | DecodingFieldError Text
  | LibraryError Text
  | TransactionAborted
  | TimeoutError

instance Aeson.ToJSON Error where
  toJSON :: Error -> Value
toJSON Error
err = Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Error -> Text
errorForHumans Error
err)

instance Show Error where
  show :: Error -> String
show = Error -> Text
errorForHumans (Error -> Text) -> (Text -> String) -> Error -> String
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> Text -> String
Text.toList

errorForHumans :: Error -> Text
errorForHumans :: Error -> Text
errorForHumans Error
topError =
  case Error
topError of
    RedisError Text
err -> Text
"Redis error: " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
err
    Error
ConnectionLost -> Text
"Connection Lost"
    LibraryError Text
err -> Text
"Library error when executing (probably due to a bug in the library): " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
err
    DecodingError Text
err -> Text
"Could not decode value in key: " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
err
    DecodingFieldError Text
err -> Text
"Could not decode field of hash: " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
err
    Error
TransactionAborted -> Text
"Transaction aborted."
    Error
TimeoutError -> Text
"Redis query took too long."

-- | Render the commands a query is going to run for monitoring and debugging
-- purposes. Values we write are replaced with "*****" because they might
-- contain sensitive data.
cmds :: Query b -> [Text]
cmds :: Query b -> [Text]
cmds Query b
query'' =
  case Query b
query'' of
    Del NonEmpty Text
keys -> [[Text] -> Text
unwords (Text
"DEL" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
keys)]
    Exists Text
key -> [[Text] -> Text
unwords [Text
"EXISTS", Text
key]]
    Expire Text
key Int
val -> [[Text] -> Text
unwords [Text
"EXPIRE", Text
key, Int -> Text
Text.fromInt Int
val]]
    Get Text
key -> [[Text] -> Text
unwords [Text
"GET", Text
key]]
    Getset Text
key ByteString
_ -> [[Text] -> Text
unwords [Text
"GETSET", Text
key, Text
"*****"]]
    Hdel Text
key NonEmpty Text
fields -> [[Text] -> Text
unwords (Text
"HDEL" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
fields)]
    Hgetall Text
key -> [[Text] -> Text
unwords [Text
"HGETALL", Text
key]]
    Hget Text
key Text
field -> [[Text] -> Text
unwords [Text
"HGET", Text
key, Text
field]]
    Hkeys Text
key -> [[Text] -> Text
unwords [Text
"HKEY", Text
key]]
    Hmget Text
key NonEmpty Text
fields -> [[Text] -> Text
unwords (Text
"HMGET" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
fields)]
    Hmset Text
key NonEmpty (Text, ByteString)
pairs ->
      [[Text] -> Text
unwords (Text
"HMSET" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, ByteString) -> [Text]) -> List (Text, ByteString) -> [Text]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (\(Text
field, ByteString
_) -> [Text
field, Text
"*****"]) (NonEmpty (Text, ByteString) -> List (Text, ByteString)
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Text, ByteString)
pairs))]
    Hset Text
key Text
field ByteString
_ -> [[Text] -> Text
unwords [Text
"HSET", Text
key, Text
field, Text
"*****"]]
    Hsetnx Text
key Text
field ByteString
_ -> [[Text] -> Text
unwords [Text
"HSETNX", Text
key, Text
field, Text
"*****"]]
    Incr Text
key -> [[Text] -> Text
unwords [Text
"INCR", Text
key]]
    Incrby Text
key Int
amount -> [[Text] -> Text
unwords [Text
"INCRBY", Text
key, Int -> Text
Text.fromInt Int
amount]]
    Lrange Text
key Int
lower Int
upper -> [[Text] -> Text
unwords [Text
"LRANGE", Text
key, Int -> Text
Text.fromInt Int
lower, Int -> Text
Text.fromInt Int
upper]]
    Mget NonEmpty Text
keys -> [[Text] -> Text
unwords (Text
"MGET" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
keys)]
    Mset NonEmpty (Text, ByteString)
pairs -> [[Text] -> Text
unwords (Text
"MSET" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, ByteString) -> [Text]) -> List (Text, ByteString) -> [Text]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (\(Text
key, ByteString
_) -> [Text
key, Text
"*****"]) (NonEmpty (Text, ByteString) -> List (Text, ByteString)
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Text, ByteString)
pairs))]
    Query b
Ping -> [Text
"PING"]
    Rpush Text
key NonEmpty ByteString
vals -> [[Text] -> Text
unwords (Text
"RPUSH" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (ByteString -> Text) -> List ByteString -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\ByteString
_ -> Text
"*****") (NonEmpty ByteString -> List ByteString
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals))]
    Set Text
key ByteString
_ -> [[Text] -> Text
unwords [Text
"SET", Text
key, Text
"*****"]]
    Setex Text
key Int
seconds ByteString
_ -> [[Text] -> Text
unwords [Text
"SETEX", Text
key, Int -> Text
Text.fromInt Int
seconds, Text
"*****"]]
    Setnx Text
key ByteString
_ -> [[Text] -> Text
unwords [Text
"SETNX", Text
key, Text
"*****"]]
    Sadd Text
key NonEmpty ByteString
vals -> [[Text] -> Text
unwords (Text
"SADD" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (ByteString -> Text) -> List ByteString -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\ByteString
_ -> Text
"*****") (NonEmpty ByteString -> List ByteString
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals))]
    Scard Text
key -> [[Text] -> Text
unwords [Text
"SCARD", Text
key]]
    Srem Text
key NonEmpty ByteString
vals -> [[Text] -> Text
unwords (Text
"SREM" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (ByteString -> Text) -> List ByteString -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\ByteString
_ -> Text
"*****") (NonEmpty ByteString -> List ByteString
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals))]
    Smembers Text
key -> [[Text] -> Text
unwords [Text
"SMEMBERS", Text
key]]
    Pure b
_ -> []
    Apply Query (a -> b)
f Query a
x -> Query (a -> b) -> [Text]
forall b. Query b -> [Text]
cmds Query (a -> b)
f [Text] -> [Text] -> [Text]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Query a -> [Text]
forall b. Query b -> [Text]
cmds Query a
x
    WithResult a -> Result Error b
_ Query a
x -> Query a -> [Text]
forall b. Query b -> [Text]
cmds Query a
x

unwords :: [Text] -> Text
unwords :: [Text] -> Text
unwords = Text -> [Text] -> Text
Text.join Text
" "

-- | A Redis query
data Query a where
  Del :: NonEmpty Text -> Query Int
  Exists :: Text -> Query Bool
  Expire :: Text -> Int -> Query ()
  Get :: Text -> Query (Maybe ByteString)
  Getset :: Text -> ByteString -> Query (Maybe ByteString)
  Hdel :: Text -> NonEmpty Text -> Query Int
  Hgetall :: Text -> Query [(Text, ByteString)]
  Hget :: Text -> Text -> Query (Maybe ByteString)
  Hkeys :: Text -> Query [Text]
  Hmget :: Text -> NonEmpty Text -> Query [Maybe ByteString]
  Hmset :: Text -> NonEmpty (Text, ByteString) -> Query ()
  Hset :: Text -> Text -> ByteString -> Query ()
  Hsetnx :: Text -> Text -> ByteString -> Query Bool
  Incr :: Text -> Query Int
  Incrby :: Text -> Int -> Query Int
  Lrange :: Text -> Int -> Int -> Query [ByteString]
  Mget :: NonEmpty Text -> Query [Maybe ByteString]
  Mset :: NonEmpty (Text, ByteString) -> Query ()
  Ping :: Query Database.Redis.Status
  Rpush :: Text -> NonEmpty ByteString -> Query Int
  Set :: Text -> ByteString -> Query ()
  Setex :: Text -> Int -> ByteString -> Query ()
  Setnx :: Text -> ByteString -> Query Bool
  Sadd :: Text -> NonEmpty ByteString -> Query Int
  Scard :: Text -> Query Int
  Srem :: Text -> NonEmpty ByteString -> Query Int
  Smembers :: Text -> Query (List ByteString)
  -- The constructors below are not Redis-related, but support using functions
  -- like `map` and `map2` on queries.
  Pure :: a -> Query a
  Apply :: Query (a -> b) -> Query a -> Query b
  WithResult :: (a -> Result Error b) -> Query a -> Query b

instance Prelude.Functor Query where
  fmap :: (a -> b) -> Query a -> Query b
fmap = (a -> b) -> Query a -> Query b
forall a b. (a -> b) -> Query a -> Query b
map

-- | Used to map the type of a query to another type
-- useful in combination with 'transaction'
map :: (a -> b) -> Query a -> Query b
map :: (a -> b) -> Query a -> Query b
map a -> b
f Query a
q = (a -> Result Error b) -> Query a -> Query b
forall a b. (a -> Result Error b) -> Query a -> Query b
WithResult (a -> b
f (a -> b) -> (b -> Result Error b) -> a -> Result Error b
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> b -> Result Error b
forall error value. value -> Result error value
Ok) Query a
q

-- | Used to combine two queries
-- Useful to combine two queries.
-- @
-- Redis.map2
--   (Maybe.map2 (,))
--   (Redis.get api1 key)
--   (Redis.get api2 key)
--   |> Redis.query redis
-- @
map2 :: (a -> b -> c) -> Query a -> Query b -> Query c
map2 :: (a -> b -> c) -> Query a -> Query b -> Query c
map2 a -> b -> c
f Query a
queryA Query b
queryB =
  Query (b -> c) -> Query b -> Query c
forall a b. Query (a -> b) -> Query a -> Query b
Apply ((a -> b -> c) -> Query a -> Query (b -> c)
forall a b. (a -> b) -> Query a -> Query b
map a -> b -> c
f Query a
queryA) Query b
queryB

-- | Used to combine three queries
-- Useful to combine three queries.
map3 :: (a -> b -> c -> d) -> Query a -> Query b -> Query c -> Query d
map3 :: (a -> b -> c -> d) -> Query a -> Query b -> Query c -> Query d
map3 a -> b -> c -> d
f Query a
queryA Query b
queryB Query c
queryC =
  Query (c -> d) -> Query c -> Query d
forall a b. Query (a -> b) -> Query a -> Query b
Apply (Query (b -> c -> d) -> Query b -> Query (c -> d)
forall a b. Query (a -> b) -> Query a -> Query b
Apply ((a -> b -> c -> d) -> Query a -> Query (b -> c -> d)
forall a b. (a -> b) -> Query a -> Query b
map a -> b -> c -> d
f Query a
queryA) Query b
queryB) Query c
queryC

-- | Used to run a series of queries in sequence.
-- Useful to run a list of queries in sequence.
-- @
-- queries
--   |> Redis.sequence
--   |> Redis.query redis
-- @
sequence :: List (Query a) -> Query (List a)
sequence :: List (Query a) -> Query (List a)
sequence =
  (Query a -> Query (List a) -> Query (List a))
-> Query (List a) -> List (Query a) -> Query (List a)
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldr ((a -> List a -> List a)
-> Query a -> Query (List a) -> Query (List a)
forall a b c. (a -> b -> c) -> Query a -> Query b -> Query c
map2 (:)) (List a -> Query (List a)
forall a. a -> Query a
Pure [])

-- | The redis handler allows applications to run scoped IO
data Handler = Handler
  { Handler -> forall a. HasCallStack => Query a -> Task Error a
doQuery :: Stack.HasCallStack => forall a. Query a -> Task Error a,
    Handler -> forall a. HasCallStack => Query a -> Task Error a
doTransaction :: Stack.HasCallStack => forall a. Query a -> Task Error a,
    Handler -> Text
namespace :: Text
  }

-- | Run a 'Query'.
-- Note: A 'Query' in this library can consist of one or more queries in sequence.
-- if a 'Query' contains multiple queries, it may make more sense, if possible
-- to run them using 'transaction'
query :: Stack.HasCallStack => Handler -> Query a -> Task Error a
query :: Handler -> Query a -> Task Error a
query Handler
handler Query a
query' =
  Text -> Query a -> Query a
forall a. Text -> Query a -> Query a
namespaceQuery (Handler -> Text
namespace Handler
handler Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":") Query a
query'
    Query a -> (Query a -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> (HasCallStack => Handler -> Query a -> Task Error a)
-> Handler -> Query a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Handler -> Query a -> Task Error a
Handler -> forall a. HasCallStack => Query a -> Task Error a
doQuery Handler
handler

-- | Run a redis Query in a transaction. If the query contains several Redis
-- commands they're all executed together, and Redis will guarantee other
-- requests won't be able change values in between.
--
-- In redis terms, this is wrappping the 'Query' in `MULTI` and `EXEC
-- see redis transaction semantics here: https://redis.io/topics/transactions
transaction :: Stack.HasCallStack => Handler -> Query a -> Task Error a
transaction :: Handler -> Query a -> Task Error a
transaction Handler
handler Query a
query' =
  Text -> Query a -> Query a
forall a. Text -> Query a -> Query a
namespaceQuery (Handler -> Text
namespace Handler
handler Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":") Query a
query'
    Query a -> (Query a -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> (HasCallStack => Handler -> Query a -> Task Error a)
-> Handler -> Query a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Handler -> Query a -> Task Error a
Handler -> forall a. HasCallStack => Query a -> Task Error a
doTransaction Handler
handler

namespaceQuery :: Text -> Query a -> Query a
namespaceQuery :: Text -> Query a -> Query a
namespaceQuery Text
prefix Query a
query' =
  case Query a
query' of
    Exists Text
key -> Text -> Query Bool
Exists (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Query a
Ping -> Query a
Query Status
Ping
    Get Text
key -> Text -> Query (Maybe ByteString)
Get (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Set Text
key ByteString
value -> Text -> ByteString -> Query ()
Set (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) ByteString
value
    Setex Text
key Int
seconds ByteString
value -> Text -> Int -> ByteString -> Query ()
Setex (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Int
seconds ByteString
value
    Setnx Text
key ByteString
value -> Text -> ByteString -> Query Bool
Setnx (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) ByteString
value
    Getset Text
key ByteString
value -> Text -> ByteString -> Query (Maybe ByteString)
Getset (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) ByteString
value
    Mget NonEmpty Text
keys -> NonEmpty Text -> Query [Maybe ByteString]
Mget ((Text -> Text) -> NonEmpty Text -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (\Text
k -> Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
k) NonEmpty Text
keys)
    Mset NonEmpty (Text, ByteString)
assocs -> NonEmpty (Text, ByteString) -> Query ()
Mset (((Text, ByteString) -> (Text, ByteString))
-> NonEmpty (Text, ByteString) -> NonEmpty (Text, ByteString)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (\(Text
k, ByteString
v) -> (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
k, ByteString
v)) NonEmpty (Text, ByteString)
assocs)
    Del NonEmpty Text
keys -> NonEmpty Text -> Query Int
Del ((Text -> Text) -> NonEmpty Text -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++) NonEmpty Text
keys)
    Hgetall Text
key -> Text -> Query (List (Text, ByteString))
Hgetall (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Hkeys Text
key -> Text -> Query [Text]
Hkeys (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Hmget Text
key NonEmpty Text
fields -> Text -> NonEmpty Text -> Query [Maybe ByteString]
Hmget (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) NonEmpty Text
fields
    Hget Text
key Text
field -> Text -> Text -> Query (Maybe ByteString)
Hget (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Text
field
    Hset Text
key Text
field ByteString
val -> Text -> Text -> ByteString -> Query ()
Hset (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Text
field ByteString
val
    Hsetnx Text
key Text
field ByteString
val -> Text -> Text -> ByteString -> Query Bool
Hsetnx (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Text
field ByteString
val
    Hmset Text
key NonEmpty (Text, ByteString)
vals -> Text -> NonEmpty (Text, ByteString) -> Query ()
Hmset (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) NonEmpty (Text, ByteString)
vals
    Hdel Text
key NonEmpty Text
fields -> Text -> NonEmpty Text -> Query Int
Hdel (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) NonEmpty Text
fields
    Incr Text
key -> Text -> Query Int
Incr (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Incrby Text
key Int
amount -> Text -> Int -> Query Int
Incrby (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Int
amount
    Expire Text
key Int
secs -> Text -> Int -> Query ()
Expire (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Int
secs
    Lrange Text
key Int
lower Int
upper -> Text -> Int -> Int -> Query (List ByteString)
Lrange (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) Int
lower Int
upper
    Rpush Text
key NonEmpty ByteString
vals -> Text -> NonEmpty ByteString -> Query Int
Rpush (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) NonEmpty ByteString
vals
    Sadd Text
key NonEmpty ByteString
vals -> Text -> NonEmpty ByteString -> Query Int
Sadd (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) NonEmpty ByteString
vals
    Scard Text
key -> Text -> Query Int
Scard (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Srem Text
key NonEmpty ByteString
vals -> Text -> NonEmpty ByteString -> Query Int
Srem (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key) NonEmpty ByteString
vals
    Smembers Text
key -> Text -> Query (List ByteString)
Smembers (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)
    Pure a
x -> a -> Query a
forall a. a -> Query a
Pure a
x
    Apply Query (a -> a)
f Query a
x -> Query (a -> a) -> Query a -> Query a
forall a b. Query (a -> b) -> Query a -> Query b
Apply (Text -> Query (a -> a) -> Query (a -> a)
forall a. Text -> Query a -> Query a
namespaceQuery Text
prefix Query (a -> a)
f) (Text -> Query a -> Query a
forall a. Text -> Query a -> Query a
namespaceQuery Text
prefix Query a
x)
    WithResult a -> Result Error a
f Query a
q -> (a -> Result Error a) -> Query a -> Query a
forall a b. (a -> Result Error b) -> Query a -> Query b
WithResult a -> Result Error a
f (Text -> Query a -> Query a
forall a. Text -> Query a -> Query a
namespaceQuery Text
prefix Query a
q)

keysTouchedByQuery :: Query a -> Set.Set Text
keysTouchedByQuery :: Query a -> Set Text
keysTouchedByQuery Query a
query' =
  case Query a
query' of
    Apply Query (a -> a)
f Query a
x -> Set Text -> Set Text -> Set Text
forall comparable.
Ord comparable =>
Set comparable -> Set comparable -> Set comparable
Set.union (Query (a -> a) -> Set Text
forall a. Query a -> Set Text
keysTouchedByQuery Query (a -> a)
f) (Query a -> Set Text
forall a. Query a -> Set Text
keysTouchedByQuery Query a
x)
    Del NonEmpty Text
keys -> [Text] -> Set Text
forall comparable.
Ord comparable =>
List comparable -> Set comparable
Set.fromList (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
keys)
    Exists Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    -- We use this function to collect keys we need to expire. If the user is
    -- explicitly setting an expiry we don't want to overwrite that.
    Expire Text
_key Int
_ -> Set Text
forall a. Set a
Set.empty
    Get Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Getset Text
key ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hdel Text
key NonEmpty Text
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hget Text
key Text
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hgetall Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hkeys Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hmget Text
key NonEmpty Text
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hmset Text
key NonEmpty (Text, ByteString)
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hset Text
key Text
_ ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Hsetnx Text
key Text
_ ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Incr Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Incrby Text
key Int
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Lrange Text
key Int
_ Int
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Mget NonEmpty Text
keys -> [Text] -> Set Text
forall comparable.
Ord comparable =>
List comparable -> Set comparable
Set.fromList (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
keys)
    Mset NonEmpty (Text, ByteString)
assocs -> [Text] -> Set Text
forall comparable.
Ord comparable =>
List comparable -> Set comparable
Set.fromList (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList (((Text, ByteString) -> Text)
-> NonEmpty (Text, ByteString) -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (Text, ByteString) -> Text
forall a b. (a, b) -> a
Tuple.first NonEmpty (Text, ByteString)
assocs))
    Query a
Ping -> Set Text
forall a. Set a
Set.empty
    Pure a
_ -> Set Text
forall a. Set a
Set.empty
    Rpush Text
key NonEmpty ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Set Text
key ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Setex Text
key Int
_ ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Setnx Text
key ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Sadd Text
key NonEmpty ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Scard Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Srem Text
key NonEmpty ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Smembers Text
key -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    WithResult a -> Result Error a
_ Query a
q -> Query a -> Set Text
forall a. Query a -> Set Text
keysTouchedByQuery Query a
q

maybesToDict :: Ord key => List key -> List (Maybe a) -> Dict.Dict key a
maybesToDict :: List key -> List (Maybe a) -> Dict key a
maybesToDict List key
keys List (Maybe a)
values =
  (key -> Maybe a -> (key, Maybe a))
-> List key -> List (Maybe a) -> List (key, Maybe a)
forall a b result.
(a -> b -> result) -> List a -> List b -> List result
List.map2 (,) List key
keys List (Maybe a)
values
    List (key, Maybe a)
-> (List (key, Maybe a) -> List (key, a)) -> List (key, a)
forall a b. a -> (a -> b) -> b
|> ((key, Maybe a) -> Maybe (key, a))
-> List (key, Maybe a) -> List (key, a)
forall a b. (a -> Maybe b) -> List a -> List b
List.filterMap
      ( \(key
key, Maybe a
value) ->
          case Maybe a
value of
            Maybe a
Nothing -> Maybe (key, a)
forall a. Maybe a
Nothing
            Just a
v -> (key, a) -> Maybe (key, a)
forall a. a -> Maybe a
Just (key
key, a
v)
      )
    List (key, a) -> (List (key, a) -> Dict key a) -> Dict key a
forall a b. a -> (a -> b) -> b
|> List (key, a) -> Dict key a
forall comparable v.
Ord comparable =>
List (comparable, v) -> Dict comparable v
Dict.fromList

traceQuery :: Stack.HasCallStack => [Text] -> Text -> Maybe Int -> Task e a -> Task e a
traceQuery :: [Text] -> Text -> Maybe Int -> Task e a -> Task e a
traceQuery [Text]
commands Text
host Maybe Int
port Task e a
task =
  let info :: Details
info =
        Details
RedisCommands.emptyDetails
          { commands :: [Text]
RedisCommands.commands = [Text]
commands,
            host :: Maybe Text
RedisCommands.host = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
host,
            port :: Maybe Int
RedisCommands.port = Maybe Int
port
          }
   in (HasCallStack => Text -> Task e a -> Task e a)
-> Text -> Task e a -> Task e a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
        HasCallStack => Text -> Task e a -> Task e a
forall e a. HasCallStack => Text -> Task e a -> Task e a
Platform.tracingSpan
        Text
"Redis Query"
        ( Task e a -> Task e () -> Task e a
forall e a b. Task e a -> Task e b -> Task e a
Platform.finally
            Task e a
task
            ( do
                Details -> Task e ()
forall d e. TracingSpanDetails d => d -> Task e ()
Platform.setTracingSpanDetails Details
info
                Text -> Task e ()
forall e. Text -> Task e ()
Platform.setTracingSpanSummary
                  ( case [Text]
commands of
                      [] -> Text
""
                      [Text
cmd] -> Text
cmd
                      Text
cmd : [Text]
_ -> Text
cmd Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
" (+ more)"
                  )
            )
        )