fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(jobs): delimit resource allocation to within handler

Browse Source 
Hopefully fixes memory leak in production
This commit is contained in:
Gregor Kleen 2020-09-18 11:34:58 +02:00
parent e099e13816
commit 7038099389
4 changed files with 41 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Jobs.hs
View File

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

20
src/Utils.hs
View File

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

12
src/Yesod/Core/Types/Instances.hs
View File

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

18
src/Yesod/Core/Types/Instances/Catch.hs Normal file
View File

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