diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Unreleased next version +# 0.1.0.1 + +- Support GHC 9.0.1. + # 0.1.0.0 - First release, but we've battle-tested it against significant load for months now! diff --git a/nri-redis.cabal b/nri-redis.cabal --- a/nri-redis.cabal +++ b/nri-redis.cabal @@ -1,13 +1,13 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack name: nri-redis -version: 0.1.0.0 +version: 0.1.0.1 synopsis: An intuitive hedis wrapper library. -description: Please see the README at . +description: Please see the README at . category: Web homepage: https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis#readme bug-reports: https://github.com/NoRedInk/haskell-libraries/issues @@ -44,7 +44,22 @@ Paths_nri_redis hs-source-dirs: src - default-extensions: DataKinds DeriveGeneric ExtendedDefaultRules FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude NumericUnderscores OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators + 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 @@ -82,8 +97,23 @@ 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 + 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 -threaded -rtsopts "-with-rtsopts=-N -T" -fno-warn-type-defaults build-depends: aeson >=1.4.6.0 && <1.6 , async >=2.2.2 && <2.3 diff --git a/src/NonEmptyDict.hs b/src/NonEmptyDict.hs --- a/src/NonEmptyDict.hs +++ b/src/NonEmptyDict.hs @@ -13,6 +13,8 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import Dict +-- | A Dict with at least one entry. For use in writing to redis, where it's an +-- error when writing nothing data NonEmptyDict k v = NonEmptyDict (k, v) (Dict.Dict k v) deriving (Show) @@ -34,6 +36,7 @@ toNonEmptyList (NonEmptyDict kv dict) = kv :| Dict.toList dict +-- | creates a `Dict` from a key, value, and dict init :: Ord k => k -> v -> Dict.Dict k v -> NonEmptyDict k v init key val dict = NonEmptyDict (key, val) (Dict.remove key dict) diff --git a/src/Redis.hs b/src/Redis.hs --- a/src/Redis.hs +++ b/src/Redis.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- | A simple Redis library providing high level access to Redis features we -- use here at NoRedInk @@ -123,7 +124,7 @@ -- -- 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 + -- | 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". -- @@ -132,15 +133,18 @@ } -- | 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 +-- > 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 :: + forall a key. + (Aeson.ToJSON a, Aeson.FromJSON a) => + (key -> Text) -> + Api key a +jsonApi toKey = makeApi Codec.jsonCodec toKey -- | Creates a Redis API mapping a 'key' to Text textApi :: (key -> Text) -> Api key Text diff --git a/src/Redis/Counter.hs b/src/Redis/Counter.hs --- a/src/Redis/Counter.hs +++ b/src/Redis/Counter.hs @@ -46,6 +46,8 @@ import qualified Redis.Settings as Settings import qualified Prelude +-- | a API type can be used to help enforce a consistent key usage. +-- Without an API type, it can be easy to naiively change key serialization. data Api key = Api { -- | Removes the specified keys. A key is ignored if it does not exist. -- @@ -97,6 +99,10 @@ set :: key -> Int -> Internal.Query () } +-- | Creates a Redis API to help enforce consistent key serialization +-- +-- > myJsonApi :: Redis.Counter.Api Key +-- > myJsonApi = Redis.counter.makeApi (\Key {fieldA, fieldB}-> Text.join "-" [fieldA, fieldB, "v1"]) makeApi :: (key -> Text) -> Api key diff --git a/src/Redis/Hash.hs b/src/Redis/Hash.hs --- a/src/Redis/Hash.hs +++ b/src/Redis/Hash.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- | A simple Redis library providing high level access to Redis features we -- use here at NoRedInk @@ -58,6 +59,14 @@ import qualified Result 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 field a = Api { -- | Removes the specified keys. A key is ignored if it does not exist. -- @@ -124,7 +133,15 @@ hsetnx :: key -> field -> 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, jsonApi :: + forall a field key. (Aeson.ToJSON a, Aeson.FromJSON a, Ord field) => (key -> Text) -> (field -> Text) -> @@ -132,6 +149,7 @@ Api key field a jsonApi = makeApi Codec.jsonCodec +-- | Creates a Redis API mapping a 'key' to Text textApi :: Ord field => (key -> Text) -> @@ -140,6 +158,7 @@ Api key field Text textApi = makeApi Codec.textCodec +-- | Creates a Redis API mapping a 'key' to a ByteString byteStringApi :: Ord field => (key -> Text) -> diff --git a/src/Redis/Internal.hs b/src/Redis/Internal.hs --- a/src/Redis/Internal.hs +++ b/src/Redis/Internal.hs @@ -30,6 +30,7 @@ import qualified Log.RedisCommands as RedisCommands import NriPrelude hiding (map, map2, map3) import qualified Platform +import qualified Redis.Settings as Settings import qualified Set import qualified Text import qualified Tuple @@ -44,6 +45,7 @@ | LibraryError Text | TransactionAborted | TimeoutError + | KeyExceedsMaxSize Text Int instance Aeson.ToJSON Error where toJSON err = Aeson.toJSON (errorForHumans err) @@ -61,6 +63,7 @@ DecodingFieldError err -> "Could not decode field of hash: " ++ err TransactionAborted -> "Transaction aborted." TimeoutError -> "Redis query took too long." + KeyExceedsMaxSize key maxKeySize -> "Redis key (" ++ key ++ ") exceeded max size (" ++ Text.fromInt maxKeySize ++ ")." -- | Render the commands a query is going to run for monitoring and debugging -- purposes. Values we write are replaced with "*****" because they might @@ -141,6 +144,9 @@ instance Prelude.Functor Query where fmap = map +instance Prelude.Show (Query a) where + show = Text.toList << Text.join "<|" << cmds + -- | Used to map the type of a query to another type -- useful in combination with 'transaction' map :: (a -> b) -> Query a -> Query b @@ -180,7 +186,8 @@ 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 + namespace :: Text, + maxKeySize :: Settings.MaxKeySize } -- | Run a 'Query'. @@ -190,7 +197,8 @@ query :: Stack.HasCallStack => Handler -> Query a -> Task Error a query handler query' = namespaceQuery (namespace handler ++ ":") query' - |> Stack.withFrozenCallStack doQuery handler + |> Task.andThen (ensureMaxKeySize handler) + |> Task.andThen (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 @@ -201,41 +209,58 @@ transaction :: Stack.HasCallStack => Handler -> Query a -> Task Error a transaction handler query' = namespaceQuery (namespace handler ++ ":") query' - |> Stack.withFrozenCallStack doTransaction handler + |> Task.andThen (ensureMaxKeySize handler) + |> Task.andThen (Stack.withFrozenCallStack (doTransaction handler)) -namespaceQuery :: Text -> Query a -> Query a -namespaceQuery prefix query' = +namespaceQuery :: Text -> Query a -> Task err (Query a) +namespaceQuery prefix query' = mapKeys (\key -> Task.succeed (prefix ++ key)) query' + +mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a) +mapKeys fn 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) + Exists key -> Task.map Exists (fn key) + Ping -> Task.succeed Ping + Get key -> Task.map Get (fn key) + Set key value -> Task.map (\newKey -> Set newKey value) (fn key) + Setex key seconds value -> Task.map (\newKey -> Setex newKey seconds value) (fn key) + Setnx key value -> Task.map (\newKey -> Setnx newKey value) (fn key) + Getset key value -> Task.map (\newKey -> Getset newKey value) (fn key) + Mget keys -> Task.map Mget (Prelude.traverse (\k -> fn k) keys) + Mset assocs -> Task.map Mset (Prelude.traverse (\(k, v) -> Task.map (\newKey -> (newKey, v)) (fn k)) assocs) + Del keys -> Task.map Del (Prelude.traverse (fn) keys) + Hgetall key -> Task.map Hgetall (fn key) + Hkeys key -> Task.map Hkeys (fn key) + Hmget key fields -> Task.map (\newKeys -> Hmget newKeys fields) (fn key) + Hget key field -> Task.map (\newKeys -> Hget newKeys field) (fn key) + Hset key field val -> Task.map (\newKeys -> Hset newKeys field val) (fn key) + Hsetnx key field val -> Task.map (\newKeys -> Hsetnx newKeys field val) (fn key) + Hmset key vals -> Task.map (\newKeys -> Hmset newKeys vals) (fn key) + Hdel key fields -> Task.map (\newKeys -> Hdel newKeys fields) (fn key) + Incr key -> Task.map Incr (fn key) + Incrby key amount -> Task.map (\newKeys -> Incrby newKeys amount) (fn key) + Expire key secs -> Task.map (\newKeys -> Expire newKeys secs) (fn key) + Lrange key lower upper -> Task.map (\newKeys -> Lrange newKeys lower upper) (fn key) + Rpush key vals -> Task.map (\newKeys -> Rpush newKeys vals) (fn key) + Sadd key vals -> Task.map (\newKeys -> Sadd newKeys vals) (fn key) + Scard key -> Task.map Scard (fn key) + Srem key vals -> Task.map (\newKeys -> Srem newKeys vals) (fn key) + Smembers key -> Task.map Smembers (fn key) + Pure x -> Task.succeed (Pure x) + Apply f x -> Task.map2 Apply (mapKeys fn f) (mapKeys fn x) + WithResult f q -> Task.map (WithResult f) (mapKeys fn q) + +ensureMaxKeySize :: Handler -> Query a -> Task Error (Query a) +ensureMaxKeySize handler query' = + case maxKeySize handler of + Settings.NoMaxKeySize -> Task.succeed query' + Settings.MaxKeySize maxKeySize -> + mapKeys (checkMaxKeySize maxKeySize) query' + +checkMaxKeySize :: Int -> Text -> Task Error Text +checkMaxKeySize maxKeySize key = + if Text.length key <= maxKeySize + then Task.succeed key + else Task.fail (KeyExceedsMaxSize key maxKeySize) keysTouchedByQuery :: Query a -> Set.Set Text keysTouchedByQuery query' = diff --git a/src/Redis/List.hs b/src/Redis/List.hs --- a/src/Redis/List.hs +++ b/src/Redis/List.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- | A simple Redis library providing high level access to Redis features we -- use here at NoRedInk @@ -48,6 +49,14 @@ 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. -- @@ -84,12 +93,25 @@ rpush :: key -> NonEmpty a -> Internal.Query Int } -jsonApi :: (Aeson.ToJSON a, Aeson.FromJSON a) => (key -> Text) -> Api key a +-- | 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, +jsonApi :: + forall a key. + (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 diff --git a/src/Redis/Mock.hs b/src/Redis/Mock.hs --- a/src/Redis/Mock.hs +++ b/src/Redis/Mock.hs @@ -19,6 +19,7 @@ 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) @@ -40,7 +41,8 @@ Internal.Handler { Internal.doQuery = doQuery' modelRef doAnything, Internal.doTransaction = doQuery' modelRef doAnything, - Internal.namespace = "tests" + Internal.namespace = "tests", + Internal.maxKeySize = Settings.NoMaxKeySize } |> Prelude.pure where diff --git a/src/Redis/Real.hs b/src/Redis/Real.hs --- a/src/Redis/Real.hs +++ b/src/Redis/Real.hs @@ -44,10 +44,10 @@ timeoutAfterMilliseconds milliseconds handler' = handler' { Internal.doQuery = - Stack.withFrozenCallStack Internal.doQuery handler' + Stack.withFrozenCallStack (Internal.doQuery handler') >> Task.timeout milliseconds Internal.TimeoutError, Internal.doTransaction = - Stack.withFrozenCallStack Internal.doTransaction handler' + Stack.withFrozenCallStack (Internal.doTransaction handler') >> Task.timeout milliseconds Internal.TimeoutError } @@ -63,10 +63,10 @@ in handler' { Internal.doQuery = \query' -> wrapWithExpire query' - |> Stack.withFrozenCallStack Internal.doQuery handler', + |> Stack.withFrozenCallStack (Internal.doQuery handler'), Internal.doTransaction = \query' -> wrapWithExpire query' - |> Stack.withFrozenCallStack Internal.doTransaction handler' + |> Stack.withFrozenCallStack (Internal.doTransaction handler') } acquireHandler :: Text -> Settings.Settings -> IO (Internal.Handler, Connection) @@ -102,8 +102,9 @@ 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 + |> Stack.withFrozenCallStack (platformRedis (Internal.cmds query) connection anything), + Internal.namespace = namespace, + Internal.maxKeySize = Settings.maxKeySize settings }, connection ) diff --git a/src/Redis/Set.hs b/src/Redis/Set.hs --- a/src/Redis/Set.hs +++ b/src/Redis/Set.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- | A simple Redis library providing high level access to Redis features we -- use here at NoRedInk @@ -51,6 +52,14 @@ import qualified Set 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. -- @@ -95,12 +104,25 @@ smembers :: key -> Internal.Query (Set.Set a) } -jsonApi :: (Aeson.ToJSON a, Aeson.FromJSON a, Ord a) => (key -> Text) -> Api key a +-- | 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, +jsonApi :: + forall a key. + (Aeson.ToJSON a, Aeson.FromJSON a, Ord 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 diff --git a/src/Redis/Settings.hs b/src/Redis/Settings.hs --- a/src/Redis/Settings.hs +++ b/src/Redis/Settings.hs @@ -1,4 +1,13 @@ -module Redis.Settings (Settings (..), ClusterMode (..), DefaultExpiry (..), QueryTimeout (..), decoder, decoderWithEnvVarPrefix) where +module Redis.Settings + ( Settings (..), + ClusterMode (..), + DefaultExpiry (..), + QueryTimeout (..), + MaxKeySize (..), + decoder, + decoderWithEnvVarPrefix, + ) +where import Database.Redis hiding (Ok) import qualified Environment @@ -30,28 +39,32 @@ -- -- Default env var name is REDIS_QUERY_TIMEOUT_MILLISECONDS -- default is 1000 - queryTimeout :: QueryTimeout + queryTimeout :: QueryTimeout, + maxKeySize :: MaxKeySize } +data MaxKeySize = NoMaxKeySize | MaxKeySize Int + data DefaultExpiry = NoDefaultExpiry | ExpireKeysAfterSeconds Int data QueryTimeout = NoQueryTimeout | TimeoutQueryAfterMilliseconds Int --- decodes Settings from environmental variables +-- | decodes Settings from environmental variables decoder :: Environment.Decoder Settings decoder = decoderWithEnvVarPrefix "" --- decodes Settings from environmental variables prefixed with a Text +-- | decodes Settings from environmental variables prefixed with a Text -- >>> decoderWithEnvVarPrefix "WORKER_" decoderWithEnvVarPrefix :: Text -> Environment.Decoder Settings decoderWithEnvVarPrefix prefix = - map4 + map5 Settings (decoderConnectInfo prefix) (decoderClusterMode prefix) (decoderDefaultExpiry prefix) (decoderQueryTimeout prefix) + (decoderMaxKeySize prefix) decoderClusterMode :: Text -> Environment.Decoder ClusterMode decoderClusterMode prefix = @@ -117,5 +130,22 @@ if milliseconds <= 0 then Ok NoQueryTimeout else Ok (TimeoutQueryAfterMilliseconds milliseconds) + ) + ) + +decoderMaxKeySize :: Text -> Environment.Decoder MaxKeySize +decoderMaxKeySize prefix = + Environment.variable + Environment.Variable + { Environment.name = prefix ++ "REDIS_MAX_KEY_SIZE", + Environment.description = "0 means no max key size, every other value is a max key size.", + Environment.defaultValue = "0" + } + ( Environment.custom + Environment.int + ( \maxKeySize -> + if maxKeySize <= 0 + then Ok NoMaxKeySize + else Ok (MaxKeySize maxKeySize) ) )