diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,23 @@ +# 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2024, NoRedInk +Copyright (c) 2026, NoRedInk All rights reserved. Redistribution and use in source and binary forms, with or without 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.36.0. +-- 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.2.0.3 +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: 2024 NoRedInk Corp. +copyright: 2026 NoRedInk Corp. license: BSD3 license-file: LICENSE build-type: Simple @@ -63,25 +63,25 @@ 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 >=2.0 && <2.2 + aeson >=2.0 && <2.3 , async >=2.2.2 && <2.3 - , base >=4.16.4.0 && <4.19 - , 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.7 + , 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 - , megaparsec >=9.2.2 && <9.6 + , megaparsec >=9.2.2 && <9.8 , modern-uri >=0.3.1.0 && <0.4 - , nri-env-parser >=0.1.0.0 && <0.3 - , nri-observability >=0.1.0 && <0.3 - , nri-prelude >=0.1.0.0 && <0.7 + , 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 , template-haskell >=2.16 && <3.0 - , text >=1.2.3.1 && <2.1 + , text >=1.2.3.1 && <2.2 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 default-language: Haskell2010 @@ -128,25 +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 >=2.0 && <2.2 + aeson >=2.0 && <2.3 , async >=2.2.2 && <2.3 - , base >=4.16.4.0 && <4.19 - , 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.7 + , 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 - , megaparsec >=9.2.2 && <9.6 + , megaparsec >=9.2.2 && <9.8 , modern-uri >=0.3.1.0 && <0.4 - , nri-env-parser >=0.1.0.0 && <0.3 - , nri-observability >=0.1.0 && <0.3 - , nri-prelude >=0.1.0.0 && <0.7 + , 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 , template-haskell >=2.16 && <3.0 - , text >=1.2.3.1 && <2.1 + , 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,14 +20,14 @@ 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 @@ -37,6 +37,6 @@ kv :| Dict.toList dict -- | creates a `NonEmptyDict` from a key, value, and dict -init :: Ord k => k -> v -> Dict.Dict k v -> NonEmptyDict k v +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 @@ -10,6 +10,7 @@ ( -- * Creating a redis handler Handler.handler, Handler.handlerAutoExtendExpire, + Handler.handlerWithoutNamespace, Internal.Handler, Internal.HandlerAutoExtendExpire, Internal.Handler', @@ -39,6 +40,8 @@ set, setex, setnx, + ttl, + Internal.TTLResponse (..), -- * Running Redis queries Internal.query, @@ -110,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. @@ -143,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 @@ -189,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/Handler.hs b/src/Redis/Handler.hs --- a/src/Redis/Handler.hs +++ b/src/Redis/Handler.hs @@ -4,6 +4,7 @@ module Redis.Handler ( handler, handlerAutoExtendExpire, + handlerWithoutNamespace, withQueryTimeoutMilliseconds, withoutQueryTimeout, ) @@ -31,15 +32,25 @@ -- | 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, _) <- 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 namespace settings) releaseHandler + (namespacedHandler, _) <- Data.Acquire.mkAcquire (acquireHandler (Just namespace) settings) releaseHandler namespacedHandler |> ( \handler' -> case Settings.defaultExpiry settings of Settings.NoDefaultExpiry -> @@ -95,7 +106,7 @@ Stack.withFrozenCallStack (Internal.doEval handler' queryTimeout script') } -acquireHandler :: Text -> Settings.Settings -> IO (Internal.Handler' x, Connection) +acquireHandler :: Maybe Text -> Settings.Settings -> IO (Internal.Handler' x, Connection) acquireHandler namespace settings = do connection <- do let connectionInfo = Settings.connectionInfo settings @@ -305,6 +316,10 @@ 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)) diff --git a/src/Redis/Hash.hs b/src/Redis/Hash.hs --- a/src/Redis/Hash.hs +++ b/src/Redis/Hash.hs @@ -153,7 +153,7 @@ -- | Creates a Redis API mapping a 'key' to Text textApi :: - Ord field => + (Ord field) => (key -> Text) -> (field -> Text) -> (Text -> Maybe field) -> @@ -162,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) -> @@ -170,7 +170,7 @@ byteStringApi = makeApi Codec.byteStringCodec makeApi :: - Ord field => + (Ord field) => Codec.Codec a -> (key -> Text) -> (field -> Text) -> @@ -211,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 @@ -11,6 +11,7 @@ HandlerAutoExtendExpire, HasAutoExtendExpire (..), Query (..), + TTLResponse (..), Database.Redis.Cursor, Database.Redis.cursor0, cmds, @@ -26,6 +27,7 @@ wrapQuery, maybesToDict, keysTouchedByQuery, + ttlResponseDecoder, ) where @@ -113,6 +115,7 @@ 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"]] @@ -170,6 +173,7 @@ 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)] @@ -233,7 +237,7 @@ { 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 :: Text, + namespace :: Maybe Text, maxKeySize :: Settings.MaxKeySize, queryTimeout :: Settings.QueryTimeout } @@ -256,7 +260,7 @@ -- to run them using 'transaction' 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) (queryTimeout handler)) @@ -268,15 +272,21 @@ -- see redis transaction semantics here: https://redis.io/topics/transactions 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) (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 (namespace handler ++ ":" ++ key)) 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' @@ -317,6 +327,7 @@ 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) @@ -360,6 +371,7 @@ 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 @@ -418,6 +430,9 @@ 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 @@ -485,6 +500,21 @@ 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 diff --git a/src/Redis/Script.hs b/src/Redis/Script.hs --- a/src/Redis/Script.hs +++ b/src/Redis/Script.hs @@ -70,7 +70,7 @@ -- -- It is what forces us to hav UndecidableInstances enabled. instance - GHC.TypeLits.TypeError ('GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.") => + (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." @@ -129,18 +129,18 @@ ScriptText text -> [|EvaluatedText text|] ScriptVariable var -> pure <| (TH.VarE 'evaluateScriptParam) `TH.AppE` (varToExp var) -evaluateScriptParam :: HasScriptParam a => a -> EvaluatedToken +evaluateScriptParam :: (HasScriptParam a) => a -> EvaluatedToken evaluateScriptParam scriptParam = case getScriptParam scriptParam of Key a -> - EvaluatedVariable - <| EvaluatedParam + EvaluatedVariable <| + EvaluatedParam { kind = RedisKey, value = unquoteString (Debug.toString a) } Literal a -> - EvaluatedVariable - <| EvaluatedParam + EvaluatedVariable <| + EvaluatedParam { kind = ArbitraryValue, value = unquoteString (Debug.toString a) } diff --git a/src/Redis/Set.hs b/src/Redis/Set.hs --- a/src/Redis/Set.hs +++ b/src/Redis/Set.hs @@ -134,7 +134,7 @@ byteStringApi = makeApi Codec.byteStringCodec makeApi :: - Ord a => + (Ord a) => Codec.Codec a -> (key -> Text) -> Api key a @@ -154,7 +154,6 @@ Internal.Smembers (toKey key) |> Internal.WithResult (Prelude.traverse codecDecoder) |> Internal.map Set.fromList, - sismember = \key val-> - Internal.Sismember (toKey key) (codecEncoder val) - + 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 @@ -160,8 +160,8 @@ in do uriPathText <- uriPathTextFromURI dbNum <- dbNumFromParams (URI.uriQuery uri) - pure - <| defaultConnectInfo + pure <| + defaultConnectInfo { connectPort = UnixSocket (Text.toList uriPathText), connectDatabase = dbNum, connectAuth = maybePasswordFromURI diff --git a/src/Redis/SortedSet.hs b/src/Redis/SortedSet.hs --- a/src/Redis/SortedSet.hs +++ b/src/Redis/SortedSet.hs @@ -138,7 +138,7 @@ byteStringApi = makeApi Codec.byteStringCodec makeApi :: - Ord a => + (Ord a) => Codec.Codec a -> (key -> Text) -> Api key a diff --git a/test/Helpers.hs b/test/Helpers.hs --- a/test/Helpers.hs +++ b/test/Helpers.hs @@ -11,7 +11,8 @@ data TestHandlers = TestHandlers { autoExtendExpireHandler :: Redis.HandlerAutoExtendExpire, - handler :: Redis.Handler + handler :: Redis.Handler, + noNamespaceHandler :: Redis.Handler } getHandlers :: Conduit.Acquire TestHandlers @@ -19,7 +20,8 @@ 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} - Prelude.pure TestHandlers {autoExtendExpireHandler, handler} + 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 @@ -37,4 +39,4 @@ -- -- We keep this here in case similar is true in later versions of GHC. goldenResultsDir :: Text -goldenResultsDir = "test/golden-results-9.2" +goldenResultsDir = "test/golden-results-9.8" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,8 +9,8 @@ main :: Prelude.IO () main = Conduit.withAcquire Helpers.getHandlers <| \testHandlers -> - Test.run - <| Test.describe + Test.run <| + Test.describe "nri-redis" [ Spec.Redis.tests testHandlers, Spec.Settings.tests, diff --git a/test/Spec/Redis.hs b/test/Spec/Redis.hs --- a/test/Spec/Redis.hs +++ b/test/Spec/Redis.hs @@ -30,6 +30,7 @@ res <- Platform.rootTracingSpanIO "test-request" + Platform.silentTrack (MVar.putMVar spanVar) "test-root" (\log -> Task.attempt log task) @@ -46,6 +47,7 @@ res <- Platform.rootTracingSpanIO "test-request" + Platform.silentTrack (MVar.putMVar spanVar) "test-root" (\log -> Task.attempt log task) @@ -57,12 +59,14 @@ Prelude.fail "Expected task to fail" tests :: TestHandlers -> Test.Test -tests TestHandlers {handler, autoExtendExpireHandler} = +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 "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 @@ -365,8 +369,8 @@ let firstKey = "scanTest::key1" let firstValue = "value 1" let nonEmptyDict = - NonEmptyDict.init firstKey firstValue - <| Dict.fromList + NonEmptyDict.init firstKey firstValue <| + Dict.fromList [ ("scanTest::key2", "value 2"), ("scanTest::key3", "value 3"), ("scanTest::key4", "value 4") @@ -389,8 +393,8 @@ let firstKey = "scanDeleteTest::key1" let firstValue = "value 1" let nonEmptyDict = - NonEmptyDict.init firstKey firstValue - <| Dict.fromList + NonEmptyDict.init firstKey firstValue <| + Dict.fromList [ ("scanDeleteTest::key2", "value 2"), ("scanDeleteTest::key3", "value 3"), ("scanDeleteTest::key4", "value 4") @@ -468,9 +472,74 @@ 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' = - handler' {Internal.namespace = Internal.namespace handler' ++ ":" ++ namespace} + 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 diff --git a/test/Spec/Settings.hs b/test/Spec/Settings.hs --- a/test/Spec/Settings.hs +++ b/test/Spec/Settings.hs @@ -21,7 +21,7 @@ -- -- 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 :: (Show a) => a -> a -> Expect.Expectation expectEqualShow x y = Expect.equal (show x) (show y) decoderTests :: Test.Test @@ -242,7 +242,7 @@ parseConnectInfoElseFailTest :: String -> Expect.Expectation' ConnectInfo parseConnectInfoElseFailTest uri = do - Expect.succeeds - <| case parseConnectInfo uri of + Expect.succeeds <| + case parseConnectInfo uri of Left err -> Task.fail <| "you wrote this test wrong, got err: " ++ Text.fromList err Right connectInfo -> pure connectInfo