chore(tests): fix tests

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

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

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