Enable job-handling explicitly where needed

This commit is contained in:
Gregor Kleen 2019-05-04 17:52:02 +02:00
parent 5bf7c42a66
commit 7933877bed
3 changed files with 14 additions and 18 deletions

View File

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev, getAppDevSettings
( getAppDevSettings
, appMain
, develMain
, makeFoundation
@ -202,9 +202,6 @@ makeFoundation appSettings'@AppSettings{..} = do
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
$logDebugS "setup" "Job-Handling"
handleJobs foundation
-- Return the foundation
$logDebugS "setup" "Done"
return foundation
@ -343,15 +340,6 @@ warpSettings foundation = defaultSettings
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
getApplicationDev = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv
@ -369,8 +357,14 @@ adjustSettings = execStateT $ do
-- | main function for use by yesod devel
develMain :: IO ()
develMain = runResourceT $
liftIO . develMainHelper . return =<< getApplicationDev
develMain = runResourceT $ do
settings <- getAppDevSettings
foundation <- makeFoundation settings
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app <- makeApplication foundation
handleJobs foundation
liftIO . develMainHelper $ return (wsettings, app)
-- | The @main@ function for an executable running this site.
appMain :: MonadResourceBase m => m ()
@ -381,6 +375,9 @@ appMain = runResourceT $ do
foundation <- makeFoundation settings
runAppLoggingT foundation $ do
$logDebugS "setup" "Job-Handling"
handleJobs foundation
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
@ -414,6 +411,7 @@ getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWor
getApplicationRepl = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
handleJobs foundation
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation

View File

@ -113,7 +113,7 @@ data UniWorX = UniWorX
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe LdapPool
, appWidgetMemcached :: Maybe Memcached.Connection
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
, appHttpManager :: Manager
, appLogger :: (ReleaseKey, TVar Logger)
, appLogSettings :: TVar LogSettings

View File

@ -53,8 +53,6 @@ main = do
rawExecute "drop owned by current_user;" []
DBTruncate -> db $ do
foundation <- getYesod
stopJobCtl foundation
release . fst $ appLogger foundation
liftIO . destroyAllResources $ appConnPool foundation
truncateDb
DBMigrate -> db $ return ()