diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 120295e1f69..2f030168ba6 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -45,7 +45,6 @@ where import Bilge hiding (Request, header, options, statusCode) import Bilge.RPC import Cassandra -import Control.Concurrent.Async (async) import Control.Error hiding (err) import Control.Lens hiding ((.=)) import Control.Monad.Catch hiding (tryJust) @@ -61,6 +60,7 @@ import Network.Wai import Network.Wai.Utilities import qualified System.Logger as Logger import System.Logger.Class hiding (Error, info) +import UnliftIO (async) -- | TODO: 'Client' already has an 'Env'. Why do we need two? How does this even work? We should -- probably explain this here. @@ -96,13 +96,14 @@ newtype WithDefaultRedis a = WithDefaultRedis {runWithDefaultRedis :: Gundeck a} MonadMask, MonadReader Env, MonadClient, - MonadUnliftIO + MonadUnliftIO, + MonadLogger ) instance Redis.MonadRedis WithDefaultRedis where liftRedis action = do defaultConn <- view rstate - liftIO $ Redis.runRobust defaultConn action + Redis.runRobust defaultConn action instance Redis.RedisCtx WithDefaultRedis (Either Redis.Reply) where returnDecode :: Redis.RedisResult a => Redis.Reply -> WithDefaultRedis (Either Redis.Reply a) @@ -131,10 +132,10 @@ newtype WithAdditionalRedis a = WithAdditionalRedis {runWithAdditionalRedis :: G instance Redis.MonadRedis WithAdditionalRedis where liftRedis action = do defaultConn <- view rstate - ret <- liftIO $ Redis.runRobust defaultConn action + ret <- Redis.runRobust defaultConn action mAdditionalRedisConn <- view rstateAdditionalWrite - liftIO . for_ mAdditionalRedisConn $ \additionalRedisConn -> + for_ mAdditionalRedisConn $ \additionalRedisConn -> -- We just fire and forget this call, as there is not much we can do if -- this fails. async $ Redis.runRobust additionalRedisConn action diff --git a/services/gundeck/src/Gundeck/Redis.hs b/services/gundeck/src/Gundeck/Redis.hs index efaa8f01e6c..74b116cf374 100644 --- a/services/gundeck/src/Gundeck/Redis.hs +++ b/services/gundeck/src/Gundeck/Redis.hs @@ -37,6 +37,8 @@ import Control.Retry import Database.Redis import Imports import qualified System.Logger as Log +import System.Logger.Class (MonadLogger) +import qualified System.Logger.Class as LogClass import System.Logger.Extended import UnliftIO.Exception @@ -102,25 +104,30 @@ connectRobust l retryStrategy connectLowLevel = do unlessM (tryPutMVar robustConnection newReConnection) $ void $ swapMVar robustConnection newReConnection + logEx :: Show e => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () + logEx lLevel e description = lLevel $ Log.msg (Log.val description) . Log.field "error" (show e) + -- | Run a 'Redis' action through a 'RobustConnection'. -- -- Blocks on connection errors as long as the connection is not reestablished. -- Without externally enforcing timeouts, this may lead to leaking threads. -runRobust :: RobustConnection -> Redis a -> IO a +runRobust :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => RobustConnection -> Redis a -> m a runRobust mvar action = do robustConnection <- readMVar mvar catches - (runRedis (_rrConnection robustConnection) action) - [ Handler (\(_ :: ConnectionLostException) -> reconnectRetry robustConnection), -- Redis connection lost during request - Handler (\(_ :: IOException) -> reconnectRetry robustConnection) -- Redis unreachable + (liftIO $ runRedis (_rrConnection robustConnection) action) + [ logAndHandle $ Handler (\(_ :: ConnectionLostException) -> reconnectRetry robustConnection), -- Redis connection lost during request + logAndHandle $ Handler (\(_ :: IOException) -> reconnectRetry robustConnection) -- Redis unreachable ] where reconnectRetry robustConnection = do - _rrReconnect robustConnection + liftIO $ _rrReconnect robustConnection runRobust mvar action -logEx :: Show e => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () -logEx lLevel e description = lLevel $ Log.msg $ Log.val $ description <> ": " <> fromString (show e) + logAndHandle (Handler handler) = + Handler $ \e -> do + LogClass.err $ Log.msg (Log.val "Redis connection failed") . Log.field "error" (show e) + handler e data PingException = PingException Reply deriving (Show)