{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
-- For the RedisResult Text instance
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Redis.Internal
  ( Error (..),
    Handler,
    Handler' (..),
    HandlerAutoExtendExpire,
    HasAutoExtendExpire (..),
    Query (..),
    Database.Redis.Cursor,
    Database.Redis.cursor0,
    cmds,
    map,
    map2,
    map3,
    sequence,
    query,
    transaction,
    eval,
    foldWithScan,
    -- internal tools
    wrapQuery,
    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 Data.Text.Encoding
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.Script as Script
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 :: forall b. 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]) -> [(Text, ByteString)] -> [Text]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (\(Text
field, ByteString
_) -> [Text
field, Text
"*****"]) (NonEmpty (Text, ByteString) -> [(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]) -> [(Text, ByteString)] -> [Text]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (\(Text
key, ByteString
_) -> [Text
key, Text
"*****"]) (NonEmpty (Text, ByteString) -> [(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) -> [ByteString] -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\ByteString
_ -> Text
"*****") (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals))]
    Scan Cursor
cursor Maybe Text
maybeMatch Maybe Int
maybeCount -> [Cursor -> Maybe Text -> Maybe Int -> Text
scanCmd Cursor
cursor Maybe Text
maybeMatch Maybe Int
maybeCount]
    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) -> [ByteString] -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\ByteString
_ -> Text
"*****") (NonEmpty ByteString -> [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) -> [ByteString] -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\ByteString
_ -> Text
"*****") (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals))]
    Sismember Text
key ByteString
_ -> [[Text] -> Text
unwords [Text
"SISMEMBER", Text
key, Text
"*****"]]
    Smembers Text
key -> [[Text] -> Text
unwords [Text
"SMEMBERS", Text
key]]
    Zadd Text
key Dict ByteString Float
vals -> [[Text] -> Text
unwords (Text
"ZADD" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
key Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((ByteString, Float) -> [Text])
-> List (ByteString, Float) -> [Text]
forall a b. (a -> List b) -> List a -> List b
List.concatMap (\(ByteString
_, Float
val) -> [Text
"*****", Float -> Text
Text.fromFloat Float
val]) (Dict ByteString Float -> List (ByteString, Float)
forall k v. Dict k v -> List (k, v)
Dict.toList Dict ByteString Float
vals))]
    Zrange Text
key Int
start Int
stop -> [[Text] -> Text
unwords [Text
"ZRANGE", Text
key, Int -> Text
Text.fromInt Int
start, Int -> Text
Text.fromInt Int
stop]]
    ZrangeByScoreWithScores Text
key Float
start Float
stop -> [[Text] -> Text
unwords [Text
"ZRANGE", Text
key, Text
"BYSCORE", Float -> Text
Text.fromFloat Float
start, Float -> Text
Text.fromFloat Float
stop, Text
"WITHSCORES"]]
    Zrank Text
key ByteString
_ -> [[Text] -> Text
unwords [Text
"ZRANK", Text
key, Text
"*****"]]
    Zrevrank Text
key ByteString
_ -> [[Text] -> Text
unwords [Text
"ZREVRANK", Text
key, Text
"*****"]]
    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
  where
    scanCmd :: Database.Redis.Cursor -> Maybe Text -> Maybe Int -> Text
    scanCmd :: Cursor -> Maybe Text -> Maybe Int -> Text
scanCmd Cursor
cursor Maybe Text
maybeMatch Maybe Int
maybeCount =
      let cursorWord :: Text
cursorWord =
            String -> Text
Text.fromList (Cursor -> String
forall a. Show a => a -> String
Prelude.show Cursor
cursor)
          matchWords :: [Text]
matchWords =
            case Maybe Text
maybeMatch of
              Maybe Text
Nothing -> []
              Just Text
keyPattern -> [Text
"MATCH", Text
keyPattern]
          countWords :: [Text]
countWords =
            case Maybe Int
maybeCount of
              Maybe Int
Nothing -> []
              Just Int
c -> [Text
"COUNT", Int -> Text
Text.fromInt Int
c]
       in [Text] -> Text
unwords (Text
"SCAN" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
cursorWord Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
matchWords [Text] -> [Text] -> [Text]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [Text]
countWords)

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
  Scan :: Database.Redis.Cursor -> Maybe Text -> Maybe Int -> Query (Database.Redis.Cursor, [Text])
  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
  Sismember :: Text -> ByteString -> Query Bool
  Smembers :: Text -> Query (List ByteString)
  Zadd :: Text -> Dict.Dict ByteString Float -> Query Int
  Zrange :: Text -> Int -> Int -> Query [ByteString]
  ZrangeByScoreWithScores :: Text -> Float -> Float -> Query [(ByteString, Float)]
  Zrank :: Text -> ByteString -> Query (Maybe Int)
  Zrevrank :: Text -> ByteString -> Query (Maybe Int)
  -- 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 :: forall a b. (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 :: forall a b. (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 :: forall a b c. (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 :: forall a b c d.
(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 :: forall a. 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 [])

-- | We use this to parametrize the handler. It specifies if the handler has
-- the auto extend expire feater enabled or not.
data HasAutoExtendExpire = NoAutoExtendExpire | AutoExtendExpire

-- | The redis handler allows applications to run scoped IO
-- A handler that can only be parametrized by a value of this kind.
-- Meaning that we use the values of the type parameter at a type level.
data Handler' (x :: HasAutoExtendExpire) = Handler'
  { forall (x :: HasAutoExtendExpire).
Handler' x
-> forall a.
   HasCallStack =>
   QueryTimeout -> Query a -> Task Error a
doQuery :: (Stack.HasCallStack) => forall a. Settings.QueryTimeout -> Query a -> Task Error a,
    forall (x :: HasAutoExtendExpire).
Handler' x
-> forall a.
   HasCallStack =>
   QueryTimeout -> Query a -> Task Error a
doTransaction :: (Stack.HasCallStack) => forall a. Settings.QueryTimeout -> Query a -> Task Error a,
    forall (x :: HasAutoExtendExpire).
Handler' x
-> forall a.
   (HasCallStack, RedisResult a) =>
   QueryTimeout -> Script a -> Task Error a
doEval :: (Stack.HasCallStack) => forall a. (Database.Redis.RedisResult a) => Settings.QueryTimeout -> Script.Script a -> Task Error a,
    forall (x :: HasAutoExtendExpire). Handler' x -> Text
namespace :: Text,
    forall (x :: HasAutoExtendExpire). Handler' x -> MaxKeySize
maxKeySize :: Settings.MaxKeySize,
    forall (x :: HasAutoExtendExpire). Handler' x -> QueryTimeout
queryTimeout :: Settings.QueryTimeout
  }

-- | This is a type alias of a handler parametrized by a value that indicates
-- that the auto extend feature is disabled.
-- Note: The tick in front of NoAutoExtendExpire is not necessary, but good
-- practice to indicate that we are lifting a value to the type level.
type Handler = Handler' 'NoAutoExtendExpire

-- | This is a type alias of a handler parametrized by a value that indicates
-- that the auto extend feature is enabled.
-- Note: The tick in front of AutoExtendExpire is not necessary, but good
-- practice to indicate that we are lifting a value to the type level.
type HandlerAutoExtendExpire = Handler' 'AutoExtendExpire

-- | 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' x -> Query a -> Task Error a
query :: forall (x :: HasAutoExtendExpire) a.
HasCallStack =>
Handler' x -> Query a -> Task Error a
query Handler' x
handler Query a
query' =
  Text -> Query a -> Task Error (Query a)
forall a err. Text -> Query a -> Task err (Query a)
namespaceQuery (Handler' x -> Text
forall (x :: HasAutoExtendExpire). Handler' x -> Text
namespace Handler' x
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' x -> Query a -> Task Error (Query a)
forall (x :: HasAutoExtendExpire) a.
Handler' x -> Query a -> Task Error (Query a)
ensureMaxKeySize Handler' x
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 => QueryTimeout -> Query a -> Task Error a)
-> QueryTimeout -> Query a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack (Handler' x
-> forall a.
   HasCallStack =>
   QueryTimeout -> Query a -> Task Error a
forall (x :: HasAutoExtendExpire).
Handler' x
-> forall a.
   HasCallStack =>
   QueryTimeout -> Query a -> Task Error a
doQuery Handler' x
handler) (Handler' x -> QueryTimeout
forall (x :: HasAutoExtendExpire). Handler' x -> QueryTimeout
queryTimeout Handler' x
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' x -> Query a -> Task Error a
transaction :: forall (x :: HasAutoExtendExpire) a.
HasCallStack =>
Handler' x -> Query a -> Task Error a
transaction Handler' x
handler Query a
query' =
  Text -> Query a -> Task Error (Query a)
forall a err. Text -> Query a -> Task err (Query a)
namespaceQuery (Handler' x -> Text
forall (x :: HasAutoExtendExpire). Handler' x -> Text
namespace Handler' x
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' x -> Query a -> Task Error (Query a)
forall (x :: HasAutoExtendExpire) a.
Handler' x -> Query a -> Task Error (Query a)
ensureMaxKeySize Handler' x
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 => QueryTimeout -> Query a -> Task Error a)
-> QueryTimeout -> Query a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack (Handler' x
-> forall a.
   HasCallStack =>
   QueryTimeout -> Query a -> Task Error a
forall (x :: HasAutoExtendExpire).
Handler' x
-> forall a.
   HasCallStack =>
   QueryTimeout -> Query a -> Task Error a
doTransaction Handler' x
handler) (Handler' x -> QueryTimeout
forall (x :: HasAutoExtendExpire). Handler' x -> QueryTimeout
queryTimeout Handler' x
handler))

eval :: (Stack.HasCallStack, Database.Redis.RedisResult a) => Handler' x -> Script.Script a -> Task Error a
eval :: forall a (x :: HasAutoExtendExpire).
(HasCallStack, RedisResult a) =>
Handler' x -> Script a -> Task Error a
eval Handler' x
handler Script a
script =
  (Text -> Task Error Text) -> Script a -> Task Error (Script a)
forall err a.
(Text -> Task err Text) -> Script a -> Task err (Script a)
Script.mapKeys (\Text
key -> Text -> Task Error Text
forall a x. a -> Task x a
Task.succeed (Handler' x -> Text
forall (x :: HasAutoExtendExpire). Handler' x -> Text
namespace Handler' x
handler Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
":" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
key)) Script a
script
    Task Error (Script a)
-> (Task Error (Script a) -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> (Script a -> Task Error a) -> Task Error (Script a) -> Task Error a
forall a x b. (a -> Task x b) -> Task x a -> Task x b
Task.andThen ((HasCallStack => QueryTimeout -> Script a -> Task Error a)
-> QueryTimeout -> Script a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack (Handler' x
-> forall a.
   (HasCallStack, RedisResult a) =>
   QueryTimeout -> Script a -> Task Error a
forall (x :: HasAutoExtendExpire).
Handler' x
-> forall a.
   (HasCallStack, RedisResult a) =>
   QueryTimeout -> Script a -> Task Error a
doEval Handler' x
handler) (Handler' x -> QueryTimeout
forall (x :: HasAutoExtendExpire). Handler' x -> QueryTimeout
queryTimeout Handler' x
handler))

namespaceQuery :: Text -> Query a -> Task err (Query a)
namespaceQuery :: forall a err. 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'
    Task err (Query a)
-> (Task err (Query a) -> Task err (Query a)) -> Task err (Query a)
forall a b. a -> (a -> b) -> b
|> (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 ((Text -> Text) -> Query a -> Query a
forall a. (Text -> Text) -> Query a -> Query a
mapReturnedKeys (Int -> Text -> Text
Text.dropLeft (Text -> Int
Text.length Text
prefix)))

mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a)
mapKeys :: forall err a.
(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 a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query Bool
Exists (Text -> Task err Text
fn Text
key)
    Query a
Ping -> Query a -> Task err (Query a)
forall a x. a -> Task x a
Task.succeed Query a
Query Status
Ping
    Get Text
key -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query (Maybe ByteString)
Get (Text -> Task err Text
fn Text
key)
    Set Text
key ByteString
value -> (Text -> Query a) -> Task err Text -> Task err (Query a)
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 a) -> Task err Text -> Task err (Query a)
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 a) -> Task err Text -> Task err (Query a)
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 a) -> Task err Text -> Task err (Query a)
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 a)
-> Task err (NonEmpty Text) -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map NonEmpty Text -> Query a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
Prelude.traverse (\Text
k -> Text -> Task err Text
fn Text
k) NonEmpty Text
keys)
    Mset NonEmpty (Text, ByteString)
assocs -> (NonEmpty (Text, ByteString) -> Query a)
-> Task err (NonEmpty (Text, ByteString)) -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map NonEmpty (Text, ByteString) -> Query a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty 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 a)
-> Task err (NonEmpty Text) -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map NonEmpty Text -> Query a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
Prelude.traverse (Text -> Task err Text
fn) NonEmpty Text
keys)
    Hgetall Text
key -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query [(Text, ByteString)]
Hgetall (Text -> Task err Text
fn Text
key)
    Hkeys Text
key -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query [Text]
Hkeys (Text -> Task err Text
fn Text
key)
    Hmget Text
key NonEmpty Text
fields -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> NonEmpty Text -> Query [Maybe ByteString]
Hmget Text
newKey NonEmpty Text
fields) (Text -> Task err Text
fn Text
key)
    Hget Text
key Text
field -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Text -> Query (Maybe ByteString)
Hget Text
newKey Text
field) (Text -> Task err Text
fn Text
key)
    Hset Text
key Text
field ByteString
val -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Text -> ByteString -> Query ()
Hset Text
newKey Text
field ByteString
val) (Text -> Task err Text
fn Text
key)
    Hsetnx Text
key Text
field ByteString
val -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Text -> ByteString -> Query Bool
Hsetnx Text
newKey Text
field ByteString
val) (Text -> Task err Text
fn Text
key)
    Hmset Text
key NonEmpty (Text, ByteString)
vals -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> NonEmpty (Text, ByteString) -> Query ()
Hmset Text
newKey NonEmpty (Text, ByteString)
vals) (Text -> Task err Text
fn Text
key)
    Hdel Text
key NonEmpty Text
fields -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> NonEmpty Text -> Query Int
Hdel Text
newKey NonEmpty Text
fields) (Text -> Task err Text
fn Text
key)
    Incr Text
key -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query Int
Incr (Text -> Task err Text
fn Text
key)
    Incrby Text
key Int
amount -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Int -> Query Int
Incrby Text
newKey Int
amount) (Text -> Task err Text
fn Text
key)
    Expire Text
key Int
secs -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Int -> Query ()
Expire Text
newKey Int
secs) (Text -> Task err Text
fn Text
key)
    Lrange Text
key Int
lower Int
upper -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Int -> Int -> Query [ByteString]
Lrange Text
newKey Int
lower Int
upper) (Text -> Task err Text
fn Text
key)
    Rpush Text
key NonEmpty ByteString
vals -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> NonEmpty ByteString -> Query Int
Rpush Text
newKey NonEmpty ByteString
vals) (Text -> Task err Text
fn Text
key)
    Scan Cursor
cursor Maybe Text
maybeMatch Maybe Int
maybeCount ->
      case Maybe Text
maybeMatch of
        Just Text
match -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newMatch -> Cursor -> Maybe Text -> Maybe Int -> Query (Cursor, [Text])
Scan Cursor
cursor (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
newMatch) Maybe Int
maybeCount) (Text -> Task err Text
fn Text
match)
        Maybe Text
Nothing -> Query a -> Task err (Query a)
forall a x. a -> Task x a
Task.succeed (Cursor -> Maybe Text -> Maybe Int -> Query (Cursor, [Text])
Scan Cursor
cursor Maybe Text
forall a. Maybe a
Nothing Maybe Int
maybeCount)
    Sadd Text
key NonEmpty ByteString
vals -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> NonEmpty ByteString -> Query Int
Sadd Text
newKey NonEmpty ByteString
vals) (Text -> Task err Text
fn Text
key)
    Scard Text
key -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query Int
Scard (Text -> Task err Text
fn Text
key)
    Srem Text
key NonEmpty ByteString
vals -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> NonEmpty ByteString -> Query Int
Srem Text
newKey NonEmpty ByteString
vals) (Text -> Task err Text
fn Text
key)
    Sismember Text
key ByteString
val -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> ByteString -> Query Bool
Sismember Text
newKey ByteString
val) (Text -> Task err Text
fn Text
key)
    Smembers Text
key -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map Text -> Query a
Text -> Query [ByteString]
Smembers (Text -> Task err Text
fn Text
key)
    Zadd Text
key Dict ByteString Float
vals -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Dict ByteString Float -> Query Int
Zadd Text
newKey Dict ByteString Float
vals) (Text -> Task err Text
fn Text
key)
    Zrange Text
key Int
start Int
stop -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Int -> Int -> Query [ByteString]
Zrange Text
newKey Int
start Int
stop) (Text -> Task err Text
fn Text
key)
    ZrangeByScoreWithScores Text
key Float
start Float
stop -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> Float -> Float -> Query (List (ByteString, Float))
ZrangeByScoreWithScores Text
newKey Float
start Float
stop) (Text -> Task err Text
fn Text
key)
    Zrank Text
key ByteString
member -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> ByteString -> Query (Maybe Int)
Zrank Text
newKey ByteString
member) (Text -> Task err Text
fn Text
key)
    Zrevrank Text
key ByteString
member -> (Text -> Query a) -> Task err Text -> Task err (Query a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\Text
newKey -> Text -> ByteString -> Query (Maybe Int)
Zrevrank Text
newKey ByteString
member) (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)

mapReturnedKeys :: (Text -> Text) -> Query a -> Query a
mapReturnedKeys :: forall a. (Text -> Text) -> Query a -> Query a
mapReturnedKeys Text -> Text
fn Query a
query' =
  case Query a
query' of
    Exists Text
key -> Text -> Query Bool
Exists Text
key
    Query a
Ping -> Query a
Query Status
Ping
    Get Text
key -> Text -> Query (Maybe ByteString)
Get Text
key
    Set Text
key ByteString
value -> Text -> ByteString -> Query ()
Set Text
key ByteString
value
    Setex Text
key Int
seconds ByteString
value -> Text -> Int -> ByteString -> Query ()
Setex Text
key Int
seconds ByteString
value
    Setnx Text
key ByteString
value -> Text -> ByteString -> Query Bool
Setnx Text
key ByteString
value
    Getset Text
key ByteString
value -> Text -> ByteString -> Query (Maybe ByteString)
Getset Text
key ByteString
value
    Mget NonEmpty Text
keys -> NonEmpty Text -> Query [Maybe ByteString]
Mget NonEmpty Text
keys
    Mset NonEmpty (Text, ByteString)
assocs -> NonEmpty (Text, ByteString) -> Query ()
Mset NonEmpty (Text, ByteString)
assocs
    Del NonEmpty Text
keys -> NonEmpty Text -> Query Int
Del NonEmpty Text
keys
    Hgetall Text
key -> Text -> Query [(Text, ByteString)]
Hgetall Text
key
    Hkeys Text
key -> Text -> Query [Text]
Hkeys Text
key
    Hmget Text
key NonEmpty Text
fields -> Text -> NonEmpty Text -> Query [Maybe ByteString]
Hmget Text
key NonEmpty Text
fields
    Hget Text
key Text
field -> Text -> Text -> Query (Maybe ByteString)
Hget Text
key Text
field
    Hset Text
key Text
field ByteString
val -> Text -> Text -> ByteString -> Query ()
Hset Text
key Text
field ByteString
val
    Hsetnx Text
key Text
field ByteString
val -> Text -> Text -> ByteString -> Query Bool
Hsetnx Text
key Text
field ByteString
val
    Hmset Text
key NonEmpty (Text, ByteString)
vals -> Text -> NonEmpty (Text, ByteString) -> Query ()
Hmset Text
key NonEmpty (Text, ByteString)
vals
    Hdel Text
key NonEmpty Text
fields -> Text -> NonEmpty Text -> Query Int
Hdel Text
key NonEmpty Text
fields
    Incr Text
key -> Text -> Query Int
Incr Text
key
    Incrby Text
key Int
amount -> Text -> Int -> Query Int
Incrby Text
key Int
amount
    Expire Text
key Int
secs -> Text -> Int -> Query ()
Expire Text
key Int
secs
    Lrange Text
key Int
lower Int
upper -> Text -> Int -> Int -> Query [ByteString]
Lrange Text
key Int
lower Int
upper
    Rpush Text
key NonEmpty ByteString
vals -> Text -> NonEmpty ByteString -> Query Int
Rpush Text
key NonEmpty ByteString
vals
    Scan Cursor
cursor Maybe Text
maybeMatch Maybe Int
maybeCount ->
      Cursor -> Maybe Text -> Maybe Int -> Query (Cursor, [Text])
Scan Cursor
cursor Maybe Text
maybeMatch Maybe Int
maybeCount
        Query (Cursor, [Text])
-> (Query (Cursor, [Text]) -> Query a) -> Query a
forall a b. a -> (a -> b) -> b
|> ((Cursor, [Text]) -> a) -> Query (Cursor, [Text]) -> Query a
forall a b. (a -> b) -> Query a -> Query b
map (\(Cursor
nextCursor, [Text]
keys) -> (Cursor
nextCursor, (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map Text -> Text
fn [Text]
keys))
    Sadd Text
key NonEmpty ByteString
vals -> Text -> NonEmpty ByteString -> Query Int
Sadd Text
key NonEmpty ByteString
vals
    Scard Text
key -> Text -> Query Int
Scard Text
key
    Srem Text
key NonEmpty ByteString
vals -> Text -> NonEmpty ByteString -> Query Int
Srem Text
key NonEmpty ByteString
vals
    Sismember Text
key ByteString
val -> Text -> ByteString -> Query Bool
Sismember Text
key ByteString
val
    Smembers Text
key -> Text -> Query [ByteString]
Smembers Text
key
    Zadd Text
key Dict ByteString Float
vals -> Text -> Dict ByteString Float -> Query Int
Zadd Text
key Dict ByteString Float
vals
    Zrange Text
key Int
start Int
stop -> Text -> Int -> Int -> Query [ByteString]
Zrange Text
key Int
start Int
stop
    ZrangeByScoreWithScores Text
key Float
start Float
stop -> Text -> Float -> Float -> Query (List (ByteString, Float))
ZrangeByScoreWithScores Text
key Float
start Float
stop
    Zrank Text
key ByteString
member -> Text -> ByteString -> Query (Maybe Int)
Zrank Text
key ByteString
member
    Zrevrank Text
key ByteString
member -> Text -> ByteString -> Query (Maybe Int)
Zrevrank Text
key ByteString
member
    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 -> Text) -> Query (a -> a) -> Query (a -> a)
forall a. (Text -> Text) -> Query a -> Query a
mapReturnedKeys Text -> Text
fn Query (a -> a)
f) ((Text -> Text) -> Query a -> Query a
forall a. (Text -> Text) -> Query a -> Query a
mapReturnedKeys Text -> Text
fn 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 -> Text) -> Query a -> Query a
forall a. (Text -> Text) -> Query a -> Query a
mapReturnedKeys Text -> Text
fn Query a
q)

ensureMaxKeySize :: Handler' x -> Query a -> Task Error (Query a)
ensureMaxKeySize :: forall (x :: HasAutoExtendExpire) a.
Handler' x -> Query a -> Task Error (Query a)
ensureMaxKeySize Handler' x
handler Query a
query' =
  case Handler' x -> MaxKeySize
forall (x :: HasAutoExtendExpire). Handler' x -> MaxKeySize
maxKeySize Handler' x
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 :: forall a. 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
    Scan {} -> Set Text
forall a. Set a
Set.empty
    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
    Sismember Text
key 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
    Zadd Text
key Dict ByteString Float
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Zrange Text
key Int
_ Int
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    ZrangeByScoreWithScores Text
key Float
_ Float
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Zrank Text
key ByteString
_ -> Text -> Set Text
forall comparable. comparable -> Set comparable
Set.singleton Text
key
    Zrevrank Text
key ByteString
_ -> 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 :: forall key a. Ord key => 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

wrapQuery :: (Stack.HasCallStack) => Settings.QueryTimeout -> [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
wrapQuery :: forall a.
HasCallStack =>
QueryTimeout
-> [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
wrapQuery QueryTimeout
queryTimeout [Text]
commands Text
host Maybe Int
port Task Error a
task =
  [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
forall a.
HasCallStack =>
[Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
traceQuery [Text]
commands Text
host Maybe Int
port (Task Error a -> Task Error a) -> Task Error a -> Task Error a
forall a b. (a -> b) -> a -> b
<| case QueryTimeout
queryTimeout of
    QueryTimeout
Settings.NoQueryTimeout ->
      Task Error a
task
    Settings.TimeoutQueryAfterMilliseconds Int
timeoutMs ->
      Float -> Error -> Task Error a -> Task Error a
forall err a. Float -> err -> Task err a -> Task err a
Task.timeout (Int -> Float
toFloat Int
timeoutMs) Error
TimeoutError Task Error a
task

traceQuery :: (Stack.HasCallStack) => [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
traceQuery :: forall a.
HasCallStack =>
[Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
traceQuery [Text]
commands Text
host Maybe Int
port Task Error a
task =
  let info :: Details
info =
        Details
RedisCommands.emptyDetails
          { RedisCommands.commands = commands,
            RedisCommands.host = Just host,
            RedisCommands.port = port
          }
   in (HasCallStack => Text -> Task Error a -> Task Error a)
-> Text -> Task Error a -> Task Error a
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
        HasCallStack => Text -> Task Error a -> Task Error a
Text -> Task Error a -> Task Error a
forall e a. HasCallStack => Text -> Task e a -> Task e a
Platform.tracingSpan
        Text
"Redis Query"
        ( Task Error a -> Task Error () -> Task Error a
forall e a b. Task e a -> Task e b -> Task e a
Platform.finally
            Task Error a
task
            ( do
                Details -> Task Error ()
forall d e. TracingSpanDetails d => d -> Task e ()
Platform.setTracingSpanDetails Details
info
                Text -> Task Error ()
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)"
                  )
            )
        )

-- | Use SCAN command to find keys matching a pattern, and "fold" over them in batches, producing a result value.
-- keyMatchPattern       A glob-like pattern to match keys, see https://redis.io/commands/keys/
-- approxCountPerBatch   A hint for the batch size you want to process at once. Only approximate.
-- processKeyBatch       Function to process one batch of keys (provided as plain Text without namespace prefix)
-- initAccumulator       Initial value for the fold accumulator
foldWithScan :: Handler' x -> Maybe Text -> Maybe Int -> ([Text] -> a -> Task Error a) -> a -> Task Error a
foldWithScan :: forall (x :: HasAutoExtendExpire) a.
Handler' x
-> Maybe Text
-> Maybe Int
-> ([Text] -> a -> Task Error a)
-> a
-> Task Error a
foldWithScan Handler' x
handler Maybe Text
keyMatchPattern Maybe Int
approxCountPerBatch [Text] -> a -> Task Error a
processKeyBatch a
initAccumulator =
  let go :: a -> Cursor -> Task Error a
go a
accumulator Cursor
cursor = do
        (Cursor
nextCursor, [Text]
keyBatch) <-
          Cursor -> Maybe Text -> Maybe Int -> Query (Cursor, [Text])
Scan Cursor
cursor Maybe Text
keyMatchPattern Maybe Int
approxCountPerBatch
            Query (Cursor, [Text])
-> (Query (Cursor, [Text]) -> Task Error (Cursor, [Text]))
-> Task Error (Cursor, [Text])
forall a b. a -> (a -> b) -> b
|> Handler' x -> Query (Cursor, [Text]) -> Task Error (Cursor, [Text])
forall (x :: HasAutoExtendExpire) a.
HasCallStack =>
Handler' x -> Query a -> Task Error a
query Handler' x
handler
        a
nextAccumulator <-
          [Text] -> a -> Task Error a
processKeyBatch [Text]
keyBatch a
accumulator
        if Cursor
nextCursor Cursor -> Cursor -> Bool
forall a. Eq a => a -> a -> Bool
== Cursor
Database.Redis.cursor0
          then a -> Task Error a
forall a x. a -> Task x a
Task.succeed a
nextAccumulator
          else a -> Cursor -> Task Error a
go a
nextAccumulator Cursor
nextCursor
   in a -> Cursor -> Task Error a
go a
initAccumulator Cursor
Database.Redis.cursor0

--------------------------------------
-- Orphaned instances for RedisResult
--------------------------------------
instance Database.Redis.RedisResult Text where
  decode :: Reply -> Either Reply Text
decode Reply
r = do
    ByteString
decodedBs <- Reply -> Either Reply ByteString
forall a. RedisResult a => Reply -> Either Reply a
Database.Redis.decode Reply
r
    Text -> Either Reply Text
forall a. a -> Either Reply a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Text -> Either Reply Text) -> Text -> Either Reply Text
forall a b. (a -> b) -> a -> b
<| ByteString -> Text
Data.Text.Encoding.decodeUtf8 ByteString
decodedBs

instance Database.Redis.RedisResult Int where
  decode :: Reply -> Either Reply Int
decode Reply
r = do
    (Integer
decodedInteger :: Prelude.Integer) <- Reply -> Either Reply Integer
forall a. RedisResult a => Reply -> Either Reply a
Database.Redis.decode Reply
r
    Int -> Either Reply Int
forall a. a -> Either Reply a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Int -> Either Reply Int) -> Int -> Either Reply Int
forall a b. (a -> b) -> a -> b
<| Integer -> Int
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral Integer
decodedInteger

instance Database.Redis.RedisResult () where
  decode :: Reply -> Either Reply ()
decode Reply
r = do
    (Reply
reply :: Database.Redis.Reply) <- Reply -> Either Reply Reply
forall a. RedisResult a => Reply -> Either Reply a
Database.Redis.decode Reply
r
    case Reply
reply of
      Database.Redis.Bulk Maybe ByteString
Nothing -> () -> Either Reply ()
forall a. a -> Either Reply a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()
      Reply
other -> Reply -> Either Reply ()
forall a b. a -> Either a b
Prelude.Left Reply
other