fix: improve async behaviour

app/DevelMain.hs

@@ -77,10 +77,7 @@ update = do
       (port, site, app) <- getApplicationRepl
       resourceForkIO $ do
         finally (liftIO $ runSettings (setPort port defaultSettings) app)
-          -- Note that this implies concurrency
-          -- between shutdownApp and the next app that is starting.
-          -- Normally this should be fine
-          (liftIO $ putMVar done () >> shutdownApp site)
+          (liftIO $ shutdownApp site >> putMVar done ())
 
 -- | kill the server
 shutdown :: IO ()

src/Jobs.hs

@@ -55,8 +55,6 @@ import Data.Time.Zones
 import Control.Concurrent.STM (retry)
 import Control.Concurrent.STM.Delay
 
-import UnliftIO.Concurrent (forkIO)
-
 
 import Jobs.Handler.SendNotification
 import Jobs.Handler.SendTestEmail
@@ -143,6 +141,9 @@ manageJobPool foundation@UniWorX{..}
 
     spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ())
     spawnMissingWorkers = do
+      shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
+      guard $ not shouldTerminate'
+  
       oldState <- takeTMVar appJobState
       let missing = num - Map.size (jobWorkers oldState)
       guard $ missing > 0
@@ -204,6 +205,10 @@ manageJobPool foundation@UniWorX{..}
     terminateGracefully = do
       shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
       guard shouldTerminate
+
+      oldState <- takeTMVar appJobState
+      guard $ 0 == Map.size (jobWorkers oldState)
+
       return . callCC $ \terminate -> do
         $logInfoS "JobPoolManager" "Shutting down"
         terminate ()
@@ -214,7 +219,7 @@ stopJobCtl UniWorX{appJobState} = do
   didStop <- atomically $ do
     jState <- tryReadTMVar appJobState
     for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown ()
-  whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do
+  whenIsJust didStop $ \jSt' -> void . atomically $ do
     workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState
     mapM_ (void . waitCatchSTM) $
       [ jobPoolManager jSt'

src/Utils/Sql.hs

@@ -7,6 +7,7 @@ import ClassyPrelude.Yesod
 import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint)
 import Control.Monad.Catch (MonadMask)
 
+import Database.Persist.Sql
 import Database.Persist.Sql.Raw.QQ
 
 import Control.Retry
@@ -14,20 +15,22 @@ import Control.Retry
 import Control.Lens ((&))
 
 
-retryTransaction :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => m a -> m a
-retryTransaction = recovering policy [logRetries suggestRetry logRetry] . const
+setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
+setSerializable act = recovering policy [logRetries suggestRetry logRetry] act'
   where
-    policy :: RetryPolicyM m
+    policy :: RetryPolicyM (ReaderT SqlBackend m)
     policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6
 
-    suggestRetry :: SqlError -> m Bool
+    suggestRetry :: SqlError -> ReaderT SqlBackend m Bool
     suggestRetry SqlError{sqlErrorHint} = return $ "The transaction might succeed if retried." `isInfixOf` sqlErrorHint
   
     logRetry :: Bool -- ^ Will retry
              -> SqlError
              -> RetryStatus
-             -> m ()
+             -> ReaderT SqlBackend m ()
     logRetry shouldRetry err status = $logDebugS "Sql" . pack $ defaultLogMsg shouldRetry err status
 
-setSerializable :: (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
-setSerializable act = retryTransaction $ [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
+    act' :: RetryStatus -> ReaderT SqlBackend m a
+    act' RetryStatus{..}
+      | rsIterNumber == 0 = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
+      | otherwise         = transactionUndoWithIsolation Serializable *> act