diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/nri-redis.cabal b/nri-redis.cabal --- a/nri-redis.cabal +++ b/nri-redis.cabal @@ -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 . 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 diff --git a/src/NonEmptyDict.hs b/src/NonEmptyDict.hs --- a/src/NonEmptyDict.hs +++ b/src/NonEmptyDict.hs @@ -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) diff --git a/src/Redis.hs b/src/Redis.hs --- a/src/Redis.hs +++ b/src/Redis.hs @@ -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)) } diff --git a/src/Redis/Codec.hs b/src/Redis/Codec.hs --- a/src/Redis/Codec.hs +++ b/src/Redis/Codec.hs @@ -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 diff --git a/src/Redis/Counter.hs b/src/Redis/Counter.hs --- a/src/Redis/Counter.hs +++ b/src/Redis/Counter.hs @@ -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 diff --git a/src/Redis/Handler.hs b/src/Redis/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Redis/Handler.hs @@ -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 diff --git a/src/Redis/Hash.hs b/src/Redis/Hash.hs --- a/src/Redis/Hash.hs +++ b/src/Redis/Hash.hs @@ -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 diff --git a/src/Redis/Internal.hs b/src/Redis/Internal.hs --- a/src/Redis/Internal.hs +++ b/src/Redis/Internal.hs @@ -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 diff --git a/src/Redis/List.hs b/src/Redis/List.hs --- a/src/Redis/List.hs +++ b/src/Redis/List.hs @@ -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 diff --git a/src/Redis/Mock.hs b/src/Redis/Mock.hs deleted file mode 100644 --- a/src/Redis/Mock.hs +++ /dev/null @@ -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" diff --git a/src/Redis/Real.hs b/src/Redis/Real.hs deleted file mode 100644 --- a/src/Redis/Real.hs +++ /dev/null @@ -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 diff --git a/src/Redis/Script.hs b/src/Redis/Script.hs new file mode 100644 --- /dev/null +++ b/src/Redis/Script.hs @@ -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 diff --git a/src/Redis/Set.hs b/src/Redis/Set.hs --- a/src/Redis/Set.hs +++ b/src/Redis/Set.hs @@ -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) } diff --git a/src/Redis/Settings.hs b/src/Redis/Settings.hs --- a/src/Redis/Settings.hs +++ b/src/Redis/Settings.hs @@ -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 = diff --git a/src/Redis/SortedSet.hs b/src/Redis/SortedSet.hs new file mode 100644 --- /dev/null +++ b/src/Redis/SortedSet.hs @@ -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 and 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) + } diff --git a/test/Helpers.hs b/test/Helpers.hs new file mode 100644 --- /dev/null +++ b/test/Helpers.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -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) - } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Spec/Redis.hs b/test/Spec/Redis.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Redis.hs @@ -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) + } diff --git a/test/Spec/Redis/Script.hs b/test/Spec/Redis/Script.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Redis/Script.hs @@ -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 | \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" diff --git a/test/Spec/Settings.hs b/test/Spec/Settings.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Settings.hs @@ -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