{-# 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 Redis.Settings as Settings
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
  | KeyExceedsMaxSize Text Int

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."
    KeyExceedsMaxSize Text
key Int
maxKeySize -> Text
"Redis key (" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
") exceeded max size (" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
maxKeySize Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
")."

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

instance Prelude.Show (Query a) where
  show :: Query a -> String
show = Text -> String
Text.toList (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Text -> [Text] -> Text
Text.join Text
"<|" ([Text] -> String) -> (Query a -> [Text]) -> Query a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Query a -> [Text]
forall b. Query b -> [Text]
cmds

-- | 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,
    Handler -> MaxKeySize
maxKeySize :: Settings.MaxKeySize
  }

-- | 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 -> Task Error (Query a)
forall a err. Text -> Query a -> Task err (Query a)
namespaceQuery (Handler -> Text
namespace Handler
handler Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":") Query a
query'
    Task Error (Query a)
-> (Task Error (Query a) -> Task Error (Query a))
-> Task Error (Query a)
forall a b. a -> (a -> b) -> b
|> (Query a -> Task Error (Query a))
-> Task Error (Query a) -> Task Error (Query a)
forall a x b. (a -> Task x b) -> Task x a -> Task x b
Task.andThen (Handler -> Query a -> Task Error (Query a)
forall a. Handler -> Query a -> Task Error (Query a)
ensureMaxKeySize Handler
handler)
    Task Error (Query a)
-> (Task Error (Query a) -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> (Query a -> Task Error a) -> Task Error (Query a) -> Task Error a
forall a x b. (a -> Task x b) -> Task x a -> Task x b
Task.andThen ((HasCallStack => Query a -> Task Error a)
-> Query a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack (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 -> Task Error (Query a)
forall a err. Text -> Query a -> Task err (Query a)
namespaceQuery (Handler -> Text
namespace Handler
handler Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":") Query a
query'
    Task Error (Query a)
-> (Task Error (Query a) -> Task Error (Query a))
-> Task Error (Query a)
forall a b. a -> (a -> b) -> b
|> (Query a -> Task Error (Query a))
-> Task Error (Query a) -> Task Error (Query a)
forall a x b. (a -> Task x b) -> Task x a -> Task x b
Task.andThen (Handler -> Query a -> Task Error (Query a)
forall a. Handler -> Query a -> Task Error (Query a)
ensureMaxKeySize Handler
handler)
    Task Error (Query a)
-> (Task Error (Query a) -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> (Query a -> Task Error a) -> Task Error (Query a) -> Task Error a
forall a x b. (a -> Task x b) -> Task x a -> Task x b
Task.andThen ((HasCallStack => Query a -> Task Error a)
-> Query a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack (Handler -> forall a. HasCallStack => Query a -> Task Error a
doTransaction Handler
handler))

namespaceQuery :: Text -> Query a -> Task err (Query a)
namespaceQuery :: Text -> Query a -> Task err (Query a)
namespaceQuery Text
prefix Query a
query' = (Text -> Task err Text) -> Query a -> Task err (Query a)
forall err a.
(Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys (\Text
key -> Text -> Task err Text
forall a x. a -> Task x a
Task.succeed (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)) Query a
query'

mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys Text -> Task err Text
fn Query a
query' =
  case Query a
query' of
    Exists Text
key -> (Text -> Query Bool) -> Task err Text -> Task err (Query Bool)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query Bool
Exists (Text -> Task err Text
fn Text
key)
    Query a
Ping -> Query Status -> Task err (Query Status)
forall a x. a -> Task x a
Task.succeed Query Status
Ping
    Get Text
key -> (Text -> Query (Maybe ByteString))
-> Task err Text -> Task err (Query (Maybe ByteString))
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query (Maybe ByteString)
Get (Text -> Task err Text
fn Text
key)
    Set Text
key ByteString
value -> (Text -> Query ()) -> Task err Text -> Task err (Query ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> ByteString -> Query ()
Set Text
newKey ByteString
value) (Text -> Task err Text
fn Text
key)
    Setex Text
key Int
seconds ByteString
value -> (Text -> Query ()) -> Task err Text -> Task err (Query ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Int -> ByteString -> Query ()
Setex Text
newKey Int
seconds ByteString
value) (Text -> Task err Text
fn Text
key)
    Setnx Text
key ByteString
value -> (Text -> Query Bool) -> Task err Text -> Task err (Query Bool)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> ByteString -> Query Bool
Setnx Text
newKey ByteString
value) (Text -> Task err Text
fn Text
key)
    Getset Text
key ByteString
value -> (Text -> Query (Maybe ByteString))
-> Task err Text -> Task err (Query (Maybe ByteString))
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> ByteString -> Query (Maybe ByteString)
Getset Text
newKey ByteString
value) (Text -> Task err Text
fn Text
key)
    Mget NonEmpty Text
keys -> (NonEmpty Text -> Query [Maybe ByteString])
-> Task err (NonEmpty Text) -> Task err (Query [Maybe ByteString])
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map NonEmpty Text -> Query [Maybe ByteString]
Mget ((Text -> Task err Text)
-> NonEmpty Text -> Task err (NonEmpty Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse (\Text
k -> Text -> Task err Text
fn Text
k) NonEmpty Text
keys)
    Mset NonEmpty (Text, ByteString)
assocs -> (NonEmpty (Text, ByteString) -> Query ())
-> Task err (NonEmpty (Text, ByteString)) -> Task err (Query ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map NonEmpty (Text, ByteString) -> Query ()
Mset (((Text, ByteString) -> Task err (Text, ByteString))
-> NonEmpty (Text, ByteString)
-> Task err (NonEmpty (Text, ByteString))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse (\(Text
k, ByteString
v) -> (Text -> (Text, ByteString))
-> Task err Text -> Task err (Text, ByteString)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> (Text
newKey, ByteString
v)) (Text -> Task err Text
fn Text
k)) NonEmpty (Text, ByteString)
assocs)
    Del NonEmpty Text
keys -> (NonEmpty Text -> Query Int)
-> Task err (NonEmpty Text) -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map NonEmpty Text -> Query Int
Del ((Text -> Task err Text)
-> NonEmpty Text -> Task err (NonEmpty Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse (Text -> Task err Text
fn) NonEmpty Text
keys)
    Hgetall Text
key -> (Text -> Query (List (Text, ByteString)))
-> Task err Text -> Task err (Query (List (Text, ByteString)))
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query (List (Text, ByteString))
Hgetall (Text -> Task err Text
fn Text
key)
    Hkeys Text
key -> (Text -> Query [Text]) -> Task err Text -> Task err (Query [Text])
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query [Text]
Hkeys (Text -> Task err Text
fn Text
key)
    Hmget Text
key NonEmpty Text
fields -> (Text -> Query [Maybe ByteString])
-> Task err Text -> Task err (Query [Maybe ByteString])
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> NonEmpty Text -> Query [Maybe ByteString]
Hmget Text
newKeys NonEmpty Text
fields) (Text -> Task err Text
fn Text
key)
    Hget Text
key Text
field -> (Text -> Query (Maybe ByteString))
-> Task err Text -> Task err (Query (Maybe ByteString))
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> Text -> Query (Maybe ByteString)
Hget Text
newKeys Text
field) (Text -> Task err Text
fn Text
key)
    Hset Text
key Text
field ByteString
val -> (Text -> Query ()) -> Task err Text -> Task err (Query ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> Text -> ByteString -> Query ()
Hset Text
newKeys Text
field ByteString
val) (Text -> Task err Text
fn Text
key)
    Hsetnx Text
key Text
field ByteString
val -> (Text -> Query Bool) -> Task err Text -> Task err (Query Bool)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> Text -> ByteString -> Query Bool
Hsetnx Text
newKeys Text
field ByteString
val) (Text -> Task err Text
fn Text
key)
    Hmset Text
key NonEmpty (Text, ByteString)
vals -> (Text -> Query ()) -> Task err Text -> Task err (Query ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> NonEmpty (Text, ByteString) -> Query ()
Hmset Text
newKeys NonEmpty (Text, ByteString)
vals) (Text -> Task err Text
fn Text
key)
    Hdel Text
key NonEmpty Text
fields -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> NonEmpty Text -> Query Int
Hdel Text
newKeys NonEmpty Text
fields) (Text -> Task err Text
fn Text
key)
    Incr Text
key -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query Int
Incr (Text -> Task err Text
fn Text
key)
    Incrby Text
key Int
amount -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> Int -> Query Int
Incrby Text
newKeys Int
amount) (Text -> Task err Text
fn Text
key)
    Expire Text
key Int
secs -> (Text -> Query ()) -> Task err Text -> Task err (Query ())
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> Int -> Query ()
Expire Text
newKeys Int
secs) (Text -> Task err Text
fn Text
key)
    Lrange Text
key Int
lower Int
upper -> (Text -> Query (List ByteString))
-> Task err Text -> Task err (Query (List ByteString))
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> Int -> Int -> Query (List ByteString)
Lrange Text
newKeys Int
lower Int
upper) (Text -> Task err Text
fn Text
key)
    Rpush Text
key NonEmpty ByteString
vals -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> NonEmpty ByteString -> Query Int
Rpush Text
newKeys NonEmpty ByteString
vals) (Text -> Task err Text
fn Text
key)
    Sadd Text
key NonEmpty ByteString
vals -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> NonEmpty ByteString -> Query Int
Sadd Text
newKeys NonEmpty ByteString
vals) (Text -> Task err Text
fn Text
key)
    Scard Text
key -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query Int
Scard (Text -> Task err Text
fn Text
key)
    Srem Text
key NonEmpty ByteString
vals -> (Text -> Query Int) -> Task err Text -> Task err (Query Int)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKeys -> Text -> NonEmpty ByteString -> Query Int
Srem Text
newKeys NonEmpty ByteString
vals) (Text -> Task err Text
fn Text
key)
    Smembers Text
key -> (Text -> Query (List ByteString))
-> Task err Text -> Task err (Query (List ByteString))
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query (List ByteString)
Smembers (Text -> Task err Text
fn Text
key)
    Pure a
x -> Query a -> Task err (Query a)
forall a x. a -> Task x a
Task.succeed (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)
-> Task err (Query (a -> a))
-> Task err (Query a)
-> Task err (Query a)
forall a b result x.
(a -> b -> result) -> Task x a -> Task x b -> Task x result
Task.map2 Query (a -> a) -> Query a -> Query a
forall a b. Query (a -> b) -> Query a -> Query b
Apply ((Text -> Task err Text)
-> Query (a -> a) -> Task err (Query (a -> a))
forall err a.
(Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys Text -> Task err Text
fn Query (a -> a)
f) ((Text -> Task err Text) -> Query a -> Task err (Query a)
forall err a.
(Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys Text -> Task err Text
fn Query a
x)
    WithResult a -> Result Error a
f Query a
q -> (Query a -> Query a) -> Task err (Query a) -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map ((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 -> Task err Text) -> Query a -> Task err (Query a)
forall err a.
(Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys Text -> Task err Text
fn Query a
q)

ensureMaxKeySize :: Handler -> Query a -> Task Error (Query a)
ensureMaxKeySize :: Handler -> Query a -> Task Error (Query a)
ensureMaxKeySize Handler
handler Query a
query' =
  case Handler -> MaxKeySize
maxKeySize Handler
handler of
    MaxKeySize
Settings.NoMaxKeySize -> Query a -> Task Error (Query a)
forall a x. a -> Task x a
Task.succeed Query a
query'
    Settings.MaxKeySize Int
maxKeySize ->
      (Text -> Task Error Text) -> Query a -> Task Error (Query a)
forall err a.
(Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys (Int -> Text -> Task Error Text
checkMaxKeySize Int
maxKeySize) Query a
query'

checkMaxKeySize :: Int -> Text -> Task Error Text
checkMaxKeySize :: Int -> Text -> Task Error Text
checkMaxKeySize Int
maxKeySize Text
key =
  if Text -> Int
Text.length Text
key Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
<= Int
maxKeySize
    then Text -> Task Error Text
forall a x. a -> Task x a
Task.succeed Text
key
    else Error -> Task Error Text
forall x a. x -> Task x a
Task.fail (Text -> Int -> Error
KeyExceedsMaxSize Text
key Int
maxKeySize)

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