@@ -557,6 +557,13 @@ transitionErrorToServerError = \case
557557 where
558558 show'' = BSLC.pack . show
559559
560+getDeploymentS
561+ :: (MonadReader AppState m, MonadBase IO m, MonadError ServerError m)
562+ => Connection -> DeploymentName -> m DeploymentFullInfo
563+getDeploymentS conn dName = (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
564+ [x] -> return x
565+ _ -> throwError err404 {errBody = "Deployment not found."}
566+
560567transitionToStatus
561568 :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m)
562569 => DeploymentName -> DeploymentStatusTransition -> ExceptT StatusTransitionError m ()
@@ -564,10 +571,8 @@ transitionToStatus dName s = do
564571 p <- asks pool
565572 st <- ask
566573 let log = liftBase . logInfo (logger st)
567− (oldS, newS) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do
568− dep <- lift (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case
569− [x] -> return x
570− _ -> throwError $ DeploymentNotFound dName
574+ (oldS, newS, dep :: DeploymentFullInfo) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do
575+ dep <- lift $ getDeploymentS conn dName
571576 let
572577 oldS = recordedStatus $ dep ^. #status
573578 newS = transitionStatus s
@@ -589,10 +594,11 @@ transitionToStatus dName s = do
589594 (output ^. #duration)
590595 (output ^. #stdout)
591596 (output ^. #stderr)
592− return (oldS, newS)
597+ return (oldS, newS, dep)
593598 notificationCmd <- asks notificationCommand
594599 forM_ notificationCmd $ \nCmd ->
595− runBgWorker . void $ runCommandArgs' nCmd =<< notificationCommandArgs dName oldS newS
600+ runBgWorker . void $ runCommandArgs' nCmd
601+ =<< notificationCommandArgs dName (dep ^. #deployment . #tag) oldS newS
596602 liftBase $ sendReloadEvent st
597603
598604assertStatusTransitionPossible
@@ -915,15 +921,9 @@ projectNameH = projectName <$> ask
915921-- | Handles the 'status' request.
916922statusH :: DeploymentName -> AppM CurrentDeploymentStatus
917923statusH dName = do
918− st <- ask
919− let
920− log = logInfo (logger st)
921− cmd = checkingCommand st
922− args =
923− [ "--namespace", coerce $ namespace st
924− , "--name", coerce $ dName ]
925− liftIO $ log $ "call " <> unwords (coerce cmd : args)
926− ec <- liftIO $ runCommandWithoutPipes (unpack $ coerce cmd) (unpack <$> args)
924+ pgPool <- asks pool
925+ dep <- withResource pgPool $ \conn -> getDeploymentS conn dName
926+ (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dName (dep ^. #deployment . #tag)
927927 pure . CurrentDeploymentStatus $
928928 case ec of
929929 ExitSuccess -> Ok
@@ -1210,6 +1210,7 @@ runStatusUpdater state = do
12101210 "SELECT name, status::text, \
12111211 \extract(epoch from now())::int - \
12121212 \extract(epoch from status_updated_at)::int \
1213+ \, tag \
12131214 \FROM deployments \
12141215 \WHERE checked_at < now() - interval '?' second AND status != 'Archived'"
12151216 updateCheckedAt =
@@ -1218,22 +1219,16 @@ runStatusUpdater state = do
12181219 logErr = logWarning (logger state)
12191220
12201221 forever $ do
1221− rows :: [(DeploymentName, DeploymentStatus, Int)] <- liftIO $
1222+ rows :: [(DeploymentName, DeploymentStatus, Int, DeploymentTag)] <- liftIO $
12221223 withResource pgPool $ \conn -> query conn selectDeps (Only interval)
12231224 let
1224− checkList :: [(DeploymentName, DeploymentStatus, Timestamp)] =
1225− (\(n, s, t) -> (n, s, coerce t)) <$> rows
1226− checkResult <- for checkList $ \(dName, dStatus, ts) -> do
1227− let
1228− args =
1229− [ "--project-name", unpack . coerce $ projectName state
1230− , "--base-domain", unpack . coerce $ baseDomain state
1231− , "--namespace", unpack . coerce $ namespace state
1232− , "--name", unpack . coerce $ dName ]
1233− cmd ArchivePending = unpack . coerce $ archiveCheckingCommand state
1234− cmd _ = unpack . coerce $ checkingCommand state
1235− timeout = statusUpdateTimeout state
1236− ec <- runCommandWithoutPipes (cmd dStatus) args
1225+ checkList :: [(DeploymentName, DeploymentStatus, Timestamp, DeploymentTag)] =
1226+ (\(n, s, t, dTag) -> (n, s, coerce t, dTag)) <$> rows
1227+ checkResult <- for checkList $ \(dName, dStatus, ts, dTag) -> do
1228+ let timeout = statusUpdateTimeout state
1229+ (ec, _, _) <- flip runReaderT state case dStatus of
1230+ ArchivePending -> runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName
1231+ _ -> runCommandArgs checkingCommand =<< checkCommandArgs dName dTag
12371232 pure (dName, statusTransition ec dStatus ts timeout, dStatus)
12381233 updated <-
12391234 for checkResult $ \(dName, transitionM, dStatus) ->