Enable job-handling explicitly where needed
This commit is contained in:
parent
5bf7c42a66
commit
7933877bed
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user