diff --git a/app/DevelMain.hs b/app/DevelMain.hs index 0a7a89562..ab065aaa2 100644 --- a/app/DevelMain.hs +++ b/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 () diff --git a/src/Jobs.hs b/src/Jobs.hs index c65410dc0..39a1d7bac 100644 --- a/src/Jobs.hs +++ b/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' diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 5c2a504f7..9726b5222 100644 --- a/src/Utils/Sql.hs +++ b/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