Merge pull request #154 from NoRedInk/redis-without-namespace

nri-redis: add handlerWithoutNamespace constructor

Author: waj

nri-redis/CHANGELOG.md

@@ -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`

nri-redis/nri-redis.cabal

@@ -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

nri-redis/package.yaml

@@ -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

nri-redis/src/Redis.hs

@@ -10,6 +10,7 @@ module Redis
   ( -- * Creating a redis handler
     Handler.handler,
     Handler.handlerAutoExtendExpire,
+    Handler.handlerWithoutNamespace,
     Internal.Handler,
     Internal.HandlerAutoExtendExpire,
     Internal.Handler',

nri-redis/src/Redis/Handler.hs

@@ -4,6 +4,7 @@
 module Redis.Handler
   ( handler,
     handlerAutoExtendExpire,
+    handlerWithoutNamespace,
     withQueryTimeoutMilliseconds,
     withoutQueryTimeout,
   )
@@ -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 ->
@@ -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

nri-redis/src/Redis/Internal.hs

@@ -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
   }
@@ -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))
 
@@ -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'

nri-redis/test/Helpers.hs

@@ -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

nri-redis/test/Spec/Redis.hs

@@ -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
@@ -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

nri-redis/test/golden-results-9.8/observability-spec-reporting-redis-counter-query

@@ -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
@@ -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
                     }
                 )

nri-redis/test/golden-results-9.8/observability-spec-reporting-redis-counter-transaction

@@ -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
@@ -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
                     }
                 )