From 7933877bed9545b3bccac6f6f7b9097292d75a05 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Sat, 4 May 2019 17:52:02 +0200
Subject: [PATCH] Enable job-handling explicitly where needed

---
 src/Application.hs | 28 +++++++++++++---------------
 src/Foundation.hs  |  2 +-
 test/Database.hs   |  2 --
 3 files changed, 14 insertions(+), 18 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 503386d64..11eb60210 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -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
 
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 05b086ed0..8ce8987de 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -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
diff --git a/test/Database.hs b/test/Database.hs
index 3774e09ea..257edf9bd 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -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 ()