Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 6 additions & 0 deletions nri-redis/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
# 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`
Expand Down
2 changes: 1 addition & 1 deletion nri-redis/nri-redis.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ cabal-version: 1.18
-- see: https://github.com/sol/hpack

name: nri-redis
version: 0.4.0.0
version: 0.4.1.0
synopsis: An intuitive hedis wrapper library.
description: Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis#readme>.
category: Web
Expand Down
2 changes: 1 addition & 1 deletion nri-redis/package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@ synopsis: An intuitive hedis wrapper library.
description: Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis#readme>.
homepage: https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-redis#readme
author: NoRedInk
version: 0.4.0.0
version: 0.4.1.0
maintainer: haskell-open-source@noredink.com
copyright: 2024 NoRedInk Corp.
github: NoRedInk/haskell-libraries/nri-redis
Expand Down
1 change: 1 addition & 0 deletions nri-redis/src/Redis.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ module Redis
( -- * Creating a redis handler
Handler.handler,
Handler.handlerAutoExtendExpire,
Handler.handlerWithoutNamespace,
Internal.Handler,
Internal.HandlerAutoExtendExpire,
Internal.Handler',
Expand Down
17 changes: 14 additions & 3 deletions nri-redis/src/Redis/Handler.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
module Redis.Handler
( handler,
handlerAutoExtendExpire,
handlerWithoutNamespace,
withQueryTimeoutMilliseconds,
withoutQueryTimeout,
)
Expand Down Expand Up @@ -31,15 +32,25 @@ 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, _) <- 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 ->
Expand Down Expand Up @@ -95,7 +106,7 @@ defaultExpiryKeysAfterSeconds secs handler' =
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
Expand Down
14 changes: 10 additions & 4 deletions nri-redis/src/Redis/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -237,7 +237,7 @@ 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 :: Text,
namespace :: Maybe Text,
maxKeySize :: Settings.MaxKeySize,
queryTimeout :: Settings.QueryTimeout
}
Expand All @@ -260,7 +260,7 @@ type HandlerAutoExtendExpire = Handler' 'AutoExtendExpire
-- 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))

Expand All @@ -272,15 +272,21 @@ query handler query' =
-- 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'
Expand Down
6 changes: 4 additions & 2 deletions nri-redis/test/Helpers.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,15 +11,17 @@ import qualified Prelude

data TestHandlers = TestHandlers
{ autoExtendExpireHandler :: Redis.HandlerAutoExtendExpire,
handler :: Redis.Handler
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}
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
Expand Down
55 changes: 52 additions & 3 deletions nri-redis/test/Spec/Redis.hs
Original file line number Diff line number Diff line change
Expand Up @@ -57,13 +57,14 @@ spanForFailingTask task =
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 "ttl tests" (ttlTests handler autoExtendExpireHandler)
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
Expand Down Expand Up @@ -486,9 +487,57 @@ ttlTests handler autoExtendExpireHandler =
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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "query"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 123
, srcLocStartLine = 124
, srcLocStartCol = 9
, srcLocEndLine = 123
, srcLocEndLine = 124
, srcLocEndCol = 28
}
)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "transaction"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 130
, srcLocStartLine = 131
, srcLocStartCol = 9
, srcLocEndLine = 130
, srcLocEndLine = 131
, srcLocEndCol = 34
}
)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "query"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 95
, srcLocStartLine = 96
, srcLocStartCol = 9
, srcLocEndLine = 95
, srcLocEndLine = 96
, srcLocEndCol = 25
}
)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "transaction"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 102
, srcLocStartLine = 103
, srcLocStartCol = 9
, srcLocEndLine = 102
, srcLocEndLine = 103
, srcLocEndCol = 31
}
)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "query"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 109
, srcLocStartLine = 110
, srcLocStartCol = 9
, srcLocEndLine = 109
, srcLocEndLine = 110
, srcLocEndCol = 25
}
)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "transaction"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 116
, srcLocStartLine = 117
, srcLocStartCol = 9
, srcLocEndLine = 116
, srcLocEndLine = 117
, srcLocEndCol = 31
}
)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ TracingSpan
Just
( "rootTracingSpanIO"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 31
Expand All @@ -29,12 +29,12 @@ TracingSpan
Just
( "query"
, SrcLoc
{ srcLocPackage = "nri-redis-0.4.0.0-inplace-tests"
{ srcLocPackage = "nri-redis-0.4.1.0-inplace-tests"
, srcLocModule = "Spec.Redis"
, srcLocFile = "test/Spec/Redis.hs"
, srcLocStartLine = 81
, srcLocStartLine = 82
, srcLocStartCol = 9
, srcLocEndLine = 81
, srcLocEndLine = 82
, srcLocEndCol = 20
}
)
Expand Down
Loading
Loading