diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/nri-redis.cabal b/nri-redis.cabal --- a/nri-redis.cabal +++ b/nri-redis.cabal @@ -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 . category: Web diff --git a/src/Redis.hs b/src/Redis.hs --- a/src/Redis.hs +++ b/src/Redis.hs @@ -18,6 +18,8 @@ Settings.decoder, Settings.decoderWithEnvVarPrefix, Settings.decoderWithCustomConnectionString, + Handler.withQueryTimeoutMilliseconds, + Handler.withoutQueryTimeout, -- * Creating a redis API jsonApi, 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,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 diff --git a/src/Redis/Internal.hs b/src/Redis/Internal.hs --- a/src/Redis/Internal.hs +++ b/src/Redis/Internal.hs @@ -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 diff --git a/test/Spec/Redis.hs b/test/Spec/Redis.hs --- a/test/Spec/Redis.hs +++ b/test/Spec/Redis.hs @@ -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