{-# LANGUAGE GADTs #-}

-- | Redis.Mock is useful for writing tests without Redis running
module Redis.Mock
  ( handler,
    handlerIO,
  )
where

import Data.ByteString (ByteString)
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import qualified Data.List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text.Encoding as TE
import qualified Database.Redis
import qualified Expect
import qualified List
import qualified Platform
import qualified Redis.Internal as Internal
import qualified Redis.Settings as Settings
import qualified Text
import qualified Tuple
import Prelude (IO, pure)
import qualified Prelude

-- | This functions returns a task that you can run in each test to retrieve a
-- fresh mock handler
handler :: Expect.Expectation' Internal.Handler
handler :: Expectation' Handler
handler =
  IO Handler
handlerIO
    IO Handler
-> (IO Handler -> Expectation' Handler) -> Expectation' Handler
forall a b. a -> (a -> b) -> b
|> IO Handler -> Expectation' Handler
forall a. IO a -> Expectation' a
Expect.fromIO

-- | It's better to use handler and create a new mock handler for each test.
-- Tests run in parallel which means that they all share the same hashmap.
handlerIO :: IO Internal.Handler
handlerIO :: IO Handler
handlerIO = do
  IORef Model
modelRef <- IO (IORef Model)
init
  Handler
doAnything <- IO Handler
Platform.doAnythingHandler
  Handler :: (forall a. HasCallStack => Query a -> Task Error a)
-> (forall a. HasCallStack => Query a -> Task Error a)
-> Text
-> MaxKeySize
-> Handler
Internal.Handler
    { doQuery :: forall a. HasCallStack => Query a -> Task Error a
Internal.doQuery = IORef Model -> Handler -> Query a -> Task Error a
forall a. IORef Model -> Handler -> Query a -> Task Error a
doQuery' IORef Model
modelRef Handler
doAnything,
      doTransaction :: forall a. HasCallStack => Query a -> Task Error a
Internal.doTransaction = IORef Model -> Handler -> Query a -> Task Error a
forall a. IORef Model -> Handler -> Query a -> Task Error a
doQuery' IORef Model
modelRef Handler
doAnything,
      namespace :: Text
Internal.namespace = Text
"tests",
      maxKeySize :: MaxKeySize
Internal.maxKeySize = MaxKeySize
Settings.NoMaxKeySize
    }
    Handler -> (Handler -> IO Handler) -> IO Handler
forall a b. a -> (a -> b) -> b
|> Handler -> IO Handler
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
  where
    doQuery' :: IORef Model -> Handler -> Query a -> Task Error a
doQuery' IORef Model
modelRef Handler
doAnything = \Query a
query ->
      IORef Model
-> (Model -> (Model, Result Error a)) -> IO (Result Error a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef'
        IORef Model
modelRef
        ( \Model
model ->
            let (HashMap Text RedisType
newHash, Result Error a
res) = Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
forall a.
Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
doQuery Query a
query (Model -> HashMap Text RedisType
hash Model
model)
             in ( Model
model {hash :: HashMap Text RedisType
hash = HashMap Text RedisType
newHash},
                  Result Error a
res
                )
        )
        IO (Result Error a)
-> (IO (Result Error a) -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> Handler -> IO (Result Error a) -> Task Error a
forall e a. Handler -> IO (Result e a) -> Task e a
Platform.doAnything Handler
doAnything
        Task Error a -> (Task Error a -> Task Error a) -> Task Error a
forall a b. a -> (a -> b) -> b
|> [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a
forall e a.
HasCallStack =>
[Text] -> Text -> Maybe Int -> Task e a -> Task e a
Internal.traceQuery (Query a -> [Text]
forall b. Query b -> [Text]
Internal.cmds Query a
query) Text
"Redis.Mock" Maybe Int
forall a. Maybe a
Nothing

-- | This is our mock implementation of the Redis state. Our mock implementation
-- will store a single value of this type, and redis commands will modify it.
data Model = Model
  {Model -> HashMap Text RedisType
hash :: HM.HashMap Text RedisType}

-- | Redis supports a small number of types and most of its commands expect a
-- particular type in the keys the command is used on.
--
-- The type below contains a subset of the types supported by Redis, just those
-- we currently have commands for.
data RedisType
  = RedisByteString ByteString
  | RedisHash (HM.HashMap Text ByteString)
  | RedisList [ByteString]
  | RedisSet (HS.HashSet ByteString)
  deriving (RedisType -> RedisType -> Bool
(RedisType -> RedisType -> Bool)
-> (RedisType -> RedisType -> Bool) -> Eq RedisType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedisType -> RedisType -> Bool
$c/= :: RedisType -> RedisType -> Bool
== :: RedisType -> RedisType -> Bool
$c== :: RedisType -> RedisType -> Bool
Eq)

expectByteString :: RedisType -> Result Internal.Error ByteString
expectByteString :: RedisType -> Result Error ByteString
expectByteString RedisType
val =
  case RedisType
val of
    RedisByteString ByteString
bytestring -> ByteString -> Result Error ByteString
forall error value. value -> Result error value
Ok ByteString
bytestring
    RedisHash HashMap Text ByteString
_ -> Error -> Result Error ByteString
forall error value. error -> Result error value
Err Error
wrongTypeErr
    RedisList [ByteString]
_ -> Error -> Result Error ByteString
forall error value. error -> Result error value
Err Error
wrongTypeErr
    RedisSet HashSet ByteString
_ -> Error -> Result Error ByteString
forall error value. error -> Result error value
Err Error
wrongTypeErr

expectHash :: RedisType -> Result Internal.Error (HM.HashMap Text ByteString)
expectHash :: RedisType -> Result Error (HashMap Text ByteString)
expectHash RedisType
val =
  case RedisType
val of
    RedisByteString ByteString
_ -> Error -> Result Error (HashMap Text ByteString)
forall error value. error -> Result error value
Err Error
wrongTypeErr
    RedisHash HashMap Text ByteString
hash -> HashMap Text ByteString -> Result Error (HashMap Text ByteString)
forall error value. value -> Result error value
Ok HashMap Text ByteString
hash
    RedisList [ByteString]
_ -> Error -> Result Error (HashMap Text ByteString)
forall error value. error -> Result error value
Err Error
wrongTypeErr
    RedisSet HashSet ByteString
_ -> Error -> Result Error (HashMap Text ByteString)
forall error value. error -> Result error value
Err Error
wrongTypeErr

expectInt :: RedisType -> Result Internal.Error Int
expectInt :: RedisType -> Result Error Int
expectInt RedisType
val =
  case RedisType
val of
    RedisByteString ByteString
val' ->
      case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
val' of
        Prelude.Left UnicodeException
_ -> Error -> Result Error Int
forall error value. error -> Result error value
Err Error
wrongTypeErr
        Prelude.Right Text
str ->
          case Text -> Maybe Int
Text.toInt Text
str of
            Maybe Int
Nothing -> Error -> Result Error Int
forall error value. error -> Result error value
Err Error
wrongTypeErr
            Just Int
int -> Int -> Result Error Int
forall error value. value -> Result error value
Ok Int
int
    RedisHash HashMap Text ByteString
_ -> Error -> Result Error Int
forall error value. error -> Result error value
Err Error
wrongTypeErr
    RedisList [ByteString]
_ -> Error -> Result Error Int
forall error value. error -> Result error value
Err Error
wrongTypeErr
    RedisSet HashSet ByteString
_ -> Error -> Result Error Int
forall error value. error -> Result error value
Err Error
wrongTypeErr

init :: IO (IORef Model)
init :: IO (IORef Model)
init = Model -> IO (IORef Model)
forall a. a -> IO (IORef a)
newIORef (HashMap Text RedisType -> Model
Model HashMap Text RedisType
forall k v. HashMap k v
HM.empty)

doQuery ::
  Internal.Query a ->
  HM.HashMap Text RedisType ->
  (HM.HashMap Text RedisType, Result Internal.Error a)
doQuery :: Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
doQuery Query a
query HashMap Text RedisType
hm =
  case Query a
query of
    Internal.Apply Query (a -> a)
fQuery Query a
xQuery ->
      let (HashMap Text RedisType
hm1, Result Error (a -> a)
f) = Query (a -> a)
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error (a -> a))
forall a.
Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
doQuery Query (a -> a)
fQuery HashMap Text RedisType
hm
          (HashMap Text RedisType
hm2, Result Error a
x) = Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
forall a.
Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
doQuery Query a
xQuery HashMap Text RedisType
hm1
       in (HashMap Text RedisType
hm2, ((a -> a) -> a -> a)
-> Result Error (a -> a) -> Result Error a -> Result Error a
forall (m :: * -> *) a b value.
Applicative m =>
(a -> b -> value) -> m a -> m b -> m value
map2 (\a -> a
f' a
x' -> a -> a
f' a
x') Result Error (a -> a)
f Result Error a
x)
    Internal.Del NonEmpty Text
keys ->
      (Text
 -> (HashMap Text RedisType, Int) -> (HashMap Text RedisType, Int))
-> (HashMap Text RedisType, Int)
-> [Text]
-> (HashMap Text RedisType, Int)
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldl
        ( \Text
key (HashMap Text RedisType
hm', Int
count) ->
            if Text -> HashMap Text RedisType -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member Text
key HashMap Text RedisType
hm'
              then (Text -> HashMap Text RedisType -> HashMap Text RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
key HashMap Text RedisType
hm', Int
count Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
1)
              else (HashMap Text RedisType
hm', Int
count)
        )
        (HashMap Text RedisType
hm, Int
0 :: Int)
        (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
keys)
        (HashMap Text RedisType, Int)
-> ((HashMap Text RedisType, Int)
    -> (HashMap Text RedisType, Result Error Int))
-> (HashMap Text RedisType, Result Error Int)
forall a b. a -> (a -> b) -> b
|> (Int -> Result Error Int)
-> (HashMap Text RedisType, Int)
-> (HashMap Text RedisType, Result Error Int)
forall b y a. (b -> y) -> (a, b) -> (a, y)
Tuple.mapSecond Int -> Result Error Int
forall error value. value -> Result error value
Ok
    Internal.Exists Text
key ->
      ( HashMap Text RedisType
hm,
        Bool -> Result Error Bool
forall error value. value -> Result error value
Ok (Text -> HashMap Text RedisType -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member Text
key HashMap Text RedisType
hm)
      )
    Internal.Expire Text
_ Int
_ ->
      -- Expiring is an intentional no-op in `Redis.Mock`. Implementing it would
      -- likely be a lot of effort, and only support writing slow tests.
      ( HashMap Text RedisType
hm,
        () -> Result Error ()
forall error value. value -> Result error value
Ok ()
      )
    Internal.Get Text
key ->
      ( HashMap Text RedisType
hm,
        Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm
          Maybe RedisType
-> (Maybe RedisType -> Result Error (Maybe ByteString))
-> Result Error (Maybe ByteString)
forall a b. a -> (a -> b) -> b
|> (RedisType -> Result Error ByteString)
-> Maybe RedisType -> Result Error (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse RedisType -> Result Error ByteString
expectByteString
      )
    Internal.Getset Text
key ByteString
value ->
      ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (ByteString -> RedisType
RedisByteString ByteString
value) HashMap Text RedisType
hm,
        Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm
          Maybe RedisType
-> (Maybe RedisType -> Result Error (Maybe ByteString))
-> Result Error (Maybe ByteString)
forall a b. a -> (a -> b) -> b
|> (RedisType -> Result Error ByteString)
-> Maybe RedisType -> Result Error (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse RedisType -> Result Error ByteString
expectByteString
      )
    Internal.Hdel Text
key NonEmpty Text
fields ->
      case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
        Maybe RedisType
Nothing ->
          ( HashMap Text RedisType
hm,
            a -> Result Error a
forall error value. value -> Result error value
Ok a
0
          )
        Just (RedisHash HashMap Text ByteString
hm') ->
          let hmAfterDeletions :: HashMap Text ByteString
hmAfterDeletions = (Text -> HashMap Text ByteString -> HashMap Text ByteString)
-> HashMap Text ByteString
-> NonEmpty Text
-> HashMap Text ByteString
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr Text -> HashMap Text ByteString -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete HashMap Text ByteString
hm' NonEmpty Text
fields
           in ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash HashMap Text ByteString
hmAfterDeletions) HashMap Text RedisType
hm,
                HashMap Text ByteString -> Int
forall k v. HashMap k v -> Int
HM.size HashMap Text ByteString
hm' Int -> Int -> Int
forall number. Num number => number -> number -> number
- HashMap Text ByteString -> Int
forall k v. HashMap k v -> Int
HM.size HashMap Text ByteString
hmAfterDeletions
                  Int -> (Int -> a) -> a
forall a b. a -> (a -> b) -> b
|> Int -> a
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral
                  a -> (a -> Result Error a) -> Result Error a
forall a b. a -> (a -> b) -> b
|> a -> Result Error a
forall error value. value -> Result error value
Ok
              )
        Just RedisType
_ ->
          ( HashMap Text RedisType
hm,
            Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
          )
    Internal.Hget Text
key Text
field ->
      case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
        Maybe RedisType
Nothing ->
          ( HashMap Text RedisType
hm,
            Maybe ByteString -> Result Error (Maybe ByteString)
forall error value. value -> Result error value
Ok Maybe ByteString
forall a. Maybe a
Nothing
          )
        Just (RedisHash HashMap Text ByteString
hm') ->
          ( HashMap Text RedisType
hm,
            Maybe ByteString -> Result Error (Maybe ByteString)
forall error value. value -> Result error value
Ok (Text -> HashMap Text ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
field HashMap Text ByteString
hm')
          )
        Just RedisType
_ ->
          ( HashMap Text RedisType
hm,
            Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
          )
    Internal.Hgetall Text
key ->
      ( HashMap Text RedisType
hm,
        Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm
          Maybe RedisType
-> (Maybe RedisType
    -> Result Error (Maybe (HashMap Text ByteString)))
-> Result Error (Maybe (HashMap Text ByteString))
forall a b. a -> (a -> b) -> b
|> (RedisType -> Result Error (HashMap Text ByteString))
-> Maybe RedisType
-> Result Error (Maybe (HashMap Text ByteString))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse RedisType -> Result Error (HashMap Text ByteString)
expectHash
          Result Error (Maybe (HashMap Text ByteString))
-> (Result Error (Maybe (HashMap Text ByteString))
    -> Result Error [(Text, ByteString)])
-> Result Error [(Text, ByteString)]
forall a b. a -> (a -> b) -> b
|> (Maybe (HashMap Text ByteString) -> [(Text, ByteString)])
-> Result Error (Maybe (HashMap Text ByteString))
-> Result Error [(Text, ByteString)]
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map
            ( \Maybe (HashMap Text ByteString)
res ->
                case Maybe (HashMap Text ByteString)
res of
                  Just HashMap Text ByteString
hm' -> HashMap Text ByteString -> [(Text, ByteString)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text ByteString
hm'
                  Maybe (HashMap Text ByteString)
Nothing -> []
            )
      )
    Internal.Hkeys Text
key ->
      ( HashMap Text RedisType
hm,
        Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm
          Maybe RedisType
-> (Maybe RedisType
    -> Result Error (Maybe (HashMap Text ByteString)))
-> Result Error (Maybe (HashMap Text ByteString))
forall a b. a -> (a -> b) -> b
|> (RedisType -> Result Error (HashMap Text ByteString))
-> Maybe RedisType
-> Result Error (Maybe (HashMap Text ByteString))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse RedisType -> Result Error (HashMap Text ByteString)
expectHash
          Result Error (Maybe (HashMap Text ByteString))
-> (Result Error (Maybe (HashMap Text ByteString))
    -> Result Error [Text])
-> Result Error [Text]
forall a b. a -> (a -> b) -> b
|> (Maybe (HashMap Text ByteString) -> [Text])
-> Result Error (Maybe (HashMap Text ByteString))
-> Result Error [Text]
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map
            ( \Maybe (HashMap Text ByteString)
res ->
                case Maybe (HashMap Text ByteString)
res of
                  Just HashMap Text ByteString
hm' -> HashMap Text ByteString -> [Text]
forall k v. HashMap k v -> [k]
HM.keys HashMap Text ByteString
hm'
                  Maybe (HashMap Text ByteString)
Nothing -> []
            )
      )
    Internal.Hmget Text
key NonEmpty Text
fields ->
      case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
        Maybe RedisType
Nothing ->
          ( HashMap Text RedisType
hm,
            [Maybe ByteString] -> Result Error [Maybe ByteString]
forall error value. value -> Result error value
Ok []
          )
        Just (RedisHash HashMap Text ByteString
hm') ->
          ( HashMap Text RedisType
hm,
            (Text -> Maybe ByteString)
-> NonEmpty Text -> NonEmpty (Maybe ByteString)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (\Text
field -> Text -> HashMap Text ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
field HashMap Text ByteString
hm') NonEmpty Text
fields
              NonEmpty (Maybe ByteString)
-> (NonEmpty (Maybe ByteString) -> [Maybe ByteString])
-> [Maybe ByteString]
forall a b. a -> (a -> b) -> b
|> NonEmpty (Maybe ByteString) -> [Maybe ByteString]
forall a. NonEmpty a -> [a]
NonEmpty.toList
              [Maybe ByteString]
-> ([Maybe ByteString] -> Result Error [Maybe ByteString])
-> Result Error [Maybe ByteString]
forall a b. a -> (a -> b) -> b
|> [Maybe ByteString] -> Result Error [Maybe ByteString]
forall error value. value -> Result error value
Ok
          )
        Just RedisType
_ ->
          ( HashMap Text RedisType
hm,
            Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
          )
    Internal.Hmset Text
key NonEmpty (Text, ByteString)
vals' ->
      let vals :: [(Text, ByteString)]
vals = NonEmpty (Text, ByteString) -> [(Text, ByteString)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Text, ByteString)
vals'
       in case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
            Maybe RedisType
Nothing ->
              ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash ([(Text, ByteString)] -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, ByteString)]
vals)) HashMap Text RedisType
hm,
                () -> Result Error ()
forall error value. value -> Result error value
Ok ()
              )
            Just (RedisHash HashMap Text ByteString
hm') ->
              ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash ([(Text, ByteString)] -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, ByteString)]
vals HashMap Text ByteString
-> HashMap Text ByteString -> HashMap Text ByteString
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ HashMap Text ByteString
hm')) HashMap Text RedisType
hm,
                () -> Result Error ()
forall error value. value -> Result error value
Ok ()
              )
            Just RedisType
_ ->
              ( HashMap Text RedisType
hm,
                Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
              )
    Internal.Hset Text
key Text
field ByteString
val ->
      case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
        Maybe RedisType
Nothing ->
          ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash (Text -> ByteString -> HashMap Text ByteString
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
field ByteString
val)) HashMap Text RedisType
hm,
            () -> Result Error ()
forall error value. value -> Result error value
Ok ()
          )
        Just (RedisHash HashMap Text ByteString
hm') ->
          ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash (Text
-> ByteString -> HashMap Text ByteString -> HashMap Text ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
field ByteString
val HashMap Text ByteString
hm')) HashMap Text RedisType
hm,
            () -> Result Error ()
forall error value. value -> Result error value
Ok ()
          )
        Just RedisType
_ ->
          ( HashMap Text RedisType
hm,
            Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
          )
    Internal.Hsetnx Text
key Text
field ByteString
val ->
      case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
        Maybe RedisType
Nothing ->
          ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash (Text -> ByteString -> HashMap Text ByteString
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
field ByteString
val)) HashMap Text RedisType
hm,
            Bool -> Result Error Bool
forall error value. value -> Result error value
Ok Bool
True
          )
        Just (RedisHash HashMap Text ByteString
hm') ->
          if Text -> HashMap Text ByteString -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member Text
field HashMap Text ByteString
hm'
            then
              ( HashMap Text RedisType
hm,
                Bool -> Result Error Bool
forall error value. value -> Result error value
Ok Bool
False
              )
            else
              ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashMap Text ByteString -> RedisType
RedisHash (Text
-> ByteString -> HashMap Text ByteString -> HashMap Text ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
field ByteString
val HashMap Text ByteString
hm')) HashMap Text RedisType
hm,
                Bool -> Result Error Bool
forall error value. value -> Result error value
Ok Bool
True
              )
        Just RedisType
_ ->
          ( HashMap Text RedisType
hm,
            Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
          )
    Internal.Incr Text
key ->
      Query Int
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error Int)
forall a.
Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
doQuery (Text -> Int -> Query Int
Internal.Incrby Text
key Int
1) HashMap Text RedisType
hm
    Internal.Incrby Text
key Int
amount ->
      let encodeInt :: Int -> RedisType
encodeInt = ByteString -> RedisType
RedisByteString (ByteString -> RedisType)
-> (Text -> ByteString) -> Text -> RedisType
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Text -> ByteString
TE.encodeUtf8 (Text -> RedisType) -> (Int -> Text) -> Int -> RedisType
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Int -> Text
Text.fromInt
       in case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
            Maybe RedisType
Nothing ->
              ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (Int -> RedisType
encodeInt Int
amount) HashMap Text RedisType
hm,
                a -> Result Error a
forall error value. value -> Result error value
Ok a
1
              )
            Just RedisType
val ->
              case RedisType -> Result Error Int
expectInt RedisType
val of
                Err Error
err -> (HashMap Text RedisType
hm, Error -> Result Error a
forall error value. error -> Result error value
Err Error
err)
                Ok Int
x ->
                  ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (Int -> RedisType
encodeInt (Int
x Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
amount)) HashMap Text RedisType
hm,
                    Int -> Result Error Int
forall error value. value -> Result error value
Ok (Int
x Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
amount)
                  )
    Internal.Lrange Text
key Int
lower' Int
upper' ->
      ( HashMap Text RedisType
hm,
        case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
          Maybe RedisType
Nothing ->
            [ByteString] -> Result Error [ByteString]
forall error value. value -> Result error value
Ok []
          Just (RedisList [ByteString]
elems) ->
            let length :: Int
length = [ByteString] -> Int
forall a. List a -> Int
List.length [ByteString]
elems
                lower :: Int
lower = if Int
lower' Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
>= Int
0 then Int
lower' else Int
length Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
lower'
                upper :: Int
upper = if Int
upper' Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
>= Int
0 then Int
upper' else Int
length Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
upper'
             in [ByteString]
elems
                  [ByteString]
-> ([ByteString] -> ([ByteString], [ByteString]))
-> ([ByteString], [ByteString])
forall a b. a -> (a -> b) -> b
|> Int -> [ByteString] -> ([ByteString], [ByteString])
forall a. Int -> [a] -> ([a], [a])
Data.List.splitAt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (Int
upper Int -> Int -> Int
forall number. Num number => number -> number -> number
+ Int
1))
                  ([ByteString], [ByteString])
-> (([ByteString], [ByteString]) -> [ByteString]) -> [ByteString]
forall a b. a -> (a -> b) -> b
|> ([ByteString], [ByteString]) -> [ByteString]
forall a b. (a, b) -> a
Tuple.first
                  [ByteString] -> ([ByteString] -> [ByteString]) -> [ByteString]
forall a b. a -> (a -> b) -> b
|> Int -> [ByteString] -> [ByteString]
forall a. Int -> List a -> List a
List.drop Int
lower
                  [ByteString]
-> ([ByteString] -> Result Error [ByteString])
-> Result Error [ByteString]
forall a b. a -> (a -> b) -> b
|> [ByteString] -> Result Error [ByteString]
forall error value. value -> Result error value
Ok
          Just RedisType
_ ->
            Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
      )
    Internal.Mget NonEmpty Text
keys ->
      ( HashMap Text RedisType
hm,
        (Text -> Result Error (Maybe ByteString))
-> [Text] -> Result Error [Maybe ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse
          (\Text
key -> Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm Maybe RedisType
-> (Maybe RedisType -> Result Error (Maybe ByteString))
-> Result Error (Maybe ByteString)
forall a b. a -> (a -> b) -> b
|> (RedisType -> Result Error ByteString)
-> Maybe RedisType -> Result Error (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse RedisType -> Result Error ByteString
expectByteString)
          (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
keys)
      )
    Internal.Mset NonEmpty (Text, ByteString)
assocs ->
      ( ((Text, RedisType)
 -> HashMap Text RedisType -> HashMap Text RedisType)
-> HashMap Text RedisType
-> List (Text, RedisType)
-> HashMap Text RedisType
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldl
          (\(Text
key, RedisType
val) HashMap Text RedisType
hm' -> Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key RedisType
val HashMap Text RedisType
hm')
          HashMap Text RedisType
hm
          (((Text, ByteString) -> (Text, RedisType))
-> [(Text, ByteString)] -> List (Text, RedisType)
forall a b. (a -> b) -> List a -> List b
List.map (\(Text
k, ByteString
v) -> (Text
k, ByteString -> RedisType
RedisByteString ByteString
v)) (NonEmpty (Text, ByteString) -> [(Text, ByteString)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Text, ByteString)
assocs)),
        () -> Result Error ()
forall error value. value -> Result error value
Ok ()
      )
    Query a
Internal.Ping ->
      ( HashMap Text RedisType
hm,
        Status -> Result Error Status
forall error value. value -> Result error value
Ok Status
Database.Redis.Pong
      )
    Internal.Pure a
x -> (HashMap Text RedisType
hm, a -> Result Error a
forall error value. value -> Result error value
Ok a
x)
    Internal.Rpush Text
key NonEmpty ByteString
vals' ->
      let vals :: [ByteString]
vals = NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals'
       in case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
            Maybe RedisType
Nothing ->
              ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key ([ByteString] -> RedisType
RedisList [ByteString]
vals) HashMap Text RedisType
hm,
                Int -> Result Error Int
forall error value. value -> Result error value
Ok ([ByteString] -> Int
forall a. List a -> Int
List.length [ByteString]
vals)
              )
            Just (RedisList [ByteString]
prev) ->
              let combined :: [ByteString]
combined = [ByteString]
prev [ByteString] -> [ByteString] -> [ByteString]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ [ByteString]
vals
               in ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key ([ByteString] -> RedisType
RedisList [ByteString]
combined) HashMap Text RedisType
hm,
                    Int -> Result Error Int
forall error value. value -> Result error value
Ok ([ByteString] -> Int
forall a. List a -> Int
List.length [ByteString]
combined)
                  )
            Just RedisType
_ ->
              ( HashMap Text RedisType
hm,
                Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
              )
    Internal.Set Text
key ByteString
value ->
      ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (ByteString -> RedisType
RedisByteString ByteString
value) HashMap Text RedisType
hm,
        () -> Result Error ()
forall error value. value -> Result error value
Ok ()
      )
    Internal.Setex Text
key Int
_ ByteString
value ->
      ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (ByteString -> RedisType
RedisByteString ByteString
value) HashMap Text RedisType
hm,
        () -> Result Error ()
forall error value. value -> Result error value
Ok ()
      )
    Internal.Setnx Text
key ByteString
value ->
      if Text -> HashMap Text RedisType -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member Text
key HashMap Text RedisType
hm
        then (HashMap Text RedisType
hm, Bool -> Result Error Bool
forall error value. value -> Result error value
Ok Bool
False)
        else (Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (ByteString -> RedisType
RedisByteString ByteString
value) HashMap Text RedisType
hm, Bool -> Result Error Bool
forall error value. value -> Result error value
Ok Bool
True)
    Internal.WithResult a -> Result Error a
f Query a
q ->
      Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
forall a.
Query a
-> HashMap Text RedisType
-> (HashMap Text RedisType, Result Error a)
doQuery Query a
q HashMap Text RedisType
hm
        (HashMap Text RedisType, Result Error a)
-> ((HashMap Text RedisType, Result Error a)
    -> (HashMap Text RedisType, Result Error a))
-> (HashMap Text RedisType, Result Error a)
forall a b. a -> (a -> b) -> b
|> (Result Error a -> Result Error a)
-> (HashMap Text RedisType, Result Error a)
-> (HashMap Text RedisType, Result Error a)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map
          ( \Result Error a
result ->
              case Result Error a
result of
                Err Error
a -> Error -> Result Error a
forall error value. error -> Result error value
Err Error
a
                Ok a
res -> a -> Result Error a
f a
res
          )
    Internal.Sadd Text
key NonEmpty ByteString
vals ->
      let valsSet :: HashSet ByteString
valsSet = [ByteString] -> HashSet ByteString
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals)
       in case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
            Maybe RedisType
Nothing ->
              ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashSet ByteString -> RedisType
RedisSet HashSet ByteString
valsSet) HashMap Text RedisType
hm,
                a -> Result Error a
forall error value. value -> Result error value
Ok (Int -> a
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (HashSet ByteString -> Int
forall a. HashSet a -> Int
HS.size HashSet ByteString
valsSet))
              )
            Just (RedisSet HashSet ByteString
set) ->
              let newSet :: HashSet ByteString
newSet = HashSet ByteString
valsSet HashSet ByteString -> HashSet ByteString -> HashSet ByteString
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ HashSet ByteString
set
               in ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashSet ByteString -> RedisType
RedisSet HashSet ByteString
newSet) HashMap Text RedisType
hm,
                    a -> Result Error a
forall error value. value -> Result error value
Ok (Int -> a
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (HashSet ByteString -> Int
forall a. HashSet a -> Int
HS.size HashSet ByteString
newSet Int -> Int -> Int
forall number. Num number => number -> number -> number
- HashSet ByteString -> Int
forall a. HashSet a -> Int
HS.size HashSet ByteString
set))
                  )
            Just RedisType
_ ->
              ( HashMap Text RedisType
hm,
                Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
              )
    Internal.Scard Text
key ->
      ( HashMap Text RedisType
hm,
        case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
          Maybe RedisType
Nothing -> a -> Result Error a
forall error value. value -> Result error value
Ok a
0
          Just (RedisSet HashSet ByteString
set) -> a -> Result Error a
forall error value. value -> Result error value
Ok (Int -> a
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (HashSet ByteString -> Int
forall a. HashSet a -> Int
HS.size HashSet ByteString
set))
          Just RedisType
_ -> Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
      )
    Internal.Srem Text
key NonEmpty ByteString
vals ->
      let valsSet :: HashSet ByteString
valsSet = [ByteString] -> HashSet ByteString
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList (NonEmpty ByteString -> [ByteString]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ByteString
vals)
       in case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
            Maybe RedisType
Nothing ->
              ( HashMap Text RedisType
hm,
                a -> Result Error a
forall error value. value -> Result error value
Ok a
0
              )
            Just (RedisSet HashSet ByteString
set) ->
              let newSet :: HashSet ByteString
newSet = HashSet ByteString -> HashSet ByteString -> HashSet ByteString
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.difference HashSet ByteString
set HashSet ByteString
valsSet
               in ( Text
-> RedisType -> HashMap Text RedisType -> HashMap Text RedisType
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key (HashSet ByteString -> RedisType
RedisSet HashSet ByteString
newSet) HashMap Text RedisType
hm,
                    a -> Result Error a
forall error value. value -> Result error value
Ok (Int -> a
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (HashSet ByteString -> Int
forall a. HashSet a -> Int
HS.size HashSet ByteString
set Int -> Int -> Int
forall number. Num number => number -> number -> number
- HashSet ByteString -> Int
forall a. HashSet a -> Int
HS.size HashSet ByteString
newSet))
                  )
            Just RedisType
_ ->
              ( HashMap Text RedisType
hm,
                Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
              )
    Internal.Smembers Text
key ->
      ( HashMap Text RedisType
hm,
        case Text -> HashMap Text RedisType -> Maybe RedisType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key HashMap Text RedisType
hm of
          Maybe RedisType
Nothing -> [ByteString] -> Result Error [ByteString]
forall error value. value -> Result error value
Ok []
          Just (RedisSet HashSet ByteString
set) -> [ByteString] -> Result Error [ByteString]
forall error value. value -> Result error value
Ok (HashSet ByteString -> [ByteString]
forall a. HashSet a -> [a]
HS.toList HashSet ByteString
set)
          Just RedisType
_ -> Error -> Result Error a
forall error value. error -> Result error value
Err Error
wrongTypeErr
      )

wrongTypeErr :: Internal.Error
wrongTypeErr :: Error
wrongTypeErr = Text -> Error
Internal.RedisError Text
"WRONGTYPE Operation against a key holding the wrong kind of value"