diff --git a/docs/en/Control_scripts.md b/docs/en/Control_scripts.md index 9d549ef..b13b1ca 100644 --- a/docs/en/Control_scripts.md +++ b/docs/en/Control_scripts.md @@ -312,6 +312,16 @@ This script receives the following additional command-line arguments as input: - `--old-status` – The previous status the deployment was in. - `--new-status` – The new status the deployment transitioned to. +The last two arguments can have one of the following values: +- `Running` +- `GenericFailure` +- `TagMismatch` +- `PartialAvailability` +- `CreatePending` +- `UpdatePending` +- `ArchivePending` +- `Archived` + #### Execution example The script might be called something like this: diff --git a/docs/ru/Control_scripts.md b/docs/ru/Control_scripts.md index 527ca9e..4f4ecb9 100644 --- a/docs/ru/Control_scripts.md +++ b/docs/ru/Control_scripts.md @@ -228,3 +228,13 @@ echo "api,https://api.${name}.example.com" * `--tag` – тег развертывания - `--old-status` – предыдущий статус - `--new-status` – новый статус + +Последние два аргумент могут иметь одно из следующих значений: +- `Running` +- `GenericFailure` +- `TagMismatch` +- `PartialAvailability` +- `CreatePending` +- `UpdatePending` +- `ArchivePending` +- `Archived` diff --git a/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs b/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs index 2423940..fa96d77 100644 --- a/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs +++ b/octopod-backend/src/Database/PostgreSQL/Simple/Instances.hs @@ -13,16 +13,6 @@ import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField import qualified Data.Text.Encoding as T -deploymentStatusText :: DeploymentStatus -> Text -deploymentStatusText Running = "Running" -deploymentStatusText (Failure GenericFailure) = "GenericFailure" -deploymentStatusText (Failure TagMismatch) = "TagMismatch" -deploymentStatusText (Failure PartialAvailability) = "PartialAvailability" -deploymentStatusText CreatePending = "CreatePending" -deploymentStatusText UpdatePending = "UpdatePending" -deploymentStatusText ArchivePending = "ArchivePending" -deploymentStatusText Archived = "Archived" - instance ToField DeploymentStatus where toField = toField @Text . deploymentStatusText diff --git a/octopod-backend/src/Octopod/Server.hs b/octopod-backend/src/Octopod/Server.hs index ce000de..df28e06 100644 --- a/octopod-backend/src/Octopod/Server.hs +++ b/octopod-backend/src/Octopod/Server.hs @@ -557,6 +557,13 @@ transitionErrorToServerError = \case where show'' = BSLC.pack . show +getDeploymentS + :: (MonadReader AppState m, MonadBase IO m, MonadError ServerError m) + => Connection -> DeploymentName -> m DeploymentFullInfo +getDeploymentS conn dName = (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case + [x] -> return x + _ -> throwError err404 {errBody = "Deployment not found."} + transitionToStatus :: (MonadError ServerError m, MonadReader AppState m, MonadBaseControl IO m) => DeploymentName -> DeploymentStatusTransition -> ExceptT StatusTransitionError m () @@ -564,10 +571,8 @@ transitionToStatus dName s = do p <- asks pool st <- ask let log = liftBase . logInfo (logger st) - (oldS, newS) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do - dep <- lift (getFullInfo' conn (FullInfoOnlyForOne dName)) >>= \case - [x] -> return x - _ -> throwError $ DeploymentNotFound dName + (oldS, newS, dep :: DeploymentFullInfo) <- withResource p $ \conn -> liftBaseOp_ (withTransaction conn) $ do + dep <- lift $ getDeploymentS conn dName let oldS = recordedStatus $ dep ^. #status newS = transitionStatus s @@ -589,10 +594,11 @@ transitionToStatus dName s = do (output ^. #duration) (output ^. #stdout) (output ^. #stderr) - return (oldS, newS) + return (oldS, newS, dep) notificationCmd <- asks notificationCommand forM_ notificationCmd $ \nCmd -> - runBgWorker . void $ runCommandArgs' nCmd =<< notificationCommandArgs dName oldS newS + runBgWorker . void $ runCommandArgs' nCmd + =<< notificationCommandArgs dName (dep ^. #deployment . #tag) oldS newS liftBase $ sendReloadEvent st assertStatusTransitionPossible @@ -915,15 +921,9 @@ projectNameH = projectName <$> ask -- | Handles the 'status' request. statusH :: DeploymentName -> AppM CurrentDeploymentStatus statusH dName = do - st <- ask - let - log = logInfo (logger st) - cmd = checkingCommand st - args = - [ "--namespace", coerce $ namespace st - , "--name", coerce $ dName ] - liftIO $ log $ "call " <> unwords (coerce cmd : args) - ec <- liftIO $ runCommandWithoutPipes (unpack $ coerce cmd) (unpack <$> args) + pgPool <- asks pool + dep <- withResource pgPool $ \conn -> getDeploymentS conn dName + (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dName (dep ^. #deployment . #tag) pure . CurrentDeploymentStatus $ case ec of ExitSuccess -> Ok @@ -1210,6 +1210,7 @@ runStatusUpdater state = do "SELECT name, status::text, \ \extract(epoch from now())::int - \ \extract(epoch from status_updated_at)::int \ + \, tag \ \FROM deployments \ \WHERE checked_at < now() - interval '?' second AND status != 'Archived'" updateCheckedAt = @@ -1218,22 +1219,16 @@ runStatusUpdater state = do logErr = logWarning (logger state) forever $ do - rows :: [(DeploymentName, DeploymentStatus, Int)] <- liftIO $ + rows :: [(DeploymentName, DeploymentStatus, Int, DeploymentTag)] <- liftIO $ withResource pgPool $ \conn -> query conn selectDeps (Only interval) let - checkList :: [(DeploymentName, DeploymentStatus, Timestamp)] = - (\(n, s, t) -> (n, s, coerce t)) <$> rows - checkResult <- for checkList $ \(dName, dStatus, ts) -> do - let - args = - [ "--project-name", unpack . coerce $ projectName state - , "--base-domain", unpack . coerce $ baseDomain state - , "--namespace", unpack . coerce $ namespace state - , "--name", unpack . coerce $ dName ] - cmd ArchivePending = unpack . coerce $ archiveCheckingCommand state - cmd _ = unpack . coerce $ checkingCommand state - timeout = statusUpdateTimeout state - ec <- runCommandWithoutPipes (cmd dStatus) args + checkList :: [(DeploymentName, DeploymentStatus, Timestamp, DeploymentTag)] = + (\(n, s, t, dTag) -> (n, s, coerce t, dTag)) <$> rows + checkResult <- for checkList $ \(dName, dStatus, ts, dTag) -> do + let timeout = statusUpdateTimeout state + (ec, _, _) <- flip runReaderT state case dStatus of + ArchivePending -> runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName + _ -> runCommandArgs checkingCommand =<< checkCommandArgs dName dTag pure (dName, statusTransition ec dStatus ts timeout, dStatus) updated <- for checkResult $ \(dName, transitionM, dStatus) -> diff --git a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs index aaa5085..aeec040 100644 --- a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs +++ b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs @@ -13,6 +13,8 @@ module Octopod.Server.ControlScriptUtils , runCommandWithoutPipes , runCommandArgs , runCommandArgs' + , checkCommandArgs + , archiveCheckArgs ) where @@ -52,12 +54,13 @@ notificationCommandArgs , HasType Domain r ) => DeploymentName + -> DeploymentTag -> DeploymentStatus -- ^ Previous status -> DeploymentStatus -- ^ New status -> m ControlScriptArgs -notificationCommandArgs dName old new = do +notificationCommandArgs dName dTag old new = do (Namespace namespace) <- asks getTyped (ProjectName projectName) <- asks getTyped (Domain domain) <- asks getTyped @@ -66,9 +69,51 @@ notificationCommandArgs dName old new = do , "--base-domain", T.unpack domain , "--namespace", T.unpack namespace , "--name", T.unpack . coerce $ dName - , "--tag", T.unpack . coerce $ dName - , "--old-status", show old - , "--new-status", show new + , "--tag", T.unpack . coerce $ dTag + , "--old-status", T.unpack $ deploymentStatusText old + , "--new-status", T.unpack $ deploymentStatusText new + ] + +checkCommandArgs + :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) + => DeploymentName + -> DeploymentTag + -> m ControlScriptArgs +checkCommandArgs dName dTag = do + (ProjectName projectName) <- asks getTyped + (Domain domain) <- asks getTyped + (Namespace namespace) <- asks getTyped + return $ ControlScriptArgs + [ "--namespace", T.unpack namespace + , "--name", T.unpack . coerce $ dName + , "--tag", T.unpack . unDeploymentTag $ dTag + , "--project-name", T.unpack projectName + , "--base-domain", T.unpack domain + ] + +archiveCheckArgs + :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) + => DeploymentName + -> m ControlScriptArgs +archiveCheckArgs dName = do + (ProjectName projectName) <- asks getTyped + (Domain domain) <- asks getTyped + (Namespace namespace) <- asks getTyped + return $ ControlScriptArgs + [ "--project-name", T.unpack projectName + , "--base-domain", T.unpack domain + , "--namespace", T.unpack namespace + , "--name", T.unpack . coerce $ dName ] runCommandArgs diff --git a/octopod-common/src/Common/Types.hs b/octopod-common/src/Common/Types.hs index 6944d0d..84bedbf 100644 --- a/octopod-common/src/Common/Types.hs +++ b/octopod-common/src/Common/Types.hs @@ -85,6 +85,16 @@ newtype Timestamp = Timestamp { unTimestamp :: Int } newtype ProjectName = ProjectName { uProjectName :: Text } deriving (Show, FromJSON, ToJSON) +deploymentStatusText :: DeploymentStatus -> Text +deploymentStatusText Running = "Running" +deploymentStatusText (Failure GenericFailure) = "GenericFailure" +deploymentStatusText (Failure TagMismatch) = "TagMismatch" +deploymentStatusText (Failure PartialAvailability) = "PartialAvailability" +deploymentStatusText CreatePending = "CreatePending" +deploymentStatusText UpdatePending = "UpdatePending" +deploymentStatusText ArchivePending = "ArchivePending" +deploymentStatusText Archived = "Archived" + data DeploymentStatus = Running | Failure FailureType