Improved check and notification control script arguments (#34)

* Corrected control script arguments

* Updated documentation

* added project name and base domain to check script

* split the checking and archive checking commands

* checkArchiveArgs -> archiveCheckArgs

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:

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`

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
 

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) ->

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

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