@@ -6,10 +6,11 @@ import Control.Applicative
66import Control.Concurrent (threadDelay)
77import Control.Concurrent.Async (race_)
88import qualified Control.Concurrent.Lifted as L
9+import qualified Control.Exception.Lifted as L
910import Control.Concurrent.MVar
1011import Control.Concurrent.STM
1112import Control.Exception (Exception, throwIO, try)
12−import Control.Lens
13+import Control.Lens hiding (pre)
1314import Control.Monad
1415import Control.Monad.Except
1516import Control.Monad.Reader
@@ -359,43 +360,46 @@ createH dep = do
359360 { errBody = validationError [badNameText] [] }
360361 t1 <- liftIO $ now
361362 st <- ask
363+ let pgPool = pool st
362364 failIfImageNotFound (name dep) (tag dep)
363365 failIfGracefulShutdownActivated
364− runDeploymentBgWorker Nothing (name dep) $ do
365− let
366− q =
367− "INSERT INTO deployments (name, tag, status) \
368− \VALUES (?, ?, ?) RETURNING id"
369− pgPool = pool st
370− createDep :: PgPool -> Deployment -> IO [Only Int]
371− createDep p Deployment { name = n, tag = t } =
372− withResource p $ \conn ->
373− query conn q (n, t, CreatePending)
374− res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
375− dId <- case res of
376− Right ((Only depId) : _) ->
377− pure . DeploymentId $ depId
378− Right [] ->
379− throwError err404
380− { errBody = validationError ["Name not found"] [] }
381− Left (SqlError code _ _ _ _) | code == unique_violation ->
382− throwError err400
383− { errBody = validationError ["Deployment already exists"] [] }
384− Left (SqlError _ _ _ _ _) ->
385− throwError err409 { errBody = appError "Some database error" }
386− liftIO . withResource pgPool $ \conn ->
387− upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep)
388− liftBase $ sendReloadEvent st
389− liftBase $ updateDeploymentInfo (name dep) st
390− (ec, out, err) <- liftBase $ createDeployment dep st
391− t2 <- liftBase $ now
392− let
393− elTime = elapsedTime t2 t1
394− liftIO . withResource pgPool $ \conn ->
395− -- calling it directly now is fine since there is no previous status.
396− createDeploymentLog conn dep "create" ec elTime out err
397− liftBase $ sendReloadEvent st
398− liftBase $ handleExitCode ec
366+ runDeploymentBgWorker Nothing (name dep)
367+ ( do
368+ let
369+ q =
370+ "INSERT INTO deployments (name, tag, status) \
371+ \VALUES (?, ?, ?) RETURNING id"
372+ createDep :: PgPool -> Deployment -> IO [Only Int]
373+ createDep p Deployment { name = n, tag = t } =
374+ withResource p $ \conn ->
375+ query conn q (n, t, CreatePending)
376+ res :: Either SqlError [Only Int] <- liftIO . try $ createDep pgPool dep
377+ case res of
378+ Right ((Only depId) : _) ->
379+ pure . DeploymentId $ depId
380+ Right [] ->
381+ throwError err404
382+ { errBody = validationError ["Name not found"] [] }
383+ Left (SqlError code _ _ _ _) | code == unique_violation ->
384+ throwError err400
385+ { errBody = validationError ["Deployment already exists"] [] }
386+ Left (SqlError _ _ _ _ _) ->
387+ throwError err409 { errBody = appError "Some database error" }
388+ )
389+ $ \dId -> do
390+ liftIO . withResource pgPool $ \conn ->
391+ upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep)
392+ liftBase $ sendReloadEvent st
393+ liftBase $ updateDeploymentInfo (name dep) st
394+ (ec, out, err) <- liftBase $ createDeployment dep st
395+ t2 <- liftBase $ now
396+ let
397+ elTime = elapsedTime t2 t1
398+ liftIO . withResource pgPool $ \conn ->
399+ -- calling it directly now is fine since there is no previous status.
400+ createDeploymentLog conn dep "create" ec elTime out err
401+ liftBase $ sendReloadEvent st
402+ liftBase $ handleExitCode ec
399403 pure Success
400404
401405-- | Updates deployment info.
@@ -652,7 +656,7 @@ archiveH dName = do
652656 , "--name", coerce dName
653657 ]
654658 cmd = coerce $ archiveCommand st
655− runDeploymentBgWorker (Just ArchivePending) dName $ do
659+ runDeploymentBgWorker (Just ArchivePending) dName (pure ()) $ \() -> do
656660 log $ "call " <> unwords (cmd : args)
657661 (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
658662 t2 <- liftBase now
@@ -685,7 +689,7 @@ updateH dName dUpdate = do
685689 dId <- selectDeploymentId pgPool dName
686690 failIfImageNotFound dName dTag
687691 failIfGracefulShutdownActivated
688− runDeploymentBgWorker (Just UpdatePending) dName $ do
692+ runDeploymentBgWorker (Just UpdatePending) dName (pure ()) $ \() -> do
689693 (appOvs, depOvs) <- liftBase . withResource pgPool $ \conn ->
690694 withTransaction conn $ do
691695 deleteOldOverrides conn dId oldAppOvs oldDepOvs
@@ -930,7 +934,7 @@ cleanupH :: DeploymentName -> AppM CommandResponse
930934cleanupH dName = do
931935 failIfGracefulShutdownActivated
932936 st <- ask
933− runDeploymentBgWorker Nothing dName $ liftBase $ cleanupDeployment dName st
937+ runDeploymentBgWorker Nothing dName (pure ()) $ \ () -> liftBase $ cleanupDeployment dName st
934938 pure Success
935939
936940-- | Helper to cleanup deployment.
@@ -1005,7 +1009,7 @@ cleanArchiveH = do
10051009 withResource pgPool $ \conn -> query conn q (In archivedStatuses, archRetention)
10061010 runBgWorker . void $
10071011 for retrieved $ \(Only dName) ->
1008− runDeploymentBgWorker Nothing dName $ liftBase $ cleanupDeployment dName st
1012+ runDeploymentBgWorker Nothing dName (pure ()) $ \() -> liftBase $ cleanupDeployment dName st
10091013
10101014 pure Success
10111015
@@ -1018,7 +1022,7 @@ restoreH dName = do
10181022 dep <- selectDeployment dName
10191023 failIfImageNotFound (name dep) (tag dep)
10201024 failIfGracefulShutdownActivated
1021− runDeploymentBgWorker (Just CreatePending) dName $ do
1025+ runDeploymentBgWorker (Just CreatePending) dName (pure ()) $ \() -> do
10221026 dep' <- selectDeployment dName
10231027 liftBase $ updateDeploymentInfo dName st
10241028 (ec, out, err) <- liftBase $ createDeployment dep' st
@@ -1316,27 +1320,39 @@ runBgWorker act = void $ L.forkFinally act' cleanup
13161320
13171321-- | Same as 'runBgWorker' but also locks the specified deployment.
13181322runDeploymentBgWorker
1319− :: (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m)
1320− => Maybe DeploymentStatus -> DeploymentName -> m () -> m ()
1321−runDeploymentBgWorker newS dName m = do
1323+ :: forall m a. (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m)
1324+ => Maybe DeploymentStatus
1325+ -> DeploymentName
1326+ -> m a
1327+ -- ^ Think of this as running synchronously.
1328+ -- The resulting monad state will be forwarded to the calling context.
1329+ -> (a -> m ())
1330+ -- ^ The computation to run asynchronously.
1331+ -> m ()
1332+runDeploymentBgWorker newS dName pre post = do
13221333 st <- ask
1323− (err :: MVar (Either ServerError ())) <- L.newEmptyMVar
1334+ mainThread <- L.myThreadId
1335+ (err :: MVar (Either ServerError (StM m a))) <- L.newEmptyMVar
13241336 runBgWorker $ withLockedDeployment
13251337 dName
13261338 (L.putMVar err $ Left err409 {errBody = "The deployment is currently being processed."})
13271339 ( do
1328− let
1329− ok = do
1330− L.putMVar err $ Right ()
1340+ L.try (liftBaseWith \runInBase -> runInBase pre) >>= \case
1341+ Left (e :: L.SomeException) -> L.throwTo mainThread e
1342+ Right x -> do
1343+ proceed <- flip L.finally (L.tryPutMVar err (Left err500)) $ case newS of
1344+ Just newS' -> do
1345+ runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case
1346+ Left e -> L.putMVar err (Left e) $> False
1347+ Right () -> L.putMVar err (Right x) $> True
1348+ Nothing -> L.putMVar err (Right x) $> True
13311349 liftBase (sendReloadEvent st)
1332− m
1333− case newS of
1334− Just newS' ->
1335− runExceptT (assertDeploymentTransitionPossibleS dName newS') >>= \case
1336− Left e -> L.putMVar err $ Left e
1337− Right () -> ok
1338− Nothing -> ok
1350+ when proceed $ restoreM x >>= post
13391351 )
13401352 L.readMVar err >>= \case
13411353 Left e -> throwError e
1342− Right () -> return ()
1354+ Right (stm :: StM m a) -> do
1355+ -- This might be a bad idea in general, but with just ReaderT and ExceptT
1356+ -- it should be fine.
1357+ _ :: a <- restoreM stm
1358+ return ()