nri-redis (empty) → 0.1.0.0

raw patch · 16 files changed

+2512/−0 lines, 16 filesdep +aesondep +asyncdep +base

Dependencies added: aeson, async, base, bytestring, conduit, hedis, nri-env-parser, nri-observability, nri-prelude, resourcet, safe-exceptions, text, unordered-containers, uuid

Files

• CHANGELOG.md +6/−0
• LICENSE +29/−0
• README.md +102/−0
• nri-redis.cabal +102/−0
• src/NonEmptyDict.hs +39/−0
• src/Redis.hs +175/−0
• src/Redis/Codec.hs +39/−0
• src/Redis/Counter.hs +115/−0
• src/Redis/Hash.hs +205/−0
• src/Redis/Internal.hs +309/−0
• src/Redis/List.hs +111/−0
• src/Redis/Mock.hs +402/−0
• src/Redis/Real.hs +316/−0
• src/Redis/Set.hs +128/−0
• src/Redis/Settings.hs +121/−0
• test/Main.hs +313/−0

@@ -0,0 +1,6 @@+# Unreleased next version++# 0.1.0.0++- First release, but we've battle-tested it against significant load for months now!+  Hope you enjoy

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, NoRedInk+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,102 @@+# Redis++_Reviewed last on 2020-10-14_++This library provides functions for working with [Redis][redis] and+JSON-serialized haskell records.++Because JSON encoding is quite lenient for containers (e.g. lists, maps),+using Hedis alone makes it easy to accidentally write a record to redis, and+only later discover that, when reading, you actually get back a list of that+record.++This library helps avoid those problem by levering specific Key-Value mapping+that we call an API.++At present this library implements a subset of the available [redis commands].+If you miss a command please feel free to add it!++## How to use me++1. make a handler++(optional) Set up some environmental variables.++these are the defaults:++```sh+REDIS_CONNECTION_STRING=redis://localhost:6379+REDIS_CLUSTER=0 # 1 is on+REDIS_DEFAULT_EXPIRY_SECONDS=0 # 0 is no expiration+REDIS_QUERY_TIMEOUT_MILLISECONDS=1000 # 0 is no timeout+```++```haskell+main : IO ()+main =+  -- use nri-env-parser to parse settings from the environment+  settings <- Environment.decode Redis.decoder+  -- get a handler+  Conduit.withAcquire (Redis.handler settings) <| \redisHandler ->+    callSomeRedisFuncs redisHandler+```++2. Define a codec type++```haskell+data Key = Key+  { userId :: Int,+    quizId :: Int+  }++data User =+  User {+    name :: Text,+    favoriteColor :: Text+  }+  deriving (Generic)+-- payload needs this!+instance Aeson.ToJSON User+instance Aeson.FromJSON User++-- using this enforces this key-value mapping+redisApi :: Redis.Api Key User+redisApi =+  Redis.Hash.jsonApi toKey+  where+    toKey :: Key -> Text+    toKey Key {userId, quizId} =+      Text.join+        "-"+        [ "quiz",+          Text.fromInt userId,+          Text.fromInt quizId,+          "v1" -- good idea to version your keys!+        ]+```++3. use the codec to read and writee!++```haskell+_ <- Redis.query handler (Redis.set redisApi (Key 1 2) (User "alice" "orange"))+Redis.query (Redis.get redisApi (Key 1 2))  -- Just (User "alice" "orange")+-- or, perhaps better+[ (Redis.set redisApi (Key 1 2) (User "alice" "orange"))+, (Redis.get redisApi (Key 1 2))+]+  |> Redis.sequence+  |> Redis.transaction -- Transaction ensures these commands are run together+```++## FAQ++### Your default env variables cause a collision. What do I do?++add a prefix, and use `decoderWithEnvVarPrefix` instead of `decoder`++[redis]: https://redis.io+[redis commands]: https://redis.io/commands++```++```

@@ -0,0 +1,102 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name:           nri-redis+version:        0.1.0.0+synopsis:       An intuitive hedis wrapper library.+description:    Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis>.+category:       Web+homepage:       https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis#readme+bug-reports:    https://github.com/NoRedInk/haskell-libraries/issues+author:         NoRedInk+maintainer:     haskell-open-source@noredink.com+copyright:      2021 NoRedInk Corp.+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md+    LICENSE+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/NoRedInk/haskell-libraries+  subdir: nri-redis++library+  exposed-modules:+      NonEmptyDict+      Redis+      Redis.Counter+      Redis.Hash+      Redis.List+      Redis.Mock+      Redis.Set+  other-modules:+      Redis.Codec+      Redis.Internal+      Redis.Real+      Redis.Settings+      Paths_nri_redis+  hs-source-dirs:+      src+  default-extensions: DataKinds DeriveGeneric ExtendedDefaultRules FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fno-warn-type-defaults -fplugin=NriPrelude.Plugin+  build-depends:+      aeson >=1.4.6.0 && <1.6+    , async >=2.2.2 && <2.3+    , base >=4.12.0.0 && <4.16+    , bytestring >=0.10.8.2 && <0.12+    , conduit >=1.3.0 && <1.4+    , hedis >=0.14.0 && <0.15+    , nri-env-parser >=0.1.0.0 && <0.2+    , nri-observability >=0.1.0 && <0.2+    , nri-prelude >=0.1.0.0 && <0.7+    , resourcet >=1.2.0 && <1.3+    , safe-exceptions >=0.1.7.0 && <1.3+    , text >=1.2.3.1 && <1.3+    , unordered-containers >=0.2.0.0 && <0.3+    , uuid >=1.3.0 && <1.4+  default-language: Haskell2010++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      NonEmptyDict+      Redis+      Redis.Codec+      Redis.Counter+      Redis.Hash+      Redis.Internal+      Redis.List+      Redis.Mock+      Redis.Real+      Redis.Set+      Redis.Settings+      Paths_nri_redis+  hs-source-dirs:+      test+      src+  default-extensions: DataKinds DeriveGeneric ExtendedDefaultRules FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fno-warn-type-defaults -fplugin=NriPrelude.Plugin+  build-depends:+      aeson >=1.4.6.0 && <1.6+    , async >=2.2.2 && <2.3+    , base >=4.12.0.0 && <4.16+    , bytestring >=0.10.8.2 && <0.12+    , conduit >=1.3.0 && <1.4+    , hedis >=0.14.0 && <0.15+    , nri-env-parser >=0.1.0.0 && <0.2+    , nri-observability >=0.1.0 && <0.2+    , nri-prelude >=0.1.0.0 && <0.7+    , resourcet >=1.2.0 && <1.3+    , safe-exceptions >=0.1.7.0 && <1.3+    , text >=1.2.3.1 && <1.3+    , unordered-containers >=0.2.0.0 && <0.3+    , uuid >=1.3.0 && <1.4+  default-language: Haskell2010

@@ -0,0 +1,39 @@+-- | A simple NonEmpty dict wrapper to protect us from writing invalid empty Dicts+-- to Redis Hashes.+module NonEmptyDict+  ( NonEmptyDict,+    fromDict,+    toDict,+    toNonEmptyList,+    init,+    keys,+  )+where++import Data.List.NonEmpty (NonEmpty ((:|)))+import Dict++data NonEmptyDict k v+  = NonEmptyDict (k, v) (Dict.Dict k v)+  deriving (Show)++-- | tries to create a 'NonEmptyDict' from a 'Dict'+fromDict :: Ord k => Dict.Dict k v -> Maybe (NonEmptyDict k v)+fromDict dict =+  case Dict.toList dict of+    [] -> Nothing+    (k, v) : _ -> Just <| init k v dict++-- | creates a 'Dict' from a 'NonEmptyDict'+toDict :: Ord k => NonEmptyDict k v -> Dict k v+toDict (NonEmptyDict (k, v) dict) =+  Dict.insert k v dict++-- | creates a 'Dict' from a 'NonEmptyDict'+toNonEmptyList :: NonEmptyDict k v -> NonEmpty (k, v)+toNonEmptyList (NonEmptyDict kv dict) =+  kv :| Dict.toList dict++init :: Ord k => k -> v -> Dict.Dict k v -> NonEmptyDict k v+init key val dict =+  NonEmptyDict (key, val) (Dict.remove key dict)

@@ -0,0 +1,175 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A simple Redis library providing high level access to Redis features we+-- use here at NoRedInk+--+-- As with our Ruby Redis access, we enforce working within a "namespace".+module Redis+  ( -- * Creating a redis handler+    Real.handler,+    Internal.Handler,+    Settings.Settings (..),+    Settings.decoder,+    Settings.decoderWithEnvVarPrefix,++    -- * Creating a redis API+    jsonApi,+    textApi,+    byteStringApi,+    Api,++    -- * Creating redis queries+    del,+    exists,+    expire,+    get,+    getset,+    mget,+    mset,+    ping,+    set,+    setex,+    setnx,++    -- * Running Redis queries+    Internal.query,+    Internal.transaction,+    Internal.Query,+    Internal.Error (..),+    Internal.map,+    Internal.map2,+    Internal.map3,+    Internal.sequence,+  )+where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Dict+import qualified NonEmptyDict+import qualified Redis.Codec as Codec+import qualified Redis.Internal as Internal+import qualified Redis.Real as Real+import qualified Redis.Settings as Settings+import qualified Prelude++-- | a API type can be used to enforce a mapping of keys to values.+-- without an API type, it can be easy to naiively serialize the wrong type+-- into a redis key.+--+-- Out of the box, we have helpers to support+-- - 'jsonApi' for json-encodable and decodable values+-- - 'textApi' for 'Text' values+-- - 'byteStringApi' for 'ByteString' values+data Api key a = Api+  { -- | Removes the specified keys. A key is ignored if it does not exist.+    --+    -- https://redis.io/commands/del+    del :: NonEmpty key -> Internal.Query Int,+    -- | Returns if key exists.+    --+    -- https://redis.io/commands/exists+    exists :: key -> Internal.Query Bool,+    -- | Set a timeout on key. After the timeout has expired, the key will+    -- automatically be deleted. A key with an associated timeout is often said to+    -- be volatile in Redis terminology.+    --+    -- https://redis.io/commands/expire+    expire :: key -> Int -> Internal.Query (),+    -- | Get the value of key. If the key does not exist the special value Nothing+    -- is returned. An error is returned if the value stored at key is not a+    -- string, because GET only handles string values.+    --+    -- https://redis.io/commands/get+    get :: key -> Internal.Query (Maybe a),+    -- | Atomically sets key to value and returns the old value stored at key.+    -- Returns an error when key exists but does not hold a string value.+    --+    -- https://redis.io/commands/getset+    getset :: key -> a -> Internal.Query (Maybe a),+    -- | Returns the values of all specified keys. For every key that does not hold+    -- a string value or does not exist, no value is returned. Because of this, the+    -- operation never fails.+    --+    -- https://redis.io/commands/mget+    mget :: Ord key => NonEmpty key -> Internal.Query (Dict.Dict key a),+    -- | Sets the given keys to their respective values. MSET replaces existing+    -- values with new values, just as regular SET. See MSETNX if you don't want to+    -- overwrite existing values.+    --+    -- MSET is atomic, so all given keys are set at once. It is not possible for+    -- clients to see that some of the keys were updated while others are+    -- unchanged.+    --+    -- https://redis.io/commands/mset+    mset :: NonEmptyDict.NonEmptyDict key a -> Internal.Query (),+    -- | Returns PONG if no argument is provided, otherwise return a copy of the+    -- argument as a bulk. This command is often used to test if a connection is+    -- still alive, or to measure latency.+    --+    -- https://redis.io/commands/ping+    ping :: Internal.Query (),+    -- | Set key to hold the string value. If key already holds a value, it is+    -- overwritten, regardless of its type. Any previous time to live associated+    -- with the key is discarded on successful SET operation.+    --+    -- https://redis.io/commands/set+    set :: key -> a -> Internal.Query (),+    -- | Set key to hold the string value and set key to timeout after a given+    -- number of seconds.+    --+    -- https://redis.io/commands/setex+    setex :: key -> Int -> a -> Internal.Query (),+    -- Set key to hold string value if key does not exist. In that case, it+    -- is equal to SET. When key already holds a value, no operation is+    -- performed. SETNX is short for "SET if Not eXists".+    --+    -- https://redis.io/commands/setnx+    setnx :: key -> a -> Internal.Query Bool+  }++-- | Creates a json API mapping a 'key' to a json-encodable-decodable type+-- @+-- data Key = Key { fieldA: Text, fieldB: Text }+-- data Val = Val { ... }+--+-- myJsonApi :: Redis.Api Key Val+-- myJsonApi = Redis.jsonApi (\Key {fieldA, fieldB}-> Text.join "-" [fieldA, fieldB, "v1"])+-- @+jsonApi :: (Aeson.ToJSON a, Aeson.FromJSON a) => (key -> Text) -> Api key a+jsonApi = makeApi Codec.jsonCodec++-- | Creates a Redis API mapping a 'key' to Text+textApi :: (key -> Text) -> Api key Text+textApi = makeApi Codec.textCodec++-- | Creates a Redis API mapping a 'key' to a ByteString+byteStringApi :: (key -> Text) -> Api key ByteString.ByteString+byteStringApi = makeApi Codec.byteStringCodec++-- | Private API used to make an API+makeApi :: Codec.Codec a -> (key -> Text) -> Api key a+makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey =+  Api+    { del = Internal.Del << NonEmpty.map toKey,+      exists = Internal.Exists << toKey,+      expire = \key secs -> Internal.Expire (toKey key) secs,+      get = \key -> Internal.WithResult (Prelude.traverse codecDecoder) (Internal.Get (toKey key)),+      getset = \key value -> Internal.WithResult (Prelude.traverse codecDecoder) (Internal.Getset (toKey key) (codecEncoder value)),+      mget = \keys ->+        NonEmpty.map toKey keys+          |> Internal.Mget+          |> map (Internal.maybesToDict (NonEmpty.toList keys))+          |> Internal.WithResult (Prelude.traverse codecDecoder),+      mset = \vals ->+        NonEmptyDict.toNonEmptyList vals+          |> map (\(k, v) -> (toKey k, codecEncoder v))+          |> Internal.Mset,+      ping = Internal.Ping |> map (\_ -> ()),+      set = \key value -> Internal.Set (toKey key) (codecEncoder value),+      setex = \key seconds value -> Internal.Setex (toKey key) seconds (codecEncoder value),+      setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value)+    }

@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Redis.Codec where++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy+import qualified Data.Text.Encoding+import qualified Redis.Internal as Internal+import qualified Prelude++data Codec a = Codec+  { codecEncoder :: Encoder a,+    codecDecoder :: Decoder a+  }++type Encoder a = a -> ByteString++type Decoder a = ByteString -> Result Internal.Error a++jsonCodec :: (Aeson.FromJSON a, Aeson.ToJSON a) => Codec a+jsonCodec = Codec jsonEncoder jsonDecoder++jsonEncoder :: Aeson.ToJSON a => Encoder a+jsonEncoder = Aeson.encode >> Data.ByteString.Lazy.toStrict++jsonDecoder :: Aeson.FromJSON a => Decoder a+jsonDecoder byteString =+  case Aeson.eitherDecodeStrict' byteString of+    Prelude.Right decoded -> Ok decoded+    Prelude.Left err ->+      Internal.DecodingError (Text.fromList err)+        |> Err++byteStringCodec :: Codec ByteString+byteStringCodec = Codec identity Ok++textCodec :: Codec Text+textCodec = Codec Data.Text.Encoding.encodeUtf8 (Data.Text.Encoding.decodeUtf8 >> Ok)

@@ -0,0 +1,115 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A simple Redis library providing high level access to Redis features we+-- use here at NoRedInk+--+-- As with our Ruby Redis access, we enforce working within a "namespace".+module Redis.Counter+  ( -- * Creating a redis handler+    Real.handler,+    Internal.Handler,+    Settings.Settings (..),+    Settings.decoder,++    -- * Creating a redis API+    makeApi,+    Api,++    -- * Creating redis queries+    del,+    exists,+    expire,+    ping,+    get,+    incr,+    incrby,+    set,++    -- * Running Redis queries+    Internal.query,+    Internal.transaction,+    Internal.Query,+    Internal.Error (..),+    Internal.map,+    Internal.map2,+    Internal.map3,+    Internal.sequence,+  )+where++import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Redis.Codec as Codec+import qualified Redis.Internal as Internal+import qualified Redis.Real as Real+import qualified Redis.Settings as Settings+import qualified Prelude++data Api key = Api+  { -- | Removes the specified keys. A key is ignored if it does not exist.+    --+    -- https://redis.io/commands/del+    del :: NonEmpty key -> Internal.Query Int,+    -- | Returns if key exists.+    --+    -- https://redis.io/commands/exists+    exists :: key -> Internal.Query Bool,+    -- | Set a timeout on key. After the timeout has expired, the key will+    -- automatically be deleted. A key with an associated timeout is often said to+    -- be volatile in Redis terminology.+    --+    -- https://redis.io/commands/expire+    expire :: key -> Int -> Internal.Query (),+    -- | Returns PONG if no argument is provided, otherwise return a copy of the+    -- argument as a bulk. This command is often used to test if a connection is+    -- still alive, or to measure latency.+    --+    -- https://redis.io/commands/ping+    ping :: Internal.Query (),+    -- | Get the value of key. If the key does not exist the special value Nothing+    -- is returned. An error is returned if the value stored at key is not a+    -- string, because GET only handles string values.+    --+    -- https://redis.io/commands/get+    get :: key -> Internal.Query (Maybe Int),+    -- | Increments the number stored at key by one. If the key does not+    -- exist, it is set to 0 before performing the operation. An error is+    -- returned if the key contains a value of the wrong type or contains a+    -- string that can not be represented as integer. This operation is+    -- limited to 64 bit signed integers.+    --+    -- https://redis.io/commands/incr+    incr :: key -> Internal.Query Int,+    -- | Increments the number stored at key by increment. If the key does+    -- not exist, it is set to 0 before performing the operation. An error+    -- is returned if the key contains a value of the wrong type or+    -- contains a string that can not be represented as integer. This+    -- operation is limited to 64 bit signed integers.+    --+    -- https://redis.io/commands/incrby+    incrby :: key -> Int -> Internal.Query Int,+    -- | Set key to hold the string value. If key already holds a value, it is+    -- overwritten, regardless of its type. Any previous time to live associated+    -- with the key is discarded on successful SET operation.+    --+    -- https://redis.io/commands/set+    set :: key -> Int -> Internal.Query ()+  }++makeApi ::+  (key -> Text) ->+  Api key+makeApi toKey =+  Api+    { del = Internal.Del << NonEmpty.map toKey,+      exists = Internal.Exists << toKey,+      expire = \key secs -> Internal.Expire (toKey key) secs,+      ping = Internal.Ping |> map (\_ -> ()),+      get = \key ->+        Internal.Get (toKey key)+          |> Internal.WithResult (Prelude.traverse (Codec.codecDecoder Codec.jsonCodec)),+      incr = \key -> Internal.Incr (toKey key),+      incrby = \key amount -> Internal.Incrby (toKey key) amount,+      set = \key val -> Internal.Set (toKey key) (Codec.codecEncoder Codec.jsonCodec val)+    }

@@ -0,0 +1,205 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A simple Redis library providing high level access to Redis features we+-- use here at NoRedInk+--+-- As with our Ruby Redis access, we enforce working within a "namespace".+module Redis.Hash+  ( -- * Creating a redis handler+    Real.handler,+    Internal.Handler,+    Settings.Settings (..),+    Settings.decoder,++    -- * Creating a redis API+    jsonApi,+    textApi,+    byteStringApi,+    Api,++    -- * Creating redis queries+    del,+    exists,+    expire,+    ping,+    hdel,+    hget,+    hgetall,+    hkeys,+    hmget,+    hmset,+    hset,+    hsetnx,++    -- * Running Redis queries+    Internal.query,+    Internal.transaction,+    Internal.Query,+    Internal.Error (..),+    Internal.map,+    Internal.map2,+    Internal.map3,+    Internal.sequence,+  )+where++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Dict+import qualified NonEmptyDict+import qualified Redis.Codec as Codec+import qualified Redis.Internal as Internal+import qualified Redis.Real as Real+import qualified Redis.Settings as Settings+import qualified Result+import qualified Prelude++data Api key field a = Api+  { -- | Removes the specified keys. A key is ignored if it does not exist.+    --+    -- https://redis.io/commands/del+    del :: NonEmpty key -> Internal.Query Int,+    -- | Returns if key exists.+    --+    -- https://redis.io/commands/exists+    exists :: key -> Internal.Query Bool,+    -- | Set a timeout on key. After the timeout has expired, the key will+    -- automatically be deleted. A key with an associated timeout is often said to+    -- be volatile in Redis terminology.+    --+    -- https://redis.io/commands/expire+    expire :: key -> Int -> Internal.Query (),+    -- | Returns PONG if no argument is provided, otherwise return a copy of the+    -- argument as a bulk. This command is often used to test if a connection is+    -- still alive, or to measure latency.+    --+    -- https://redis.io/commands/ping+    ping :: Internal.Query (),+    -- | Removes the specified fields from the hash stored at key. Specified fields+    -- that do not exist within this hash are ignored. If key does not exist, it is+    -- treated as an empty hash and this command returns 0.+    --+    -- https://redis.io/commands/hdel+    hdel :: key -> NonEmpty field -> Internal.Query Int,+    -- | Get the value of the field of a hash at key. If the key does not exist,+    -- or the field in the hash does not exis the special value Nothing is returned+    -- An error is returned if the value stored at key is not a+    -- hash, because HGET only handles string values.+    --+    -- https://redis.io/commands/hget+    hget :: key -> field -> Internal.Query (Maybe a),+    -- | Returns all fields and values of the hash stored at key. In the returned value, every field name is followed by its value, so the length of the reply is twice the size of the hash.+    -- Nothing in the returned value means failed utf8 decoding, not that it doesn't exist+    --+    -- https://redis.io/commands/hgetall+    hgetall :: key -> Internal.Query (Dict.Dict field a),+    -- | Returns all field names in the hash stored at key.+    -- Empty list means key doesn't exist+    --+    -- https://redis.io/commands/hkeys+    hkeys :: key -> Internal.Query (List field),+    -- | Returns the values associated with the specified fields in the hash stored at key.--+    --+    -- equivalent to modern hget+    -- https://redis.io/commands/hmget+    hmget :: key -> NonEmpty field -> Internal.Query (Dict.Dict field a),+    -- | Sets fields in the hash stored at key to values. If key does not exist, a new key holding a hash is created. If any fields exists, they are overwritten.+    --+    -- equivalent to modern hset+    -- https://redis.io/commands/hmset+    hmset :: key -> NonEmptyDict.NonEmptyDict field a -> Internal.Query (),+    -- | Sets field in the hash stored at key to value. If key does not exist, a new key holding a hash is created. If field already exists in the hash, it is overwritten.+    --+    -- https://redis.io/commands/hset+    hset :: key -> field -> a -> Internal.Query (),+    -- | Sets field in the hash stored at key to value, only if field does not yet+    -- exist. If key does not exist, a new key holding a hash is created. If field+    -- already exists, this operation has no effect.+    --+    -- https://redis.io/commands/hsetnx+    hsetnx :: key -> field -> a -> Internal.Query Bool+  }++jsonApi ::+  (Aeson.ToJSON a, Aeson.FromJSON a, Ord field) =>+  (key -> Text) ->+  (field -> Text) ->+  (Text -> Maybe field) ->+  Api key field a+jsonApi = makeApi Codec.jsonCodec++textApi ::+  Ord field =>+  (key -> Text) ->+  (field -> Text) ->+  (Text -> Maybe field) ->+  Api key field Text+textApi = makeApi Codec.textCodec++byteStringApi ::+  Ord field =>+  (key -> Text) ->+  (field -> Text) ->+  (Text -> Maybe field) ->+  Api key field ByteString.ByteString+byteStringApi = makeApi Codec.byteStringCodec++makeApi ::+  Ord field =>+  Codec.Codec a ->+  (key -> Text) ->+  (field -> Text) ->+  (Text -> Maybe field) ->+  Api key field a+makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey toField fromField =+  Api+    { del = Internal.Del << NonEmpty.map toKey,+      exists = Internal.Exists << toKey,+      expire = \key secs -> Internal.Expire (toKey key) secs,+      ping = Internal.Ping |> map (\_ -> ()),+      hdel = \key fields -> Internal.Hdel (toKey key) (NonEmpty.map toField fields),+      hget = \key field -> Internal.WithResult (Prelude.traverse codecDecoder) (Internal.Hget (toKey key) (toField field)),+      hgetall = Internal.WithResult (toDict fromField codecDecoder) << Internal.Hgetall << toKey,+      hkeys = \key ->+        Internal.Hkeys (toKey key)+          |> Internal.WithResult+            ( Prelude.traverse+                ( \field -> case fromField field of+                    Just field' -> Result.Ok field'+                    Nothing -> Result.Err (Internal.DecodingFieldError field)+                )+            ),+      hmget = \key fields ->+        fields+          |> NonEmpty.map toField+          |> Internal.Hmget (toKey key)+          |> map (Internal.maybesToDict (NonEmpty.toList fields))+          |> Internal.WithResult (Prelude.traverse codecDecoder),+      hmset = \key vals ->+        vals+          |> NonEmptyDict.toNonEmptyList+          |> NonEmpty.map (\(k, v) -> (toField k, codecEncoder v))+          |> Internal.Hmset (toKey key),+      hset = \key field val ->+        Internal.Hset (toKey key) (toField field) (codecEncoder val),+      hsetnx = \key field val ->+        Internal.Hsetnx (toKey key) (toField field) (codecEncoder val)+    }++toDict :: Ord field => (Text -> Maybe field) -> Codec.Decoder a -> List (Text, ByteString) -> Result Internal.Error (Dict.Dict field a)+toDict fromField decode =+  Result.map Dict.fromList+    << Prelude.traverse+      ( \(k, v) ->+          Result.andThen+            ( \v' ->+                case fromField k of+                  Just k' -> Result.Ok (k', v')+                  Nothing -> Result.Err (Internal.DecodingFieldError k)+            )+            (decode v)+      )

@@ -0,0 +1,309 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Redis.Internal+  ( Error (..),+    Handler (..),+    Query (..),+    cmds,+    map,+    map2,+    map3,+    sequence,+    query,+    transaction,+    -- internal tools+    traceQuery,+    maybesToDict,+    keysTouchedByQuery,+  )+where++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Database.Redis+import qualified Dict+import qualified GHC.Stack as Stack+import qualified List+import qualified Log.RedisCommands as RedisCommands+import NriPrelude hiding (map, map2, map3)+import qualified Platform+import qualified Set+import qualified Text+import qualified Tuple+import qualified Prelude++-- | Redis Errors, scoped by where they originate.+data Error+  = RedisError Text+  | ConnectionLost+  | DecodingError Text+  | DecodingFieldError Text+  | LibraryError Text+  | TransactionAborted+  | TimeoutError++instance Aeson.ToJSON Error where+  toJSON err = Aeson.toJSON (errorForHumans err)++instance Show Error where+  show = errorForHumans >> Text.toList++errorForHumans :: Error -> Text+errorForHumans topError =+  case topError of+    RedisError err -> "Redis error: " ++ err+    ConnectionLost -> "Connection Lost"+    LibraryError err -> "Library error when executing (probably due to a bug in the library): " ++ err+    DecodingError err -> "Could not decode value in key: " ++ err+    DecodingFieldError err -> "Could not decode field of hash: " ++ err+    TransactionAborted -> "Transaction aborted."+    TimeoutError -> "Redis query took too long."++-- | Render the commands a query is going to run for monitoring and debugging+-- purposes. Values we write are replaced with "*****" because they might+-- contain sensitive data.+cmds :: Query b -> [Text]+cmds query'' =+  case query'' of+    Del keys -> [unwords ("DEL" : NonEmpty.toList keys)]+    Exists key -> [unwords ["EXISTS", key]]+    Expire key val -> [unwords ["EXPIRE", key, Text.fromInt val]]+    Get key -> [unwords ["GET", key]]+    Getset key _ -> [unwords ["GETSET", key, "*****"]]+    Hdel key fields -> [unwords ("HDEL" : key : NonEmpty.toList fields)]+    Hgetall key -> [unwords ["HGETALL", key]]+    Hget key field -> [unwords ["HGET", key, field]]+    Hkeys key -> [unwords ["HKEY", key]]+    Hmget key fields -> [unwords ("HMGET" : key : NonEmpty.toList fields)]+    Hmset key pairs ->+      [unwords ("HMSET" : key : List.concatMap (\(field, _) -> [field, "*****"]) (NonEmpty.toList pairs))]+    Hset key field _ -> [unwords ["HSET", key, field, "*****"]]+    Hsetnx key field _ -> [unwords ["HSETNX", key, field, "*****"]]+    Incr key -> [unwords ["INCR", key]]+    Incrby key amount -> [unwords ["INCRBY", key, Text.fromInt amount]]+    Lrange key lower upper -> [unwords ["LRANGE", key, Text.fromInt lower, Text.fromInt upper]]+    Mget keys -> [unwords ("MGET" : NonEmpty.toList keys)]+    Mset pairs -> [unwords ("MSET" : List.concatMap (\(key, _) -> [key, "*****"]) (NonEmpty.toList pairs))]+    Ping -> ["PING"]+    Rpush key vals -> [unwords ("RPUSH" : key : List.map (\_ -> "*****") (NonEmpty.toList vals))]+    Set key _ -> [unwords ["SET", key, "*****"]]+    Setex key seconds _ -> [unwords ["SETEX", key, Text.fromInt seconds, "*****"]]+    Setnx key _ -> [unwords ["SETNX", key, "*****"]]+    Sadd key vals -> [unwords ("SADD" : key : List.map (\_ -> "*****") (NonEmpty.toList vals))]+    Scard key -> [unwords ["SCARD", key]]+    Srem key vals -> [unwords ("SREM" : key : List.map (\_ -> "*****") (NonEmpty.toList vals))]+    Smembers key -> [unwords ["SMEMBERS", key]]+    Pure _ -> []+    Apply f x -> cmds f ++ cmds x+    WithResult _ x -> cmds x++unwords :: [Text] -> Text+unwords = Text.join " "++-- | A Redis query+data Query a where+  Del :: NonEmpty Text -> Query Int+  Exists :: Text -> Query Bool+  Expire :: Text -> Int -> Query ()+  Get :: Text -> Query (Maybe ByteString)+  Getset :: Text -> ByteString -> Query (Maybe ByteString)+  Hdel :: Text -> NonEmpty Text -> Query Int+  Hgetall :: Text -> Query [(Text, ByteString)]+  Hget :: Text -> Text -> Query (Maybe ByteString)+  Hkeys :: Text -> Query [Text]+  Hmget :: Text -> NonEmpty Text -> Query [Maybe ByteString]+  Hmset :: Text -> NonEmpty (Text, ByteString) -> Query ()+  Hset :: Text -> Text -> ByteString -> Query ()+  Hsetnx :: Text -> Text -> ByteString -> Query Bool+  Incr :: Text -> Query Int+  Incrby :: Text -> Int -> Query Int+  Lrange :: Text -> Int -> Int -> Query [ByteString]+  Mget :: NonEmpty Text -> Query [Maybe ByteString]+  Mset :: NonEmpty (Text, ByteString) -> Query ()+  Ping :: Query Database.Redis.Status+  Rpush :: Text -> NonEmpty ByteString -> Query Int+  Set :: Text -> ByteString -> Query ()+  Setex :: Text -> Int -> ByteString -> Query ()+  Setnx :: Text -> ByteString -> Query Bool+  Sadd :: Text -> NonEmpty ByteString -> Query Int+  Scard :: Text -> Query Int+  Srem :: Text -> NonEmpty ByteString -> Query Int+  Smembers :: Text -> Query (List ByteString)+  -- The constructors below are not Redis-related, but support using functions+  -- like `map` and `map2` on queries.+  Pure :: a -> Query a+  Apply :: Query (a -> b) -> Query a -> Query b+  WithResult :: (a -> Result Error b) -> Query a -> Query b++instance Prelude.Functor Query where+  fmap = map++-- | Used to map the type of a query to another type+-- useful in combination with 'transaction'+map :: (a -> b) -> Query a -> Query b+map f q = WithResult (f >> Ok) 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 f queryA queryB =+  Apply (map f queryA) 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 f queryA queryB queryC =+  Apply (Apply (map f queryA) queryB) queryC++-- | Used to run a series of queries in sequence.+-- Useful to run a list of queries in sequence.+-- @+-- queries+--   |> Redis.sequence+--   |> Redis.query redis+-- @+sequence :: List (Query a) -> Query (List a)+sequence =+  List.foldr (map2 (:)) (Pure [])++-- | The redis handler allows applications to run scoped IO+data Handler = Handler+  { doQuery :: Stack.HasCallStack => forall a. Query a -> Task Error a,+    doTransaction :: Stack.HasCallStack => forall a. Query a -> Task Error a,+    namespace :: Text+  }++-- | Run a 'Query'.+-- Note: A 'Query' in this library can consist of one or more queries in sequence.+-- if a 'Query' contains multiple queries, it may make more sense, if possible+-- to run them using 'transaction'+query :: Stack.HasCallStack => Handler -> Query a -> Task Error a+query handler query' =+  namespaceQuery (namespace handler ++ ":") query'+    |> Stack.withFrozenCallStack doQuery handler++-- | Run a redis Query in a transaction. If the query contains several Redis+-- commands they're all executed together, and Redis will guarantee other+-- requests won't be able change values in between.+--+-- In redis terms, this is wrappping the 'Query' in `MULTI` and `EXEC+-- see redis transaction semantics here: https://redis.io/topics/transactions+transaction :: Stack.HasCallStack => Handler -> Query a -> Task Error a+transaction handler query' =+  namespaceQuery (namespace handler ++ ":") query'+    |> Stack.withFrozenCallStack doTransaction handler++namespaceQuery :: Text -> Query a -> Query a+namespaceQuery prefix query' =+  case query' of+    Exists key -> Exists (prefix ++ key)+    Ping -> Ping+    Get key -> Get (prefix ++ key)+    Set key value -> Set (prefix ++ key) value+    Setex key seconds value -> Setex (prefix ++ key) seconds value+    Setnx key value -> Setnx (prefix ++ key) value+    Getset key value -> Getset (prefix ++ key) value+    Mget keys -> Mget (NonEmpty.map (\k -> prefix ++ k) keys)+    Mset assocs -> Mset (NonEmpty.map (\(k, v) -> (prefix ++ k, v)) assocs)+    Del keys -> Del (NonEmpty.map (prefix ++) keys)+    Hgetall key -> Hgetall (prefix ++ key)+    Hkeys key -> Hkeys (prefix ++ key)+    Hmget key fields -> Hmget (prefix ++ key) fields+    Hget key field -> Hget (prefix ++ key) field+    Hset key field val -> Hset (prefix ++ key) field val+    Hsetnx key field val -> Hsetnx (prefix ++ key) field val+    Hmset key vals -> Hmset (prefix ++ key) vals+    Hdel key fields -> Hdel (prefix ++ key) fields+    Incr key -> Incr (prefix ++ key)+    Incrby key amount -> Incrby (prefix ++ key) amount+    Expire key secs -> Expire (prefix ++ key) secs+    Lrange key lower upper -> Lrange (prefix ++ key) lower upper+    Rpush key vals -> Rpush (prefix ++ key) vals+    Sadd key vals -> Sadd (prefix ++ key) vals+    Scard key -> Scard (prefix ++ key)+    Srem key vals -> Srem (prefix ++ key) vals+    Smembers key -> Smembers (prefix ++ key)+    Pure x -> Pure x+    Apply f x -> Apply (namespaceQuery prefix f) (namespaceQuery prefix x)+    WithResult f q -> WithResult f (namespaceQuery prefix q)++keysTouchedByQuery :: Query a -> Set.Set Text+keysTouchedByQuery query' =+  case query' of+    Apply f x -> Set.union (keysTouchedByQuery f) (keysTouchedByQuery x)+    Del keys -> Set.fromList (NonEmpty.toList keys)+    Exists key -> Set.singleton 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 _key _ -> Set.empty+    Get key -> Set.singleton key+    Getset key _ -> Set.singleton key+    Hdel key _ -> Set.singleton key+    Hget key _ -> Set.singleton key+    Hgetall key -> Set.singleton key+    Hkeys key -> Set.singleton key+    Hmget key _ -> Set.singleton key+    Hmset key _ -> Set.singleton key+    Hset key _ _ -> Set.singleton key+    Hsetnx key _ _ -> Set.singleton key+    Incr key -> Set.singleton key+    Incrby key _ -> Set.singleton key+    Lrange key _ _ -> Set.singleton key+    Mget keys -> Set.fromList (NonEmpty.toList keys)+    Mset assocs -> Set.fromList (NonEmpty.toList (NonEmpty.map Tuple.first assocs))+    Ping -> Set.empty+    Pure _ -> Set.empty+    Rpush key _ -> Set.singleton key+    Set key _ -> Set.singleton key+    Setex key _ _ -> Set.singleton key+    Setnx key _ -> Set.singleton key+    Sadd key _ -> Set.singleton key+    Scard key -> Set.singleton key+    Srem key _ -> Set.singleton key+    Smembers key -> Set.singleton key+    WithResult _ q -> keysTouchedByQuery q++maybesToDict :: Ord key => List key -> List (Maybe a) -> Dict.Dict key a+maybesToDict keys values =+  List.map2 (,) keys values+    |> List.filterMap+      ( \(key, value) ->+          case value of+            Nothing -> Nothing+            Just v -> Just (key, v)+      )+    |> Dict.fromList++traceQuery :: Stack.HasCallStack => [Text] -> Text -> Maybe Int -> Task e a -> Task e a+traceQuery commands host port task =+  let info =+        RedisCommands.emptyDetails+          { RedisCommands.commands = commands,+            RedisCommands.host = Just host,+            RedisCommands.port = port+          }+   in Stack.withFrozenCallStack+        Platform.tracingSpan+        "Redis Query"+        ( Platform.finally+            task+            ( do+                Platform.setTracingSpanDetails info+                Platform.setTracingSpanSummary+                  ( case commands of+                      [] -> ""+                      [cmd] -> cmd+                      cmd : _ -> cmd ++ " (+ more)"+                  )+            )+        )

@@ -0,0 +1,111 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A simple Redis library providing high level access to Redis features we+-- use here at NoRedInk+--+-- As with our Ruby Redis access, we enforce working within a "namespace".+module Redis.List+  ( -- * Creating a redis handler+    Real.handler,+    Internal.Handler,+    Settings.Settings (..),+    Settings.decoder,++    -- * Creating a redis API+    jsonApi,+    textApi,+    byteStringApi,+    Api,++    -- * Creating redis queries+    del,+    exists,+    expire,+    ping,+    lrange,+    rpush,++    -- * Running Redis queries+    Internal.query,+    Internal.transaction,+    Internal.Query,+    Internal.Error (..),+    Internal.map,+    Internal.map2,+    Internal.map3,+    Internal.sequence,+  )+where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Redis.Codec as Codec+import qualified Redis.Internal as Internal+import qualified Redis.Real as Real+import qualified Redis.Settings as Settings+import qualified Prelude++data Api key a = Api+  { -- | Removes the specified keys. A key is ignored if it does not exist.+    --+    -- https://redis.io/commands/del+    del :: NonEmpty key -> Internal.Query Int,+    -- | Returns if key exists.+    --+    -- https://redis.io/commands/exists+    exists :: key -> Internal.Query Bool,+    -- | Set a timeout on key. After the timeout has expired, the key will+    -- automatically be deleted. A key with an associated timeout is often said to+    -- be volatile in Redis terminology.+    --+    -- https://redis.io/commands/expire+    expire :: key -> Int -> Internal.Query (),+    -- | Returns PONG if no argument is provided, otherwise return a copy of the+    -- argument as a bulk. This command is often used to test if a connection is+    -- still alive, or to measure latency.+    --+    -- https://redis.io/commands/ping+    ping :: Internal.Query (),+    -- | Returns the specified elements of the list stored at key. The+    -- offsets start and stop are zero-based indexes, with 0 being the+    -- first element of the list (the head of the list), 1 being the next+    -- element and so on.+    --+    -- These offsets can also be negative numbers indicating offsets+    -- starting at the end of the list. For example, -1 is the last element+    -- of the list, -2 the penultimate, and so on.+    lrange :: key -> Int -> Int -> Internal.Query [a],+    -- | Insert all the specified values at the tail of the list stored at key. If key does not exist, it is created as empty list before performing the push operation. When key holds a value that is not a list, an error is returned.+    --+    -- https://redis.io/commands/rpush+    rpush :: key -> NonEmpty a -> Internal.Query Int+  }++jsonApi :: (Aeson.ToJSON a, Aeson.FromJSON a) => (key -> Text) -> Api key a+jsonApi = makeApi Codec.jsonCodec++textApi :: (key -> Text) -> Api key Text+textApi = makeApi Codec.textCodec++byteStringApi :: (key -> Text) -> Api key ByteString.ByteString+byteStringApi = makeApi Codec.byteStringCodec++makeApi ::+  Codec.Codec a ->+  (key -> Text) ->+  Api key a+makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey =+  Api+    { del = Internal.Del << NonEmpty.map toKey,+      exists = Internal.Exists << toKey,+      expire = \key secs -> Internal.Expire (toKey key) secs,+      ping = Internal.Ping |> map (\_ -> ()),+      lrange = \key lower upper ->+        Internal.Lrange (toKey key) lower upper+          |> Internal.WithResult (Prelude.traverse codecDecoder),+      rpush = \key vals ->+        Internal.Rpush (toKey key) (NonEmpty.map codecEncoder vals)+    }

@@ -0,0 +1,402 @@+{-# 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 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 =+  handlerIO+    |> 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 = do+  modelRef <- init+  doAnything <- Platform.doAnythingHandler+  Internal.Handler+    { Internal.doQuery = doQuery' modelRef doAnything,+      Internal.doTransaction = doQuery' modelRef doAnything,+      Internal.namespace = "tests"+    }+    |> Prelude.pure+  where+    doQuery' modelRef doAnything = \query ->+      atomicModifyIORef'+        modelRef+        ( \model ->+            let (newHash, res) = doQuery query (hash model)+             in ( model {hash = newHash},+                  res+                )+        )+        |> Platform.doAnything doAnything+        |> Internal.traceQuery (Internal.cmds query) "Redis.Mock" 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+  {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 (Eq)++expectByteString :: RedisType -> Result Internal.Error ByteString+expectByteString val =+  case val of+    RedisByteString bytestring -> Ok bytestring+    RedisHash _ -> Err wrongTypeErr+    RedisList _ -> Err wrongTypeErr+    RedisSet _ -> Err wrongTypeErr++expectHash :: RedisType -> Result Internal.Error (HM.HashMap Text ByteString)+expectHash val =+  case val of+    RedisByteString _ -> Err wrongTypeErr+    RedisHash hash -> Ok hash+    RedisList _ -> Err wrongTypeErr+    RedisSet _ -> Err wrongTypeErr++expectInt :: RedisType -> Result Internal.Error Int+expectInt val =+  case val of+    RedisByteString val' ->+      case TE.decodeUtf8' val' of+        Prelude.Left _ -> Err wrongTypeErr+        Prelude.Right str ->+          case Text.toInt str of+            Nothing -> Err wrongTypeErr+            Just int -> Ok int+    RedisHash _ -> Err wrongTypeErr+    RedisList _ -> Err wrongTypeErr+    RedisSet _ -> Err wrongTypeErr++init :: IO (IORef Model)+init = newIORef (Model HM.empty)++doQuery ::+  Internal.Query a ->+  HM.HashMap Text RedisType ->+  (HM.HashMap Text RedisType, Result Internal.Error a)+doQuery query hm =+  case query of+    Internal.Apply fQuery xQuery ->+      let (hm1, f) = doQuery fQuery hm+          (hm2, x) = doQuery xQuery hm1+       in (hm2, map2 (\f' x' -> f' x') f x)+    Internal.Del keys ->+      List.foldl+        ( \key (hm', count) ->+            if HM.member key hm'+              then (HM.delete key hm', count + 1)+              else (hm', count)+        )+        (hm, 0 :: Int)+        (NonEmpty.toList keys)+        |> Tuple.mapSecond Ok+    Internal.Exists key ->+      ( hm,+        Ok (HM.member key hm)+      )+    Internal.Expire _ _ ->+      -- Expiring is an intentional no-op in `Redis.Mock`. Implementing it would+      -- likely be a lot of effort, and only support writing slow tests.+      ( hm,+        Ok ()+      )+    Internal.Get key ->+      ( hm,+        HM.lookup key hm+          |> Prelude.traverse expectByteString+      )+    Internal.Getset key value ->+      ( HM.insert key (RedisByteString value) hm,+        HM.lookup key hm+          |> Prelude.traverse expectByteString+      )+    Internal.Hdel key fields ->+      case HM.lookup key hm of+        Nothing ->+          ( hm,+            Ok 0+          )+        Just (RedisHash hm') ->+          let hmAfterDeletions = Prelude.foldr HM.delete hm' fields+           in ( HM.insert key (RedisHash hmAfterDeletions) hm,+                HM.size hm' - HM.size hmAfterDeletions+                  |> Prelude.fromIntegral+                  |> Ok+              )+        Just _ ->+          ( hm,+            Err wrongTypeErr+          )+    Internal.Hget key field ->+      case HM.lookup key hm of+        Nothing ->+          ( hm,+            Ok Nothing+          )+        Just (RedisHash hm') ->+          ( hm,+            Ok (HM.lookup field hm')+          )+        Just _ ->+          ( hm,+            Err wrongTypeErr+          )+    Internal.Hgetall key ->+      ( hm,+        HM.lookup key hm+          |> Prelude.traverse expectHash+          |> map+            ( \res ->+                case res of+                  Just hm' -> HM.toList hm'+                  Nothing -> []+            )+      )+    Internal.Hkeys key ->+      ( hm,+        HM.lookup key hm+          |> Prelude.traverse expectHash+          |> map+            ( \res ->+                case res of+                  Just hm' -> HM.keys hm'+                  Nothing -> []+            )+      )+    Internal.Hmget key fields ->+      case HM.lookup key hm of+        Nothing ->+          ( hm,+            Ok []+          )+        Just (RedisHash hm') ->+          ( hm,+            map (\field -> HM.lookup field hm') fields+              |> NonEmpty.toList+              |> Ok+          )+        Just _ ->+          ( hm,+            Err wrongTypeErr+          )+    Internal.Hmset key vals' ->+      let vals = NonEmpty.toList vals'+       in case HM.lookup key hm of+            Nothing ->+              ( HM.insert key (RedisHash (HM.fromList vals)) hm,+                Ok ()+              )+            Just (RedisHash hm') ->+              ( HM.insert key (RedisHash (HM.fromList vals ++ hm')) hm,+                Ok ()+              )+            Just _ ->+              ( hm,+                Err wrongTypeErr+              )+    Internal.Hset key field val ->+      case HM.lookup key hm of+        Nothing ->+          ( HM.insert key (RedisHash (HM.singleton field val)) hm,+            Ok ()+          )+        Just (RedisHash hm') ->+          ( HM.insert key (RedisHash (HM.insert field val hm')) hm,+            Ok ()+          )+        Just _ ->+          ( hm,+            Err wrongTypeErr+          )+    Internal.Hsetnx key field val ->+      case HM.lookup key hm of+        Nothing ->+          ( HM.insert key (RedisHash (HM.singleton field val)) hm,+            Ok True+          )+        Just (RedisHash hm') ->+          if HM.member field hm'+            then+              ( hm,+                Ok False+              )+            else+              ( HM.insert key (RedisHash (HM.insert field val hm')) hm,+                Ok True+              )+        Just _ ->+          ( hm,+            Err wrongTypeErr+          )+    Internal.Incr key ->+      doQuery (Internal.Incrby key 1) hm+    Internal.Incrby key amount ->+      let encodeInt = RedisByteString << TE.encodeUtf8 << Text.fromInt+       in case HM.lookup key hm of+            Nothing ->+              ( HM.insert key (encodeInt amount) hm,+                Ok 1+              )+            Just val ->+              case expectInt val of+                Err err -> (hm, Err err)+                Ok x ->+                  ( HM.insert key (encodeInt (x + amount)) hm,+                    Ok (x + amount)+                  )+    Internal.Lrange key lower' upper' ->+      ( hm,+        case HM.lookup key hm of+          Nothing ->+            Ok []+          Just (RedisList elems) ->+            let length = List.length elems+                lower = if lower' >= 0 then lower' else length + lower'+                upper = if upper' >= 0 then upper' else length + upper'+             in elems+                  |> Data.List.splitAt (Prelude.fromIntegral (upper + 1))+                  |> Tuple.first+                  |> List.drop lower+                  |> Ok+          Just _ ->+            Err wrongTypeErr+      )+    Internal.Mget keys ->+      ( hm,+        Prelude.traverse+          (\key -> HM.lookup key hm |> Prelude.traverse expectByteString)+          (NonEmpty.toList keys)+      )+    Internal.Mset assocs ->+      ( List.foldl+          (\(key, val) hm' -> HM.insert key val hm')+          hm+          (List.map (\(k, v) -> (k, RedisByteString v)) (NonEmpty.toList assocs)),+        Ok ()+      )+    Internal.Ping ->+      ( hm,+        Ok Database.Redis.Pong+      )+    Internal.Pure x -> (hm, Ok x)+    Internal.Rpush key vals' ->+      let vals = NonEmpty.toList vals'+       in case HM.lookup key hm of+            Nothing ->+              ( HM.insert key (RedisList vals) hm,+                Ok (List.length vals)+              )+            Just (RedisList prev) ->+              let combined = prev ++ vals+               in ( HM.insert key (RedisList combined) hm,+                    Ok (List.length combined)+                  )+            Just _ ->+              ( hm,+                Err wrongTypeErr+              )+    Internal.Set key value ->+      ( HM.insert key (RedisByteString value) hm,+        Ok ()+      )+    Internal.Setex key _ value ->+      ( HM.insert key (RedisByteString value) hm,+        Ok ()+      )+    Internal.Setnx key value ->+      if HM.member key hm+        then (hm, Ok False)+        else (HM.insert key (RedisByteString value) hm, Ok True)+    Internal.WithResult f q ->+      doQuery q hm+        |> map+          ( \result ->+              case result of+                Err a -> Err a+                Ok res -> f res+          )+    Internal.Sadd key vals ->+      let valsSet = HS.fromList (NonEmpty.toList vals)+       in case HM.lookup key hm of+            Nothing ->+              ( HM.insert key (RedisSet valsSet) hm,+                Ok (Prelude.fromIntegral (HS.size valsSet))+              )+            Just (RedisSet set) ->+              let newSet = valsSet ++ set+               in ( HM.insert key (RedisSet newSet) hm,+                    Ok (Prelude.fromIntegral (HS.size newSet - HS.size set))+                  )+            Just _ ->+              ( hm,+                Err wrongTypeErr+              )+    Internal.Scard key ->+      ( hm,+        case HM.lookup key hm of+          Nothing -> Ok 0+          Just (RedisSet set) -> Ok (Prelude.fromIntegral (HS.size set))+          Just _ -> Err wrongTypeErr+      )+    Internal.Srem key vals ->+      let valsSet = HS.fromList (NonEmpty.toList vals)+       in case HM.lookup key hm of+            Nothing ->+              ( hm,+                Ok 0+              )+            Just (RedisSet set) ->+              let newSet = HS.difference set valsSet+               in ( HM.insert key (RedisSet newSet) hm,+                    Ok (Prelude.fromIntegral (HS.size set - HS.size newSet))+                  )+            Just _ ->+              ( hm,+                Err wrongTypeErr+              )+    Internal.Smembers key ->+      ( hm,+        case HM.lookup key hm of+          Nothing -> Ok []+          Just (RedisSet set) -> Ok (HS.toList set)+          Just _ -> Err wrongTypeErr+      )++wrongTypeErr :: Internal.Error+wrongTypeErr = Internal.RedisError "WRONGTYPE Operation against a key holding the wrong kind of value"

@@ -0,0 +1,316 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}++module Redis.Real+  ( handler,+  )+where++import qualified Control.Exception.Safe as Exception+import qualified Data.Acquire+import qualified Data.ByteString+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text.Encoding+import qualified Database.Redis+import qualified GHC.Stack as Stack+import qualified Platform+import qualified Redis.Internal as Internal+import qualified Redis.Settings as Settings+import qualified Set+import qualified Text+import Prelude (Either (Left, Right), IO, fromIntegral, pure)+import qualified Prelude++-- | Produce a namespaced handler for Redis access.+handler :: Text -> Settings.Settings -> Data.Acquire.Acquire Internal.Handler+handler namespace settings = do+  (namespacedHandler, _) <- Data.Acquire.mkAcquire (acquireHandler namespace settings) releaseHandler+  namespacedHandler+    |> ( \handler' ->+           case Settings.defaultExpiry settings of+             Settings.NoDefaultExpiry -> handler'+             Settings.ExpireKeysAfterSeconds secs ->+               defaultExpiryKeysAfterSeconds secs handler'+       )+    |> ( \handler' ->+           case Settings.queryTimeout settings of+             Settings.NoQueryTimeout -> handler'+             Settings.TimeoutQueryAfterMilliseconds milliseconds ->+               timeoutAfterMilliseconds (toFloat milliseconds) handler'+       )+    |> Prelude.pure++timeoutAfterMilliseconds :: Float -> Internal.Handler -> Internal.Handler+timeoutAfterMilliseconds milliseconds handler' =+  handler'+    { Internal.doQuery =+        Stack.withFrozenCallStack Internal.doQuery handler'+          >> Task.timeout milliseconds Internal.TimeoutError,+      Internal.doTransaction =+        Stack.withFrozenCallStack Internal.doTransaction handler'+          >> Task.timeout milliseconds Internal.TimeoutError+    }++defaultExpiryKeysAfterSeconds :: Int -> Internal.Handler -> Internal.Handler+defaultExpiryKeysAfterSeconds secs handler' =+  let wrapWithExpire :: Internal.Query a -> Internal.Query a+      wrapWithExpire query' =+        Internal.keysTouchedByQuery query'+          |> Set.toList+          |> List.map (\key -> Internal.Expire key secs)+          |> Internal.sequence+          |> Internal.map2 (\res _ -> res) query'+   in handler'+        { Internal.doQuery = \query' ->+            wrapWithExpire query'+              |> Stack.withFrozenCallStack Internal.doQuery handler',+          Internal.doTransaction = \query' ->+            wrapWithExpire query'+              |> Stack.withFrozenCallStack Internal.doTransaction handler'+        }++acquireHandler :: Text -> Settings.Settings -> IO (Internal.Handler, Connection)+acquireHandler namespace settings = do+  connection <- do+    let connectionInfo = Settings.connectionInfo settings+    connectionHedis <-+      case Settings.clusterMode settings of+        Settings.Cluster ->+          Database.Redis.connectCluster connectionInfo+        Settings.NotCluster ->+          Database.Redis.checkedConnect connectionInfo+    let connectionHost = Text.fromList (Database.Redis.connectHost connectionInfo)+    let connectionPort =+          case Database.Redis.connectPort connectionInfo of+            Database.Redis.PortNumber port -> Just (Prelude.fromIntegral port)+            Database.Redis.UnixSocket _ -> Nothing+    pure Connection {connectionHedis, connectionHost, connectionPort}+  anything <- Platform.doAnythingHandler+  pure+    ( Internal.Handler+        { Internal.doQuery = \query ->+            let PreparedQuery {redisCtx} = doRawQuery query+             in Stack.withFrozenCallStack platformRedis (Internal.cmds query) connection anything redisCtx,+          Internal.doTransaction = \query ->+            let PreparedQuery {redisCtx} = doRawQuery query+                redisCmd = Database.Redis.multiExec redisCtx+             in redisCmd+                  |> map+                    ( \txResult ->+                        case txResult of+                          Database.Redis.TxSuccess y -> Right y+                          Database.Redis.TxAborted -> Right (Err Internal.TransactionAborted)+                          Database.Redis.TxError err -> Right (Err (Internal.RedisError (Text.fromList err)))+                    )+                  |> Stack.withFrozenCallStack platformRedis (Internal.cmds query) connection anything,+          Internal.namespace = namespace+        },+      connection+    )++newtype PreparedQuery m f result = PreparedQuery+  { redisCtx :: m (f result)+  }+  deriving (Prelude.Functor)++instance (Prelude.Applicative m, Prelude.Applicative f) => Prelude.Applicative (PreparedQuery m f) where+  pure x =+    PreparedQuery+      { redisCtx = pure (pure x)+      }+  f <*> x =+    PreparedQuery+      { redisCtx = map2 (map2 (<|)) (redisCtx f) (redisCtx x)+      }++-- Construct a query in the underlying `hedis` library we depend on. It has a+-- polymorphic type signature that allows the returning query to be passed to+-- `Database.Redis.run` for direct execution, or `Database.Redis.multiExec` for+-- executation as part of a transaction.+doRawQuery :: (Prelude.Applicative f, Database.Redis.RedisCtx m f) => Internal.Query result -> PreparedQuery m f (Result Internal.Error result)+doRawQuery query =+  case query of+    Internal.Apply f x ->+      map2 (map2 (<|)) (doRawQuery f) (doRawQuery x)+    Internal.Del keys ->+      Database.Redis.del (NonEmpty.toList (map toB keys))+        |> PreparedQuery+        |> map (Ok << Prelude.fromIntegral)+    Internal.Exists key ->+      Database.Redis.exists (toB key)+        |> PreparedQuery+        |> map Ok+    Internal.Expire key secs ->+      Database.Redis.expire (toB key) (fromIntegral secs)+        |> PreparedQuery+        |> map (\_ -> Ok ())+    Internal.Get key ->+      Database.Redis.get (toB key)+        |> PreparedQuery+        |> map Ok+    Internal.Getset key val ->+      Database.Redis.getset (toB key) val+        |> PreparedQuery+        |> map Ok+    Internal.Hdel key fields ->+      Database.Redis.hdel (toB key) (NonEmpty.toList (map toB fields))+        |> PreparedQuery+        |> map (Ok << Prelude.fromIntegral)+    Internal.Hget key field ->+      Database.Redis.hget (toB key) (toB field)+        |> PreparedQuery+        |> map Ok+    Internal.Hgetall key ->+      Database.Redis.hgetall (toB key)+        |> PreparedQuery+        |> map+          ( \results ->+              results+                |> Prelude.traverse+                  ( \(byteKey, v) ->+                      case Data.Text.Encoding.decodeUtf8' byteKey of+                        Prelude.Right textKey -> Ok (textKey, v)+                        Prelude.Left _ -> Err (Internal.LibraryError "key exists but not parsable text")+                  )+          )+    Internal.Hkeys key ->+      Database.Redis.hkeys (toB key)+        |> PreparedQuery+        |> map+          ( Prelude.traverse+              ( \byteKey -> case Data.Text.Encoding.decodeUtf8' byteKey of+                  Prelude.Right textKey -> Ok textKey+                  Prelude.Left _ -> Err (Internal.LibraryError "key exists but not parsable text")+              )+          )+    Internal.Hsetnx key field val ->+      Database.Redis.hsetnx (toB key) (toB field) val+        |> PreparedQuery+        |> map Ok+    Internal.Hmget key fields ->+      Database.Redis.hmget (toB key) (NonEmpty.toList (map toB fields))+        |> PreparedQuery+        |> map Ok+    Internal.Hmset key vals ->+      Database.Redis.hmset (toB key) (map (\(field, val) -> (toB field, val)) (NonEmpty.toList vals))+        |> PreparedQuery+        |> map (\_ -> Ok ())+    Internal.Hset key field val ->+      Database.Redis.hset (toB key) (toB field) val+        |> PreparedQuery+        |> map (\_ -> Ok ())+    Internal.Incr key ->+      Database.Redis.incr (toB key)+        |> PreparedQuery+        |> map (Ok << fromIntegral)+    Internal.Incrby key amount ->+      Database.Redis.incrby (toB key) (fromIntegral amount)+        |> PreparedQuery+        |> map (Ok << fromIntegral)+    Internal.Lrange key lower upper ->+      Database.Redis.lrange (toB key) (fromIntegral lower) (fromIntegral upper)+        |> PreparedQuery+        |> map Ok+    Internal.Mget keys ->+      Database.Redis.mget (NonEmpty.toList (map toB keys))+        |> PreparedQuery+        |> map Ok+    Internal.Mset vals ->+      Database.Redis.mset (NonEmpty.toList (NonEmpty.map (\(key, val) -> (toB key, val)) vals))+        |> PreparedQuery+        |> map (\_ -> Ok ())+    Internal.Ping ->+      Database.Redis.ping+        |> PreparedQuery+        |> map Ok+    Internal.Pure x ->+      pure (Ok x)+    Internal.Rpush key vals ->+      Database.Redis.rpush (toB key) (NonEmpty.toList vals)+        |> PreparedQuery+        |> map (Ok << fromIntegral)+    Internal.Set key val ->+      Database.Redis.set (toB key) val+        |> PreparedQuery+        |> map (\_ -> Ok ())+    Internal.Setex key seconds val ->+      Database.Redis.setex (toB key) (Prelude.fromIntegral seconds) val+        |> PreparedQuery+        |> map (\_ -> Ok ())+    Internal.Setnx key val ->+      Database.Redis.setnx (toB key) val+        |> PreparedQuery+        |> map Ok+    Internal.Sadd key vals ->+      Database.Redis.sadd (toB key) (NonEmpty.toList vals)+        |> PreparedQuery+        |> map (Ok << Prelude.fromIntegral)+    Internal.Scard key ->+      Database.Redis.scard (toB key)+        |> PreparedQuery+        |> map (Ok << Prelude.fromIntegral)+    Internal.Srem key vals ->+      Database.Redis.srem (toB key) (NonEmpty.toList vals)+        |> PreparedQuery+        |> map (Ok << Prelude.fromIntegral)+    Internal.Smembers key ->+      Database.Redis.smembers (toB key)+        |> PreparedQuery+        |> map Ok+    Internal.WithResult f q ->+      let PreparedQuery redisCtx = doRawQuery q+       in PreparedQuery+            ( (map << map)+                ( \result -> case result of+                    Err a -> Err a+                    Ok res -> f res+                )+                redisCtx+            )++releaseHandler :: (Internal.Handler, Connection) -> IO ()+releaseHandler (_, Connection {connectionHedis}) = Database.Redis.disconnect connectionHedis++data Connection = Connection+  { connectionHedis :: Database.Redis.Connection,+    connectionHost :: Text,+    connectionPort :: Maybe Int+  }++platformRedis ::+  Stack.HasCallStack =>+  [Text] ->+  Connection ->+  Platform.DoAnythingHandler ->+  Database.Redis.Redis (Either Database.Redis.Reply (Result Internal.Error a)) ->+  Task Internal.Error a+platformRedis cmds connection anything action =+  Database.Redis.runRedis (connectionHedis connection) action+    |> map toResult+    |> map+      ( \result ->+          case result of+            Ok a -> a+            Err err -> Err err+      )+    |> Exception.handle (\(_ :: Database.Redis.ConnectionLostException) -> pure <| Err Internal.ConnectionLost)+    |> Exception.handleAny+      ( \err ->+          Exception.displayException err+            |> Text.fromList+            |> Internal.LibraryError+            |> Err+            |> pure+      )+    |> Platform.doAnything anything+    |> Stack.withFrozenCallStack Internal.traceQuery cmds (connectionHost connection) (connectionPort connection)++toResult :: Either Database.Redis.Reply a -> Result Internal.Error a+toResult reply =+  case reply of+    Left (Database.Redis.Error err) -> Err (Internal.RedisError <| Data.Text.Encoding.decodeUtf8 err)+    Left err -> Err (Internal.RedisError ("Redis library got back a value with a type it didn't expect: " ++ Text.fromList (Prelude.show err)))+    Right r -> Ok r++toB :: Text -> Data.ByteString.ByteString+toB = Data.Text.Encoding.encodeUtf8

@@ -0,0 +1,128 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A simple Redis library providing high level access to Redis features we+-- use here at NoRedInk+--+-- As with our Ruby Redis access, we enforce working within a "namespace".+module Redis.Set+  ( -- * Creating a redis handler+    Real.handler,+    Internal.Handler,+    Settings.Settings (..),+    Settings.decoder,++    -- * Creating a redis API+    jsonApi,+    textApi,+    byteStringApi,+    Api,++    -- * Creating redis queries+    del,+    exists,+    expire,+    ping,+    sadd,+    scard,+    srem,+    smembers,++    -- * Running Redis queries+    Internal.query,+    Internal.transaction,+    Internal.Query,+    Internal.Error (..),+    Internal.map,+    Internal.map2,+    Internal.map3,+    Internal.sequence,+  )+where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Redis.Codec as Codec+import qualified Redis.Internal as Internal+import qualified Redis.Real as Real+import qualified Redis.Settings as Settings+import qualified Set+import qualified Prelude++data Api key a = Api+  { -- | Removes the specified keys. A key is ignored if it does not exist.+    --+    -- https://redis.io/commands/del+    del :: NonEmpty key -> Internal.Query Int,+    -- | Returns if key exists.+    --+    -- https://redis.io/commands/exists+    exists :: key -> Internal.Query Bool,+    -- | Set a timeout on key. After the timeout has expired, the key will+    -- automatically be deleted. A key with an associated timeout is often said to+    -- be volatile in Redis terminology.+    --+    -- https://redis.io/commands/expire+    expire :: key -> Int -> Internal.Query (),+    -- | Returns PONG if no argument is provided, otherwise return a copy of the+    -- argument as a bulk. This command is often used to test if a connection is+    -- still alive, or to measure latency.+    --+    -- https://redis.io/commands/ping+    ping :: Internal.Query (),+    -- | Add the specified members to the set stored at key. Specified members+    -- that are already a member of this set are ignored. If key does not+    -- exist, a new set is created before adding the specified members.+    --+    -- https://redis.io/commands/sadd+    sadd :: key -> NonEmpty a -> Internal.Query Int,+    -- | Returns the set cardinality (number of elements) of the set stored at+    -- key.+    --+    -- https://redis.io/commands/scard+    scard :: key -> Internal.Query Int,+    -- | remove the specified members from the set stored at key. specified+    -- members that are not a member of this set are ignored. if key does not+    -- exist, it is treated as an empty set and this command returns 0.+    --+    -- https://redis.io/commands/srem+    srem :: key -> NonEmpty a -> Internal.Query Int,+    -- | Returns all the members of the set value stored at key.+    --+    -- https://redis.io/commands/smembers+    smembers :: key -> Internal.Query (Set.Set a)+  }++jsonApi :: (Aeson.ToJSON a, Aeson.FromJSON a, Ord a) => (key -> Text) -> Api key a+jsonApi = makeApi Codec.jsonCodec++textApi :: (key -> Text) -> Api key Text+textApi = makeApi Codec.textCodec++byteStringApi :: (key -> Text) -> Api key ByteString.ByteString+byteStringApi = makeApi Codec.byteStringCodec++makeApi ::+  Ord a =>+  Codec.Codec a ->+  (key -> Text) ->+  Api key a+makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey =+  Api+    { del = Internal.Del << NonEmpty.map toKey,+      exists = Internal.Exists << toKey,+      expire = \key secs -> Internal.Expire (toKey key) secs,+      ping = Internal.Ping |> map (\_ -> ()),+      sadd = \key vals ->+        Internal.Sadd (toKey key) (NonEmpty.map codecEncoder vals),+      scard = \key ->+        Internal.Scard (toKey key),+      srem = \key vals ->+        Internal.Srem (toKey key) (NonEmpty.map codecEncoder vals),+      smembers = \key ->+        Internal.Smembers (toKey key)+          |> Internal.WithResult (Prelude.traverse codecDecoder)+          |> Internal.map Set.fromList+    }

@@ -0,0 +1,121 @@+module Redis.Settings (Settings (..), ClusterMode (..), DefaultExpiry (..), QueryTimeout (..), decoder, decoderWithEnvVarPrefix) where++import Database.Redis hiding (Ok)+import qualified Environment+import qualified Text+import Prelude (Either (Left, Right))++data ClusterMode = Cluster | NotCluster++-- | Settings required to initiate a redis connection.+data Settings = Settings+  { -- | Full redis connection string.+    --+    -- Default env var name is REDIS_CONNECTION_STRING+    -- default is "redis://localhost:6379"+    connectionInfo :: ConnectInfo,+    -- | Set to 1 for cluster, everything else is not.+    --+    -- Default env var name is REDIS_CLUSTER+    -- Default is 0+    clusterMode :: ClusterMode,+    -- | Set a default amount of seconds after which all keys touched by this+    -- handler will expire. The expire time of a key is reset every time it is+    -- read or written. A value of 0 means no default expiry.+    --+    -- Default env var name is REDIS_DEFAULT_EXPIRY_SECONDS+    -- default is 0+    defaultExpiry :: DefaultExpiry,+    -- | 0 means no timeout, every other value is a timeout in milliseconds.+    --+    -- Default env var name is REDIS_QUERY_TIMEOUT_MILLISECONDS+    -- default is 1000+    queryTimeout :: QueryTimeout+  }++data DefaultExpiry = NoDefaultExpiry | ExpireKeysAfterSeconds Int++data QueryTimeout = NoQueryTimeout | TimeoutQueryAfterMilliseconds Int++-- decodes Settings from environmental variables+decoder :: Environment.Decoder Settings+decoder =+  decoderWithEnvVarPrefix ""++-- decodes Settings from environmental variables prefixed with a Text+-- >>> decoderWithEnvVarPrefix "WORKER_"+decoderWithEnvVarPrefix :: Text -> Environment.Decoder Settings+decoderWithEnvVarPrefix prefix =+  map4+    Settings+    (decoderConnectInfo prefix)+    (decoderClusterMode prefix)+    (decoderDefaultExpiry prefix)+    (decoderQueryTimeout prefix)++decoderClusterMode :: Text -> Environment.Decoder ClusterMode+decoderClusterMode prefix =+  Environment.variable+    Environment.Variable+      { Environment.name = prefix ++ "REDIS_CLUSTER",+        Environment.description = "Set to 1 for cluster, everything else is not",+        Environment.defaultValue = "0"+      }+    ( Environment.custom+        Environment.text+        ( \str ->+            if Text.trim str == "1"+              then Ok Cluster+              else Ok NotCluster+        )+    )++decoderConnectInfo :: Text -> Environment.Decoder ConnectInfo+decoderConnectInfo prefix =+  Environment.variable+    Environment.Variable+      { Environment.name = prefix ++ "REDIS_CONNECTION_STRING",+        Environment.description = "Full redis connection string",+        Environment.defaultValue = "redis://localhost:6379"+      }+    ( Environment.custom+        Environment.text+        ( \str ->+            case str |> Text.toList |> parseConnectInfo of+              Right info' -> Ok info'+              Left parseError -> Err ("Invalid Redis connection string: " ++ Text.fromList parseError)+        )+    )++decoderDefaultExpiry :: Text -> Environment.Decoder DefaultExpiry+decoderDefaultExpiry prefix =+  Environment.variable+    Environment.Variable+      { Environment.name = prefix ++ "REDIS_DEFAULT_EXPIRY_SECONDS",+        Environment.description = "Set a default amount of seconds after which all keys touched by this handler will expire. The expire time of a key is reset every time it is read or written. A value of 0 means no default expiry.",+        Environment.defaultValue = "0"+      }+    Environment.int+    |> map+      ( \secs ->+          if secs == 0+            then NoDefaultExpiry+            else ExpireKeysAfterSeconds secs+      )++decoderQueryTimeout :: Text -> Environment.Decoder QueryTimeout+decoderQueryTimeout prefix =+  Environment.variable+    Environment.Variable+      { Environment.name = prefix ++ "REDIS_QUERY_TIMEOUT_MILLISECONDS",+        Environment.description = "0 means no timeout, every other value is a timeout in milliseconds.",+        Environment.defaultValue = "1000"+      }+    ( Environment.custom+        Environment.int+        ( \milliseconds ->+            if milliseconds <= 0+              then Ok NoQueryTimeout+              else Ok (TimeoutQueryAfterMilliseconds milliseconds)+        )+    )

@@ -0,0 +1,313 @@+module Main (main) where++import qualified Conduit+import qualified Control.Concurrent.MVar as MVar+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Dict+import qualified Environment+import qualified Expect+import qualified NonEmptyDict+import qualified Platform+import qualified Redis+import qualified Redis.Counter+import qualified Redis.Hash+import qualified Redis.Internal as Internal+import qualified Redis.List+import qualified Redis.Mock as Mock+import qualified Redis.Real as Real+import qualified Redis.Settings as Settings+import qualified Task+import qualified Test+import qualified Prelude++main :: Prelude.IO ()+main = Conduit.withAcquire getHandlers (Test.run << tests)++-- put this at the top of the file so that adding tests doesn't push+-- the line number of the source location of this file down, which would+-- change golden test results+spanForTask :: Show e => Task e () -> Expect.Expectation' Platform.TracingSpan+spanForTask task =+  Expect.fromIO <| do+    spanVar <- MVar.newEmptyMVar+    res <-+      Platform.rootTracingSpanIO+        "test-request"+        (MVar.putMVar spanVar)+        "test-root"+        (\log -> Task.attempt log task)+    case res of+      Err err -> Prelude.fail <| Text.toList (Debug.toString err)+      Ok _ ->+        MVar.takeMVar spanVar+          |> map constantValuesForVariableFields++tests :: TestHandlers -> Test.Test+tests TestHandlers {realHandler, mockHandler} =+  Test.describe+    "Redis Library"+    [ Test.describe "query tests using mock handler" (queryTests mockHandler),+      Test.describe "query tests using real handler" (queryTests realHandler),+      Test.describe "observability tests" (observabilityTests realHandler)+    ]++-- We want to test all of our potential makeApi alternatives because it's easy+-- to break. Right now they all share code but if we change that, we would+-- break the observability usability without noticing.+--+-- All the `srcLocFile` fields in the golden result files should contain the+-- value "test/Main.hs". If it points to one of the src files of the redis+-- library it means stack frames for redis query in bugsnag, newrelic, etc will+-- not point to the application code making the query!+observabilityTests :: Redis.Handler -> List Test.Test+observabilityTests handler =+  [ Test.test "Redis.query reports the span data we expect" <| \() -> do+      span <-+        Redis.query handler (Redis.ping api)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-query",+    Test.test "Redis.transaction reports the span data we expect" <| \() -> do+      span <-+        Redis.transaction handler (Redis.ping api)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-transaction",+    Test.test "Redis.Hash.query reports the span data we expect" <| \() -> do+      span <-+        Redis.Hash.query handler (Redis.Hash.ping hashApi)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-hash-query",+    Test.test "Redis.Hash.transaction reports the span data we expect" <| \() -> do+      span <-+        Redis.Hash.transaction handler (Redis.Hash.ping hashApi)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-hash-transaction",+    Test.test "Redis.List.query reports the span data we expect" <| \() -> do+      span <-+        Redis.List.query handler (Redis.List.ping listApi)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-list-query",+    Test.test "Redis.List.transaction reports the span data we expect" <| \() -> do+      span <-+        Redis.List.transaction handler (Redis.List.ping listApi)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-list-transaction",+    Test.test "Redis.Counter.query reports the span data we expect" <| \() -> do+      span <-+        Redis.Counter.query handler (Redis.Counter.ping counterApi)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-counter-query",+    Test.test "Redis.Counter.transaction reports the span data we expect" <| \() -> do+      span <-+        Redis.Counter.transaction handler (Redis.Counter.ping counterApi)+          |> spanForTask+      span+        |> Debug.toString+        |> Expect.equalToContentsOf "test/golden-results/observability-spec-reporting-redis-counter-transaction"+  ]++queryTests :: Redis.Handler -> List Test.Test+queryTests redisHandler =+  [ Test.test "get and set" <| \() -> do+      Redis.set api "bob" "hello!" |> Redis.query testNS |> Expect.succeeds+      result <- Redis.get api "bob" |> Redis.query testNS |> Expect.succeeds+      Expect.equal result (Just "hello!"),+    Test.test "namespaces namespace" <| \() -> do+      let nsHandler1 = addNamespace "NS1" redisHandler+      let nsHandler2 = addNamespace "NS2" redisHandler+      Redis.set api "bob" "hello!" |> Redis.query nsHandler1 |> Expect.succeeds+      Redis.set api "bob" "goodbye" |> Redis.query nsHandler2 |> Expect.succeeds+      result1 <- Redis.get api "bob" |> Redis.query nsHandler1 |> Expect.succeeds+      result2 <- Redis.get api "bob" |> Redis.query nsHandler2 |> Expect.succeeds+      Expect.all+        [ \() -> Expect.notEqual result1 result2,+          \() -> Expect.equal (Just "hello!") result1,+          \() -> Expect.equal (Just "goodbye") result2+        ]+        (),+    Test.test "getset" <| \() -> do+      Redis.set api "getset" "1" |> Redis.query testNS |> Expect.succeeds+      result1 <- Redis.getset api "getset" "2" |> Redis.query testNS |> Expect.succeeds+      result2 <- Redis.get api "getset" |> Redis.query testNS |> Expect.succeeds+      Expect.all+        [ \() -> Expect.equal (Just "1") result1,+          \() -> Expect.equal (Just "2") result2+        ]+        (),+    Test.test "del dels" <| \() -> do+      Redis.set api "del" "mistake..." |> Redis.query testNS |> Expect.succeeds+      _ <- Redis.del api ("del" :| []) |> Redis.query testNS |> Expect.succeeds+      result <- Redis.get api "del" |> Redis.query testNS |> Expect.succeeds+      Expect.equal Nothing result,+    Test.test "del counts" <| \() -> do+      Redis.set api "delCount" "A thing" |> Redis.query testNS |> Expect.succeeds+      result <- Redis.del api ("delCount" :| ["key that doesn't exist"]) |> Redis.query testNS |> Expect.succeeds+      Expect.equal 1 result,+    Test.test "json roundtrip" <| \() -> do+      let testData :: [Int] = [1, 2, 3]+      Redis.set jsonApi' "JSON list" testData |> Redis.query testNS |> Expect.succeeds+      result <- Redis.get jsonApi' "JSON list" |> Redis.query testNS |> Expect.succeeds+      Expect.equal (Just testData) result,+    Test.test "mget retrieves a mapping of the requested keys and their corresponding values" <| \() -> do+      Redis.set api "mgetTest::key1" "value 1" |> Redis.query testNS |> Expect.succeeds+      Redis.set api "mgetTest::key3" "value 3" |> Redis.query testNS |> Expect.succeeds+      result <-+        Redis.mget api ("mgetTest::key1" :| ["mgetTest::key2", "mgetTest::key3"]) |> Redis.query testNS+          |> Expect.succeeds+      Expect.equal+        (Dict.toList result)+        [("mgetTest::key1", "value 1"), ("mgetTest::key3", "value 3")],+    Test.test "mget json roundtrip" <| \() -> do+      Redis.set jsonApi' "Json.mgetTest::key1" ([1, 2] :: [Int]) |> Redis.query testNS |> Expect.succeeds+      Redis.set jsonApi' "Json.mgetTest::key2" ([3, 4] :: [Int]) |> Redis.query testNS |> Expect.succeeds+      result <-+        Redis.mget jsonApi' ("Json.mgetTest::key1" :| ["Json.mgetTest::key2"])+          |> Redis.query testNS+          |> Expect.succeeds+      Expect.equal+        (Dict.toList result)+        [ ("Json.mgetTest::key1", [1, 2]),+          ("Json.mgetTest::key2", [3, 4])+        ],+    Test.test "mset allows setting multiple values at once" <| \() -> do+      let firstKey = "msetTest::key1"+      let firstValue = "value 1"+      let nonEmptyDict = NonEmptyDict.init firstKey firstValue (Dict.fromList [("msetTest::key2", "value 2")])+      let dict = NonEmptyDict.toDict nonEmptyDict+      Redis.mset api nonEmptyDict |> Redis.query testNS |> Expect.succeeds+      result <- Redis.mget api (firstKey :| Dict.keys dict) |> Redis.query testNS |> Expect.succeeds+      Expect.equal result dict,+    Test.test "Json.mset allows setting multiple JSON values at once" <| \() -> do+      let firstKey = "Json.msetTest::key1"+      let firstValue = [1, 2]+      let nonEmptyDict = NonEmptyDict.init firstKey firstValue (Dict.fromList [("Json.msetTest::key2", [3, 4] :: [Int])])+      let dict = NonEmptyDict.toDict nonEmptyDict+      Redis.mset jsonApi' nonEmptyDict |> Redis.query testNS |> Expect.succeeds+      result <- Redis.mget jsonApi' (firstKey :| Dict.keys dict) |> Redis.query testNS |> Expect.succeeds+      Expect.equal result dict,+    Test.test "transaction preserves order" <| \() -> do+      [ Redis.List.del listApi ("order" :| []),+        Redis.List.rpush listApi "order" ("1" :| []),+        Redis.List.rpush listApi "order" ("2" :| []),+        Redis.List.rpush listApi "order" ("3" :| [])+        ]+        |> Redis.sequence+        |> map (\_ -> ())+        |> Redis.transaction testNS+        |> Expect.succeeds+      result <- Redis.List.lrange listApi "order" 0 (-1) |> Redis.query testNS |> Expect.succeeds+      Expect.equal result ["1", "2", "3"],+    Test.test "sequence is happy doing nothing" <| \() -> do+      _ <-+        Redis.sequence []+          |> Redis.transaction testNS+          |> Expect.succeeds+      Redis.sequence []+        |> Redis.query testNS+        |> Expect.succeeds+        |> map (\_ -> ()),+    Test.test "hmset inserts at least one field" <| \() -> do+      Redis.Hash.hmset hashApi "hmset-insert-test" (NonEmptyDict.init "field" "val" Dict.empty)+        |> Redis.query redisHandler+        |> Expect.succeeds+      response <-+        Redis.Hash.hget hashApi "hmset-insert-test" "field"+          |> Redis.query redisHandler+          |> Expect.succeeds+      response+        |> Expect.equal (Just "val"),+    Test.test "hmset overwrites at least existing field" <| \() -> do+      Redis.Hash.hset hashApi "hmset-overwrite-test" "field" "old-val"+        |> Redis.query redisHandler+        |> Expect.succeeds+      Redis.Hash.hmset hashApi "hmset-overwrite-test" (NonEmptyDict.init "field" "val" Dict.empty)+        |> Redis.query redisHandler+        |> Expect.succeeds+      response <-+        Redis.Hash.hget hashApi "hmset-overwrite-test" "field"+          |> Redis.query redisHandler+          |> Expect.succeeds+      response+        |> Expect.equal (Just "val"),+    Test.test "hmset inserts multiple fields" <| \() -> do+      NonEmptyDict.init+        "field"+        "val"+        (Dict.fromList [("field2", "val2")])+        |> Redis.Hash.hmset hashApi "hmset-insert-multiple-test"+        |> Redis.query redisHandler+        |> Expect.succeeds+      field <-+        Redis.Hash.hget hashApi "hmset-insert-multiple-test" "field"+          |> Redis.query redisHandler+          |> Expect.succeeds+      field+        |> Expect.equal (Just "val")+      field2 <-+        Redis.Hash.hget hashApi "hmset-insert-multiple-test" "field2"+          |> Redis.query redisHandler+          |> Expect.succeeds+      field2+        |> Expect.equal (Just "val2")+  ]+  where+    testNS = addNamespace "testNamespace" redisHandler++data TestHandlers = TestHandlers+  { mockHandler :: Redis.Handler,+    realHandler :: Redis.Handler+  }++getHandlers :: Conduit.Acquire TestHandlers+getHandlers = do+  settings <- Conduit.liftIO (Environment.decode Settings.decoder)+  let realHandler = Real.handler "tests" settings {Settings.defaultExpiry = Settings.ExpireKeysAfterSeconds 1}+  mockHandler <- Conduit.liftIO <| Mock.handlerIO+  NriPrelude.map (TestHandlers mockHandler) realHandler++addNamespace :: Text -> Redis.Handler -> Redis.Handler+addNamespace namespace handler' =+  handler' {Internal.namespace = Internal.namespace handler' ++ ":" ++ namespace}++api :: Redis.Api Text Text+api = Redis.textApi identity++hashApi :: Redis.Hash.Api Text Text Text+hashApi = Redis.Hash.textApi identity identity Just++listApi :: Redis.List.Api Text Text+listApi = Redis.List.textApi identity++counterApi :: Redis.Counter.Api Text+counterApi = Redis.Counter.makeApi identity++jsonApi' :: Redis.Api Text [Int]+jsonApi' = Redis.jsonApi identity++-- | Timestamps recorded in spans would make each test result different from the+-- last. This helper sets all timestamps to zero to prevent this.+--+-- Similarly the db URI changes in each test, because we create temporary test+-- database. To prevent this from failing tests we set the URI to a standard+-- value.+constantValuesForVariableFields :: Platform.TracingSpan -> Platform.TracingSpan+constantValuesForVariableFields span =+  span+    { Platform.started = 0,+      Platform.finished = 0,+      Platform.allocated = 0,+      Platform.children = map constantValuesForVariableFields (Platform.children span)+    }