nri-redis 0.2.0.2 → 0.2.0.3
raw patch · 6 files changed
+127/−69 lines, 6 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Redis: withQueryTimeoutMilliseconds :: Int -> Handler' x -> Task () (Handler' x)
+ Redis: withoutQueryTimeout :: Handler' x -> Task () (Handler' x)
Files
- CHANGELOG.md +6/−0
- nri-redis.cabal +1/−1
- src/Redis.hs +2/−0
- src/Redis/Handler.hs +49/−53
- src/Redis/Internal.hs +22/−13
- test/Spec/Redis.hs +47/−2
CHANGELOG.md view
@@ -1,4 +1,10 @@+# 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
nri-redis.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: nri-redis-version: 0.2.0.2+version: 0.2.0.3 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
src/Redis.hs view
@@ -18,6 +18,8 @@ Settings.decoder, Settings.decoderWithEnvVarPrefix, Settings.decoderWithCustomConnectionString,+ Handler.withQueryTimeoutMilliseconds,+ Handler.withoutQueryTimeout, -- * Creating a redis API jsonApi,
src/Redis/Handler.hs view
@@ -4,6 +4,8 @@ module Redis.Handler ( handler, handlerAutoExtendExpire,+ withQueryTimeoutMilliseconds,+ withoutQueryTimeout, ) where @@ -16,6 +18,7 @@ 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@@ -30,12 +33,6 @@ handler namespace settings = do (namespacedHandler, _) <- Data.Acquire.mkAcquire (acquireHandler namespace settings) releaseHandler namespacedHandler- |> ( \handler' ->- case Settings.queryTimeout settings of- Settings.NoQueryTimeout -> handler'- Settings.TimeoutQueryAfterMilliseconds milliseconds ->- timeoutAfterMilliseconds (toFloat milliseconds) handler'- ) |> Prelude.pure -- | Produce a namespaced handler for Redis access.@@ -44,12 +41,6 @@ handlerAutoExtendExpire namespace settings = do (namespacedHandler, _) <- Data.Acquire.mkAcquire (acquireHandler namespace settings) releaseHandler namespacedHandler- |> ( \handler' ->- case Settings.queryTimeout settings of- Settings.NoQueryTimeout -> handler'- Settings.TimeoutQueryAfterMilliseconds milliseconds ->- timeoutAfterMilliseconds (toFloat milliseconds) handler'- ) |> ( \handler' -> case Settings.defaultExpiry settings of Settings.NoDefaultExpiry -> -- We create the handler as part of starting the application. Throwing@@ -69,20 +60,20 @@ ) |> liftIO -timeoutAfterMilliseconds :: Float -> Internal.Handler' x -> Internal.Handler' x-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,- Internal.doEval =- Stack.withFrozenCallStack (Internal.doEval handler')- >> Task.timeout milliseconds Internal.TimeoutError- }+-- | 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@@ -93,15 +84,15 @@ |> Internal.sequence |> Internal.map2 (\res _ -> res) query' in handler'- { Internal.doQuery = \query' ->+ { Internal.doQuery = \queryTimeout query' -> wrapWithExpire query'- |> Stack.withFrozenCallStack (Internal.doQuery handler'),- Internal.doTransaction = \query' ->+ |> Stack.withFrozenCallStack (Internal.doQuery handler') queryTimeout,+ Internal.doTransaction = \queryTimeout query' -> wrapWithExpire query'- |> Stack.withFrozenCallStack (Internal.doTransaction handler'),- Internal.doEval = \script' ->+ |> 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' script')+ Stack.withFrozenCallStack (Internal.doEval handler' queryTimeout script') } acquireHandler :: Text -> Settings.Settings -> IO (Internal.Handler' x, Connection)@@ -123,10 +114,10 @@ anything <- Platform.doAnythingHandler pure ( Internal.Handler'- { Internal.doQuery = \query ->+ { Internal.doQuery = \queryTimeout query -> let PreparedQuery {redisCtx} = doRawQuery query- in Stack.withFrozenCallStack platformRedis (Internal.cmds query) connection anything redisCtx,- Internal.doTransaction = \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@@ -137,11 +128,12 @@ 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.doEval = \script' ->- Stack.withFrozenCallStack (platformRedisScript script' connection anything),+ |> 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.maxKeySize = Settings.maxKeySize settings,+ Internal.queryTimeout = Settings.queryTimeout settings }, connection )@@ -306,9 +298,9 @@ |> PreparedQuery |> map (Ok << Prelude.fromIntegral) Internal.Sismember key val ->- Database.Redis.sismember (toB key) val- |> PreparedQuery- |> map Ok+ Database.Redis.sismember (toB key) val+ |> PreparedQuery+ |> map Ok Internal.Smembers key -> Database.Redis.smembers (toB key) |> PreparedQuery@@ -362,13 +354,14 @@ } platformRedis ::- Stack.HasCallStack =>+ (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 action =+platformRedis cmds connection anything queryTimeout action = Database.Redis.runRedis (connectionHedis connection) action |> map toResult |> map@@ -379,7 +372,7 @@ ) |> handleExceptions |> Platform.doAnything anything- |> Stack.withFrozenCallStack Internal.traceQuery cmds (connectionHost connection) (connectionPort connection)+ |> Stack.withFrozenCallStack Internal.wrapQuery queryTimeout cmds (connectionHost connection) (connectionPort connection) toResult :: Either Database.Redis.Reply a -> Result Internal.Error a toResult reply =@@ -406,17 +399,18 @@ Script.Script a -> Connection -> Platform.DoAnythingHandler ->+ Settings.QueryTimeout -> Task Internal.Error a-platformRedisScript script connection anything = do+platformRedisScript script connection anything queryTimeout = do -- Try EVALSHA- evalsha script connection anything+ 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- evalsha script connection anything+ loadScript script connection anything queryTimeout+ evalsha script connection anything queryTimeout _ -> Task.fail err ) @@ -425,8 +419,9 @@ Script.Script a -> Connection -> Platform.DoAnythingHandler ->+ Settings.QueryTimeout -> Task Internal.Error a-evalsha script connection anything =+evalsha script connection anything queryTimeout = Database.Redis.evalsha (toB (Script.luaScriptHash script)) (map toB (Script.keys script))@@ -435,15 +430,16 @@ |> map toResult |> handleExceptions |> Platform.doAnything anything- |> Stack.withFrozenCallStack Internal.traceQuery [Script.evalShaString script] (connectionHost connection) (connectionPort connection)+ |> Stack.withFrozenCallStack Internal.wrapQuery queryTimeout [Script.evalShaString script] (connectionHost connection) (connectionPort connection) loadScript ::- Stack.HasCallStack =>+ (Stack.HasCallStack) => Script.Script a -> Connection -> Platform.DoAnythingHandler ->+ Settings.QueryTimeout -> Task Internal.Error ()-loadScript script connection anything = do+loadScript script connection anything queryTimeout = do Database.Redis.scriptLoad (toB (Script.luaScript script)) |> Database.Redis.runRedis (connectionHedis connection) |> map toResult@@ -451,7 +447,7 @@ -- The result is the hash, which we already have. No sense in decoding it. |> map (map (\_ -> ())) |> Platform.doAnything anything- |> Stack.withFrozenCallStack Internal.traceQuery [Script.scriptLoadString script] (connectionHost connection) (connectionPort connection)+ |> Stack.withFrozenCallStack Internal.wrapQuery queryTimeout [Script.scriptLoadString script] (connectionHost connection) (connectionPort connection) toB :: Text -> Data.ByteString.ByteString toB = Data.Text.Encoding.encodeUtf8
src/Redis/Internal.hs view
@@ -23,7 +23,7 @@ eval, foldWithScan, -- internal tools- traceQuery,+ wrapQuery, maybesToDict, keysTouchedByQuery, )@@ -111,7 +111,7 @@ 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 , "*****"]]+ Sismember key _ -> [unwords ["SISMEMBER", key, "*****"]] Smembers key -> [unwords ["SMEMBERS", 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]]@@ -230,11 +230,12 @@ -- 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. Query a -> Task Error a,- doTransaction :: Stack.HasCallStack => forall a. Query a -> Task Error a,- doEval :: Stack.HasCallStack => forall a. Database.Redis.RedisResult a => Script.Script a -> Task Error a,+ { 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,- maxKeySize :: Settings.MaxKeySize+ maxKeySize :: Settings.MaxKeySize,+ queryTimeout :: Settings.QueryTimeout } -- | This is a type alias of a handler parametrized by a value that indicates@@ -253,11 +254,11 @@ -- 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' x -> Query a -> Task Error a+query :: (Stack.HasCallStack) => Handler' x -> Query a -> Task Error a query handler query' = namespaceQuery (namespace 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@@ -265,16 +266,16 @@ -- -- 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' x -> Query a -> Task Error a+transaction :: (Stack.HasCallStack) => Handler' x -> Query a -> Task Error a transaction handler query' = namespaceQuery (namespace 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 (namespace handler ++ ":" ++ key)) script- |> Task.andThen (Stack.withFrozenCallStack (doEval handler))+ |> Task.andThen (Stack.withFrozenCallStack (doEval handler) (queryTimeout handler)) namespaceQuery :: Text -> Query a -> Task err (Query a) namespaceQuery prefix query' =@@ -424,7 +425,7 @@ 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@@ -435,7 +436,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
test/Spec/Redis.hs view
@@ -23,7 +23,7 @@ -- 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 :: (Show e) => Task e a -> Expect.Expectation' Platform.TracingSpan spanForTask task = Expect.fromIO <| do spanVar <- MVar.newEmptyMVar@@ -39,6 +39,23 @@ 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"+ (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} = Test.describe@@ -113,7 +130,35 @@ |> spanForTask span |> Debug.toString- |> Expect.equalToContentsOf (goldenResultsDir ++ "/observability-spec-reporting-redis-counter-transaction")+ |> 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