nri-redis 0.1.0.4 → 0.4.1.1
raw patch · 24 files changed
Files
- CHANGELOG.md +51/−0
- LICENSE +1/−1
- README.md +3/−0
- nri-redis.cabal +44/−24
- src/NonEmptyDict.hs +5/−5
- src/Redis.hs +29/−5
- src/Redis/Codec.hs +2/−2
- src/Redis/Counter.hs +4/−2
- src/Redis/Handler.hs +468/−0
- src/Redis/Hash.hs +8/−6
- src/Redis/Internal.hs +232/−29
- src/Redis/List.hs +4/−2
- src/Redis/Mock.hs +0/−404
- src/Redis/Real.hs +0/−317
- src/Redis/Script.hs +276/−0
- src/Redis/Set.hs +14/−5
- src/Redis/Settings.hs +76/−9
- src/Redis/SortedSet.hs +166/−0
- test/Helpers.hs +42/−0
- test/Main.hs +0/−313
- test/Spec.hs +18/−0
- test/Spec/Redis.hs +575/−0
- test/Spec/Redis/Script.hs +174/−0
- test/Spec/Settings.hs +248/−0
CHANGELOG.md view
@@ -1,3 +1,54 @@+# 0.4.1.1++- Require `nri-prelude >= 0.7.0.0`++# 0.4.1.0++- Add `handlerWithoutNamespace` for creating Redis handlers that skip+ namespace prefixing, for the cases where keys are shared with another+ system that doesn't follow the same namespacing convention.++# 0.4.0.0++- Support GHC 9.10.2, GHC 9.12.2, `megaparsec-9.7.x`, `containers-0.7.x`+- Drop support for GHC 9.4.x++# 0.3.0.0++- Drop support for GHC 9.2.x+- Support GHC 9.8.3, `bytestring-0.12.x.x`, `text-2.1.x`, `aeson-2.2.x.x`, `megaparsec-9.6.x`++# 0.2.0.3++- [bugfix] When a query times out, its context is no longer removed from the Stack+- query timeout setting can be modified at runtime++# 0.2.0.2++- Adds `sismember`++# 0.2.0.1++- Drop support for `aeson-1.x`+- Allow `resourcet-1.3.x`, `megaparsec-9.5.x`+- Support GHC 9.6.5++# 0.2.0.0++- Drop support for GHC 8.10.7++# 0.1.2.1++- Support GHC 9.4.7, `aeson-2.1.x`++# 0.1.2.0++- Remove `Redis.Mock` - best to test against a real Redis.++# 0.1.1.0++- Add Unix socket config support.+ # 0.1.0.4 - Relax version bounds to encompass `text-2.0.x`, `base-4.16.x` and `template-haskell-2.18.x`
LICENSE view
@@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2022, NoRedInk+Copyright (c) 2026, NoRedInk All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -26,6 +26,9 @@ ```sh REDIS_CONNECTION_STRING=redis://localhost:6379+# we also support unix sockets via a scheme we provide:+# REDIS_CONNECTION_STRING=redis+unix:///path/to/redis.sock[?db=DB_NUM]+ REDIS_CLUSTER=0 # 1 is on REDIS_DEFAULT_EXPIRY_SECONDS=0 # 0 is no expiration REDIS_QUERY_TIMEOUT_MILLISECONDS=1000 # 0 is no timeout
nri-redis.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.5.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: nri-redis-version: 0.1.0.4+version: 0.4.1.1 synopsis: An intuitive hedis wrapper library. description: Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis#readme>. category: Web@@ -13,7 +13,7 @@ bug-reports: https://github.com/NoRedInk/haskell-libraries/issues author: NoRedInk maintainer: haskell-open-source@noredink.com-copyright: 2022 NoRedInk Corp.+copyright: 2026 NoRedInk Corp. license: BSD3 license-file: LICENSE build-type: Simple@@ -34,12 +34,13 @@ Redis.Counter Redis.Hash Redis.List- Redis.Mock Redis.Set+ Redis.SortedSet other-modules: Redis.Codec+ Redis.Handler Redis.Internal- Redis.Real+ Redis.Script Redis.Settings Paths_nri_redis hs-source-dirs:@@ -62,37 +63,49 @@ 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 && <2.1+ aeson >=2.0 && <2.3 , async >=2.2.2 && <2.3- , base >=4.12.0.0 && <4.17- , bytestring >=0.10.8.2 && <0.12+ , base >=4.18 && <4.22+ , bytestring >=0.10.8.2 && <0.13 , conduit >=1.3.0 && <1.4+ , containers >=0.6.0.1 && <0.8+ , cryptohash-sha1 >=0.11.101.0 && <0.12+ , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16- , 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+ , megaparsec >=9.2.2 && <9.8+ , modern-uri >=0.3.1.0 && <0.4+ , nri-env-parser >=0.1.0.0 && <0.5+ , nri-observability >=0.1.0 && <0.5+ , nri-prelude >=0.7.0.0 && <0.8+ , pcre-light >=0.4.1.0 && <0.4.2+ , resourcet >=1.2.0 && <1.4 , safe-exceptions >=0.1.7.0 && <1.3- , text >=1.2.3.1 && <2.1+ , template-haskell >=2.16 && <3.0+ , text >=1.2.3.1 && <2.2 , 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+ main-is: Spec.hs other-modules:+ Helpers+ Spec.Redis+ Spec.Redis.Script+ Spec.Settings NonEmptyDict Redis Redis.Codec Redis.Counter+ Redis.Handler Redis.Hash Redis.Internal Redis.List- Redis.Mock- Redis.Real+ Redis.Script Redis.Set Redis.Settings+ Redis.SortedSet Paths_nri_redis hs-source-dirs: test@@ -115,18 +128,25 @@ 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 && <2.1+ aeson >=2.0 && <2.3 , async >=2.2.2 && <2.3- , base >=4.12.0.0 && <4.17- , bytestring >=0.10.8.2 && <0.12+ , base >=4.18 && <4.22+ , bytestring >=0.10.8.2 && <0.13 , conduit >=1.3.0 && <1.4+ , containers >=0.6.0.1 && <0.8+ , cryptohash-sha1 >=0.11.101.0 && <0.12+ , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16- , 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+ , megaparsec >=9.2.2 && <9.8+ , modern-uri >=0.3.1.0 && <0.4+ , nri-env-parser >=0.1.0.0 && <0.5+ , nri-observability >=0.1.0 && <0.5+ , nri-prelude >=0.7.0.0 && <0.8+ , pcre-light >=0.4.1.0 && <0.4.2+ , resourcet >=1.2.0 && <1.4 , safe-exceptions >=0.1.7.0 && <1.3- , text >=1.2.3.1 && <2.1+ , template-haskell >=2.16 && <3.0+ , text >=1.2.3.1 && <2.2 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 default-language: Haskell2010
src/NonEmptyDict.hs view
@@ -20,23 +20,23 @@ deriving (Show) -- | tries to create a 'NonEmptyDict' from a 'Dict'-fromDict :: Ord k => Dict.Dict k v -> Maybe (NonEmptyDict k v)+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 :: (Ord k) => NonEmptyDict k v -> Dict k v toDict (NonEmptyDict (k, v) dict) = Dict.insert k v dict --- | creates a 'Dict' from a 'NonEmptyDict'+-- | creates a 'NonEmpty' list from a 'NonEmptyDict' toNonEmptyList :: NonEmptyDict k v -> NonEmpty (k, v) 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+-- | creates a `NonEmptyDict` 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)
src/Redis.hs view
@@ -8,11 +8,19 @@ -- As with our Ruby Redis access, we enforce working within a "namespace". module Redis ( -- * Creating a redis handler- Real.handler,+ Handler.handler,+ Handler.handlerAutoExtendExpire,+ Handler.handlerWithoutNamespace, Internal.Handler,+ Internal.HandlerAutoExtendExpire,+ Internal.Handler',+ Internal.HasAutoExtendExpire (..), Settings.Settings (..), Settings.decoder, Settings.decoderWithEnvVarPrefix,+ Settings.decoderWithCustomConnectionString,+ Handler.withQueryTimeoutMilliseconds,+ Handler.withoutQueryTimeout, -- * Creating a redis API jsonApi,@@ -32,6 +40,8 @@ set, setex, setnx,+ ttl,+ Internal.TTLResponse (..), -- * Running Redis queries Internal.query,@@ -42,6 +52,12 @@ Internal.map2, Internal.map3, Internal.sequence,+ Internal.foldWithScan,++ -- * Lua Scripting+ script,+ ScriptParam (..),+ Internal.eval, ) where @@ -52,8 +68,9 @@ import qualified Dict import qualified NonEmptyDict import qualified Redis.Codec as Codec+import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal-import qualified Redis.Real as Real+import Redis.Script (ScriptParam (..), script) import qualified Redis.Settings as Settings import qualified Prelude @@ -96,7 +113,7 @@ -- operation never fails. -- -- https://redis.io/commands/mget- mget :: Ord key => NonEmpty key -> Internal.Query (Dict.Dict key a),+ 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.@@ -129,7 +146,13 @@ -- performed. SETNX is short for "SET if Not eXists". -- -- https://redis.io/commands/setnx- setnx :: key -> a -> Internal.Query Bool+ setnx :: key -> a -> Internal.Query Bool,+ -- | Get the TTL (Time To Live / expiry time) for a key, in seconds.+ --+ -- __Important__: When using `HandlerAutoExtendExpire`, this command will **NOT** auto-extend expiry.+ --+ -- https://redis.io/commands/ttl+ ttl :: key -> Internal.Query Internal.TTLResponse } -- | Creates a json API mapping a 'key' to a json-encodable-decodable type@@ -175,5 +198,6 @@ 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)+ setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value),+ ttl = \key -> Internal.WithResult Internal.ttlResponseDecoder (Internal.Ttl (toKey key)) }
src/Redis/Codec.hs view
@@ -21,10 +21,10 @@ jsonCodec :: (Aeson.FromJSON a, Aeson.ToJSON a) => Codec a jsonCodec = Codec jsonEncoder jsonDecoder -jsonEncoder :: Aeson.ToJSON a => Encoder a+jsonEncoder :: (Aeson.ToJSON a) => Encoder a jsonEncoder = Aeson.encode >> Data.ByteString.Lazy.toStrict -jsonDecoder :: Aeson.FromJSON a => Decoder a+jsonDecoder :: (Aeson.FromJSON a) => Decoder a jsonDecoder byteString = case Aeson.eitherDecodeStrict' byteString of Prelude.Right decoded -> Ok decoded
src/Redis/Counter.hs view
@@ -7,8 +7,10 @@ -- As with our Ruby Redis access, we enforce working within a "namespace". module Redis.Counter ( -- * Creating a redis handler- Real.handler,+ Handler.handler,+ Handler.handlerAutoExtendExpire, Internal.Handler,+ Internal.HandlerAutoExtendExpire, Settings.Settings (..), Settings.decoder, @@ -41,8 +43,8 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Redis.Codec as Codec+import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal-import qualified Redis.Real as Real import qualified Redis.Settings as Settings import qualified Prelude
+ src/Redis/Handler.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}++module Redis.Handler+ ( handler,+ handlerAutoExtendExpire,+ handlerWithoutNamespace,+ withQueryTimeoutMilliseconds,+ withoutQueryTimeout,+ )+where++import qualified Control.Exception.Safe as Exception+import Control.Monad.IO.Class (liftIO)+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 Dict+import qualified GHC.Stack as Stack+import qualified Log+import qualified Platform+import qualified Redis.Internal as Internal+import qualified Redis.Script as Script+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 (Just namespace) settings) releaseHandler+ namespacedHandler+ |> Prelude.pure++-- | Produce a Redis handler that does NOT prefix keys with a namespace.+--+-- Prefer 'handler' unless you have a specific reason to opt out of+-- namespacing (e.g. reading/writing keys owned by another system). Using+-- this constructor bypasses the namespace isolation that 'handler' enforces.+handlerWithoutNamespace :: Settings.Settings -> Data.Acquire.Acquire Internal.Handler+handlerWithoutNamespace settings = do+ (h, _) <- Data.Acquire.mkAcquire (acquireHandler Nothing settings) releaseHandler+ Prelude.pure h++-- | Produce a namespaced handler for Redis access.+-- This will ensure that we extend all keys accessed by a query by a configured default time (see Settings.defaultExpiry)+handlerAutoExtendExpire :: Text -> Settings.Settings -> Data.Acquire.Acquire Internal.HandlerAutoExtendExpire+handlerAutoExtendExpire namespace settings = do+ (namespacedHandler, _) <- Data.Acquire.mkAcquire (acquireHandler (Just namespace) settings) releaseHandler+ namespacedHandler+ |> ( \handler' -> case Settings.defaultExpiry settings of+ Settings.NoDefaultExpiry ->+ -- We create the handler as part of starting the application. Throwing+ -- means that if there's a problem with the settings the application will+ -- fail immediately upon start. It won't result in runtime errors during+ -- operation.+ [ "Setting up an auto extend expire handler for",+ "redis failed. Auto extending the expire of keys only works if",+ "there is a setting for `REDIS_DEFAULT_EXPIRY_SECONDS`."+ ]+ |> Text.join " "+ |> Text.toList+ |> Exception.throwString+ Settings.ExpireKeysAfterSeconds secs ->+ defaultExpiryKeysAfterSeconds secs handler'+ |> Prelude.pure+ )+ |> liftIO++-- | Sets a timeout for the query in milliseconds.+withQueryTimeoutMilliseconds :: Int -> Internal.Handler' x -> Task () (Internal.Handler' x)+withQueryTimeoutMilliseconds timeoutMs handler' =+ (handler' {Internal.queryTimeout = Settings.TimeoutQueryAfterMilliseconds timeoutMs})+ |> Task.succeed+ |> Log.withContext "setting redis query timeout" [Log.context "timeoutMilliseconds" (Text.fromInt timeoutMs)]++-- | Disables timeout for query in milliseconds+withoutQueryTimeout :: Internal.Handler' x -> Task () (Internal.Handler' x)+withoutQueryTimeout handler' =+ (handler' {Internal.queryTimeout = Settings.NoQueryTimeout})+ |> Task.succeed+ |> Log.withContext "setting no redis query timeout" []++defaultExpiryKeysAfterSeconds :: Int -> Internal.HandlerAutoExtendExpire -> Internal.HandlerAutoExtendExpire+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 = \queryTimeout query' ->+ wrapWithExpire query'+ |> Stack.withFrozenCallStack (Internal.doQuery handler') queryTimeout,+ Internal.doTransaction = \queryTimeout query' ->+ wrapWithExpire query'+ |> Stack.withFrozenCallStack (Internal.doTransaction handler') queryTimeout,+ Internal.doEval = \queryTimeout script' ->+ -- We can't guarantee auto-expire for EVAL, so we just run it as-is+ Stack.withFrozenCallStack (Internal.doEval handler' queryTimeout script')+ }++acquireHandler :: Maybe Text -> Settings.Settings -> IO (Internal.Handler' x, 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 = \queryTimeout query ->+ let PreparedQuery {redisCtx} = doRawQuery query+ in Stack.withFrozenCallStack platformRedis (Internal.cmds query) connection anything queryTimeout redisCtx,+ Internal.doTransaction = \queryTimeout 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 queryTimeout),+ Internal.doEval = \queryTimeout script' ->+ Stack.withFrozenCallStack (platformRedisScript script' connection anything queryTimeout),+ Internal.namespace = namespace,+ Internal.maxKeySize = Settings.maxKeySize settings,+ Internal.queryTimeout = Settings.queryTimeout settings+ },+ 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.Scan cursor maybeMatch maybeCount ->+ Database.Redis.ScanOpts (map toB maybeMatch) (map fromIntegral maybeCount)+ |> Database.Redis.scanOpts cursor+ |> PreparedQuery+ |> map+ ( \(nextCursor, byteKeys) ->+ byteKeys+ |> 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")+ )+ |> map (\textKeys -> (nextCursor, textKeys))+ )+ 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.Sismember key val ->+ Database.Redis.sismember (toB key) val+ |> PreparedQuery+ |> map Ok+ Internal.Smembers key ->+ Database.Redis.smembers (toB key)+ |> PreparedQuery+ |> map Ok+ Internal.Ttl key ->+ Database.Redis.ttl (toB key)+ |> PreparedQuery+ |> map (Ok << Prelude.fromIntegral)+ Internal.Zadd key vals ->+ Dict.toList vals+ |> List.map (\(a, b) -> (b, a))+ |> Database.Redis.zadd (toB key)+ |> PreparedQuery+ |> map (Ok << Prelude.fromIntegral)+ Internal.Zrange key start stop ->+ Database.Redis.zrange+ (toB key)+ (Prelude.fromIntegral start)+ (Prelude.fromIntegral stop)+ |> PreparedQuery+ |> map Ok+ Internal.ZrangeByScoreWithScores key start stop ->+ Database.Redis.zrangebyscoreWithscores+ (toB key)+ start+ stop+ |> PreparedQuery+ |> map Ok+ Internal.Zrank key member ->+ Database.Redis.zrank (toB key) member+ |> PreparedQuery+ |> map (Ok << map Prelude.fromIntegral)+ Internal.Zrevrank key member ->+ Database.Redis.zrevrank (toB key) member+ |> PreparedQuery+ |> map (Ok << map Prelude.fromIntegral)+ 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' x, 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 ->+ Settings.QueryTimeout ->+ Database.Redis.Redis (Either Database.Redis.Reply (Result Internal.Error a)) ->+ Task Internal.Error a+platformRedis cmds connection anything queryTimeout action =+ Database.Redis.runRedis (connectionHedis connection) action+ |> map toResult+ |> map+ ( \result ->+ case result of+ Ok a -> a+ Err err -> Err err+ )+ |> handleExceptions+ |> Platform.doAnything anything+ |> Stack.withFrozenCallStack Internal.wrapQuery queryTimeout 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++handleExceptions :: IO (Result Internal.Error value) -> IO (Result Internal.Error value)+handleExceptions =+ Exception.handle (\(_ :: Database.Redis.ConnectionLostException) -> pure <| Err Internal.ConnectionLost)+ >> Exception.handleAny+ ( \err ->+ Exception.displayException err+ |> Text.fromList+ |> Internal.LibraryError+ |> Err+ |> pure+ )++-- | Run a script in Redis trying to leverage the script cache+platformRedisScript ::+ (Stack.HasCallStack, Database.Redis.RedisResult a) =>+ Script.Script a ->+ Connection ->+ Platform.DoAnythingHandler ->+ Settings.QueryTimeout ->+ Task Internal.Error a+platformRedisScript script connection anything queryTimeout = do+ -- Try EVALSHA+ evalsha script connection anything queryTimeout+ |> Task.onError+ ( \err ->+ case err of+ Internal.RedisError "NOSCRIPT No matching script. Please use EVAL." -> do+ -- If it fails with NOSCRIPT, load the script and try again+ loadScript script connection anything queryTimeout+ evalsha script connection anything queryTimeout+ _ -> Task.fail err+ )++evalsha ::+ (Stack.HasCallStack, Database.Redis.RedisResult a) =>+ Script.Script a ->+ Connection ->+ Platform.DoAnythingHandler ->+ Settings.QueryTimeout ->+ Task Internal.Error a+evalsha script connection anything queryTimeout =+ Database.Redis.evalsha+ (toB (Script.luaScriptHash script))+ (map toB (Script.keys script))+ (map toB (Log.unSecret (Script.arguments script)))+ |> Database.Redis.runRedis (connectionHedis connection)+ |> map toResult+ |> handleExceptions+ |> Platform.doAnything anything+ |> Stack.withFrozenCallStack Internal.wrapQuery queryTimeout [Script.evalShaString script] (connectionHost connection) (connectionPort connection)++loadScript ::+ (Stack.HasCallStack) =>+ Script.Script a ->+ Connection ->+ Platform.DoAnythingHandler ->+ Settings.QueryTimeout ->+ Task Internal.Error ()+loadScript script connection anything queryTimeout = do+ Database.Redis.scriptLoad (toB (Script.luaScript script))+ |> Database.Redis.runRedis (connectionHedis connection)+ |> map toResult+ |> handleExceptions+ -- The result is the hash, which we already have. No sense in decoding it.+ |> map (map (\_ -> ()))+ |> Platform.doAnything anything+ |> Stack.withFrozenCallStack Internal.wrapQuery queryTimeout [Script.scriptLoadString script] (connectionHost connection) (connectionPort connection)++toB :: Text -> Data.ByteString.ByteString+toB = Data.Text.Encoding.encodeUtf8
src/Redis/Hash.hs view
@@ -8,8 +8,10 @@ -- As with our Ruby Redis access, we enforce working within a "namespace". module Redis.Hash ( -- * Creating a redis handler- Real.handler,+ Handler.handler,+ Handler.handlerAutoExtendExpire, Internal.Handler,+ Internal.HandlerAutoExtendExpire, Settings.Settings (..), Settings.decoder, @@ -53,8 +55,8 @@ import qualified Dict import qualified NonEmptyDict import qualified Redis.Codec as Codec+import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal-import qualified Redis.Real as Real import qualified Redis.Settings as Settings import qualified Result import qualified Prelude@@ -151,7 +153,7 @@ -- | Creates a Redis API mapping a 'key' to Text textApi ::- Ord field =>+ (Ord field) => (key -> Text) -> (field -> Text) -> (Text -> Maybe field) ->@@ -160,7 +162,7 @@ -- | Creates a Redis API mapping a 'key' to a ByteString byteStringApi ::- Ord field =>+ (Ord field) => (key -> Text) -> (field -> Text) -> (Text -> Maybe field) ->@@ -168,7 +170,7 @@ byteStringApi = makeApi Codec.byteStringCodec makeApi ::- Ord field =>+ (Ord field) => Codec.Codec a -> (key -> Text) -> (field -> Text) ->@@ -209,7 +211,7 @@ 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 :: (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
src/Redis/Internal.hs view
@@ -1,10 +1,19 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-}+-- For the RedisResult Text instance+{-# OPTIONS_GHC -fno-warn-orphans #-} module Redis.Internal ( Error (..),- Handler (..),+ Handler,+ Handler' (..),+ HandlerAutoExtendExpire,+ HasAutoExtendExpire (..), Query (..),+ TTLResponse (..),+ Database.Redis.Cursor,+ Database.Redis.cursor0, cmds, map, map2,@@ -12,10 +21,13 @@ sequence, query, transaction,+ eval,+ foldWithScan, -- internal tools- traceQuery,+ wrapQuery, maybesToDict, keysTouchedByQuery,+ ttlResponseDecoder, ) where @@ -23,6 +35,7 @@ import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text.Encoding import qualified Database.Redis import qualified Dict import qualified GHC.Stack as Stack@@ -30,6 +43,7 @@ import qualified Log.RedisCommands as RedisCommands import NriPrelude hiding (map, map2, map3) import qualified Platform+import qualified Redis.Script as Script import qualified Redis.Settings as Settings import qualified Set import qualified Text@@ -92,16 +106,38 @@ Mset pairs -> [unwords ("MSET" : List.concatMap (\(key, _) -> [key, "*****"]) (NonEmpty.toList pairs))] Ping -> ["PING"] Rpush key vals -> [unwords ("RPUSH" : key : List.map (\_ -> "*****") (NonEmpty.toList vals))]+ Scan cursor maybeMatch maybeCount -> [scanCmd cursor maybeMatch maybeCount] 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))]+ Sismember key _ -> [unwords ["SISMEMBER", key, "*****"]] Smembers key -> [unwords ["SMEMBERS", key]]+ Ttl key -> [unwords ["TTL", key]]+ Zadd key vals -> [unwords ("ZADD" : key : List.concatMap (\(_, val) -> ["*****", Text.fromFloat val]) (Dict.toList vals))]+ Zrange key start stop -> [unwords ["ZRANGE", key, Text.fromInt start, Text.fromInt stop]]+ ZrangeByScoreWithScores key start stop -> [unwords ["ZRANGE", key, "BYSCORE", Text.fromFloat start, Text.fromFloat stop, "WITHSCORES"]]+ Zrank key _ -> [unwords ["ZRANK", key, "*****"]]+ Zrevrank key _ -> [unwords ["ZREVRANK", key, "*****"]] Pure _ -> [] Apply f x -> cmds f ++ cmds x WithResult _ x -> cmds x+ where+ scanCmd :: Database.Redis.Cursor -> Maybe Text -> Maybe Int -> Text+ scanCmd cursor maybeMatch maybeCount =+ let cursorWord =+ Text.fromList (Prelude.show cursor)+ matchWords =+ case maybeMatch of+ Nothing -> []+ Just keyPattern -> ["MATCH", keyPattern]+ countWords =+ case maybeCount of+ Nothing -> []+ Just c -> ["COUNT", Text.fromInt c]+ in unwords ("SCAN" : cursorWord : matchWords ++ countWords) unwords :: [Text] -> Text unwords = Text.join " "@@ -128,13 +164,21 @@ Mset :: NonEmpty (Text, ByteString) -> Query () Ping :: Query Database.Redis.Status Rpush :: Text -> NonEmpty ByteString -> Query Int+ Scan :: Database.Redis.Cursor -> Maybe Text -> Maybe Int -> Query (Database.Redis.Cursor, [Text]) Set :: Text -> ByteString -> Query () Setex :: Text -> Int -> ByteString -> Query () Setnx :: Text -> ByteString -> Query Bool Sadd :: Text -> NonEmpty ByteString -> Query Int Scard :: Text -> Query Int Srem :: Text -> NonEmpty ByteString -> Query Int+ Sismember :: Text -> ByteString -> Query Bool Smembers :: Text -> Query (List ByteString)+ Ttl :: Text -> Query Int+ Zadd :: Text -> Dict.Dict ByteString Float -> Query Int+ Zrange :: Text -> Int -> Int -> Query [ByteString]+ ZrangeByScoreWithScores :: Text -> Float -> Float -> Query [(ByteString, Float)]+ Zrank :: Text -> ByteString -> Query (Maybe Int)+ Zrevrank :: Text -> ByteString -> Query (Maybe Int) -- The constructors below are not Redis-related, but support using functions -- like `map` and `map2` on queries. Pure :: a -> Query a@@ -182,23 +226,43 @@ sequence = List.foldr (map2 (:)) (Pure []) +-- | We use this to parametrize the handler. It specifies if the handler has+-- the auto extend expire feater enabled or not.+data HasAutoExtendExpire = NoAutoExtendExpire | AutoExtendExpire+ -- | The redis handler allows applications to run scoped IO-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,- maxKeySize :: Settings.MaxKeySize+-- A handler that can only be parametrized by a value of this kind.+-- Meaning that we use the values of the type parameter at a type level.+data Handler' (x :: HasAutoExtendExpire) = Handler'+ { doQuery :: (Stack.HasCallStack) => forall a. Settings.QueryTimeout -> Query a -> Task Error a,+ doTransaction :: (Stack.HasCallStack) => forall a. Settings.QueryTimeout -> Query a -> Task Error a,+ doEval :: (Stack.HasCallStack) => forall a. (Database.Redis.RedisResult a) => Settings.QueryTimeout -> Script.Script a -> Task Error a,+ namespace :: Maybe Text,+ maxKeySize :: Settings.MaxKeySize,+ queryTimeout :: Settings.QueryTimeout } +-- | This is a type alias of a handler parametrized by a value that indicates+-- that the auto extend feature is disabled.+-- Note: The tick in front of NoAutoExtendExpire is not necessary, but good+-- practice to indicate that we are lifting a value to the type level.+type Handler = Handler' 'NoAutoExtendExpire++-- | This is a type alias of a handler parametrized by a value that indicates+-- that the auto extend feature is enabled.+-- Note: The tick in front of AutoExtendExpire is not necessary, but good+-- practice to indicate that we are lifting a value to the type level.+type HandlerAutoExtendExpire = Handler' 'AutoExtendExpire+ -- | Run a 'Query'. -- Note: A 'Query' in this library can consist of one or more queries in sequence. -- if a 'Query' contains multiple queries, it may make more sense, if possible -- to run them using 'transaction'-query :: Stack.HasCallStack => Handler -> Query a -> Task Error a+query :: (Stack.HasCallStack) => Handler' x -> Query a -> Task Error a query handler query' =- namespaceQuery (namespace handler ++ ":") query'+ namespaceQuery (namespacePrefix handler) query' |> Task.andThen (ensureMaxKeySize handler)- |> Task.andThen (Stack.withFrozenCallStack (doQuery handler))+ |> Task.andThen (Stack.withFrozenCallStack (doQuery handler) (queryTimeout 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@@ -206,14 +270,27 @@ -- -- 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 :: (Stack.HasCallStack) => Handler' x -> Query a -> Task Error a transaction handler query' =- namespaceQuery (namespace handler ++ ":") query'+ namespaceQuery (namespacePrefix handler) query' |> Task.andThen (ensureMaxKeySize handler)- |> Task.andThen (Stack.withFrozenCallStack (doTransaction handler))+ |> Task.andThen (Stack.withFrozenCallStack (doTransaction handler) (queryTimeout handler)) +eval :: (Stack.HasCallStack, Database.Redis.RedisResult a) => Handler' x -> Script.Script a -> Task Error a+eval handler script =+ Script.mapKeys (\key -> Task.succeed (namespacePrefix handler ++ key)) script+ |> Task.andThen (Stack.withFrozenCallStack (doEval handler) (queryTimeout handler))++namespacePrefix :: Handler' x -> Text+namespacePrefix handler =+ case namespace handler of+ Just ns -> ns ++ ":"+ Nothing -> ""+ namespaceQuery :: Text -> Query a -> Task err (Query a)-namespaceQuery prefix query' = mapKeys (\key -> Task.succeed (prefix ++ key)) query'+namespaceQuery prefix query' =+ mapKeys (\key -> Task.succeed (prefix ++ key)) query'+ |> Task.map (mapReturnedKeys (Text.dropLeft (Text.length prefix))) mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a) mapKeys fn query' =@@ -230,26 +307,81 @@ 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)+ Hmget key fields -> Task.map (\newKey -> Hmget newKey fields) (fn key)+ Hget key field -> Task.map (\newKey -> Hget newKey field) (fn key)+ Hset key field val -> Task.map (\newKey -> Hset newKey field val) (fn key)+ Hsetnx key field val -> Task.map (\newKey -> Hsetnx newKey field val) (fn key)+ Hmset key vals -> Task.map (\newKey -> Hmset newKey vals) (fn key)+ Hdel key fields -> Task.map (\newKey -> Hdel newKey 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)+ Incrby key amount -> Task.map (\newKey -> Incrby newKey amount) (fn key)+ Expire key secs -> Task.map (\newKey -> Expire newKey secs) (fn key)+ Lrange key lower upper -> Task.map (\newKey -> Lrange newKey lower upper) (fn key)+ Rpush key vals -> Task.map (\newKey -> Rpush newKey vals) (fn key)+ Scan cursor maybeMatch maybeCount ->+ case maybeMatch of+ Just match -> Task.map (\newMatch -> Scan cursor (Just newMatch) maybeCount) (fn match)+ Nothing -> Task.succeed (Scan cursor Nothing maybeCount)+ Sadd key vals -> Task.map (\newKey -> Sadd newKey vals) (fn key) Scard key -> Task.map Scard (fn key)- Srem key vals -> Task.map (\newKeys -> Srem newKeys vals) (fn key)+ Srem key vals -> Task.map (\newKey -> Srem newKey vals) (fn key)+ Sismember key val -> Task.map (\newKey -> Sismember newKey val) (fn key) Smembers key -> Task.map Smembers (fn key)+ Ttl key -> Task.map Ttl (fn key)+ Zadd key vals -> Task.map (\newKey -> Zadd newKey vals) (fn key)+ Zrange key start stop -> Task.map (\newKey -> Zrange newKey start stop) (fn key)+ ZrangeByScoreWithScores key start stop -> Task.map (\newKey -> ZrangeByScoreWithScores newKey start stop) (fn key)+ Zrank key member -> Task.map (\newKey -> Zrank newKey member) (fn key)+ Zrevrank key member -> Task.map (\newKey -> Zrevrank newKey member) (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)+mapReturnedKeys :: (Text -> Text) -> Query a -> Query a+mapReturnedKeys fn query' =+ case query' of+ Exists key -> Exists key+ Ping -> Ping+ Get key -> Get key+ Set key value -> Set key value+ Setex key seconds value -> Setex key seconds value+ Setnx key value -> Setnx key value+ Getset key value -> Getset key value+ Mget keys -> Mget keys+ Mset assocs -> Mset assocs+ Del keys -> Del keys+ Hgetall key -> Hgetall key+ Hkeys key -> Hkeys key+ Hmget key fields -> Hmget key fields+ Hget key field -> Hget key field+ Hset key field val -> Hset key field val+ Hsetnx key field val -> Hsetnx key field val+ Hmset key vals -> Hmset key vals+ Hdel key fields -> Hdel key fields+ Incr key -> Incr key+ Incrby key amount -> Incrby key amount+ Expire key secs -> Expire key secs+ Lrange key lower upper -> Lrange key lower upper+ Rpush key vals -> Rpush key vals+ Scan cursor maybeMatch maybeCount ->+ Scan cursor maybeMatch maybeCount+ |> map (\(nextCursor, keys) -> (nextCursor, List.map fn keys))+ Sadd key vals -> Sadd key vals+ Scard key -> Scard key+ Srem key vals -> Srem key vals+ Sismember key val -> Sismember key val+ Smembers key -> Smembers key+ Ttl key -> Ttl key+ Zadd key vals -> Zadd key vals+ Zrange key start stop -> Zrange key start stop+ ZrangeByScoreWithScores key start stop -> ZrangeByScoreWithScores key start stop+ Zrank key member -> Zrank key member+ Zrevrank key member -> Zrevrank key member+ Pure x -> Pure x+ Apply f x -> Apply (mapReturnedKeys fn f) (mapReturnedKeys fn x)+ WithResult f q -> (WithResult f) (mapReturnedKeys fn q)++ensureMaxKeySize :: Handler' x -> Query a -> Task Error (Query a) ensureMaxKeySize handler query' = case maxKeySize handler of Settings.NoMaxKeySize -> Task.succeed query'@@ -289,16 +421,26 @@ Ping -> Set.empty Pure _ -> Set.empty Rpush key _ -> Set.singleton key+ Scan {} -> Set.empty 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+ Sismember key _ -> Set.singleton key Smembers key -> Set.singleton key+ -- TTL is meant to just check the TTL. Let's not report the key back+ -- so it doesn't auto-extending the TTL.+ Ttl _ -> Set.empty+ Zadd key _ -> Set.singleton key+ Zrange key _ _ -> Set.singleton key+ ZrangeByScoreWithScores key _ _ -> Set.singleton key+ Zrank key _ -> Set.singleton key+ Zrevrank key _ -> Set.singleton key WithResult _ q -> keysTouchedByQuery q -maybesToDict :: Ord key => List key -> List (Maybe a) -> Dict.Dict key a+maybesToDict :: (Ord key) => List key -> List (Maybe a) -> Dict.Dict key a maybesToDict keys values = List.map2 (,) keys values |> List.filterMap@@ -309,7 +451,15 @@ ) |> Dict.fromList -traceQuery :: Stack.HasCallStack => [Text] -> Text -> Maybe Int -> Task e a -> Task e a+wrapQuery :: (Stack.HasCallStack) => Settings.QueryTimeout -> [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a+wrapQuery queryTimeout commands host port task =+ traceQuery commands host port <| case queryTimeout of+ Settings.NoQueryTimeout ->+ task+ Settings.TimeoutQueryAfterMilliseconds timeoutMs ->+ Task.timeout (toFloat timeoutMs) TimeoutError task++traceQuery :: (Stack.HasCallStack) => [Text] -> Text -> Maybe Int -> Task Error a -> Task Error a traceQuery commands host port task = let info = RedisCommands.emptyDetails@@ -332,3 +482,56 @@ ) ) )++-- | Use SCAN command to find keys matching a pattern, and "fold" over them in batches, producing a result value.+-- keyMatchPattern A glob-like pattern to match keys, see https://redis.io/commands/keys/+-- approxCountPerBatch A hint for the batch size you want to process at once. Only approximate.+-- processKeyBatch Function to process one batch of keys (provided as plain Text without namespace prefix)+-- initAccumulator Initial value for the fold accumulator+foldWithScan :: Handler' x -> Maybe Text -> Maybe Int -> ([Text] -> a -> Task Error a) -> a -> Task Error a+foldWithScan handler keyMatchPattern approxCountPerBatch processKeyBatch initAccumulator =+ let go accumulator cursor = do+ (nextCursor, keyBatch) <-+ Scan cursor keyMatchPattern approxCountPerBatch+ |> query handler+ nextAccumulator <-+ processKeyBatch keyBatch accumulator+ if nextCursor == Database.Redis.cursor0+ then Task.succeed nextAccumulator+ else go nextAccumulator nextCursor+ in go initAccumulator Database.Redis.cursor0++data TTLResponse = TTLKeyNotFound | NeverExpires | ExpiresInSeconds Int+ deriving (Show, Eq)++ttlResponseDecoder :: Int -> Result Error TTLResponse+ttlResponseDecoder ttl =+ if ttl >= 0+ then Ok (ExpiresInSeconds ttl)+ else+ if ttl == -2+ then Ok TTLKeyNotFound+ else+ if ttl == -1+ then Ok NeverExpires+ else Err (DecodingError ("Unexpected TTL value: " ++ Text.fromInt ttl))++--------------------------------------+-- Orphaned instances for RedisResult+--------------------------------------+instance Database.Redis.RedisResult Text where+ decode r = do+ decodedBs <- Database.Redis.decode r+ Prelude.pure <| Data.Text.Encoding.decodeUtf8 decodedBs++instance Database.Redis.RedisResult Int where+ decode r = do+ (decodedInteger :: Prelude.Integer) <- Database.Redis.decode r+ Prelude.pure <| Prelude.fromIntegral decodedInteger++instance Database.Redis.RedisResult () where+ decode r = do+ (reply :: Database.Redis.Reply) <- Database.Redis.decode r+ case reply of+ Database.Redis.Bulk Nothing -> Prelude.pure ()+ other -> Prelude.Left other
src/Redis/List.hs view
@@ -8,8 +8,10 @@ -- As with our Ruby Redis access, we enforce working within a "namespace". module Redis.List ( -- * Creating a redis handler- Real.handler,+ Handler.handler,+ Handler.handlerAutoExtendExpire, Internal.Handler,+ Internal.HandlerAutoExtendExpire, Settings.Settings (..), Settings.decoder, @@ -44,8 +46,8 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Redis.Codec as Codec+import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal-import qualified Redis.Real as Real import qualified Redis.Settings as Settings import qualified Prelude
− src/Redis/Mock.hs
@@ -1,404 +0,0 @@-{-# LANGUAGE GADTs #-}---- | Redis.Mock is useful for writing tests without Redis running-module Redis.Mock- ( handler,- handlerIO,- )-where--import Data.ByteString (ByteString)-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.IORef (IORef, atomicModifyIORef', newIORef)-import qualified Data.List-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Text.Encoding as TE-import qualified Database.Redis-import qualified Expect-import qualified List-import qualified Platform-import qualified Redis.Internal as Internal-import qualified Redis.Settings as Settings-import qualified Text-import qualified Tuple-import Prelude (IO, pure)-import qualified Prelude---- | This functions returns a task that you can run in each test to retrieve a--- fresh mock handler-handler :: Expect.Expectation' Internal.Handler-handler =- 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",- Internal.maxKeySize = Settings.NoMaxKeySize- }- |> 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"
− src/Redis/Real.hs
@@ -1,317 +0,0 @@-{-# 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,- Internal.maxKeySize = Settings.maxKeySize settings- },- 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
+ src/Redis/Script.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Redis.Script+ ( Script (..),+ script,+ -- Internal API+ luaScriptHash,+ evalShaString,+ scriptLoadString,+ mapKeys,+ -- For testing+ parser,+ Tokens (..),+ ScriptParam (..),+ HasScriptParam (..),+ )+where++import qualified Control.Monad+import qualified Crypto.Hash.SHA1+import qualified Data.ByteString+import Data.Either (Either (..))+import qualified Data.Text+import qualified Data.Text.Encoding+import Data.Void (Void)+import qualified GHC.TypeLits+import Language.Haskell.Meta.Parse (parseExp)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as QQ+import Text.Megaparsec ((<|>))+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as PC+import qualified Text.Printf+import Prelude (notElem, pure, (<*))+import qualified Prelude++data Script result = Script+ { -- | The Lua script to be executed with @args placeholders for Redis+ luaScript :: Text,+ -- | The script string as extracted from a `script` quasi quote.+ quasiQuotedString :: Text,+ keys :: [Text],+ -- | The parameters that fill the placeholders in this query+ arguments :: Log.Secret [Text]+ }+ deriving (Eq, Show)++-- | A type for enforcing parameters used in [script|${ ... }|] are either tagged as Key or Literal.+--+-- We need keys to be tagged, otherwise we can't implement `mapKeys` and enforce namespacing+-- in Redis APIs.+--+-- We make this extra generic to allow us to provide nice error messages using TypeError in a+-- type class below.+data ScriptParam+ = forall a. (Show a) => Key a+ | forall a. (Show a) => Literal a++class HasScriptParam a where+ getScriptParam :: a -> ScriptParam++-- | This instance is marked as INCOHERENT so that it will be chosen if possible in the overlapping case+instance {-# INCOHERENT #-} HasScriptParam ScriptParam where+ getScriptParam = Prelude.id++-- | This instance is used to provide a helpful error message when a user tries to use a type+-- other than a ScriptParam in a [script|${ ... }|] quasi quote.+--+-- It is what forces us to hav UndecidableInstances enabled.+instance+ (GHC.TypeLits.TypeError ('GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.")) =>+ HasScriptParam x+ where+ getScriptParam = Prelude.error "This won't ever hit bc this generates a compile-time error."++-- | Quasi-quoter for creating a Redis Lua script with placeholders for Redis keys and arguments.+--+-- > [script|SET ${Key "a-redis-key"} ${Literal 123}|]+--+-- **IMPORTANT**: It is NOT SAFE to return Redis keys using this. Our Redis APIs inject+-- "namespaces" (prefixes) on keys, and any keys returned by Lua will have their namespaces+-- applied. If you try to reuse those keys in follow-up queries, namespaces will be doubly-applied.+script :: QQ.QuasiQuoter+script =+ QQ.QuasiQuoter+ { QQ.quoteExp = qqScript,+ QQ.quoteType = Prelude.error "script not supported in types",+ QQ.quotePat = Prelude.error "script not supported in patterns",+ QQ.quoteDec = Prelude.error "script not supported in declarations"+ }++qqScript :: Prelude.String -> TH.Q TH.Exp+qqScript scriptWithVars = do+ let quotedScript = Text.fromList scriptWithVars+ let parseResult = P.parse parser "" quotedScript+ case parseResult of+ Left err -> Prelude.error <| "Failed to parse script: " ++ P.errorBundlePretty err+ Right tokens -> do+ paramsExp <-+ tokens+ |> Control.Monad.mapM toEvaluatedToken+ |> map TH.ListE+ quotedScriptExp <- [|quotedScript|]+ pure <| (TH.VarE 'scriptFromEvaluatedTokens) `TH.AppE` quotedScriptExp `TH.AppE` paramsExp++----------------------------+-- Script template compile-time evaluation+----------------------------++data EvaluatedToken+ = EvaluatedText Text+ | EvaluatedVariable EvaluatedParam+ deriving (Show, Eq)++data EvaluatedParam = EvaluatedParam+ { kind :: ParamKind,+ value :: Text+ }+ deriving (Eq, Show)++data ParamKind = RedisKey | ArbitraryValue+ deriving (Eq, Show)++toEvaluatedToken :: Tokens -> TH.Q TH.Exp+toEvaluatedToken token =+ case token of+ ScriptText text -> [|EvaluatedText text|]+ ScriptVariable var -> pure <| (TH.VarE 'evaluateScriptParam) `TH.AppE` (varToExp var)++evaluateScriptParam :: (HasScriptParam a) => a -> EvaluatedToken+evaluateScriptParam scriptParam =+ case getScriptParam scriptParam of+ Key a ->+ EvaluatedVariable <|+ EvaluatedParam+ { kind = RedisKey,+ value = unquoteString (Debug.toString a)+ }+ Literal a ->+ EvaluatedVariable <|+ EvaluatedParam+ { kind = ArbitraryValue,+ value = unquoteString (Debug.toString a)+ }++-- | Remove leading and trailing quotes from a string+unquoteString :: Text -> Text+unquoteString str =+ str+ |> Data.Text.stripPrefix "\""+ |> Maybe.andThen (Data.Text.stripSuffix "\"")+ |> Maybe.withDefault str++varToExp :: Text -> TH.Exp+varToExp var =+ case parseExp (Text.toList var) of+ Left err -> Prelude.error <| "Failed to parse variable: " ++ err+ Right exp -> exp++-----------------------------+-- Script record construction+-----------------------------++data ScriptBuilder = ScriptBuilder+ { buffer :: Text,+ keyIdx :: Int,+ keyList :: List Text,+ argIdx :: Int,+ argList :: List Text+ }++scriptFromEvaluatedTokens :: Text -> [EvaluatedToken] -> Script a+scriptFromEvaluatedTokens quasiQuotedString' evaluatedTokens =+ let keyTpl n = "KEYS[" ++ Text.fromInt n ++ "]"+ argTpl n = "ARGV[" ++ Text.fromInt n ++ "]"+ script' =+ List.foldl+ ( \token scriptBuilder@(ScriptBuilder {buffer, keyIdx, keyList, argIdx, argList}) ->+ case token of+ EvaluatedText text -> scriptBuilder {buffer = buffer ++ text}+ EvaluatedVariable var ->+ case kind var of+ RedisKey ->+ scriptBuilder+ { buffer = buffer ++ keyTpl (keyIdx + 1),+ keyIdx = keyIdx + 1,+ keyList = value var : keyList+ }+ ArbitraryValue ->+ scriptBuilder+ { buffer = buffer ++ argTpl (argIdx + 1),+ argIdx = argIdx + 1,+ argList = value var : argList+ }+ )+ (ScriptBuilder "" 0 [] 0 [])+ evaluatedTokens+ in Script+ { luaScript = buffer script',+ quasiQuotedString = quasiQuotedString',+ keys = List.reverse (keyList script'),+ arguments = Log.mkSecret (List.reverse (argList script'))+ }++-----------------------------+-- Quasi-quoted text parser+-----------------------------++-- | Tokens after parsing quasi-quoted text+data Tokens+ = ScriptText Text+ | ScriptVariable Text+ deriving (Show, Eq)++type Parser = P.Parsec Void Text++parser :: Parser (List Tokens)+parser = do+ (P.some (parseText <|> parseVariable))+ <* P.eof++parseText :: Parser Tokens+parseText = do+ text <- P.takeWhile1P (Just "some plain text") (/= '$')+ pure <| ScriptText text++parseVariable :: Parser Tokens+parseVariable = do+ _ <- PC.string "${"+ _ <- PC.space+ name <- P.takeWhile1P (Just "anything but '$', '{' or '}' (no records, sorry)") (\t -> t `notElem` ['$', '{', '}'])+ _ <- PC.char '}'+ pure <| ScriptVariable <| Text.trim name++---------------------------------------------+-- Helper functions for internal library use+---------------------------------------------++-- | EVALSHA hash numkeys [key [key ...]] [arg [arg ...]]+evalShaString :: Script a -> Text+evalShaString script'@(Script {keys, arguments}) =+ let keyCount = keys |> List.length |> Text.fromInt+ keys' = keys |> Text.join " "+ args' = arguments |> Log.unSecret |> List.map (\_ -> "***") |> Text.join " "+ hash = luaScriptHash script'+ in "EVALSHA " ++ hash ++ " " ++ keyCount ++ " " ++ keys' ++ " " ++ args'++-- | SCRIPT LOAD "return KEYS[1]"+scriptLoadString :: Script a -> Text+scriptLoadString Script {luaScript} =+ "SCRIPT LOAD \"" ++ luaScript ++ "\""++-- | Map the keys in the script to the keys in the Redis API+mapKeys :: (Text -> Task err Text) -> Script a -> Task err (Script a)+mapKeys fn script' = do+ keys script'+ |> List.map fn+ |> Task.sequence+ |> Task.map (\keys' -> script' {keys = keys'})++luaScriptHash :: Script a -> Text+luaScriptHash Script {luaScript} =+ luaScript+ |> Data.Text.Encoding.encodeUtf8+ |> Crypto.Hash.SHA1.hash+ |> toHex++toHex :: Data.ByteString.ByteString -> Text+toHex bytes =+ bytes+ |> Data.ByteString.unpack+ |> List.map (Text.Printf.printf "%02x")+ |> List.concat+ |> Text.fromList
src/Redis/Set.hs view
@@ -8,8 +8,10 @@ -- As with our Ruby Redis access, we enforce working within a "namespace". module Redis.Set ( -- * Creating a redis handler- Real.handler,+ Handler.handler,+ Handler.handlerAutoExtendExpire, Internal.Handler,+ Internal.HandlerAutoExtendExpire, Settings.Settings (..), Settings.decoder, @@ -27,6 +29,7 @@ sadd, scard, srem,+ sismember, smembers, -- * Running Redis queries@@ -46,8 +49,8 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Redis.Codec as Codec+import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal-import qualified Redis.Real as Real import qualified Redis.Settings as Settings import qualified Set import qualified Prelude@@ -101,7 +104,11 @@ -- | Returns all the members of the set value stored at key. -- -- https://redis.io/commands/smembers- smembers :: key -> Internal.Query (Set.Set a)+ smembers :: key -> Internal.Query (Set.Set a),+ -- | Returns if member is a member of the set stored at key.+ --+ -- https://redis.io/docs/latest/commands/sismember/+ sismember :: key -> a -> Internal.Query Bool } -- | Creates a json API mapping a 'key' to a json-encodable-decodable type@@ -127,7 +134,7 @@ byteStringApi = makeApi Codec.byteStringCodec makeApi ::- Ord a =>+ (Ord a) => Codec.Codec a -> (key -> Text) -> Api key a@@ -146,5 +153,7 @@ smembers = \key -> Internal.Smembers (toKey key) |> Internal.WithResult (Prelude.traverse codecDecoder)- |> Internal.map Set.fromList+ |> Internal.map Set.fromList,+ sismember = \key val ->+ Internal.Sismember (toKey key) (codecEncoder val) }
src/Redis/Settings.hs view
@@ -6,15 +6,20 @@ MaxKeySize (..), decoder, decoderWithEnvVarPrefix,+ decoderWithCustomConnectionString, ) where +import qualified Data.List.NonEmpty as NonEmpty+import Data.Text.Encoding (encodeUtf8) import Database.Redis hiding (Ok) import qualified Environment import qualified Text-import Prelude (Either (Left, Right))+import qualified Text.URI as URI+import Prelude (Either (Left, Right), foldr, fromIntegral, id, pure) data ClusterMode = Cluster | NotCluster+ deriving (Show) -- | Settings required to initiate a redis connection. data Settings = Settings@@ -42,25 +47,40 @@ queryTimeout :: QueryTimeout, maxKeySize :: MaxKeySize }+ deriving (Show) data MaxKeySize = NoMaxKeySize | MaxKeySize Int+ deriving (Show) data DefaultExpiry = NoDefaultExpiry | ExpireKeysAfterSeconds Int+ deriving (Show) data QueryTimeout = NoQueryTimeout | TimeoutQueryAfterMilliseconds Int+ deriving (Show) -- | decodes Settings from environmental variables decoder :: Environment.Decoder Settings decoder = decoderWithEnvVarPrefix "" +-- | decodes Settings from environmental variables with custom connection string+decoderWithCustomConnectionString :: Text -> Environment.Decoder Settings+decoderWithCustomConnectionString connectionStringEnvVar =+ map5+ Settings+ (decoderConnectInfo connectionStringEnvVar)+ (decoderClusterMode "")+ (decoderDefaultExpiry "")+ (decoderQueryTimeout "")+ (decoderMaxKeySize "")+ -- | decodes Settings from environmental variables prefixed with a Text -- >>> decoderWithEnvVarPrefix "WORKER_" decoderWithEnvVarPrefix :: Text -> Environment.Decoder Settings decoderWithEnvVarPrefix prefix = map5 Settings- (decoderConnectInfo prefix)+ (decoderConnectInfo (prefix ++ "REDIS_CONNECTION_STRING")) (decoderClusterMode prefix) (decoderDefaultExpiry prefix) (decoderQueryTimeout prefix)@@ -84,21 +104,68 @@ ) decoderConnectInfo :: Text -> Environment.Decoder ConnectInfo-decoderConnectInfo prefix =+decoderConnectInfo envVarName = Environment.variable Environment.Variable- { Environment.name = prefix ++ "REDIS_CONNECTION_STRING",+ { Environment.name = envVarName, 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)+ Environment.uri+ ( \uri ->+ case map URI.unRText (URI.uriScheme uri) of+ Just "redis" -> parseRedisSchemeURI uri+ Just "redis+unix" -> parseRedisSocketSchemeURI uri+ Just unrecognizedScheme -> Err ("Invalid URI scheme for connection string: " ++ unrecognizedScheme)+ Nothing -> Err "URI scheme missing from connection string" ) )++parseRedisSchemeURI :: URI.URI -> Result Text ConnectInfo+parseRedisSchemeURI uri =+ case parseConnectInfo (URI.renderStr uri) of+ Left parseError -> Err ("Invalid Redis connection string: " ++ Text.fromList parseError)+ Right info' -> Ok info'++parseRedisSocketSchemeURI :: URI.URI -> Result Text ConnectInfo+parseRedisSocketSchemeURI uri =+ let uriPathTextFromURI =+ case URI.uriPath uri of+ Nothing -> Err "URI path missing from connection string"+ Just (_, uriPathSegments) ->+ uriPathSegments+ |> map URI.unRText+ |> NonEmpty.intersperse "/"+ |> foldr (++) ""+ |> (if URI.isPathAbsolute uri then ("/" ++) else id)+ |> Ok++ dbNumFromParams queryParams =+ case queryParams of+ [] -> Ok 0+ URI.QueryParam key value : rest ->+ if URI.unRText key == "db"+ then case Text.toInt (URI.unRText value) of+ Nothing -> Err "Expected an integer for db in connection string"+ Just dbNum -> Ok (fromIntegral dbNum)+ else dbNumFromParams rest+ _ : rest -> dbNumFromParams rest++ maybePasswordFromURI =+ case URI.uriAuthority uri of+ Right (URI.Authority (Just (URI.UserInfo _ (Just passwordRText))) _ _) ->+ Just (encodeUtf8 <| URI.unRText passwordRText)+ _ -> Nothing+ in do+ uriPathText <- uriPathTextFromURI+ dbNum <- dbNumFromParams (URI.uriQuery uri)+ pure <|+ defaultConnectInfo+ { connectPort = UnixSocket (Text.toList uriPathText),+ connectDatabase = dbNum,+ connectAuth = maybePasswordFromURI+ } decoderDefaultExpiry :: Text -> Environment.Decoder DefaultExpiry decoderDefaultExpiry prefix =
+ src/Redis/SortedSet.hs view
@@ -0,0 +1,166 @@+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++-- | 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.SortedSet+ ( -- * Creating a Redis handler+ Handler.handler,+ Handler.handlerAutoExtendExpire,+ Internal.Handler,+ Internal.HandlerAutoExtendExpire,+ Settings.Settings (..),+ Settings.decoder,++ -- * Creating a Redis API+ jsonApi,+ textApi,+ byteStringApi,+ Api,++ -- * Creating Redis queries+ del,+ exists,+ expire,+ ping,+ zadd,+ zrange,+ zrangeByScoreWithScores,+ zrank,+ zrevrank,++ -- * 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 Data.Map.Strict+import qualified NonEmptyDict+import qualified Redis.Codec as Codec+import qualified Redis.Handler as Handler+import qualified Redis.Internal as Internal+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 (),+ -- | Adds all the specified members with the specified scores to the sorted+ -- set. If a specified member is already a member of the sorted set, the+ -- score is updated and the element reinserted at the right position to+ -- ensure the correct ordering.+ --+ -- https://redis.io/commands/zadd+ zadd :: key -> NonEmptyDict.NonEmptyDict a Float -> Internal.Query Int,+ -- | Returns the specified range of elements in the sorted set. The order of+ -- elements is from the lowest to the highest score. Elements with the same+ -- score are ordered lexicographically. The <start> and <stop> arguments+ -- represent zero-based indexes, where 0 is the first element, 1 is the next+ -- element, and so on. These arguments specify an inclusive range, so for+ -- example, ZRANGE myzset 0 1 will return both the first and the second+ -- element of the sorted set.+ --+ -- The indexes can also be negative numbers indicating offsets from the end+ -- of the sorted set, with -1 being the last element of the sorted set, -2+ -- the penultimate element, and so on.+ --+ -- Out of range indexes do not produce an error.+ --+ -- https://redis.io/commands/zrange+ zrange :: key -> Int -> Int -> Internal.Query (List a),+ -- | Like `zrange`, but with the bounds being scores rather than offsets,+ -- and with the result including the scores for each returned result.+ zrangeByScoreWithScores :: key -> Float -> Float -> Internal.Query [(a, Float)],+ -- | Returns the rank of member in the sorted set stored at key, with the+ -- scores ordered from low to high. The rank (or index) is 0-based, which+ -- means that the member with the lowest score has rank 0.+ --+ -- https://redis.io/commands/zrank+ zrank :: key -> a -> Internal.Query (Maybe Int),+ -- | Returns the rank of member in the sorted set stored at key, with the+ -- scores ordered from high to low. The rank (or index) is 0-based, which+ -- means that the member with the highest score has rank 0.+ --+ -- https://redis.io/commands/zrevrank+ zrevrank :: key -> a -> Internal.Query (Maybe Int)+ }++-- | 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++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 (\_ -> ()),+ zadd = \key vals ->+ Internal.Zadd (toKey key) (Data.Map.Strict.mapKeys codecEncoder (NonEmptyDict.toDict vals)),+ zrange = \key start stop ->+ Internal.Zrange (toKey key) start stop+ |> Internal.WithResult (Prelude.traverse codecDecoder),+ zrangeByScoreWithScores = \key start stop ->+ Internal.ZrangeByScoreWithScores (toKey key) start stop+ |> Internal.WithResult+ ( Prelude.traverse+ ( \(v, score) ->+ codecDecoder v |> Result.map (\val -> (val, score))+ )+ ),+ zrank = \key member -> Internal.Zrank (toKey key) (codecEncoder member),+ zrevrank = \key member -> Internal.Zrevrank (toKey key) (codecEncoder member)+ }
+ test/Helpers.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Helpers where++import qualified Conduit+import qualified Environment+import qualified Redis+import qualified Redis.Handler as Handler+import qualified Redis.Settings as Settings+import qualified Prelude++data TestHandlers = TestHandlers+ { autoExtendExpireHandler :: Redis.HandlerAutoExtendExpire,+ handler :: Redis.Handler,+ noNamespaceHandler :: Redis.Handler+ }++getHandlers :: Conduit.Acquire TestHandlers+getHandlers = do+ settings <- Conduit.liftIO (Environment.decode Settings.decoder)+ autoExtendExpireHandler <- Handler.handlerAutoExtendExpire "tests-auto-extend-expire" settings {Settings.defaultExpiry = Settings.ExpireKeysAfterSeconds 1}+ handler <- Handler.handler "tests" settings {Settings.defaultExpiry = Settings.NoDefaultExpiry}+ noNamespaceHandler <- Handler.handlerWithoutNamespace settings {Settings.defaultExpiry = Settings.NoDefaultExpiry}+ Prelude.pure TestHandlers {autoExtendExpireHandler, handler, noNamespaceHandler}++-- | Historical context:+-- Golden results are slightly different between GHC 9.2.x and 8.10.x due+-- to apparent differences in internal handling of stack frame source locations.+-- In particular, the end of a function call now does not extend to the end of+-- the line but instead to the end of the function name. E.g. for the following:+--+-- > foo+-- > bar+-- > baz+--+-- In GHC 8.10.x (and possibly GHC 9.0.x?) `srcLocEndLine` and `srcLocEndCol`+-- would correspond to the `z` at the end of `baz`. Unfortunately, in GHC 9.2.x+-- it corresponds to the second `o` at the end of `foo`.+--+-- We keep this here in case similar is true in later versions of GHC.+goldenResultsDir :: Text+goldenResultsDir = "test/golden-results-9.8"
− test/Main.hs
@@ -1,313 +0,0 @@-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)- }
+ test/Spec.hs view
@@ -0,0 +1,18 @@+import qualified Conduit+import Helpers+import qualified Spec.Redis+import qualified Spec.Redis.Script+import qualified Spec.Settings+import qualified Test+import qualified Prelude++main :: Prelude.IO ()+main =+ Conduit.withAcquire Helpers.getHandlers <| \testHandlers ->+ Test.run <|+ Test.describe+ "nri-redis"+ [ Spec.Redis.tests testHandlers,+ Spec.Settings.tests,+ Spec.Redis.Script.tests+ ]
+ test/Spec/Redis.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE QuasiQuotes #-}++module Spec.Redis (tests) where++import qualified Control.Concurrent.MVar as MVar+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Dict+import qualified Expect+import Helpers+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.SortedSet+import qualified Set+import qualified Task+import qualified Test+import qualified Prelude++-- 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 a -> Expect.Expectation' Platform.TracingSpan+spanForTask task =+ Expect.fromIO <| do+ spanVar <- MVar.newEmptyMVar+ res <-+ Platform.rootTracingSpanIO+ "test-request"+ Platform.silentTrack+ (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++spanForFailingTask :: Task e () -> Expect.Expectation' Platform.TracingSpan+spanForFailingTask task =+ Expect.fromIO <| do+ spanVar <- MVar.newEmptyMVar+ res <-+ Platform.rootTracingSpanIO+ "test-request"+ Platform.silentTrack+ (MVar.putMVar spanVar)+ "test-root"+ (\log -> Task.attempt log task)+ case res of+ Err _ ->+ MVar.takeMVar spanVar+ |> map constantValuesForVariableFields+ Ok _ ->+ Prelude.fail "Expected task to fail"++tests :: TestHandlers -> Test.Test+tests TestHandlers {handler, autoExtendExpireHandler, noNamespaceHandler} =+ Test.describe+ "Redis Library"+ [ Test.describe "query tests using handler" (queryTests handler),+ Test.describe "query tests using auto extend expire handler" (queryTests autoExtendExpireHandler),+ Test.describe "observability tests" (observabilityTests handler),+ Test.describe "ttl tests" (ttlTests handler autoExtendExpireHandler),+ Test.describe "no-namespace handler tests" (noNamespaceTests noNamespaceHandler handler)+ ]++-- 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' x -> 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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/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 (goldenResultsDir ++ "/observability-spec-reporting-redis-counter-transaction"),+ Test.describe+ "with 0 ms timeout"+ [ Test.test "Redis.query reports the span data we expect" <| \() -> do+ handlerThatExpiresImmediately <- Expect.succeeds (Redis.withQueryTimeoutMilliseconds 0 handler)+ span <-+ Redis.query handlerThatExpiresImmediately (Redis.ping api)+ |> spanForFailingTask+ span+ |> Debug.toString+ |> Expect.all+ [ Expect.equalToContentsOf (goldenResultsDir ++ "/observability-spec-reporting-redis-query-timeout"),+ \spanText -> Expect.true (Text.contains "Redis Query" spanText)+ ],+ Test.test "Redis.withQueryTimeoutMilliseconds reports the span data we expect" <| \() -> do+ span <-+ Redis.withQueryTimeoutMilliseconds 0 handler+ |> spanForTask+ span+ |> Debug.toString+ |> Expect.equalToContentsOf (goldenResultsDir ++ "/observability-spec-reporting-with-query-timout"),+ Test.test "Redis.withoutQueryTimeout reports the span data we expect" <| \() -> do+ spanSettingTimeout <-+ Redis.withoutQueryTimeout handler+ |> spanForTask+ spanSettingTimeout+ |> Debug.toString+ |> Expect.equalToContentsOf (goldenResultsDir ++ "/observability-spec-reporting-without-query-timout")+ ]+ ]++queryTests :: Redis.Handler' x -> 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"),+ Test.test "zadd returns count of stored values" <| \() -> do+ _ <-+ Redis.SortedSet.del sortedSetApi ("zadd-returns-count-of-stored-values" :| [])+ |> Redis.query redisHandler+ |> Expect.succeeds+ NonEmptyDict.init "foo" 1 Dict.empty+ |> Redis.SortedSet.zadd sortedSetApi "zadd-returns-count-of-stored-values"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal 1),+ Test.test "zrange works as expected" <| \() -> do+ _ <-+ Redis.SortedSet.del sortedSetApi ("zrange-works" :| [])+ |> Redis.query redisHandler+ |> Expect.succeeds+ _ <-+ NonEmptyDict.init "one" 1 (Dict.fromList [("two", 2), ("three", 3)])+ |> Redis.SortedSet.zadd sortedSetApi "zrange-works"+ |> Redis.query redisHandler+ |> Expect.succeeds+ Redis.SortedSet.zrange sortedSetApi "zrange-works" 0 (-1)+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal ["one", "two", "three"])+ Redis.SortedSet.zrange sortedSetApi "zrange-works" 2 3+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal ["three"])+ Redis.SortedSet.zrange sortedSetApi "zrange-works" (-2) (-1)+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal ["two", "three"]),+ Test.test "zrank works as expected" <| \() -> do+ _ <-+ Redis.SortedSet.del sortedSetApi ("zrank-works" :| [])+ |> Redis.query redisHandler+ |> Expect.succeeds+ _ <-+ NonEmptyDict.init "one" 1 (Dict.fromList [("two", 2), ("twobis", 2), ("three", 3)])+ |> Redis.SortedSet.zadd sortedSetApi "zrank-works"+ |> Redis.query redisHandler+ |> Expect.succeeds+ Redis.SortedSet.zrank sortedSetApi "zrank-works" "one"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal (Just 0))+ Redis.SortedSet.zrank sortedSetApi "zrank-works" "two"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal (Just 1))+ Redis.SortedSet.zrank sortedSetApi "zrank-works" "twobis"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal (Just 2))+ Redis.SortedSet.zrank sortedSetApi "zrank-works" "three"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal (Just 3))+ Redis.SortedSet.zrank sortedSetApi "zrank-works" "foobar"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal Nothing)+ Redis.SortedSet.zrank sortedSetApi "zrank-works-nothing-stored" "foobar"+ |> Redis.query redisHandler+ |> Expect.andCheck (Expect.equal Nothing),+ Test.test "scan iterates over all matching keys in batches" <| \() -> do+ let firstKey = "scanTest::key1"+ let firstValue = "value 1"+ let nonEmptyDict =+ NonEmptyDict.init firstKey firstValue <|+ Dict.fromList+ [ ("scanTest::key2", "value 2"),+ ("scanTest::key3", "value 3"),+ ("scanTest::key4", "value 4")+ ]+ let expectedKeys =+ NonEmptyDict.toDict nonEmptyDict+ |> Dict.keys+ Redis.mset api nonEmptyDict+ |> Redis.query testNS+ |> Expect.succeeds+ let processBatch = \batchKeys acc ->+ Task.succeed (List.foldl Set.insert acc batchKeys)+ keySet <-+ Redis.foldWithScan testNS (Just "scanTest::*") (Just 2) processBatch Set.empty+ |> Expect.succeeds+ keySet+ |> Set.toList+ |> Expect.equal expectedKeys,+ Test.test "scan works correctly when deleting keys" <| \() -> do+ let firstKey = "scanDeleteTest::key1"+ let firstValue = "value 1"+ let nonEmptyDict =+ NonEmptyDict.init firstKey firstValue <|+ Dict.fromList+ [ ("scanDeleteTest::key2", "value 2"),+ ("scanDeleteTest::key3", "value 3"),+ ("scanDeleteTest::key4", "value 4")+ ]+ let expectedKeys =+ NonEmptyDict.toDict nonEmptyDict+ |> Dict.keys+ Redis.mset api nonEmptyDict+ |> Redis.query testNS+ |> Expect.succeeds+ let processBatch = \batchKeys (accDeleted, accKeys) ->+ case batchKeys of+ [] -> Task.succeed (accDeleted, accKeys)+ first : rest -> do+ nDel <-+ Redis.del api (first :| rest)+ |> Redis.query testNS+ Task.succeed (accDeleted + nDel, List.foldl Set.insert accKeys batchKeys)+ (totalDeleted, keySet) <-+ Redis.foldWithScan testNS (Just "scanDeleteTest::*") (Just 2) processBatch (0, Set.empty)+ |> Expect.succeeds+ totalDeleted+ |> Expect.equal (List.length expectedKeys)+ keySet+ |> Set.toList+ |> Expect.equal expectedKeys,+ Test.test "eval runs and returns something" <| \() -> do+ let script = [Redis.script|return 1|]+ result <- Redis.eval testNS script |> Expect.succeeds+ Expect.equal result 1,+ Test.test "eval returns Int" <| \() -> do+ let script = [Redis.script|return 1|]+ (result :: Int) <- Redis.eval testNS script |> Expect.succeeds+ Expect.equal result 1,+ Test.test "eval returns ()" <| \() -> do+ let script = [Redis.script|redis.call("ECHO", "hi")|]+ Redis.eval testNS script |> Expect.succeeds,+ Test.test "eval returns List Int" <| \() -> do+ let script = [Redis.script|return {1,2}|]+ (result :: List Int) <- Redis.eval testNS script |> Expect.succeeds+ Expect.equal result [1, 2],+ Test.test "eval with arguments runs and returns something" <| \() -> do+ let script =+ [Redis.script|+ local a = ${Redis.Key "hi"}+ local b = ${Redis.Literal "hello"}+ return 1|]+ result <- Redis.eval testNS script |> Expect.succeeds+ Expect.equal result 1,+ Test.test "eval with arguments returns argument" <| \() -> do+ let script =+ [Redis.script|+ local a = ${Redis.Key 2}+ local b = ${Redis.Literal 3}+ local c = ${Redis.Literal 4}+ local d = ${Redis.Literal 5}+ return {b, c, d}|]+ result <- Redis.eval testNS script |> Expect.succeeds+ Expect.equal result [3, 4, 5],+ Test.test "eval with arguments namespaces key" <| \() -> do+ let script = [Redis.script|return ${Redis.Key "hi"}|]+ (result :: Text) <- Redis.eval testNS script |> Expect.succeeds+ Expect.true+ ( List.member+ result+ -- All tests here run twice:+ -- - once with the auto-extend-expire handler+ -- - once with the normal handler+ -- each run generates a different namespace+ [ "tests-auto-extend-expire:testNamespace:hi",+ "tests:testNamespace:hi"+ ]+ )+ ]+ where+ testNS = addNamespace "testNamespace" redisHandler++ttlTests :: Redis.Handler -> Redis.HandlerAutoExtendExpire -> List Test.Test+ttlTests handler autoExtendExpireHandler =+ let testNS = addNamespace "ttlTestNamespace" handler+ testNSWithExpiry = addNamespace "ttlTestNamespace" autoExtendExpireHandler+ in [ Test.test "ttl reads key w/o ttl" <| \() -> do+ Redis.set api "no-expiry" "value" |> Redis.query testNS |> Expect.succeeds+ result <- Redis.ttl api "no-expiry" |> Redis.query testNS |> Expect.succeeds+ Expect.equal result Redis.NeverExpires,+ Test.test "ttl reads key w/ ttl" <| \() -> do+ Redis.set api "expires" "value" |> Redis.query testNSWithExpiry |> Expect.succeeds+ result <- Redis.ttl api "expires" |> Redis.query testNSWithExpiry |> Expect.succeeds+ Expect.equal result (Redis.ExpiresInSeconds 1),+ Test.test "ttl reports missing key" <| \() -> do+ result <- Redis.ttl api "not-found" |> Redis.query testNSWithExpiry |> Expect.succeeds+ Expect.equal result Redis.TTLKeyNotFound+ ]++-- | Tests that pin down the contract of `handlerWithoutNamespace`: keys are+-- neither prefixed on the way in nor stripped on the way out. The+-- `nsHandler` argument is the regular namespaced `handler` (namespace+-- `"tests"`); we use it to confirm prefixing happens on the namespaced side+-- but not on the no-namespace side.+noNamespaceTests :: Redis.Handler -> Redis.Handler -> List Test.Test+noNamespaceTests noNs nsHandler =+ [ Test.test "set via no-namespace handler stores the key under its literal name" <| \() -> do+ -- Write at literal key "noNs::literalKey" using the no-namespace handler.+ Redis.set api "noNs::literalKey" "value-no-ns" |> Redis.query noNs |> Expect.succeeds+ -- The namespaced handler would look at "tests:noNs::literalKey", which+ -- nothing has written to, so it should see Nothing.+ result <- Redis.get api "noNs::literalKey" |> Redis.query nsHandler |> Expect.succeeds+ Expect.equal result Nothing,+ Test.test "get via no-namespace handler reads the literal key (no prefix added)" <| \() -> do+ -- Namespaced handler writes "noNs::roundTrip" → redis sees "tests:noNs::roundTrip".+ Redis.set api "noNs::roundTrip" "via-namespace" |> Redis.query nsHandler |> Expect.succeeds+ -- The no-namespace handler can reach that same value by spelling out+ -- the full prefixed key, since it adds no prefix of its own.+ result <- Redis.get api "tests:noNs::roundTrip" |> Redis.query noNs |> Expect.succeeds+ Expect.equal result (Just "via-namespace"),+ Test.test "eval via no-namespace handler does not prefix script keys" <| \() -> do+ let script = [Redis.script|return ${Redis.Key "noNs::evalKey"}|]+ (result :: Text) <- Redis.eval noNs script |> Expect.succeeds+ Expect.equal result "noNs::evalKey",+ Test.test "foldWithScan via no-namespace handler returns keys verbatim" <| \() -> do+ let scanPrefix = "noNs::scanTest::"+ let firstKey = scanPrefix ++ "k1"+ let nonEmptyDict =+ NonEmptyDict.init firstKey "v1"+ <| Dict.fromList [(scanPrefix ++ "k2", "v2")]+ let expectedKeys =+ NonEmptyDict.toDict nonEmptyDict+ |> Dict.keys+ Redis.mset api nonEmptyDict |> Redis.query noNs |> Expect.succeeds+ let processBatch = \batchKeys acc ->+ Task.succeed (List.foldl Set.insert acc batchKeys)+ keySet <-+ Redis.foldWithScan noNs (Just (scanPrefix ++ "*")) (Just 10) processBatch Set.empty+ |> Expect.succeeds+ keySet+ |> Set.toList+ |> Expect.equal expectedKeys+ ]++addNamespace :: Text -> Redis.Handler' x -> Redis.Handler' x+addNamespace namespace handler' =+ let combined = case Internal.namespace handler' of+ Just existing -> existing ++ ":" ++ namespace+ Nothing -> namespace+ in handler' {Internal.namespace = Just combined}++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++sortedSetApi :: Redis.SortedSet.Api Text Text+sortedSetApi = Redis.SortedSet.textApi 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)+ }
+ test/Spec/Redis/Script.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Spec.Redis.Script (tests) where++import qualified Data.Bifunctor+import Data.Either (Either (..))+import qualified Expect+import Redis.Script+import qualified Test+import qualified Text.Megaparsec as P++tests :: Test.Test+tests =+ Test.describe+ "Redis.Script"+ [ Test.describe "parser" parserTests,+ Test.describe "th tests" thTests+ ]++parserTests :: List Test.Test+parserTests =+ [ Test.test "1 word" <| \_ ->+ P.runParser parser "" "Jabuticaba"+ |> Expect.equal (Right [ScriptText "Jabuticaba"]),+ Test.test "3 words" <| \_ ->+ P.runParser parser "" "Picolé de Jabuticaba"+ |> Expect.equal (Right [ScriptText "Picolé de Jabuticaba"]),+ Test.test "1 value" <| \_ ->+ P.runParser parser "" "${value}"+ |> Expect.equal (Right [ScriptVariable "value"]),+ Test.test "function application" <| \_ ->+ P.runParser parser "" "${func arg1 arg2}"+ |> Expect.equal (Right [ScriptVariable "func arg1 arg2"]),+ Test.test "text and variables" <| \_ ->+ P.runParser parser "" "some text ${value} some more text ${ anotherValue }"+ |> Expect.equal+ ( Right+ [ ScriptText "some text ",+ ScriptVariable "value",+ ScriptText " some more text ",+ ScriptVariable "anotherValue"+ ]+ ),+ Test.test "ERROR: empty" <| \_ -> do+ P.runParser parser "" ""+ |> Data.Bifunctor.first P.errorBundlePretty+ |> Expect.equal+ ( Left+ "1:1:\n\+ \ |\n\+ \1 | <empty line>\n\+ \ | ^\n\+ \unexpected end of input\n\+ \expecting \"${\" or some plain text\n\+ \"+ ),+ Test.test "ERROR: empty variable" <| \_ -> do+ P.runParser parser "" "${}"+ |> Data.Bifunctor.first P.errorBundlePretty+ |> Expect.equal+ ( Left+ "1:3:\n\+ \ |\n\+ \1 | ${}\n\+ \ | ^\n\+ \unexpected '}'\n\+ \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\+ \"+ ),+ Test.test "ERROR: nested ${}" <| \_ -> do+ P.runParser parser "" "asdasd ${ ${ value } }"+ |> Data.Bifunctor.first P.errorBundlePretty+ |> Expect.equal+ ( Left+ "1:11:\n\+ \ |\n\+ \1 | asdasd ${ ${ value } }\n\+ \ | ^\n\+ \unexpected '$'\n\+ \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\+ \"+ ),+ Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do+ P.runParser parser "" "${ v$alue }"+ |> Data.Bifunctor.first P.errorBundlePretty+ |> Expect.equal+ ( Left+ "1:5:\n\+ \ |\n\+ \1 | ${ v$alue }\n\+ \ | ^\n\+ \unexpected '$'\n\+ \expecting '}' or anything but '$', '{' or '}' (no records, sorry)\n\+ \"+ ),+ Test.test "ERROR: misplaced { inside ${}" <| \_ -> do+ P.runParser parser "" "${ v{alue }"+ |> Data.Bifunctor.first P.errorBundlePretty+ |> Expect.equal+ ( Left+ "1:5:\n\+ \ |\n\+ \1 | ${ v{alue }\n\+ \ | ^\n\+ \unexpected '{'\n\+ \expecting '}' or anything but '$', '{' or '}' (no records, sorry)\n\+ \"+ )+ ]++thTests :: List Test.Test+thTests =+ [ Test.test "just text" <| \_ ->+ [script|some text|]+ |> Expect.equal+ ( Script+ { luaScript = "some text",+ quasiQuotedString = "some text",+ keys = [],+ arguments = Log.mkSecret []+ }+ ),+ Test.test "one key argument" <| \_ ->+ [script|${Key "hi"}|]+ |> Expect.equal+ ( Script+ { luaScript = "KEYS[1]",+ quasiQuotedString = "${Key \"hi\"}",+ keys = ["hi"],+ arguments = Log.mkSecret []+ }+ ),+ Test.test "one literal argument" <| \_ ->+ [script|${Literal "hi"}|]+ |> Expect.equal+ ( Script+ { luaScript = "ARGV[1]",+ quasiQuotedString = "${Literal \"hi\"}",+ keys = [],+ arguments = Log.mkSecret ["hi"]+ }+ ),+ Test.test "one key one literal argument" <| \_ ->+ [script|${Key "a key"} ${Literal "a literal"}|]+ |> Expect.equal+ ( Script+ { luaScript = "KEYS[1] ARGV[1]",+ quasiQuotedString = "${Key \"a key\"} ${Literal \"a literal\"}",+ keys = ["a key"],+ arguments = Log.mkSecret ["a literal"]+ }+ ),+ Test.test "multiple keys and literals" <| \_ ->+ [script|${Key "key1"} ${Key "key2"} ${Key "key3"} ${Literal "literal1"} ${Literal "literal2"} ${Literal "literal3"}|]+ |> Expect.equal+ ( Script+ { luaScript = "KEYS[1] KEYS[2] KEYS[3] ARGV[1] ARGV[2] ARGV[3]",+ quasiQuotedString = "${Key \"key1\"} ${Key \"key2\"} ${Key \"key3\"} ${Literal \"literal1\"} ${Literal \"literal2\"} ${Literal \"literal3\"}",+ keys = ["key1", "key2", "key3"],+ arguments = Log.mkSecret ["literal1", "literal2", "literal3"]+ }+ ),+ Test.test "fails on type-checking when not given Key or Literal" <| \_ ->+ [script|${False}|]+ |> arguments+ |> Log.unSecret+ |> Expect.equal ["this would have been a type-checking error"]+ ]++-- This instance is picked when none of the instances in src/Redis/Script.hs work..+-- proving in real code we would have a type-checking error.+instance {-# INCOHERENT #-} HasScriptParam Bool where+ getScriptParam _ = Literal "this would have been a type-checking error"
+ test/Spec/Settings.hs view
@@ -0,0 +1,248 @@+module Spec.Settings (tests) where++import Database.Redis hiding (Ok, String)+import qualified Dict+import qualified Environment+import qualified Expect+import qualified Redis.Settings as Settings+import qualified Test+import Prelude (Either (..), Show (..), String, pure)++tests :: Test.Test+tests =+ Test.describe+ "parsing settings from environment"+ [ decoderTests,+ decoderWithEnvVarPrefixTests,+ decoderWithCustomConnectionStringTests+ ]++-- | Compare equality based on `String` representation.+--+-- We lean on `show` for equality since `Database.Redis.ConnectInfo` doesn't have+-- an `Eq` instance (but does have a `Show` instance)+expectEqualShow :: (Show a) => a -> a -> Expect.Expectation+expectEqualShow x y = Expect.equal (show x) (show y)++decoderTests :: Test.Test+decoderTests =+ Test.describe+ "decoder tests"+ [ Test.test "returns expected defaults when no env vars set" <| \_ -> do+ connectInfo <- parseConnectInfoElseFailTest "redis://localhost:6379"+ let expected =+ Settings.Settings+ { Settings.connectionInfo = connectInfo,+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ Environment.decodePairs Settings.decoder (Dict.fromList [])+ |> expectEqualShow (Ok expected),+ Test.test "returns parsed values from env when env vars set" <| \_ -> do+ connectInfo <- parseConnectInfoElseFailTest "redis://egg:bug@my-cool-host:36379/2"+ let env =+ Dict.fromList+ [ ("REDIS_CONNECTION_STRING", "redis://egg:bug@my-cool-host:36379/2"),+ ("REDIS_CLUSTER", "1"),+ ("REDIS_DEFAULT_EXPIRY_SECONDS", "10"),+ ("REDIS_QUERY_TIMEOUT_MILLISECONDS", "0"),+ ("REDIS_MAX_KEY_SIZE", "500")+ ]++ expected =+ Settings.Settings+ { Settings.connectionInfo = connectInfo,+ Settings.clusterMode = Settings.Cluster,+ Settings.defaultExpiry = Settings.ExpireKeysAfterSeconds 10,+ Settings.queryTimeout = Settings.NoQueryTimeout,+ Settings.maxKeySize = Settings.MaxKeySize 500+ }+ Environment.decodePairs Settings.decoder env+ |> expectEqualShow (Ok expected),+ Test.test "handles unix socket scheme with default db" <| \_ ->+ let env = Dict.fromList [("REDIS_CONNECTION_STRING", "redis+unix:///path/to/redis.sock")]+ expected =+ Settings.Settings+ { Settings.connectionInfo =+ defaultConnectInfo+ { connectPort = UnixSocket "/path/to/redis.sock",+ connectDatabase = 0+ },+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ in Environment.decodePairs Settings.decoder env+ |> expectEqualShow (Ok expected),+ Test.test "handles unix socket scheme with specified db" <| \_ ->+ let env = Dict.fromList [("REDIS_CONNECTION_STRING", "redis+unix://some:dude@/other/redis.sock?db=5")]+ expected =+ Settings.Settings+ { Settings.connectionInfo =+ defaultConnectInfo+ { connectPort = UnixSocket "/other/redis.sock",+ connectAuth = Just "dude",+ connectDatabase = 5+ },+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ in Environment.decodePairs Settings.decoder env+ |> expectEqualShow (Ok expected)+ ]++decoderWithEnvVarPrefixTests :: Test.Test+decoderWithEnvVarPrefixTests =+ Test.describe+ "decoderWithEnvVarPrefix tests"+ [ Test.test "returns expected defaults when no env vars set" <| \_ -> do+ connectInfo <- parseConnectInfoElseFailTest "redis://localhost:6379"+ let expected =+ Settings.Settings+ { Settings.connectionInfo = connectInfo,+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ Environment.decodePairs (Settings.decoderWithEnvVarPrefix "TEST_") (Dict.fromList [])+ |> expectEqualShow (Ok expected),+ Test.test "returns parsed values from env when env vars set" <| \_ -> do+ connectInfo <- parseConnectInfoElseFailTest "redis://egg:bug@my-cool-host:36379/2"+ let env =+ Dict.fromList+ [ ("TEST_REDIS_CONNECTION_STRING", "redis://egg:bug@my-cool-host:36379/2"),+ ("TEST_REDIS_CLUSTER", "1"),+ ("TEST_REDIS_DEFAULT_EXPIRY_SECONDS", "10"),+ ("TEST_REDIS_QUERY_TIMEOUT_MILLISECONDS", "0"),+ ("TEST_REDIS_MAX_KEY_SIZE", "500")+ ]++ expected =+ Settings.Settings+ { Settings.connectionInfo = connectInfo,+ Settings.clusterMode = Settings.Cluster,+ Settings.defaultExpiry = Settings.ExpireKeysAfterSeconds 10,+ Settings.queryTimeout = Settings.NoQueryTimeout,+ Settings.maxKeySize = Settings.MaxKeySize 500+ }+ Environment.decodePairs (Settings.decoderWithEnvVarPrefix "TEST_") env+ |> expectEqualShow (Ok expected),+ Test.test "handles unix socket scheme with default db" <| \_ ->+ let env = Dict.fromList [("TEST_REDIS_CONNECTION_STRING", "redis+unix:///path/to/redis.sock")]+ expected =+ Settings.Settings+ { Settings.connectionInfo =+ defaultConnectInfo+ { connectPort = UnixSocket "/path/to/redis.sock",+ connectDatabase = 0+ },+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ in Environment.decodePairs (Settings.decoderWithEnvVarPrefix "TEST_") env+ |> expectEqualShow (Ok expected),+ Test.test "handles unix socket scheme with specified db" <| \_ ->+ let env = Dict.fromList [("TEST_REDIS_CONNECTION_STRING", "redis+unix://some:dude@/other/redis.sock?db=5")]+ expected =+ Settings.Settings+ { Settings.connectionInfo =+ defaultConnectInfo+ { connectPort = UnixSocket "/other/redis.sock",+ connectAuth = Just "dude",+ connectDatabase = 5+ },+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ in Environment.decodePairs (Settings.decoderWithEnvVarPrefix "TEST_") env+ |> expectEqualShow (Ok expected)+ ]++decoderWithCustomConnectionStringTests :: Test.Test+decoderWithCustomConnectionStringTests =+ Test.describe+ "decoderWithCustomConnectionString tests"+ [ Test.test "returns expected defaults when no env vars set" <| \_ -> do+ connectInfo <- parseConnectInfoElseFailTest "redis://localhost:6379"+ let expected =+ Settings.Settings+ { Settings.connectionInfo = connectInfo,+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ Environment.decodePairs (Settings.decoderWithCustomConnectionString "COOL_CONNECTION_STRING") (Dict.fromList [])+ |> expectEqualShow (Ok expected),+ Test.test "returns parsed values from env when env vars set" <| \_ -> do+ connectInfo <- parseConnectInfoElseFailTest "redis://egg:bug@my-cool-host:36379/2"+ let env =+ Dict.fromList+ [ ("COOL_CONNECTION_STRING", "redis://egg:bug@my-cool-host:36379/2"),+ ("REDIS_CLUSTER", "1"),+ ("REDIS_DEFAULT_EXPIRY_SECONDS", "10"),+ ("REDIS_QUERY_TIMEOUT_MILLISECONDS", "0"),+ ("REDIS_MAX_KEY_SIZE", "500")+ ]++ expected =+ Settings.Settings+ { Settings.connectionInfo = connectInfo,+ Settings.clusterMode = Settings.Cluster,+ Settings.defaultExpiry = Settings.ExpireKeysAfterSeconds 10,+ Settings.queryTimeout = Settings.NoQueryTimeout,+ Settings.maxKeySize = Settings.MaxKeySize 500+ }+ Environment.decodePairs (Settings.decoderWithCustomConnectionString "COOL_CONNECTION_STRING") env+ |> expectEqualShow (Ok expected),+ Test.test "handles unix socket scheme with default db" <| \_ ->+ let env = Dict.fromList [("COOL_CONNECTION_STRING", "redis+unix:///path/to/redis.sock")]+ expected =+ Settings.Settings+ { Settings.connectionInfo =+ defaultConnectInfo+ { connectPort = UnixSocket "/path/to/redis.sock",+ connectDatabase = 0+ },+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ in Environment.decodePairs (Settings.decoderWithCustomConnectionString "COOL_CONNECTION_STRING") env+ |> expectEqualShow (Ok expected),+ Test.test "handles unix socket scheme with specified db" <| \_ ->+ let env = Dict.fromList [("COOL_CONNECTION_STRING", "redis+unix://some:dude@/other/redis.sock?db=5")]+ expected =+ Settings.Settings+ { Settings.connectionInfo =+ defaultConnectInfo+ { connectPort = UnixSocket "/other/redis.sock",+ connectAuth = Just "dude",+ connectDatabase = 5+ },+ Settings.clusterMode = Settings.NotCluster,+ Settings.defaultExpiry = Settings.NoDefaultExpiry,+ Settings.queryTimeout = Settings.TimeoutQueryAfterMilliseconds 1000,+ Settings.maxKeySize = Settings.NoMaxKeySize+ }+ in Environment.decodePairs (Settings.decoderWithCustomConnectionString "COOL_CONNECTION_STRING") env+ |> expectEqualShow (Ok expected)+ ]++parseConnectInfoElseFailTest :: String -> Expect.Expectation' ConnectInfo+parseConnectInfoElseFailTest uri = do+ Expect.succeeds <|+ case parseConnectInfo uri of+ Left err -> Task.fail <| "you wrote this test wrong, got err: " ++ Text.fromList err+ Right connectInfo -> pure connectInfo