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

View File

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

View File

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