From 7038099389fcca684a9e1a3f28f76629e0c194bd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 18 Sep 2020 11:34:58 +0200 Subject: [PATCH] fix(jobs): delimit resource allocation to within handler Hopefully fixes memory leak in production --- src/Jobs.hs | 2 +- src/Utils.hs | 20 +++++++++++++++++++- src/Yesod/Core/Types/Instances.hs | 12 +++--------- src/Yesod/Core/Types/Instances/Catch.hs | 18 ++++++++++++++++++ 4 files changed, 41 insertions(+), 11 deletions(-) create mode 100644 src/Yesod/Core/Types/Instances/Catch.hs diff --git a/src/Jobs.hs b/src/Jobs.hs index 7e849400f..5703bff62 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -383,7 +383,7 @@ mkLogIdent :: JobWorkerId -> Text mkLogIdent wId = "Job-Executor " <> showWorkerId wId handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) () -handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do +handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorkerState wNum JobWorkerBusy $ do $logDebugS logIdent $ tshow jctl res <- fmap (either Just $ const Nothing) . withJobWorkerState wNum (JobWorkerExecJobCtl jctl) . try' $ handleCmd jctl sentRes <- mapReaderT (liftIO . atomically) $ do diff --git a/src/Utils.hs b/src/Utils.hs index 5f25e1ac3..446f66d30 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -3,7 +3,7 @@ module Utils , List.nub, List.nubBy ) where -import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch) +import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold @@ -117,6 +117,11 @@ import Unsafe.Coerce import System.FilePath as Utils (addExtension, isExtensionOf) import System.FilePath (dropDrive) +import Yesod.Core.Types +import Yesod.Core.Types.Instances.Catch () +import Control.Monad.Trans.Resource +import Control.Monad.Reader.Class (MonadReader(local)) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -187,6 +192,19 @@ instance HasContentType YamlValue where toYAML :: ToJSON a => a -> YamlValue toYAML = YamlValue . toJSON + +delimitInternalState :: forall site a. HandlerFor site a -> HandlerFor site a +-- | Switches the `InternalState` contained within the environment of `HandlerFor` to new one created with `bracket` +-- +-- Therefor all `ResourceT`-Resources allocated within the inner `HandlerFor`-Action are collected at the end of it. +delimitInternalState act = bracket createInternalState closeInternalState $ \newInternalState -> local (renewEnviron newInternalState) act + where + renewEnviron newInternalState HandlerData{..} + = HandlerData { handlerResource = newInternalState + , .. + } + + --------------------- -- Text and String -- --------------------- diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 924c27673..50f96b0ad 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -24,24 +24,18 @@ import Language.Haskell.TH import Control.Monad.Reader (MonadReader(..)) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Base (MonadBase) -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) +import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Random.Class (MonadRandom) import Control.Monad.Morph (MFunctor, MMonad) + +import Yesod.Core.Types.Instances.Catch () deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site) -deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) -deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) -deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) - -deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site) -deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site) -deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) - deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadBase IO (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site) diff --git a/src/Yesod/Core/Types/Instances/Catch.hs b/src/Yesod/Core/Types/Instances/Catch.hs new file mode 100644 index 000000000..8e2a8388b --- /dev/null +++ b/src/Yesod/Core/Types/Instances/Catch.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Core.Types.Instances.Catch + () where + +import ClassyPrelude.Yesod +import Yesod.Core.Types + +import Control.Monad.Catch (MonadMask, MonadCatch) + + +deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) +deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) +deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) + +deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site) +deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site) +deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site)