diff --git a/src/Application.hs b/src/Application.hs index 6e2d45fd7..7291fda1c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -478,7 +478,7 @@ getApplicationRepl = do return (getPort wsettings, foundation, app1) -shutdownApp :: MonadIO m => UniWorX -> m () +shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do diff --git a/src/Jobs.hs b/src/Jobs.hs index f8cdb2ee5..4769178ff 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -113,16 +113,14 @@ manageJobPool, manageCrontab :: forall m. => UniWorX -> m () manageCrontab foundation@UniWorX{..} = do context <- atomically . fmap jobContext $ readTMVar appJobState - liftIO . unsafeHandler foundation . void $ do + let awaitTermination = atomically $ do + shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + guard shouldTerminate + liftIO . race_ awaitTermination . unsafeHandler foundation . void $ do + atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState runReaderT ?? foundation $ writeJobCtlBlock JobCtlDetermineCrontab - evalRWST execCrontab' context HashMap.empty - where - execCrontab' = do - shouldTerminate <- atomically $ readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown - if - | shouldTerminate -> return () - | otherwise -> execCrontab *> execCrontab' + evalRWST (forever execCrontab) context HashMap.empty manageJobPool foundation@UniWorX{..} @@ -158,6 +156,7 @@ manageJobPool foundation@UniWorX{..} runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do $logInfoS logIdent "Started" runConduit $ streamChan .| handleJobs' workerId + $logInfoS logIdent "Stopped" worker <- allocateLinkedAsync runWorker tell . Endo $ \cSt -> cSt @@ -196,18 +195,18 @@ manageJobPool foundation@UniWorX{..} $logInfoS "JobPoolManager" "Shutting down" terminate () -stopJobCtl :: MonadIO m => UniWorX -> m () +stopJobCtl :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () -- ^ Stop all worker threads currently running stopJobCtl UniWorX{appJobState} = do - atomically $ do - JobState{..} <- readTMVar appJobState - putTMVar jobShutdown () - atomically $ do - JobState{..} <- takeTMVar appJobState + didStop <- atomically $ do + jState <- tryReadTMVar appJobState + for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown () + whenIsJust didStop $ \jSt' -> void . fork . atomically $ do + workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState mapM_ (void . waitCatchSTM) $ - [ jobPoolManager - , jobCron - ] ++ Map.keys jobWorkers + [ jobPoolManager jSt' + , jobCron jSt' + ] ++ workers execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerT UniWorX IO) () -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have diff --git a/test/TestImport.hs b/test/TestImport.hs index 9164c3144..48e0b5d27 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -3,7 +3,7 @@ module TestImport , module X ) where -import Application (makeFoundation, makeLogWare) +import Application (makeFoundation, makeLogWare, shutdownApp) import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc) import Database.Persist as X hiding (get) import Database.Persist.Sql as X (SqlPersistM) @@ -31,7 +31,7 @@ import Test.QuickCheck.Classes.Binary as X import Data.Proxy as X import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr) -import Jobs (handleJobs, stopJobCtl) +import Jobs (handleJobs) import Numeric.Natural as X import Control.Lens as X hiding ((<.), elements) @@ -42,7 +42,6 @@ import Database (truncateDb) import Database as X (fillDb) import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) -import Data.Pool (destroyAllResources) import Settings @@ -51,6 +50,8 @@ import qualified Data.CaseInsensitive as CI import Data.Typeable +import Handler.Utils (runAppLoggingT) + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do @@ -74,13 +75,10 @@ withApp = around $ \act -> runResourceT $ do [] useEnv foundation <- makeFoundation settings - let - stopDBAccess = do - stopJobCtl foundation - liftIO . destroyAllResources $ appConnPool foundation - bracket_ stopDBAccess (handleJobs foundation) $ wipeDB foundation + wipeDB foundation + runAppLoggingT foundation $ handleJobs foundation logWare <- makeLogWare foundation - lift $ act (foundation, logWare) + lift $ act (foundation, logWare) `finally` shutdownApp foundation -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each