ec792b2 · typeable/octopod

git.iko.soy/typeable/octopod

Added more arguments to control scripts (#62)

* format * Added more arguments to scripts * Updated docs

commitec792b25d2fdb0f724d8509fc6e84ac6d5adb047 authoriko <ilyakooo0@gmail.com> dateSun 8 Aug 2021, 17:02 (5 years ago) parent9e1dcb4

6 files changed+280−177

compare with master

unifiedsplit

docs/en/Control_scripts.md+12−3 octopod-backend/octopod-backend.cabal+1 octopod-backend/src/Octopod/Server.hs+50−65 octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+202−108 octopod-backend/src/Types.hs+1 octopod-common/src/Common/Types.hs+14−1

docs/en/Control_scripts.md+12−3

@@ -181,6 +181,8 @@ This script checks the status of the deployment.

181181

182182This script receives the following additional command-line arguments as input:

183183* `--tag` – The _Docker Image tag_ that should be checked.

184+* `--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.

185+* `--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.

184186

185187If 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.

186188

@@ -194,7 +196,7 @@ You can specify exactly what error occured using exit codes:

194196The script might be called something like this:

195197

196198```bash

197−check --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button"

199+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"

198200```

199201

200202#### Sample implementation

@@ -261,13 +263,15 @@ This script is called right before [`create`](#-create) and [`update`](#-update)

261263

262264This script receives the following additional command-line arguments as input:

263265* `--tag` – The _Docker Image tag_ that should be checked.

266+* `--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.

267+* `--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.

264268

265269#### Execution example

266270

267271The script might be called something like this:

268272

269273```bash

270−tag_check --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button" --tag "c9bbc3fcc69e5aa094bca110c6f79419ab7be77a"

274+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"

271275```

272276

273277### 👀 info

@@ -276,6 +280,11 @@ tag_check --project-name "Cactus store" --base-domain "cactus-store.com" --names

276280

277281This 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.

278282

283+This script receives the following additional command-line arguments as input:

284+* `--tag` – The _Docker Image tag_ that should be checked.

285+* `--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.

286+* `--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.

287+

279288The script should return the metadata as a two-column CSV table:

280289

281290```

@@ -290,7 +299,7 @@ This script receives only [the default command-line arguments](#general-behavior

290299The script might be called something like this:

291300

292301```bash

293−info --project-name "Cactus store" --base-domain "cactus-store.com" --namespace "cactus" --name "orange-button"

302+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"

294303```

295304

296305#### Sample implementation

octopod-backend/octopod-backend.cabal+1

@@ -54,6 +54,7 @@ library

5454 , TypeFamilies

5555 , QuantifiedConstraints

5656 , DeriveAnyClass

57+ , ViewPatterns

5758 exposed-modules:

5859 Octopod.Server

5960 Octopod.Server.Args

octopod-backend/src/Octopod/Server.hs+50−65

@@ -8,7 +8,7 @@ import Control.Concurrent.Async (race_)

88import qualified Control.Concurrent.Lifted as L

99import Control.Concurrent.MVar

1010import Control.Concurrent.STM

11−import Control.Exception (Exception, throwIO, try)

11+import Control.Exception (Exception, displayException, throwIO, try)

1212import qualified Control.Exception.Lifted as L

1313import Control.Lens hiding (Context, pre)

1414import Control.Lens.Extras

@@ -34,6 +34,7 @@ import Data.Int (Int64)

3434import Data.Maybe

3535import Data.Pool

3636import Data.Text (lines, pack, unpack, unwords)

37+import qualified Data.Text as T

3738import qualified Data.Text.Encoding as T

3839import Data.Traversable

3940import Database.PostgreSQL.Simple hiding ((:.))

@@ -391,7 +392,7 @@ createH dep = do

391392 t1 <- liftIO $ now

392393 st <- ask

393394 let pgPool = pool st

394− failIfImageNotFound (name dep) (tag dep)

395+ failIfImageNotFound dep

395396 failIfGracefulShutdownActivated

396397 runDeploymentBgWorker

397398 Nothing

@@ -426,7 +427,7 @@ createH dep = do

426427 liftIO . withResource pgPool $ \conn ->

427428 upsertNewOverrides conn dId (appOverrides dep) (deploymentOverrides dep)

428429 liftBase $ sendReloadEvent st

429− liftBase $ updateDeploymentInfo (name dep) st

430+ updateDeploymentInfo (name dep)

430431 (ec, out, err) <- liftBase $ createDeployment dep st

431432 t2 <- liftBase $ now

432433 let elTime = elapsedTime t2 t1

@@ -438,17 +439,21 @@ createH dep = do

438439 pure Success

439440

440441-- | Updates deployment info.

441−updateDeploymentInfo :: DeploymentName -> AppState -> IO ()

442−updateDeploymentInfo dName st = do

443− let log = logWarning (logger st)

444− args = infoCommandArgs (projectName st) (baseDomain st) (namespace st) dName

445− cmd = coerce $ infoCommand st

446− liftIO $ do

447− (ec, out, err) <- runCommand (unpack cmd) (coerce args)

442+updateDeploymentInfo ::

443+ (MonadReader AppState m, MonadBaseControl IO m, MonadError ServerError m) =>

444+ DeploymentName ->

445+ m ()

446+updateDeploymentInfo dName = do

447+ log <- asks (logWarning . logger)

448+ pgPool <- asks pool

449+ DeploymentFullInfo {deployment = dep} <-

450+ withResource pgPool $ \conn -> getDeploymentS conn dName

451+ (ec, out, err) <- runCommandArgs infoCommand =<< infoCommandArgs dep

452+ liftBase $

448453 case ec of

449454 ExitSuccess -> do

450455 dMeta <- parseDeploymentMetadata (lines . unStdout $ out)

451− upsertDeploymentMetadata (pool st) dName dMeta

456+ upsertDeploymentMetadata pgPool dName dMeta

452457 ExitFailure _ ->

453458 log $

454459 "could not get deployment info, exit code: " <> (pack . show $ ec)

@@ -484,23 +489,6 @@ createDeployment dep st = do

484489 log $ "deployment created, deployment: " <> (pack . show $ dep)

485490 pure (ec, out, err)

486491

487−-- | Converts an application-level override list to command arguments.

488−applicationOverrideToArg :: ApplicationOverride -> [Text]

489−applicationOverrideToArg o = ["--app-env-override", overrideToArg . coerce $ o]

490−

491−-- | Helper to convert an application-level override to command arguments.

492−applicationOverridesToArgs :: ApplicationOverrides -> [Text]

493−applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs]

494−

495−-- | Converts a deployment-level override list to command arguments.

496−deploymentOverrideToArg :: DeploymentOverride -> [Text]

497−deploymentOverrideToArg o =

498− ["--deployment-override", overrideToArg . coerce $ o]

499−

500−-- | Helper to convert a deployment-level override to command arguments.

501−deploymentOverridesToArgs :: DeploymentOverrides -> [Text]

502−deploymentOverridesToArgs ovs = concat [deploymentOverrideToArg o | o <- ovs]

503−

504492-- | Helper to get deployment logs.

505493selectDeploymentLogs ::

506494 PgPool ->

@@ -527,15 +515,22 @@ selectDeployment ::

527515 AppM Deployment

528516selectDeployment dName = do

529517 pgPool <- asks pool

518+ liftBaseOp (withResource pgPool) $ \conn ->

519+ liftIO (selectDeploymentIO conn dName) >>= either throwError pure

520+

521+selectDeploymentIO ::

522+ Connection ->

523+ DeploymentName ->

524+ IO (Either ServerError Deployment)

525+selectDeploymentIO conn dName = do

530526 let q = "SELECT name, tag FROM deployments WHERE name = ?"

531− liftBaseOp (withResource pgPool) $ \conn -> do

532− retrieved <- liftBase $ query conn q (Only dName)

533− case retrieved of

534− [(n, t)] -> do

535− (appOvs, stOvs) <- liftBase $ selectOverrides conn n

536− pure $ Deployment n t appOvs stOvs

537− [] -> throwError err404 {errBody = "Deployment not found."}

538− _ -> throwError err500

527+ retrieved <- liftBase $ query conn q (Only dName)

528+ case retrieved of

529+ [(n, t)] -> do

530+ (appOvs, stOvs) <- liftBase $ selectOverrides conn n

531+ pure . Right $ Deployment n t appOvs stOvs

532+ [] -> pure . Left $ err404 {errBody = "Deployment not found."}

533+ _ -> pure . Left $ err500

539534

540535data StatusTransitionProcessOutput = StatusTransitionProcessOutput

541536 { exitCode :: ExitCode

@@ -757,7 +752,8 @@ updateH dName dUpdate = do

757752 pgPool = pool st

758753 log = logInfo (logger st)

759754 dId <- selectDeploymentId pgPool dName

760− failIfImageNotFound dName dTag

755+ olDep <- selectDeployment dName

756+ failIfImageNotFound (applyDeploymentUpdate dUpdate olDep)

761757 failIfGracefulShutdownActivated

762758 runDeploymentBgWorker (Just UpdatePending) dName (pure ()) $ \() -> do

763759 (appOvs, depOvs) <- liftBase . withResource pgPool $ \conn ->

@@ -766,7 +762,7 @@ updateH dName dUpdate = do

766762 upsertNewOverrides conn dId newAppOvs newDepOvs

767763 updateTag conn dId dTag

768764 selectOverrides conn dName

769− liftBase $ updateDeploymentInfo dName st

765+ updateDeploymentInfo dName

770766 liftBase $ sendReloadEvent st

771767 let args =

772768 [ "--project-name"

@@ -1000,7 +996,7 @@ statusH :: DeploymentName -> AppM CurrentDeploymentStatus

1000996statusH dName = do

1001997 pgPool <- asks pool

1002998 dep <- withResource pgPool $ \conn -> getDeploymentS conn dName

1003− (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs dName (dep ^. #deployment . #tag)

999+ (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs (dep ^. #deployment)

10041000 pure . CurrentDeploymentStatus $

10051001 case ec of

10061002 ExitSuccess -> Ok

@@ -1102,11 +1098,11 @@ restoreH dName = do

11021098 t1 <- liftIO $ now

11031099 st <- ask

11041100 dep <- selectDeployment dName

1105− failIfImageNotFound (name dep) (tag dep)

1101+ failIfImageNotFound dep

11061102 failIfGracefulShutdownActivated

11071103 runDeploymentBgWorker (Just CreatePending) dName (pure ()) $ \() -> do

11081104 dep' <- selectDeployment dName

1109− liftBase $ updateDeploymentInfo dName st

1105+ updateDeploymentInfo dName

11101106 (ec, out, err) <- liftBase $ createDeployment dep' st

11111107 t2 <- liftBase now

11121108 let elTime = elapsedTime t2 t1

@@ -1248,28 +1244,9 @@ upsertDeploymentMetadata pgPool dName dMetadatas = do

12481244

12491245-- | Checks the existence of a deployment tag.

12501246-- Returns 404 'Tag not found' response if the deployment tag doesn't exist.

1251−failIfImageNotFound :: DeploymentName -> DeploymentTag -> AppM ()

1252−failIfImageNotFound dName dTag = do

1253− st <- ask

1254− let log :: Text -> IO ()

1255− log = logInfo (logger st)

1256− args =

1257− [ "--project-name"

1258− , coerce $ projectName st

1259− , "--base-domain"

1260− , coerce $ baseDomain st

1261− , "--namespace"

1262− , coerce $ namespace st

1263− , "--name"

1264− , coerce $ dName

1265− , "--tag"

1266− , coerce $ dTag

1267− ]

1268− cmd = coerce $ tagCheckingCommand st

1269−

1270− ec <- liftIO $ do

1271− log $ "call " <> unwords (cmd : args)

1272− runCommandWithoutPipes (unpack cmd) (unpack <$> args)

1247+failIfImageNotFound :: Deployment -> AppM ()

1248+failIfImageNotFound dep = do

1249+ (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs dep

12731250 case ec of

12741251 ExitSuccess -> pure ()

12751252 ExitFailure _ ->

@@ -1316,11 +1293,19 @@ runStatusUpdater state = do

13161293 withResource pgPool $ \conn -> query conn selectDeps (Only interval)

13171294 let checkList :: [(DeploymentName, DeploymentStatus, Timestamp, DeploymentTag)] =

13181295 (\(n, s, t, dTag) -> (n, s, coerce t, dTag)) <$> rows

1319− checkResult <- for checkList $ \(dName, dStatus, ts, dTag) -> do

1296+ checkResult <- for checkList $ \(dName, dStatus, ts, _) -> do

13201297 let timeout = statusUpdateTimeout state

13211298 (ec, _, _) <- flip runReaderT state case dStatus of

13221299 ArchivePending -> runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName

1323− _ -> runCommandArgs checkingCommand =<< checkCommandArgs dName dTag

1300+ _ -> do

1301+ liftBase (withResource pgPool $ \conn -> selectDeploymentIO conn dName) >>= \case

1302+ Right dep -> runCommandArgs checkingCommand =<< checkCommandArgs dep

1303+ Left err -> do

1304+ log <- asks logger

1305+ let err' = T.pack $ displayException $ err

1306+ liftIO $ logWarning log err'

1307+ pure (ExitFailure 1, Stdout "Didn't call script", Stderr err')

1308+

13241309 pure (dName, statusTransition ec dStatus ts timeout, dStatus)

13251310 updated <-

13261311 for checkResult $ \(dName, transitionM, dStatus) ->

octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+202−108

@@ -1,138 +1,207 @@

1−{-|

2−Module : Octopod.Server.ControlScriptUtils

3−Description : Control script utils.

4−

5−This module contains control script utils.

6−-}

1+-- |

2+--Module : Octopod.Server.ControlScriptUtils

3+--Description : Control script utils.

4+--

5+--This module contains control script utils.

6+module Octopod.Server.ControlScriptUtils

7+ ( infoCommandArgs,

8+ notificationCommandArgs,

9+ runCommand,

10+ runCommandWithoutPipes,

11+ runCommandArgs,

12+ runCommandArgs',

13+ checkCommandArgs,

14+ archiveCheckArgs,

15+ tagCheckCommandArgs,

716

17+ -- * Helpers

18+ applicationOverrideToArg,

19+ applicationOverridesToArgs,

20+ deploymentOverrideToArg,

21+ deploymentOverridesToArgs,

22+ )

23+where

824

9−module Octopod.Server.ControlScriptUtils

10− ( infoCommandArgs

11− , notificationCommandArgs

12− , runCommand

13− , runCommandWithoutPipes

14− , runCommandArgs

15− , runCommandArgs'

16− , checkCommandArgs

17− , archiveCheckArgs

18− ) where

19−

20−

21−import Control.Monad.Base

22−import Control.Monad.Reader

25+import Control.Monad.Base

26+import Control.Monad.Reader

2327import qualified Data.ByteString.Lazy as TL

24−import Data.Coerce

25−import Data.Generics.Product.Typed

28+import Data.Coerce

29+import Data.Generics.Product.Typed

30+import Data.Text (Text)

2631import qualified Data.Text as T

2732import qualified Data.Text.Encoding as T

28−import Octopod.Server.Logger

29−import System.Exit

30−import System.Log.FastLogger

31−import System.Process.Typed

32−import Types

33−

33+import Octopod.Server.Logger

34+import System.Exit

35+import System.Log.FastLogger

36+import System.Process.Typed

37+import Types

3438

3539-- | Creates command arguments for the 'info' deployment control script.

36−infoCommandArgs

37− :: ProjectName

38− -> Domain

39− -> Namespace

40− -> DeploymentName

41− -> ControlScriptArgs

42−infoCommandArgs pName domain ns dName =

43− ControlScriptArgs

44− [ "--project-name", T.unpack . coerce $ pName

45− , "--base-domain", T.unpack . coerce $ domain

46− , "--namespace", T.unpack . coerce $ ns

47− , "--name", T.unpack . coerce $ dName ]

48−

49−notificationCommandArgs

50− ::

51− ( MonadReader r m

52− , HasType Namespace r

53− , HasType ProjectName r

54− , HasType Domain r

55− )

56− => DeploymentName

57− -> DeploymentTag

58− -> DeploymentStatus

59− -- ^ Previous status

60− -> DeploymentStatus

61− -- ^ New status

62− -> m ControlScriptArgs

40+infoCommandArgs ::

41+ ( MonadReader r m

42+ , HasType Namespace r

43+ , HasType ProjectName r

44+ , HasType Domain r

45+ ) =>

46+ Deployment ->

47+ m ControlScriptArgs

48+infoCommandArgs dep = do

49+ (Namespace namespace) <- asks getTyped

50+ (ProjectName projectName) <- asks getTyped

51+ (Domain domain) <- asks getTyped

52+ return $

53+ ControlScriptArgs

54+ [ "--project-name"

55+ , T.unpack . coerce $ projectName

56+ , "--base-domain"

57+ , T.unpack . coerce $ domain

58+ , "--namespace"

59+ , T.unpack . coerce $ namespace

60+ , "--name"

61+ , T.unpack . coerce $ name dep

62+ , "--tag"

63+ , T.unpack . coerce $ tag dep

64+ ]

65+ <> getApplicationOverrideArgs dep

66+ <> getDeploymentOverrideArgs dep

67+

68+notificationCommandArgs ::

69+ ( MonadReader r m

70+ , HasType Namespace r

71+ , HasType ProjectName r

72+ , HasType Domain r

73+ ) =>

74+ DeploymentName ->

75+ DeploymentTag ->

76+ -- | Previous status

77+ DeploymentStatus ->

78+ -- | New status

79+ DeploymentStatus ->

80+ m ControlScriptArgs

6381notificationCommandArgs dName dTag old new = do

6482 (Namespace namespace) <- asks getTyped

6583 (ProjectName projectName) <- asks getTyped

6684 (Domain domain) <- asks getTyped

67− return $ ControlScriptArgs

68− [ "--project-name", T.unpack projectName

69− , "--base-domain", T.unpack domain

70− , "--namespace", T.unpack namespace

71− , "--name", T.unpack . coerce $ dName

72− , "--tag", T.unpack . coerce $ dTag

73− , "--old-status", T.unpack $ deploymentStatusText old

74− , "--new-status", T.unpack $ deploymentStatusText new

75− ]

76−

77−checkCommandArgs

78− ::

79− ( MonadReader r m

80− , HasType Namespace r

81− , HasType ProjectName r

82− , HasType Domain r

83− )

84− => DeploymentName

85− -> DeploymentTag

86− -> m ControlScriptArgs

87−checkCommandArgs dName dTag = do

85+ return $

86+ ControlScriptArgs

87+ [ "--project-name"

88+ , T.unpack projectName

89+ , "--base-domain"

90+ , T.unpack domain

91+ , "--namespace"

92+ , T.unpack namespace

93+ , "--name"

94+ , T.unpack . coerce $ dName

95+ , "--tag"

96+ , T.unpack . coerce $ dTag

97+ , "--old-status"

98+ , T.unpack $ deploymentStatusText old

99+ , "--new-status"

100+ , T.unpack $ deploymentStatusText new

101+ ]

102+

103+checkCommandArgs ::

104+ ( MonadReader r m

105+ , HasType Namespace r

106+ , HasType ProjectName r

107+ , HasType Domain r

108+ ) =>

109+ Deployment ->

110+ m ControlScriptArgs

111+checkCommandArgs dep = do

112+ (Namespace namespace) <- asks getTyped

88113 (ProjectName projectName) <- asks getTyped

89114 (Domain domain) <- asks getTyped

115+ return $

116+ ControlScriptArgs

117+ [ "--project-name"

118+ , T.unpack . coerce $ projectName

119+ , "--base-domain"

120+ , T.unpack . coerce $ domain

121+ , "--namespace"

122+ , T.unpack . coerce $ namespace

123+ , "--name"

124+ , T.unpack . coerce $ name dep

125+ , "--tag"

126+ , T.unpack . coerce $ tag dep

127+ ]

128+ <> getApplicationOverrideArgs dep

129+ <> getDeploymentOverrideArgs dep

130+

131+tagCheckCommandArgs ::

132+ ( MonadReader r m

133+ , HasType Namespace r

134+ , HasType ProjectName r

135+ , HasType Domain r

136+ ) =>

137+ Deployment ->

138+ m ControlScriptArgs

139+tagCheckCommandArgs dep = do

90140 (Namespace namespace) <- asks getTyped

91− return $ ControlScriptArgs

92− [ "--namespace", T.unpack namespace

93− , "--name", T.unpack . coerce $ dName

94− , "--tag", T.unpack . unDeploymentTag $ dTag

95− , "--project-name", T.unpack projectName

96− , "--base-domain", T.unpack domain

97− ]

98−

99−archiveCheckArgs

100− ::

101− ( MonadReader r m

102− , HasType Namespace r

103− , HasType ProjectName r

104− , HasType Domain r

105− )

106− => DeploymentName

107− -> m ControlScriptArgs

141+ (ProjectName projectName) <- asks getTyped

142+ (Domain domain) <- asks getTyped

143+ return $

144+ ControlScriptArgs

145+ [ "--project-name"

146+ , T.unpack . coerce $ projectName

147+ , "--base-domain"

148+ , T.unpack . coerce $ domain

149+ , "--namespace"

150+ , T.unpack . coerce $ namespace

151+ , "--name"

152+ , T.unpack . coerce $ name dep

153+ , "--tag"

154+ , T.unpack . coerce $ tag dep

155+ ]

156+ <> getApplicationOverrideArgs dep

157+ <> getDeploymentOverrideArgs dep

158+

159+archiveCheckArgs ::

160+ ( MonadReader r m

161+ , HasType Namespace r

162+ , HasType ProjectName r

163+ , HasType Domain r

164+ ) =>

165+ DeploymentName ->

166+ m ControlScriptArgs

108167archiveCheckArgs dName = do

109168 (ProjectName projectName) <- asks getTyped

110169 (Domain domain) <- asks getTyped

111170 (Namespace namespace) <- asks getTyped

112− return $ ControlScriptArgs

113− [ "--project-name", T.unpack projectName

114− , "--base-domain", T.unpack domain

115− , "--namespace", T.unpack namespace

116− , "--name", T.unpack . coerce $ dName

117− ]

118−

119−runCommandArgs

120− :: (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r)

121− => (r -> Command) -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr)

171+ return $

172+ ControlScriptArgs

173+ [ "--project-name"

174+ , T.unpack projectName

175+ , "--base-domain"

176+ , T.unpack domain

177+ , "--namespace"

178+ , T.unpack namespace

179+ , "--name"

180+ , T.unpack . coerce $ dName

181+ ]

182+

183+runCommandArgs ::

184+ (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r) =>

185+ (r -> Command) ->

186+ ControlScriptArgs ->

187+ m (ExitCode, Stdout, Stderr)

122188runCommandArgs f args = do

123189 cmd <- asks f

124190 runCommandArgs' cmd args

125191

126−runCommandArgs'

127− :: (MonadBase IO m, HasType TimedFastLogger r, MonadReader r m)

128− => Command -> ControlScriptArgs -> m (ExitCode, Stdout, Stderr)

192+runCommandArgs' ::

193+ (MonadBase IO m, HasType TimedFastLogger r, MonadReader r m) =>

194+ Command ->

195+ ControlScriptArgs ->

196+ m (ExitCode, Stdout, Stderr)

129197runCommandArgs' (Command cmd) (ControlScriptArgs args) = do

130198 logger <- asks (getTyped @TimedFastLogger)

131199 let logText = T.unwords (cmd : fmap T.pack args)

132200 liftBase $ logInfo logger $ "calling: " <> logText

133201 res@(ec, _, _) <- runCommand (T.unpack cmd) args

134− liftBase $ logInfo logger

135− $ "calling `" <> logText <> "` exited with: " <> show' ec

202+ liftBase $

203+ logInfo logger $

204+ "calling `" <> logText <> "` exited with: " <> show' ec

136205 return res

137206

138207-- | Helper to run command with pipes.

@@ -149,3 +218,28 @@ runCommand cmd args = do

149218runCommandWithoutPipes :: FilePath -> [String] -> IO ExitCode

150219runCommandWithoutPipes cmd args =

151220 withProcessWait (proc cmd args) waitExitCode

221+

222+-- | Converts an application-level override list to command arguments.

223+applicationOverrideToArg :: ApplicationOverride -> [Text]

224+applicationOverrideToArg o = ["--app-env-override", overrideToArg . coerce $ o]

225+

226+-- | Helper to convert an application-level override to command arguments.

227+applicationOverridesToArgs :: ApplicationOverrides -> [Text]

228+applicationOverridesToArgs ovs = concat [applicationOverrideToArg o | o <- ovs]

229+

230+getApplicationOverrideArgs :: Deployment -> ControlScriptArgs

231+getApplicationOverrideArgs =

232+ ControlScriptArgs . map T.unpack . applicationOverridesToArgs . appOverrides

233+

234+-- | Converts a deployment-level override list to command arguments.

235+deploymentOverrideToArg :: DeploymentOverride -> [Text]

236+deploymentOverrideToArg o =

237+ ["--deployment-override", overrideToArg . coerce $ o]

238+

239+-- | Helper to convert a deployment-level override to command arguments.

240+deploymentOverridesToArgs :: DeploymentOverrides -> [Text]

241+deploymentOverridesToArgs ovs = concat [deploymentOverrideToArg o | o <- ovs]

242+

243+getDeploymentOverrideArgs :: Deployment -> ControlScriptArgs

244+getDeploymentOverrideArgs =

245+ ControlScriptArgs . map T.unpack . deploymentOverridesToArgs . deploymentOverrides

octopod-backend/src/Types.hs+1

@@ -75,3 +75,4 @@ newtype Command = Command {unCommand :: Text}

7575newtype ControlScriptArgs = ControlScriptArgs

7676 {unControlScriptArgs :: [String]}

7777 deriving stock (Show)

78+ deriving newtype (Semigroup, Monoid)

octopod-common/src/Common/Types.hs+14−1

@@ -10,7 +10,7 @@ module Common.Types where

1010import Data.Bifunctor

1111import Data.Coerce

1212import Data.String

13−import Data.Text as T

13+import Data.Text as T hiding (filter)

1414import Data.Traversable

1515import Deriving.Aeson.Stock

1616import Web.HttpApiData

@@ -187,6 +187,19 @@ data DeploymentUpdate = DeploymentUpdate

187187 deriving stock (Generic, Show)

188188 deriving (FromJSON, ToJSON) via Snake DeploymentUpdate

189189

190+applyDeploymentUpdate :: DeploymentUpdate -> Deployment -> Deployment

191+applyDeploymentUpdate du d =

192+ Deployment

193+ { name = name d

194+ , tag = newTag du

195+ , appOverrides =

196+ filter (`notElem` oldAppOverrides du) (appOverrides d)

197+ <> newAppOverrides du

198+ , deploymentOverrides =

199+ filter (`notElem` oldDeploymentOverrides du) (deploymentOverrides d)

200+ <> newDeploymentOverrides du

201+ }

202+

190203data CurrentStatus

191204 = Ok

192205 | Error