From ec792b25d2fdb0f724d8509fc6e84ac6d5adb047 Mon Sep 17 00:00:00 2001 From: iko Date: Sun, 8 Aug 2021 17:02:33 +0300 Subject: [PATCH] Added more arguments to control scripts (#62) * format * Added more arguments to scripts * Updated docs --- docs/en/Control_scripts.md | 15 +- octopod-backend/octopod-backend.cabal | 1 + octopod-backend/src/Octopod/Server.hs | 115 +++---- .../src/Octopod/Server/ControlScriptUtils.hs | 302 ++++++++++++------ octopod-backend/src/Types.hs | 1 + octopod-common/src/Common/Types.hs | 15 +- 6 files changed, 276 insertions(+), 173 deletions(-) diff --git a/docs/en/Control_scripts.md b/docs/en/Control_scripts.md index 9c3a0a8..b78d7ce 100644 --- a/docs/en/Control_scripts.md +++ b/docs/en/Control_scripts.md @@ -181,6 +181,8 @@ This script checks the status of the deployment. This script receives the following additional command-line arguments as input: * `--tag` – The _Docker Image tag_ that should be checked. +* `--app-env-override` [⭐](#star) – App-level overrides. These overrides should be passed to the server being deployed. These overrides are specified in the _Web UI_. They are passed in the format of `KEY=VALUE` pairs. +* `--deployment-override` [⭐](#star) – Deployment-level overrides. These overrides should be used to set up the deployment environment itself, rather than be passed to the server being deployed. These overrides are specified in the _Web UI_. They are passed in the format of `KEY=VALUE` pairs. If the script exits with `0`, it means that the deployment is healthy and up. If the script exits with a non-zero exit code, it means that the deployment is not healthy or down. @@ -194,7 +196,7 @@ You can specify exactly what error occured using exit codes: The script might be called something like this: ```bash -check --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" +check ---project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" --tag "c9bbc3fcc69e5aa094bca110c6f79419ab7be77a" --app-env-override "EMAIL_TOKEN=123123" --app-env-override "SECRET_BUTTON_ENABLED=True" --deployment-override "FANCY_DATABASE=True" ``` #### Sample implementation @@ -261,13 +263,15 @@ This script is called right before [`create`](#-create) and [`update`](#-update) This script receives the following additional command-line arguments as input: * `--tag` – The _Docker Image tag_ that should be checked. +* `--app-env-override` [⭐](#star) – App-level overrides. These overrides should be passed to the server being deployed. These overrides are specified in the _Web UI_. They are passed in the format of `KEY=VALUE` pairs. +* `--deployment-override` [⭐](#star) – Deployment-level overrides. These overrides should be used to set up the deployment environment itself, rather than be passed to the server being deployed. These overrides are specified in the _Web UI_. They are passed in the format of `KEY=VALUE` pairs. #### Execution example The script might be called something like this: ```bash -tag_check --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" --tag "c9bbc3fcc69e5aa094bca110c6f79419ab7be77a" +tag_check --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" --tag "c9bbc3fcc69e5aa094bca110c6f79419ab7be77a" --app-env-override "EMAIL_TOKEN=123123" --app-env-override "SECRET_BUTTON_ENABLED=True" --deployment-override "FANCY_DATABASE=True" ``` ### 👀 info @@ -276,6 +280,11 @@ tag_check --project-name "Cactus store" --base-domain "cactus-store.com" --names This script returns user-facing metadata about a deployment. Currently, the metadata consists of URLs that are relevant for the deployment. Things like the deployment URL, the URL to view logs, and the database URL. +This script receives the following additional command-line arguments as input: +* `--tag` – The _Docker Image tag_ that should be checked. +* `--app-env-override` [⭐](#star) – App-level overrides. These overrides should be passed to the server being deployed. These overrides are specified in the _Web UI_. They are passed in the format of `KEY=VALUE` pairs. +* `--deployment-override` [⭐](#star) – Deployment-level overrides. These overrides should be used to set up the deployment environment itself, rather than be passed to the server being deployed. These overrides are specified in the _Web UI_. They are passed in the format of `KEY=VALUE` pairs. + The script should return the metadata as a two-column CSV table: ``` @@ -290,7 +299,7 @@ This script receives only [the default command-line arguments](#general-behavior The script might be called something like this: ```bash -info --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" +info --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" --tag "c9bbc3fcc69e5aa094bca110c6f79419ab7be77a" --app-env-override "EMAIL_TOKEN=123123" --app-env-override "SECRET_BUTTON_ENABLED=True" --deployment-override "FANCY_DATABASE=True" ``` #### Sample implementation diff --git a/octopod-backend/octopod-backend.cabal b/octopod-backend/octopod-backend.cabal index 2d0ee66..df8364b 100644 --- a/octopod-backend/octopod-backend.cabal +++ b/octopod-backend/octopod-backend.cabal @@ -54,6 +54,7 @@ library , TypeFamilies , QuantifiedConstraints , DeriveAnyClass + , ViewPatterns exposed-modules: Octopod.Server Octopod.Server.Args diff --git a/octopod-backend/src/Octopod/Server.hs b/octopod-backend/src/Octopod/Server.hs index 77800a0..5dc6269 100644 --- a/octopod-backend/src/Octopod/Server.hs +++ b/octopod-backend/src/Octopod/Server.hs @@ -8,7 +8,7 @@ import Control.Concurrent.Async (race_) import qualified Control.Concurrent.Lifted as L import Control.Concurrent.MVar import Control.Concurrent.STM -import Control.Exception (Exception, throwIO, try) +import Control.Exception (Exception, displayException, throwIO, try) import qualified Control.Exception.Lifted as L import Control.Lens hiding (Context, pre) import Control.Lens.Extras @@ -34,6 +34,7 @@ import Data.Int (Int64) import Data.Maybe import Data.Pool import Data.Text (lines, pack, unpack, unwords) +import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Traversable import Database.PostgreSQL.Simple hiding ((:.)) @@ -391,7 +392,7 @@ createH dep = do t1 <- liftIO $ now st <- ask let pgPool = pool st - failIfImageNotFound (name dep) (tag dep) + failIfImageNotFound dep failIfGracefulShutdownActivated runDeploymentBgWorker Nothing @@ -426,7 +427,7 @@ createH dep = do liftIO . withResource pgPool $ \conn -> upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep) liftBase $ sendReloadEvent st - liftBase $ updateDeploymentInfo (name dep) st + updateDeploymentInfo (name dep) (ec, out, err) <- liftBase $ createDeployment dep st t2 <- liftBase $ now let elTime = elapsedTime t2 t1 @@ -438,17 +439,21 @@ createH dep = do pure Success -- | Updates deployment info. -updateDeploymentInfo :: DeploymentName -> AppState -> IO () -updateDeploymentInfo dName st = do - let log = logWarning (logger st) - args = infoCommandArgs (projectName st) (baseDomain st) (namespace st) dName - cmd = coerce $ infoCommand st - liftIO $ do - (ec, out, err) <- runCommand (unpack cmd) (coerce args) +updateDeploymentInfo :: + (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) => + DeploymentName -> + m () +updateDeploymentInfo dName = do + log <- asks (logWarning . logger) + pgPool <- asks pool + DeploymentFullInfo {deployment = dep} <- + withResource pgPool $ \conn -> getDeploymentS conn dName + (ec, out, err) <- runCommandArgs infoCommand =<< infoCommandArgs dep + liftBase $ case ec of ExitSuccess -> do dMeta <- parseDeploymentMetadata (lines . unStdout $ out) - upsertDeploymentMetadata (pool st) dName dMeta + upsertDeploymentMetadata pgPool dName dMeta ExitFailure _ -> log $ "could not get deployment info, exit code: " <> (pack . show $ ec) @@ -484,23 +489,6 @@ createDeployment dep st = do log $ "deployment created, deployment: " <> (pack . show $ dep) pure (ec, out, err) --- | Converts an application-level override list to command arguments. -applicationOverrideToArg :: ApplicationOverride -> [Text] -applicationOverrideToArg o = ["--app-env-override", overrideToArg . coerce $ o] - --- | Helper to convert an application-level override to command arguments. -applicationOverridesToArgs :: ApplicationOverrides -> [Text] -applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs] - --- | Converts a deployment-level override list to command arguments. -deploymentOverrideToArg :: DeploymentOverride -> [Text] -deploymentOverrideToArg o = - ["--deployment-override", overrideToArg . coerce $ o] - --- | Helper to convert a deployment-level override to command arguments. -deploymentOverridesToArgs :: DeploymentOverrides -> [Text] -deploymentOverridesToArgs ovs = concat [deploymentOverrideToArg o | o <- ovs] - -- | Helper to get deployment logs. selectDeploymentLogs :: PgPool -> @@ -527,15 +515,22 @@ selectDeployment :: AppM Deployment selectDeployment dName = do pgPool <- asks pool + liftBaseOp (withResource pgPool) $ \conn -> + liftIO (selectDeploymentIO conn dName) >>= either throwError pure + +selectDeploymentIO :: + Connection -> + DeploymentName -> + IO (Either ServerError Deployment) +selectDeploymentIO conn dName = do let q = "SELECT name, tag FROM deployments WHERE name = ?" - liftBaseOp (withResource pgPool) $ \conn -> do - retrieved <- liftBase $ query conn q (Only dName) - case retrieved of - [(n, t)] -> do - (appOvs, stOvs) <- liftBase $ selectOverrides conn n - pure $ Deployment n t appOvs stOvs - [] -> throwError err404 {errBody = "Deployment not found."} - _ -> throwError err500 + retrieved <- liftBase $ query conn q (Only dName) + case retrieved of + [(n, t)] -> do + (appOvs, stOvs) <- liftBase $ selectOverrides conn n + pure . Right $ Deployment n t appOvs stOvs + [] -> pure . Left $ err404 {errBody = "Deployment not found."} + _ -> pure . Left $ err500 data StatusTransitionProcessOutput = StatusTransitionProcessOutput { exitCode :: ExitCode @@ -757,7 +752,8 @@ updateH dName dUpdate = do pgPool = pool st log = logInfo (logger st) dId <- selectDeploymentId pgPool dName - failIfImageNotFound dName dTag + olDep <- selectDeployment dName + failIfImageNotFound (applyDeploymentUpdate dUpdate olDep) failIfGracefulShutdownActivated runDeploymentBgWorker (Just UpdatePending) dName (pure ()) $ \() -> do (appOvs, depOvs) <- liftBase . withResource pgPool $ \conn -> @@ -766,7 +762,7 @@ updateH dName dUpdate = do upsertNewOverrides conn dId newAppOvs newDepOvs updateTag conn dId dTag selectOverrides conn dName - liftBase $ updateDeploymentInfo dName st + updateDeploymentInfo dName liftBase $ sendReloadEvent st let args = [ "--project-name" @@ -1000,7 +996,7 @@ statusH :: DeploymentName -> AppM CurrentDeploymentStatus statusH dName = do pgPool <- asks pool dep <- withResource pgPool $ \conn -> getDeploymentS conn dName - (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dName (dep ^. #deployment . #tag) + (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs (dep ^. #deployment) pure . CurrentDeploymentStatus $ case ec of ExitSuccess -> Ok @@ -1102,11 +1098,11 @@ restoreH dName = do t1 <- liftIO $ now st <- ask dep <- selectDeployment dName - failIfImageNotFound (name dep) (tag dep) + failIfImageNotFound dep failIfGracefulShutdownActivated runDeploymentBgWorker (Just CreatePending) dName (pure ()) $ \() -> do dep' <- selectDeployment dName - liftBase $ updateDeploymentInfo dName st + updateDeploymentInfo dName (ec, out, err) <- liftBase $ createDeployment dep' st t2 <- liftBase now let elTime = elapsedTime t2 t1 @@ -1248,28 +1244,9 @@ upsertDeploymentMetadata pgPool dName dMetadatas = do -- | Checks the existence of a deployment tag. -- Returns 404 'Tag not found' response if the deployment tag doesn't exist. -failIfImageNotFound :: DeploymentName -> DeploymentTag -> AppM () -failIfImageNotFound dName dTag = do - st <- ask - let log :: Text -> IO () - log = logInfo (logger st) - args = - [ "--project-name" - , coerce $ projectName st - , "--base-domain" - , coerce $ baseDomain st - , "--namespace" - , coerce $ namespace st - , "--name" - , coerce $ dName - , "--tag" - , coerce $ dTag - ] - cmd = coerce $ tagCheckingCommand st - - ec <- liftIO $ do - log $ "call " <> unwords (cmd : args) - runCommandWithoutPipes (unpack cmd) (unpack <$> args) +failIfImageNotFound :: Deployment -> AppM () +failIfImageNotFound dep = do + (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs dep case ec of ExitSuccess -> pure () ExitFailure _ -> @@ -1316,11 +1293,19 @@ runStatusUpdater state = do withResource pgPool $ \conn -> query conn selectDeps (Only interval) let checkList :: [(DeploymentName, DeploymentStatus, Timestamp, DeploymentTag)] = (\(n, s, t, dTag) -> (n, s, coerce t, dTag)) <$> rows - checkResult <- for checkList $ \(dName, dStatus, ts, dTag) -> do + checkResult <- for checkList $ \(dName, dStatus, ts, _) -> do let timeout = statusUpdateTimeout state (ec, _, _) <- flip runReaderT state case dStatus of ArchivePending -> runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName - _ -> runCommandArgs checkingCommand =<< checkCommandArgs dName dTag + _ -> do + liftBase (withResource pgPool $ \conn -> selectDeploymentIO conn dName) >>= \case + Right dep -> runCommandArgs checkingCommand =<< checkCommandArgs dep + Left err -> do + log <- asks logger + let err' = T.pack $ displayException $ err + liftIO $ logWarning log err' + pure (ExitFailure 1, Stdout "Didn't call script", Stderr err') + 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 aeec040..cbb7d23 100644 --- a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs +++ b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs @@ -1,138 +1,207 @@ -{-| -Module : Octopod.Server.ControlScriptUtils -Description : Control script utils. - -This module contains control script utils. --} - - +-- | +--Module : Octopod.Server.ControlScriptUtils +--Description : Control script utils. +-- +--This module contains control script utils. module Octopod.Server.ControlScriptUtils - ( infoCommandArgs - , notificationCommandArgs - , runCommand - , runCommandWithoutPipes - , runCommandArgs - , runCommandArgs' - , checkCommandArgs - , archiveCheckArgs - ) where + ( infoCommandArgs, + notificationCommandArgs, + runCommand, + runCommandWithoutPipes, + runCommandArgs, + runCommandArgs', + checkCommandArgs, + archiveCheckArgs, + tagCheckCommandArgs, + -- * Helpers + applicationOverrideToArg, + applicationOverridesToArgs, + deploymentOverrideToArg, + deploymentOverridesToArgs, + ) +where -import Control.Monad.Base -import Control.Monad.Reader +import Control.Monad.Base +import Control.Monad.Reader import qualified Data.ByteString.Lazy as TL -import Data.Coerce -import Data.Generics.Product.Typed +import Data.Coerce +import Data.Generics.Product.Typed +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Octopod.Server.Logger -import System.Exit -import System.Log.FastLogger -import System.Process.Typed -import Types - +import Octopod.Server.Logger +import System.Exit +import System.Log.FastLogger +import System.Process.Typed +import Types -- | Creates command arguments for the 'info' deployment control script. -infoCommandArgs - :: ProjectName - -> Domain - -> Namespace - -> DeploymentName - -> ControlScriptArgs -infoCommandArgs pName domain ns dName = - ControlScriptArgs - [ "--project-name", T.unpack . coerce $ pName - , "--base-domain", T.unpack . coerce $ domain - , "--namespace", T.unpack . coerce $ ns - , "--name", T.unpack . coerce $ dName ] +infoCommandArgs :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) => + Deployment -> + m ControlScriptArgs +infoCommandArgs dep = do + (Namespace namespace) <- asks getTyped + (ProjectName projectName) <- asks getTyped + (Domain domain) <- asks getTyped + return $ + ControlScriptArgs + [ "--project-name" + , T.unpack . coerce $ projectName + , "--base-domain" + , T.unpack . coerce $ domain + , "--namespace" + , T.unpack . coerce $ namespace + , "--name" + , T.unpack . coerce $ name dep + , "--tag" + , T.unpack . coerce $ tag dep + ] + <> getApplicationOverrideArgs dep + <> getDeploymentOverrideArgs dep -notificationCommandArgs - :: - ( MonadReader r m - , HasType Namespace r - , HasType ProjectName r - , HasType Domain r - ) - => DeploymentName - -> DeploymentTag - -> DeploymentStatus - -- ^ Previous status - -> DeploymentStatus - -- ^ New status - -> m ControlScriptArgs +notificationCommandArgs :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) => + DeploymentName -> + DeploymentTag -> + -- | Previous status + DeploymentStatus -> + -- | New status + DeploymentStatus -> + m ControlScriptArgs notificationCommandArgs dName dTag old new = do (Namespace namespace) <- asks getTyped (ProjectName projectName) <- asks getTyped (Domain domain) <- asks getTyped - return $ ControlScriptArgs - [ "--project-name", T.unpack projectName - , "--base-domain", T.unpack domain - , "--namespace", T.unpack namespace - , "--name", T.unpack . coerce $ dName - , "--tag", T.unpack . coerce $ dTag - , "--old-status", T.unpack $ deploymentStatusText old - , "--new-status", T.unpack $ deploymentStatusText new - ] + return $ + ControlScriptArgs + [ "--project-name" + , T.unpack projectName + , "--base-domain" + , T.unpack domain + , "--namespace" + , T.unpack namespace + , "--name" + , T.unpack . coerce $ dName + , "--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 +checkCommandArgs :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) => + Deployment -> + m ControlScriptArgs +checkCommandArgs dep = do + (Namespace namespace) <- asks getTyped (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 - ] + return $ + ControlScriptArgs + [ "--project-name" + , T.unpack . coerce $ projectName + , "--base-domain" + , T.unpack . coerce $ domain + , "--namespace" + , T.unpack . coerce $ namespace + , "--name" + , T.unpack . coerce $ name dep + , "--tag" + , T.unpack . coerce $ tag dep + ] + <> getApplicationOverrideArgs dep + <> getDeploymentOverrideArgs dep -archiveCheckArgs - :: - ( MonadReader r m - , HasType Namespace r - , HasType ProjectName r - , HasType Domain r - ) - => DeploymentName - -> m ControlScriptArgs +tagCheckCommandArgs :: + ( MonadReader r m + , HasType Namespace r + , HasType ProjectName r + , HasType Domain r + ) => + Deployment -> + m ControlScriptArgs +tagCheckCommandArgs dep = do + (Namespace namespace) <- asks getTyped + (ProjectName projectName) <- asks getTyped + (Domain domain) <- asks getTyped + return $ + ControlScriptArgs + [ "--project-name" + , T.unpack . coerce $ projectName + , "--base-domain" + , T.unpack . coerce $ domain + , "--namespace" + , T.unpack . coerce $ namespace + , "--name" + , T.unpack . coerce $ name dep + , "--tag" + , T.unpack . coerce $ tag dep + ] + <> getApplicationOverrideArgs dep + <> getDeploymentOverrideArgs dep + +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 - ] + return $ + ControlScriptArgs + [ "--project-name" + , T.unpack projectName + , "--base-domain" + , T.unpack domain + , "--namespace" + , T.unpack namespace + , "--name" + , T.unpack . coerce $ dName + ] -runCommandArgs - :: (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r) - => (r -> Command) -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr) +runCommandArgs :: + (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r) => + (r -> Command) -> + ControlScriptArgs -> + m (ExitCode, Stdout, Stderr) runCommandArgs f args = do cmd <- asks f runCommandArgs' cmd args -runCommandArgs' - :: (MonadBase IO m, HasType TimedFastLogger r, MonadReader r m) - => Command -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr) +runCommandArgs' :: + (MonadBase IO m, HasType TimedFastLogger r, MonadReader r m) => + Command -> + ControlScriptArgs -> + m (ExitCode, Stdout, Stderr) runCommandArgs' (Command cmd) (ControlScriptArgs args) = do logger <- asks (getTyped @TimedFastLogger) let logText = T.unwords (cmd : fmap T.pack args) liftBase $ logInfo logger $ "calling: " <> logText res@(ec, _, _) <- runCommand (T.unpack cmd) args - liftBase $ logInfo logger - $ "calling `" <> logText <> "` exited with: " <> show' ec + liftBase $ + logInfo logger $ + "calling `" <> logText <> "` exited with: " <> show' ec return res -- | Helper to run command with pipes. @@ -149,3 +218,28 @@ runCommand cmd args = do runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode runCommandWithoutPipes cmd args = withProcessWait (proc cmd args) waitExitCode + +-- | Converts an application-level override list to command arguments. +applicationOverrideToArg :: ApplicationOverride -> [Text] +applicationOverrideToArg o = ["--app-env-override", overrideToArg . coerce $ o] + +-- | Helper to convert an application-level override to command arguments. +applicationOverridesToArgs :: ApplicationOverrides -> [Text] +applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs] + +getApplicationOverrideArgs :: Deployment -> ControlScriptArgs +getApplicationOverrideArgs = + ControlScriptArgs . map T.unpack . applicationOverridesToArgs . appOverrides + +-- | Converts a deployment-level override list to command arguments. +deploymentOverrideToArg :: DeploymentOverride -> [Text] +deploymentOverrideToArg o = + ["--deployment-override", overrideToArg . coerce $ o] + +-- | Helper to convert a deployment-level override to command arguments. +deploymentOverridesToArgs :: DeploymentOverrides -> [Text] +deploymentOverridesToArgs ovs = concat [deploymentOverrideToArg o | o <- ovs] + +getDeploymentOverrideArgs :: Deployment -> ControlScriptArgs +getDeploymentOverrideArgs = + ControlScriptArgs . map T.unpack . deploymentOverridesToArgs . deploymentOverrides diff --git a/octopod-backend/src/Types.hs b/octopod-backend/src/Types.hs index 5ef3377..dddcc40 100644 --- a/octopod-backend/src/Types.hs +++ b/octopod-backend/src/Types.hs @@ -75,3 +75,4 @@ newtype Command = Command {unCommand :: Text} newtype ControlScriptArgs = ControlScriptArgs {unControlScriptArgs :: [String]} deriving stock (Show) + deriving newtype (Semigroup, Monoid) diff --git a/octopod-common/src/Common/Types.hs b/octopod-common/src/Common/Types.hs index 9bbddc6..ca1bbf2 100644 --- a/octopod-common/src/Common/Types.hs +++ b/octopod-common/src/Common/Types.hs @@ -10,7 +10,7 @@ module Common.Types where import Data.Bifunctor import Data.Coerce import Data.String -import Data.Text as T +import Data.Text as T hiding (filter) import Data.Traversable import Deriving.Aeson.Stock import Web.HttpApiData @@ -187,6 +187,19 @@ data DeploymentUpdate = DeploymentUpdate deriving stock (Generic, Show) deriving (FromJSON, ToJSON) via Snake DeploymentUpdate +applyDeploymentUpdate :: DeploymentUpdate -> Deployment -> Deployment +applyDeploymentUpdate du d = + Deployment + { name = name d + , tag = newTag du + , appOverrides = + filter (`notElem` oldAppOverrides du) (appOverrides d) + <> newAppOverrides du + , deploymentOverrides = + filter (`notElem` oldDeploymentOverrides du) (deploymentOverrides d) + <> newDeploymentOverrides du + } + data CurrentStatus = Ok | Error