071d58d · typeable/octopod

charts/octopod/templates/octopod-configmap.yaml+1−1

@@ -16,7 +16,7 @@ data:

1616 CHECKING_COMMAND: {{ printf "%s/check" (include "controlScriptsPath" .) | quote }}

1717 CLEANUP_COMMAND: {{ printf "%s/cleanup" (include "controlScriptsPath" .) | quote }}

1818 ARCHIVE_CHECKING_COMMAND: {{ printf "%s/archive_check" (include "controlScriptsPath" .) | quote }}

19− TAG_CHECKING_COMMAND: {{ printf "%s/tag_check" (include "controlScriptsPath" .) | quote }}

19+ CONFIG_CHECKING_COMMAND: {{ printf "%s/tag_check" (include "controlScriptsPath" .) | quote }}

2020 INFO_COMMAND: {{ printf "%s/info" (include "controlScriptsPath" .) | quote }}

2121 {{- range $name, $value := .Values.octopod.env }}

2222 {{ $name }}: {{ $value | quote }}

dev/default.nix+6−2

@@ -97,7 +97,11 @@ in

9797 failScript = pkgs.writeScript "fail.sh" ''

9898 #!${pkgs.bash}/bin/bash

9999

100− exit 1

100+ 1>&2 echo "You did something wrong :("

101+

102+ echo "You did something wrong, but you shouldn't see this."

103+

104+ exit 0

101105 '';

102106

103107 infoScript = pkgs.writeScript "info.sh" ''

@@ -137,7 +141,7 @@ in

137141 export CHECKING_COMMAND=${echoScript}

138142 export CLEANUP_COMMAND=${echoScript}

139143 export ARCHIVE_CHECKING_COMMAND=${echoScript}

140− export TAG_CHECKING_COMMAND=${echoScript}

144+ export CONFIG_CHECKING_COMMAND=${failScript}

141145 export INFO_COMMAND=${infoScript}

142146 export NOTIFICATION_COMMAND=${writeScript}

143147 export DEPLOYMENT_OVERRIDES_COMMAND=${infoScript}

migrations/deploy/move_tag_to_overrides.sqlnew file+18

@@ -0,0 +1,18 @@

1+-- Deploy octopod:move_tag_to_overrides to pg

2+

3+BEGIN;

4+

5+

6+UPDATE deployments as d

7+ SET app_overrides = d.app_overrides ||

8+ jsonb_build_array(jsonb_build_array('image.tag', jsonb_build_object('tag', 'ValueAdded', 'contents', d.tag)));

9+

10+ALTER TABLE "deployments" DROP COLUMN "tag";

11+

12+UPDATE deployment_logs as d

13+ SET app_overrides = d.app_overrides ||

14+ jsonb_build_array(jsonb_build_array('image.tag', jsonb_build_object('tag', 'ValueAdded', 'contents', d.tag)));

15+

16+ALTER TABLE "deployment_logs" DROP COLUMN "tag";

17+

18+COMMIT;

migrations/revert/move_tag_to_overrides.sqlnew file+62

@@ -0,0 +1,62 @@

1+-- Revert octopod:move_tag_to_overrides from pg

2+BEGIN;

3+ALTER TABLE deployments

4+ADD COLUMN tag text;

5+UPDATE deployments AS d

6+SET tag = COALESCE(

7+ (

8+ WITH appOvs AS (

9+ SELECT jsonb_array_elements(d."app_overrides") AS res

10+ )

11+ SELECT a.res->1->>'contents'

12+ FROM appOvs AS a

13+ WHERE (a.res->>0) = 'image.tag'

14+ ),

15+ ''

16+ );

17+UPDATE deployments AS d

18+SET app_overrides = COALESCE(

19+ (

20+ WITH appOvs AS (

21+ SELECT jsonb_array_elements(d."app_overrides") AS res

22+ )

23+ SELECT jsonb_agg(a.res)

24+ FROM appOvs AS a

25+ WHERE (a.res->>0) != 'image.tag'

26+ ),

27+ '[]'

28+ );

29+ALTER TABLE deployments

30+ALTER COLUMN tag

31+SET NOT NULL;

32+--

33+ALTER TABLE deployment_logs

34+ADD COLUMN tag text;

35+UPDATE deployment_logs AS d

36+SET tag = COALESCE(

37+ (

38+ WITH appOvs AS (

39+ SELECT jsonb_array_elements(d."app_overrides") AS res

40+ )

41+ SELECT a.res->1->>'contents'

42+ FROM appOvs AS a

43+ WHERE (a.res->>0) = 'image.tag'

44+ ),

45+ ''

46+ );

47+UPDATE deployment_logs AS d

48+SET app_overrides = COALESCE(

49+ (

50+ WITH appOvs AS (

51+ SELECT jsonb_array_elements(d."app_overrides") AS res

52+ )

53+ SELECT jsonb_agg(a.res)

54+ FROM appOvs AS a

55+ WHERE (a.res->>0) != 'image.tag'

56+ ),

57+ '[]'

58+ );

59+ALTER TABLE deployment_logs

60+ALTER COLUMN tag

61+SET NOT NULL;

62+COMMIT;

migrations/sqitch.plan+1

@@ -16,3 +16,4 @@ rename_delete_to_archive_2 2020-11-26T08:28:58Z Typeable LLC <octopod@typeable.i

1616add_detailed_failures 2021-02-04T11:01:15Z Typeable LLC <octopod@typeable.io> # Added more failure states

1717remove_archived_column 2021-01-28T18:44:54Z Typeable LLC <octopod@typeable.io> # Removed 'archived' column

1818migrate_2.0 2021-08-11T17:09:37Z Typeable LLC <octopod@typeable.io> # Migrate to 2.0-style tables. (Less tables)

19+move_tag_to_overrides 2021-09-25T14:29:43Z Typeable LLC <octopod@typeable.io> # Remove tag as a special field, making it an override field.

migrations/verify/move_tag_to_overrides.sqlnew file+7

@@ -0,0 +1,7 @@

1+-- Verify octopod:move_tag_to_overrides on pg

2+

3+BEGIN;

4+

5+-- XXX Add verifications here.

6+

7+ROLLBACK;

octo-cli/src/Octopod/CLI.hs+9−14

@@ -64,18 +64,17 @@ runOcto = do

6464 let clientEnv = mkClientEnv manager env

6565 flip runReaderT clientEnv $

6666 case args of

67− Create tName tTag tSetAp tSetDep -> do

67+ Create tName tSetAp tSetDep -> do

6868 appOvs <- either dieT pure $ parseSetOverrides tSetAp

6969 depOvs <- either dieT pure $ parseSetOverrides tSetDep

70− handleCreate auth $ Deployment (coerce tName) (coerce tTag) appOvs depOvs

70+ handleCreate auth $ Deployment (coerce tName) appOvs depOvs

7171 List -> handleList auth

7272 Archive tName -> handleArchive auth . coerce $ tName

73− Update tName tTag tSetAp unsetApp tSetD unsetDep -> do

73+ Update tName tSetAp unsetApp tSetD unsetDep -> do

7474 appOvs <- either dieT pure $ parseSetOverrides tSetAp

7575 depOvs <- either dieT pure $ parseSetOverrides tSetD

7676 let tName' = coerce tName

77− tTag' = coerce <$> tTag

78− handleUpdate auth tName' tTag' appOvs unsetApp depOvs unsetDep

77+ handleUpdate auth tName' appOvs unsetApp depOvs unsetDep

7978 Info tName ->

8079 handleInfo auth . coerce $ tName

8180 Cleanup tName ->

@@ -126,13 +125,12 @@ handleArchive auth dName = do

126125handleUpdate ::

127126 AuthContext AuthHeaderAuth ->

128127 DeploymentName ->

129− Maybe DeploymentTag ->

130128 Overrides 'ApplicationLevel ->

131129 [Text] ->

132130 Overrides 'DeploymentLevel ->

133131 [Text] ->

134132 ReaderT ClientEnv IO ()

135−handleUpdate auth dName dTag dNewAppOvs removedAppOvs dNewDepOvs removedDepOvs = do

133+handleUpdate auth dName dNewAppOvs removedAppOvs dNewDepOvs removedDepOvs = do

136134 clientEnv <- ask

137135 dep <- runClientM' (_fullInfoH auth dName) clientEnv

138136 let removeAll :: Ord k => [k] -> OM.OMap k v -> Either k (OM.OMap k v)

@@ -156,8 +154,7 @@ handleUpdate auth dName dTag dNewAppOvs removedAppOvs dNewDepOvs removedDepOvs =

156154 liftIO $ do

157155 let dUpdate =

158156 DeploymentUpdate

159− { newTag = fromMaybe (dep ^. #deployment . #tag) dTag

160− , appOverrides = appOverrides'

157+ { appOverrides = appOverrides'

161158 , deploymentOverrides = deploymentOverrides'

162159 }

163160 response <- runClientM (updateH auth dName dUpdate) clientEnv

@@ -268,17 +265,16 @@ handleResponse _ (Left err) =

268265decodeError :: LBSC.ByteString -> Text

269266decodeError body =

270267 case decode body of

271− Just (ValidationError nameErrors tagErrors) ->

272− T.concat ((<> "\n") <$> nameErrors) <> T.concat ((<> "\n") <$> tagErrors)

268+ Just (ValidationError nameErrors) ->

269+ T.concat ((<> "\n") <$> nameErrors)

273270 Just (AppError errorMsg) -> errorMsg

274271 Just Success -> "ok"

275272 _ -> "error: " <> (T.pack . LBSC.unpack $ body)

276273

277274-- | Pretty-prints the 'info' subcommand result.

278275printInfo :: DeploymentInfo -> IO ()

279−printInfo (DeploymentInfo (Deployment _ dTag dAppOvs dStOvs) (DeploymentMetadata dMeta) dLogs) = do

276+printInfo (DeploymentInfo (Deployment _ dAppOvs dStOvs) (DeploymentMetadata dMeta) dLogs) = do

280277 T.putStrLn "Current settings:"

281− T.putStrLn $ "tag: " <> coerce dTag

282278 T.putStrLn $

283279 "application overrides: "

284280 <> formatOverrides dAppOvs

@@ -329,7 +325,6 @@ ppDeploymentLogRow dLog =

329325 ]

330326 , [dLog ^. field @"actionId" . to unActionId . re _Show . packed]

331327 , [dLog ^. field @"action" . to actionToText]

332− , [dLog ^. field @"deploymentTag" . coerced]

333328 , dLog ^. field @"deploymentAppOverrides" . to formatOverrides'

334329 , dLog ^. field @"deploymentDepOverrides" . to formatOverrides'

335330 , [dLog ^. field @"exitCode" . re _Show . packed]

octo-cli/src/Octopod/CLI/Args.hs−6

@@ -14,8 +14,6 @@ data Args

1414 = Create

1515 { -- | deployment name

1616 name :: Text

17− , -- | deployment tag

18− tag :: Text

1917 , -- | application-level overrides to set

2018 setAppOverrides :: [Text]

2119 , -- | deployment-level overrides to set

@@ -29,8 +27,6 @@ data Args

2927 | Update

3028 { -- | deployment name

3129 name :: Text

32− , -- | deployment tag

33− newTag :: Maybe Text

3430 , -- | application-level overrides to set

3531 setAppOverrides :: [Text]

3632 , -- | application-level overrides to unset

@@ -96,7 +92,6 @@ createArgs :: Parser Args

9692createArgs =

9793 Create

9894 <$> strOption (long "name" <> short 'n' <> help "deployment name")

99− <*> strOption (long "tag" <> short 't' <> help "deployment tag")

10095 <*> many

10196 ( strOption

10297 ( long "set-app-env-override"

@@ -128,7 +123,6 @@ updateArgs :: Parser Args

128123updateArgs =

129124 Update

130125 <$> strOption (long "name" <> short 'n' <> help "deployment name")

131− <*> optional (strOption (long "tag" <> short 't' <> help "deployment tag"))

132126 <*> many

133127 ( strOption

134128 ( long "set-app-env-override"

octopod-backend/octopod-backend.cabal+2

@@ -57,6 +57,8 @@ library

5757 , ViewPatterns

5858 , TupleSections

5959 , GADTs

60+ , TypeSynonymInstances

61+ , FlexibleInstances

6062 exposed-modules:

6163 Octopod.Server

6264 Octopod.Server.Args

octopod-backend/src/Octopod/Schema.hs−4

@@ -25,7 +25,6 @@ deploymentSchema =

2525 DeploymentSchema

2626 { id_ = "id"

2727 , name = "name"

28− , tag = "tag"

2928 , appOverrides = "app_overrides"

3029 , deploymentOverrides = "deployment_overrides"

3130 , createdAt = "created_at"

@@ -41,7 +40,6 @@ deploymentSchema =

4140data DeploymentSchema f = DeploymentSchema

4241 { id_ :: Column f DeploymentId

4342 , name :: Column f DeploymentName

44− , tag :: Column f DeploymentTag

4543 , appOverrides :: Column f (Overrides 'ApplicationLevel)

4644 , deploymentOverrides :: Column f (Overrides 'DeploymentLevel)

4745 , createdAt :: Column f UTCTime

@@ -62,7 +60,6 @@ data DeploymentLogSchema f = DeploymentLogSchema

6260 { actionId :: Column f ActionId

6361 , deploymentId :: Column f DeploymentId

6462 , action :: Column f Action

65− , deploymentTag :: Column f DeploymentTag

6663 , exitCode :: Column f Int64

6764 , createdAt :: Column f UTCTime

6865 , archived :: Column f Bool

@@ -85,7 +82,6 @@ deploymentLogSchema =

8582 { actionId = "id"

8683 , deploymentId = "deployment_id"

8784 , action = "action"

88− , deploymentTag = "tag"

8985 , exitCode = "exit_code"

9086 , createdAt = "created_at"

9187 , archived = "archived"

octopod-backend/src/Octopod/Server.hs+34−64

@@ -36,7 +36,7 @@ import Data.Int

3636import qualified Data.Map.Ordered.Strict as OM

3737import Data.Maybe

3838import Data.Pool

39−import Data.Text (pack, unpack, unwords)

39+import Data.Text (pack)

4040import qualified Data.Text as T

4141import qualified Data.Text.Encoding as T

4242import Data.Time

@@ -115,7 +115,7 @@ data AppState = AppState

115115 , -- | archive checking command path

116116 archiveCheckingCommand :: Command

117117 , -- | tag checking command path

118− tagCheckingCommand :: Command

118+ configCheckingCommand :: Command

119119 , infoCommand :: Command

120120 , notificationCommand :: Maybe Command

121121 , deploymentOverridesCommand :: Command

@@ -178,7 +178,7 @@ runOctopodServer = do

178178 checkingCmd <- Command . pack <$> getEnvOrDie "CHECKING_COMMAND"

179179 cleanupCmd <- Command . pack <$> getEnvOrDie "CLEANUP_COMMAND"

180180 archiveCheckingCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"

181− tagCheckingCmd <- Command . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"

181+ tagCheckingCmd <- Command . pack <$> getEnvOrDie "CONFIG_CHECKING_COMMAND"

182182 infoCmd <- Command . pack <$> getEnvOrDie "INFO_COMMAND"

183183 dOverridesCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_OVERRIDES_COMMAND"

184184 dKeysCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_KEYS_COMMAND"

@@ -244,7 +244,7 @@ runOctopodServer = do

244244 , checkingCommand = checkingCmd

245245 , cleanupCommand = cleanupCmd

246246 , archiveCheckingCommand = archiveCheckingCmd

247− , tagCheckingCommand = tagCheckingCmd

247+ , configCheckingCommand = tagCheckingCmd

248248 , infoCommand = infoCmd

249249 , notificationCommand = notificationCmd

250250 , deploymentOverridesCommand = dOverridesCmd

@@ -413,7 +413,7 @@ fullInfoH dName = do

413413 Nothing ->

414414 throwError

415415 err404

416− { errBody = validationError ["Name not found"] []

416+ { errBody = validationError ["Name not found"]

417417 }

418418

419419-- | Handles the 'full_info' request of the octo CLI API.

@@ -454,7 +454,7 @@ createH dep = do

454454 \under 17 characters and begin with a letter."

455455 throwError

456456 err400

457− { errBody = validationError [badNameText] []

457+ { errBody = validationError [badNameText]

458458 }

459459 t1 <- liftBase getCurrentTime

460460 failIfImageNotFound dep

@@ -474,7 +474,6 @@ createH dep = do

474474 [ DeploymentSchema

475475 { id_ = unsafeDefault

476476 , name = litExpr $ dep ^. #name

477− , tag = litExpr $ dep ^. #tag

478477 , appOverrides = litExpr $ dep ^. #appOverrides

479478 , deploymentOverrides = litExpr $ dep ^. #deploymentOverrides

480479 , createdAt = now

@@ -495,7 +494,7 @@ createH dep = do

495494 | code == unique_violation ->

496495 throwError

497496 err400

498− { errBody = validationError ["Deployment already exists"] []

497+ { errBody = validationError ["Deployment already exists"]

499498 }

500499 Left _ ->

501500 throwError err409 {errBody = appError "Some database error"}

@@ -566,8 +565,6 @@ createDeployment dep = do

566565 , T.unpack . coerce $ namespace st

567566 , "--name"

568567 , T.unpack . coerce $ dep ^. #name

569− , "--tag"

570− , T.unpack . coerce $ dep ^. #tag

571568 ]

572569 <> fullConfigArgs cfg

573570 (ec, out, err) <- runCommandArgs creationCommand args

@@ -722,7 +719,7 @@ transitionToStatus dName s = do

722719 forM_ notificationCmd $ \nCmd ->

723720 runBgWorker . void $

724721 runCommandArgs' nCmd

725− =<< notificationCommandArgs dName (dep ^. #tag) oldS newS

722+ =<< notificationCommandArgs dName oldS newS

726723 liftBase $ sendReloadEvent st

727724

728725assertStatusTransitionPossible ::

@@ -777,22 +774,10 @@ archiveH :: DeploymentName -> AppM CommandResponse

777774archiveH dName = do

778775 failIfGracefulShutdownActivated

779776 t1 <- liftBase getCurrentTime

780− st <- ask

781− let log = liftBase . logInfo (logger st)

782− args =

783− [ "--project-name"

784− , coerce $ projectName st

785− , "--base-domain"

786− , coerce $ baseDomain st

787− , "--namespace"

788− , coerce $ namespace st

789− , "--name"

790− , coerce dName

791− ]

792− cmd = coerce $ archiveCommand st

793777 runDeploymentBgWorker (Just ArchivePending) dName (pure ()) $ \() -> do

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

795− (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)

778+ (view #deployment -> dep) <- getDeploymentS dName

779+ cfg <- getDeploymentConfig dep

780+ (ec, out, err) <- runCommandArgs archiveCommand =<< archiveCommandArgs cfg dep

796781 t2 <- liftBase getCurrentTime

797782 let elTime = elapsedTime t2 t1

798783 transitionToStatusS dName $

@@ -831,7 +816,6 @@ updateH dName dUpdate = do

831816 , set = \() ds ->

832817 ds & #appOverrides .~ litExpr (dUpdate ^. #appOverrides)

833818 & #deploymentOverrides .~ litExpr (dUpdate ^. #deploymentOverrides)

834− & #tag .~ litExpr (dUpdate ^. #newTag)

835819 , updateWhere = \() ds -> ds ^. #name ==. litExpr dName

836820 , returning = Projection id

837821 }

@@ -851,16 +835,12 @@ updateH dName dUpdate = do

851835 , T.unpack . coerce $ namespace st

852836 , "--name"

853837 , T.unpack . coerce $ dName

854− , "--tag"

855− , T.unpack . coerce $ dep ^. #tag

856838 ]

857839 <> fullConfigArgs cfg

858840 (ec, out, err) <- runCommandArgs updateCommand args

859841 liftBase . log $

860842 "deployment updated, name: "

861843 <> coerce dName

862− <> ", tag: "

863− <> coerce (dep ^. #tag)

864844 t2 <- liftBase getCurrentTime

865845 let elTime = elapsedTime t2 t1

866846 transitionToStatusS dName $

@@ -934,25 +914,15 @@ cleanupH dName = do

934914

935915-- | Helper to cleanup deployment.

936916cleanupDeployment ::

937− (MonadBaseControl IO m, MonadReader AppState m) =>

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

938918 DeploymentName ->

939919 m ()

940920cleanupDeployment dName = do

941921 st <- ask

942922 let log = logInfo (logger st)

943− args =

944− [ "--project-name"

945− , coerce $ projectName st

946− , "--base-domain"

947− , coerce $ baseDomain st

948− , "--namespace"

949− , coerce $ namespace st

950− , "--name"

951− , coerce dName

952− ]

953− cmd = coerce $ cleanupCommand st

954− liftBase . log $ "call " <> unwords (cmd : args)

955− (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)

923+ (view #deployment -> dep) <- getDeploymentS dName

924+ cfg <- getDeploymentConfig dep

925+ (ec, out, err) <- runCommandArgs cleanupCommand =<< cleanupCommandArgs cfg dep

956926 liftBase $ print out >> print err

957927 deleteDeploymentLogs dName

958928 deleteDeployment dName

@@ -1080,7 +1050,6 @@ createDeploymentLog dep act ec dur out err = do

10801050 { actionId = unsafeDefault

10811051 , deploymentId = litExpr dId

10821052 , action = litExpr act

1083− , deploymentTag = litExpr $ dep ^. #tag

10841053 , exitCode = litExpr $ case ec of

10851054 ExitSuccess -> 0

10861055 ExitFailure errCode -> fromIntegral errCode

@@ -1123,20 +1092,20 @@ upsertDeploymentMetadatum dName dMetadata =

11231092failIfImageNotFound :: Deployment -> AppM ()

11241093failIfImageNotFound dep = do

11251094 cfg <- getDeploymentConfig dep

1126− (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs cfg dep

1095+ (ec, _, Stderr err) <- runCommandArgs configCheckingCommand =<< configCheckCommandArgs cfg dep

11271096 case ec of

11281097 ExitSuccess -> pure ()

11291098 ExitFailure _ ->

1130− throwError err400 {errBody = validationError [] ["Tag not found"]}

1099+ throwError err400 {errBody = BSL.fromStrict $ T.encodeUtf8 err}

11311100

11321101-- | Helper to create an application-level error.

11331102appError :: Text -> BSL.ByteString

11341103appError = encode . AppError

11351104

11361105-- | Helper to create a validation-level error.

1137−validationError :: [Text] -> [Text] -> BSL.ByteString

1138−validationError nameErrors tagErrors =

1139− encode $ ValidationError nameErrors tagErrors

1106+validationError :: [Text] -> BSL.ByteString

1107+validationError nameErrors =

1108+ encode $ ValidationError nameErrors

11401109

11411110-- | Helper to send an event to the WS event channel.

11421111sendReloadEvent :: AppState -> IO ()

@@ -1165,20 +1134,21 @@ runStatusUpdater state = do

11651134 ds <- each deploymentSchema

11661135 where_ $ ds ^. #checkedAt <. litExpr cutoff

11671136 where_ $ ds ^. #status /=. litExpr Archived

1168− pure (ds ^. #name, ds ^. #status, now `diffTime` (ds ^. #statusUpdatedAt), ds ^. #tag)

1169− checkResult <- for rows' $ \(dName, dStatus, Timestamp -> ts, _) -> do

1137+ pure (ds ^. #name, ds ^. #status, now `diffTime` (ds ^. #statusUpdatedAt))

1138+ checkResult <- for rows' $ \(dName, dStatus, Timestamp -> ts) -> do

11701139 let timeout = statusUpdateTimeout state

1171− mEc <- case dStatus of

1172− ArchivePending -> do

1173− (ec, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName

1174− pure $ Just ec

1175− _ -> do

1176− getSingleFullInfo dName >>= \case

1177− Nothing -> liftBase (logErr $ "Couldn't find deployment: " <> coerce dName) $> Nothing

1178− Just (view #deployment -> dep) -> do

1179− cfg <- getDeploymentConfig dep

1180− (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep

1181− pure $ Just ec

1140+ mEc <-

1141+ getSingleFullInfo dName >>= \case

1142+ Nothing -> liftBase (logErr $ "Couldn't find deployment: " <> coerce dName) $> Nothing

1143+ Just (view #deployment -> dep) -> do

1144+ cfg <- getDeploymentConfig dep

1145+ case dStatus of

1146+ ArchivePending -> do

1147+ (ec, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs cfg dep

1148+ pure $ Just ec

1149+ _ -> do

1150+ (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep

1151+ pure $ Just ec

11821152 pure $ mEc <&> \ec -> (dName, statusTransition ec dStatus ts timeout, dStatus)

11831153 updated <-

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

octopod-backend/src/Octopod/Server/ControlScriptUtils.hs+15−33

@@ -5,7 +5,9 @@

55--This module contains control script utils.

66module Octopod.Server.ControlScriptUtils

77 ( infoCommandArgs,

8+ archiveCommandArgs,

89 unarchiveCommandArgs,

10+ cleanupCommandArgs,

911 notificationCommandArgs,

1012 runCommand,

1113 runCommandWithoutPipes,

@@ -13,7 +15,7 @@ module Octopod.Server.ControlScriptUtils

1315 runCommandArgs',

1416 checkCommandArgs,

1517 archiveCheckArgs,

16− tagCheckCommandArgs,

18+ configCheckCommandArgs,

1719

1820 -- * overrides

1921 defaultDeploymentOverridesArgs,

@@ -67,8 +69,6 @@ genericDeploymentCommandArgs cfg dep = do

6769 , T.unpack . coerce $ namespace

6870 , "--name"

6971 , T.unpack . coerce $ dep ^. #name

70− , "--tag"

71− , T.unpack . coerce $ tag dep

7272 ]

7373 <> fullConfigArgs cfg

7474

@@ -101,11 +101,20 @@ genericDeploymentCommandArgsNoConfig = do

101101infoCommandArgs :: GenericDeploymentCommandArgs m r

102102infoCommandArgs = genericDeploymentCommandArgs

103103

104+archiveCommandArgs :: GenericDeploymentCommandArgs m r

105+archiveCommandArgs = genericDeploymentCommandArgs

106+

107+cleanupCommandArgs :: GenericDeploymentCommandArgs m r

108+cleanupCommandArgs = genericDeploymentCommandArgs

109+

110+archiveCheckArgs :: GenericDeploymentCommandArgs m r

111+archiveCheckArgs = genericDeploymentCommandArgs

112+

104113checkCommandArgs :: GenericDeploymentCommandArgs m r

105114checkCommandArgs = genericDeploymentCommandArgs

106115

107−tagCheckCommandArgs :: GenericDeploymentCommandArgs m r

108−tagCheckCommandArgs = genericDeploymentCommandArgs

116+configCheckCommandArgs :: GenericDeploymentCommandArgs m r

117+configCheckCommandArgs = genericDeploymentCommandArgs

109118

110119defaultDeploymentOverridesArgs :: GenericDeploymentCommandArgsNoConfig m r

111120defaultDeploymentOverridesArgs = genericDeploymentCommandArgsNoConfig

@@ -132,13 +141,12 @@ notificationCommandArgs ::

132141 , HasType Domain r

133142 ) =>

134143 DeploymentName ->

135− DeploymentTag ->

136144 -- | Previous status

137145 DeploymentStatus ->

138146 -- | New status

139147 DeploymentStatus ->

140148 m ControlScriptArgs

141−notificationCommandArgs dName dTag old new = do

149+notificationCommandArgs dName old new = do

142150 (Namespace namespace) <- asks getTyped

143151 (ProjectName projectName) <- asks getTyped

144152 (Domain domain) <- asks getTyped

@@ -152,38 +160,12 @@ notificationCommandArgs dName dTag old new = do

152160 , T.unpack namespace

153161 , "--name"

154162 , T.unpack . coerce $ dName

155− , "--tag"

156− , T.unpack . coerce $ dTag

157163 , "--old-status"

158164 , T.unpack $ deploymentStatusToText old

159165 , "--new-status"

160166 , T.unpack $ deploymentStatusToText new

161167 ]

162168

163−archiveCheckArgs ::

164− ( MonadReader r m

165− , HasType Namespace r

166− , HasType ProjectName r

167− , HasType Domain r

168− ) =>

169− DeploymentName ->

170− m ControlScriptArgs

171−archiveCheckArgs dName = do

172− (ProjectName projectName) <- asks getTyped

173− (Domain domain) <- asks getTyped

174− (Namespace namespace) <- asks getTyped

175− return $

176− ControlScriptArgs

177− [ "--project-name"

178− , T.unpack projectName

179− , "--base-domain"

180− , T.unpack domain

181− , "--namespace"

182− , T.unpack namespace

183− , "--name"

184− , T.unpack . coerce $ dName

185− ]

186−

187169runCommandArgs ::

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

189171 (r -> Command) ->

octopod-backend/src/Orphans.hs−3

@@ -23,9 +23,6 @@ deriving newtype instance DBEq DeploymentId

2323deriving newtype instance DBType DeploymentName

2424deriving newtype instance DBEq DeploymentName

2525

26−deriving newtype instance DBType DeploymentTag

27−deriving newtype instance DBEq DeploymentTag

28−

2926instance DBType Action where

3027 typeInformation = parseTypeInformationFromMapping actionText

3128

octopod-common/octopod-common.cabal+7

@@ -19,6 +19,7 @@ library

1919 , Common.Utils

2020 , Common.Validation

2121 , Data.Map.Ordered.Strict.Extra

22+ , Control.Searchable

2223 -- other-modules:

2324 -- other-extensions:

2425 default-extensions: BlockArguments

@@ -47,6 +48,12 @@ library

4748 , EmptyDataDeriving

4849 , TupleSections

4950 , AllowAmbiguousTypes

51+ , TypeFamilies

52+ , RankNTypes

53+ , MultiParamTypeClasses

54+ , ApplicativeDo

55+ , UndecidableInstances

56+ , FunctionalDependencies

5057 build-depends: base

5158 , aeson

5259 , cassava

octopod-common/src/Common/Types.hs+83−22

@@ -8,6 +8,7 @@

88module Common.Types where

99

1010import Control.Lens

11+import Control.Searchable

1112import Data.Aeson hiding (Result)

1213import Data.Csv

1314import Data.Generics.Labels ()

@@ -35,13 +36,32 @@ instance KnownOverrideLevel 'ApplicationLevel where

3536instance KnownOverrideLevel 'DeploymentLevel where

3637 knownOverrideLevel = DeploymentLevel

3738

38−data OverrideValue = ValueAdded Text | ValueDeleted

39− deriving (ToJSON, FromJSON) via Snake OverrideValue

39+instance Searchable needle t => Searchable needle (OverrideValue' t) where

40+ type SearchableConstraint needle (OverrideValue' t) res = SearchableConstraint needle t res

41+ type Searched (OverrideValue' t) res = OverrideValue' (Searched t res)

42+ searchWith _ ValueDeleted = pure ValueDeleted

43+ searchWith f (ValueAdded t) = ValueAdded <$> searchWith f t

44+ {-# INLINE searchWith #-}

45+

46+data OverrideValue' t = ValueAdded t | ValueDeleted

47+ deriving (ToJSON, FromJSON) via Snake (OverrideValue' t)

4048 deriving stock (Eq, Ord, Show, Generic)

4149

42−newtype DefaultConfig (l :: OverrideLevel) = DefaultConfig (OMap Text Text)

50+type OverrideValue = OverrideValue' Text

51+

52+type DefaultConfig = DefaultConfig' Text

53+

54+newtype DefaultConfig' te (l :: OverrideLevel) = DefaultConfig (OMap te te)

4355 deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)

4456

57+instance Searchable t x => Searchable t (DefaultConfig' x l) where

58+ type SearchableConstraint t (DefaultConfig' x l) res = (Ord (Searched x res), SearchableConstraint t x res)

59+ type Searched (DefaultConfig' x l) res = DefaultConfig' (Searched x res) l

60+ searchWith f (DefaultConfig oMap) = do

61+ oMap' <- searchWith f . OM.assocs $ oMap

62+ pure $ DefaultConfig $ OM.fromList oMap'

63+ {-# INLINE searchWith #-}

64+

4565lookupDefaultConfig :: DefaultConfig l -> Text -> Maybe Text

4666lookupDefaultConfig (DefaultConfig m) k = OM.lookup k m

4767

@@ -79,9 +99,19 @@ applyOverrides (Overrides oo) (DefaultConfig dd) =

7999 ValueDeleted -> False

80100 )

81101

82−newtype Overrides (l :: OverrideLevel) = Overrides {unOverrides :: OMap Text OverrideValue}

102+instance Searchable t x => Searchable t (Overrides' x l) where

103+ type SearchableConstraint t (Overrides' x l) res = (Ord (Searched x res), SearchableConstraint t x res)

104+ type Searched (Overrides' x l) res = Overrides' (Searched x res) l

105+ searchWith f (Overrides oMap) = do

106+ oMap' <- searchWith f . OM.assocs $ oMap

107+ pure $ Overrides $ OM.fromList oMap'

108+ {-# INLINE searchWith #-}

109+

110+newtype Overrides' t (l :: OverrideLevel) = Overrides {unOverrides :: OMap t (OverrideValue' t)}

83111 deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)

84112

113+type Overrides = Overrides' Text

114+

85115extractOverrides :: DefaultConfig l -> Config l -> Overrides l

86116extractOverrides (DefaultConfig dCfg) (Config cfg) =

87117 Overrides . OM.fromList $ removed <> present

@@ -115,13 +145,17 @@ instance Monoid (Overrides l) where

115145newtype DeploymentId = DeploymentId {unDeploymentId :: Int64}

116146 deriving stock (Show)

117147

118−newtype DeploymentName = DeploymentName {unDeploymentName :: Text}

148+instance Searchable needle t => Searchable needle (DeploymentName' t) where

149+ type SearchableConstraint needle (DeploymentName' t) res = SearchableConstraint needle t res

150+ type Searched (DeploymentName' t) res = DeploymentName' (Searched t res)

151+ searchWith f (DeploymentName t) = DeploymentName <$> searchWith f t

152+ {-# INLINE searchWith #-}

153+

154+newtype DeploymentName' t = DeploymentName {unDeploymentName :: t}

119155 deriving newtype

120156 (Show, Read, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData, Eq, Ord)

121157

122−newtype DeploymentTag = DeploymentTag {unDeploymentTag :: Text}

123− deriving newtype

124− (Show, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData, Eq)

158+type DeploymentName = DeploymentName' Text

125159

126160data Action = RestoreAction | ArchiveAction | UpdateAction | CreateAction

127161 deriving stock (Show, Read, Eq, Ord, Generic)

@@ -195,19 +229,36 @@ archivedStatuses = [ArchivePending, Archived]

195229isArchivedStatus :: DeploymentStatus -> Bool

196230isArchivedStatus = (`elem` archivedStatuses)

197231

198−data Deployment = Deployment

199− { name :: DeploymentName

200− , tag :: DeploymentTag

201− , appOverrides :: Overrides 'ApplicationLevel

202− , deploymentOverrides :: Overrides 'DeploymentLevel

232+data Deployment' t = Deployment

233+ { name :: DeploymentName' t

234+ , appOverrides :: Overrides' t 'ApplicationLevel

235+ , deploymentOverrides :: Overrides' t 'DeploymentLevel

203236 }

204237 deriving stock (Generic, Show, Eq)

205− deriving (FromJSON, ToJSON) via Snake Deployment

238+ deriving (FromJSON, ToJSON) via Snake (Deployment' t)

239+

240+instance (Searchable needle t) => Searchable needle (Deployment' t) where

241+ type

242+ SearchableConstraint needle (Deployment' t) res =

243+ (SearchableConstraint needle t res, Ord (Searched t res))

244+ type Searched (Deployment' t) res = Deployment' (Searched t res)

245+ searchWith f d = do

246+ name' <- searchWith f $ d ^. #name

247+ appOverrides' <- searchWith f $ d ^. #appOverrides

248+ deploymentOverrides' <- searchWith f $ d ^. #deploymentOverrides

249+ pure

250+ Deployment

251+ { name = name'

252+ , appOverrides = appOverrides'

253+ , deploymentOverrides = deploymentOverrides'

254+ }

255+ {-# INLINE searchWith #-}

256+

257+type Deployment = Deployment' Text

206258

207259data DeploymentLog = DeploymentLog

208260 { actionId :: ActionId

209261 , action :: Action

210− , deploymentTag :: DeploymentTag

211262 , deploymentAppOverrides :: Overrides 'ApplicationLevel

212263 , deploymentDepOverrides :: Overrides 'DeploymentLevel

213264 , exitCode :: Int64

@@ -238,17 +289,29 @@ data DeploymentInfo = DeploymentInfo

238289 deriving stock (Generic, Show)

239290 deriving (FromJSON, ToJSON) via Snake DeploymentInfo

240291

241−data DeploymentFullInfo = DeploymentFullInfo

242− { deployment :: Deployment

292+instance (Searchable needle t) => Searchable needle (DeploymentFullInfo' t) where

293+ type

294+ SearchableConstraint needle (DeploymentFullInfo' t) res =

295+ (SearchableConstraint needle t res, Ord (Searched t res))

296+ type Searched (DeploymentFullInfo' t) res = DeploymentFullInfo' (Searched t res)

297+ searchWith f d = do

298+ deployment' <- searchWith f $ d ^. #deployment

299+ pure $ d & #deployment .~ deployment'

300+ {-# INLINE searchWith #-}

301+

302+data DeploymentFullInfo' t = DeploymentFullInfo

303+ { deployment :: Deployment' t

243304 , status :: PreciseDeploymentStatus

244305 , metadata :: DeploymentMetadata

245306 , createdAt :: UTCTime

246307 , updatedAt :: UTCTime

247308 }

248309 deriving stock (Generic, Show, Eq)

249− deriving (FromJSON, ToJSON) via Snake DeploymentFullInfo

310+ deriving (FromJSON, ToJSON) via Snake (DeploymentFullInfo' t)

311+

312+type DeploymentFullInfo = DeploymentFullInfo' Text

250313

251−isDeploymentArchived :: DeploymentFullInfo -> Bool

314+isDeploymentArchived :: DeploymentFullInfo' t -> Bool

252315isDeploymentArchived DeploymentFullInfo {status = s} = case s of

253316 DeploymentNotPending s' -> isArchivedStatus s'

254317 -- if the deployment is currently undergoing some process,

@@ -256,8 +319,7 @@ isDeploymentArchived DeploymentFullInfo {status = s} = case s of

256319 DeploymentPending _ -> False

257320

258321data DeploymentUpdate = DeploymentUpdate

259− { newTag :: DeploymentTag

260− , appOverrides :: Overrides 'ApplicationLevel

322+ { appOverrides :: Overrides 'ApplicationLevel

261323 , deploymentOverrides :: Overrides 'DeploymentLevel

262324 }

263325 deriving stock (Generic, Show)

@@ -277,7 +339,6 @@ data CommandResponse

277339 = Success

278340 | ValidationError

279341 { nameField :: [Text]

280− , tagField :: [Text]

281342 }

282343 | AppError

283344 {errorMessage :: Text}

octopod-common/src/Control/Searchable.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

2+

3+module Control.Searchable

4+ ( Searchable (..),

5+ )

6+where

7+

8+import Control.Lens

9+import Data.Kind

10+import Data.Text (Text)

11+

12+-- | This says that you can search 'needle's in a 'haystack'. What precisely

13+-- "search for" means is defined by a function (the first argument) which

14+-- looks at every 'needle' and returns a "search result".

15+--

16+-- Essentially this is just a glorified 'Traversal' that can have extra

17+-- constraints and can leverage the constraint solver.

18+--

19+-- For a concrete "search" implementation see 'Data.Text.Search' from the

20+-- 'octopod-frontend' package.

21+class Searchable needle haystack where

22+ type SearchableConstraint needle haystack res :: Constraint

23+ type SearchableConstraint _ _ _ = ()

24+ type Searched haystack res

25+ searchWith ::

26+ SearchableConstraint needle haystack res =>

27+ Traversal haystack (Searched haystack res) needle res

28+

29+instance Searchable Text Text where

30+ type Searched Text res = res

31+ searchWith f t = f t

32+ {-# INLINE searchWith #-}

33+

34+instance Searchable needle x => Searchable needle [x] where

35+ type SearchableConstraint needle [x] res = SearchableConstraint needle x res

36+ type Searched [x] res = [Searched x res]

37+ searchWith f = traverse (searchWith f)

38+ {-# INLINE searchWith #-}

39+

40+instance (Searchable needle a, Searchable needle b) => Searchable needle (a, b) where

41+ type SearchableConstraint needle (a, b) res = (SearchableConstraint needle a res, SearchableConstraint needle b res)

42+ type Searched (a, b) res = (Searched a res, Searched b res)

43+ searchWith f (a, b) = do

44+ a' <- searchWith f a

45+ b' <- searchWith f b

46+ pure (a', b')

47+ {-# INLINE searchWith #-}

octopod-css/development/layouts/index.html−21

@@ -62,9 +62,6 @@

6262 <th>

6363 Links

6464 </th>

65− <th>

66− Tag

67− </th>

6865 <th>

6966 App overrides

7067 </th>

@@ -100,9 +97,6 @@

10097 </a>

10198 </div>

10299 </td>

103− <td>

104− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

105− </td>

106100 <td>

107101 <div class="listing listing--for-text">

108102 <div class="listing__item">

@@ -181,9 +175,6 @@

181175 </a>

182176 </div>

183177 </td>

184− <td>

185− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

186− </td>

187178 <td>

188179 <div class="listing listing--for-text">

189180 <div class="listing__item">

@@ -249,9 +240,6 @@

249240 </a>

250241 </div>

251242 </td>

252− <td>

253− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

254− </td>

255243 <td>

256244 <div class="listing listing--for-text">

257245 <div class="listing__item">

@@ -320,9 +308,6 @@

320308 </a>

321309 </div>

322310 </td>

323− <td>

324− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

325− </td>

326311 <td>

327312 <div class="listing listing--for-text">

328313 <div class="listing__item">

@@ -441,9 +426,6 @@

441426 <td>

442427 ...

443428 </td>

444− <td>

445− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

446− </td>

447429 <td>

448430 <div class="listing listing--for-text">

449431 <div class="listing__item">

@@ -499,9 +481,6 @@

499481 <td>

500482 ...

501483 </td>

502− <td>

503− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

504− </td>

505484 <td>

506485 <div class="listing listing--for-text">

507486 <div class="listing__item">

octopod-css/development/layouts/staging.html+3−16

@@ -173,9 +173,6 @@

173173 <th>

174174 Action type

175175 </th>

176− <th>

177− Image tag

178− </th>

179176 <th>

180177 App overrides

181178 </th>

@@ -198,13 +195,12 @@

198195 <td>

199196 Create

200197 </td>

201− <td>

202− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

203− </td>

204198 <td>

205199 <div class="listing listing--for-text">

206200 <div class="listing__item">

207− <b>ENVIRONENT:</b> production

201+ <b>ENVIRONENT:</b>

202+ <div class="listing__placeholder listing__placeholder__value"></div>

203+ <div class="listing__spinner"></div>

208204 </div>

209205 <div class="listing__item">

210206 <b>app_api_url:</b> http://my-api.my-domain.com

@@ -247,9 +243,6 @@

247243 <td>

248244 Edit

249245 </td>

250− <td>

251− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

252− </td>

253246 <td>

254247 <div class="listing listing--for-text">

255248 <div class="listing__item">

@@ -290,9 +283,6 @@

290283 <td>

291284 Update

292285 </td>

293− <td>

294− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

295− </td>

296286 <td>

297287 <div class="listing listing--for-text">

298288 <div class="listing__item">

@@ -333,9 +323,6 @@

333323 <td>

334324 Delete

335325 </td>

336− <td>

337− fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b

338− </td>

339326 <td>

340327 <div class="listing listing--for-text">

341328 <div class="listing__item">

octopod-css/development/styles/_listing.css+18−4

@@ -66,12 +66,13 @@

6666 .listing__placeholder {

6767 content: "";

6868 display: inline-block;

69− height: 14px;

69+ height: 12px;

7070 width: 140px;

7171 border-radius: 2px;

7272 background: rgba(143, 143, 143, 0.2);

7373 margin-right: 4px;

74− margin-top: 3px;

74+ margin-top: -5px;

75+ margin-bottom: -1px;

7576 }

7677

7778 .listing__placeholder__value {

@@ -95,7 +96,7 @@

9596

9697.listing__spinner {

9798 display: inline-block;

98− vertical-align: top;

99+ vertical-align: middle;

99100 border: none;

100101 background-color: transparent;

101102 background-repeat: no-repeat;

@@ -104,7 +105,9 @@

104105 padding: 0;

105106 width: 20px;

106107 height: 20px;

107− cursor: pointer;

108+ margin-top: -10px;

109+ margin-bottom: -7px;

110+ cursor: default;

108111 text-indent: 200%;

109112 white-space: nowrap;

110113 overflow: hidden;

@@ -112,3 +115,14 @@

112115 background-image: url("../vectors/spot-loader.svg");

113116 animation: loading 2.2s linear infinite;

114117}

118+

119+.listing.listing--larger .listing__placeholder {

120+ height: 14px;

121+}

122+

123+.listing.listing--larger .listing__spinner {

124+ background-size: 24px 24px;

125+ width: 24px;

126+ height: 24px;

127+ margin-bottom: -5px;

128+}

octopod-css/development/styles/_table.css+16−25

@@ -84,12 +84,11 @@

8484 /* В случае table-layout: fixed; ширины колонкам задаются по ширинам в первой строке */

8585 .table--deployments th:nth-child(1) { width: 16.1818%; } /* 178px */

8686 .table--deployments th:nth-child(2) { width: 16.1818%; } /* 178px */

87− .table--deployments th:nth-child(3) { width: 8%; } /* 88px */

88− .table--deployments th:nth-child(4) { width: 20.3636%; } /* 224px */

89− .table--deployments th:nth-child(5) { width: 20.3636%; } /* 224px */

87+ .table--deployments th:nth-child(3) { width: 24.3636%; } /* 224px */

88+ .table--deployments th:nth-child(4) { width: 24.3636%; } /* 224px */

89+ .table--deployments th:nth-child(5) { width: 9.4546%; } /* 104px */

9090 .table--deployments th:nth-child(6) { width: 9.4546%; } /* 104px */

91− .table--deployments th:nth-child(7) { width: 9.4546%; } /* 104px */

92− .table--deployments th:nth-child(8) { width: 52px; }

91+ .table--deployments th:nth-child(7) { width: 52px; }

9392

9493 .table--deployments th:first-child,

9594 .table--deployments td:first-child {

@@ -119,38 +118,32 @@

119118

120119 }

121120

122− /* Tag */

123− .table--deployments td:nth-child(3) {

124− white-space: nowrap;

125− overflow: hidden;

126− text-overflow: ellipsis;

127− }

128−

129121 /* App overrides */

130− .table--deployments td:nth-child(4) {

122+ .table--deployments td:nth-child(3) {

131123

132124 }

133125

134126 /* Deployment overrides */

135− .table--deployments td:nth-child(5) {

127+ .table--deployments td:nth-child(4) {

136128

137129 }

138130

139131 /* Created */

140− .table--deployments td:nth-child(6) {

132+ .table--deployments td:nth-child(5) {

141133 white-space: nowrap;

142134 }

143135

144136 /* Changed */

145− .table--deployments td:nth-child(7) {

137+ .table--deployments td:nth-child(6) {

146138 white-space: nowrap;

147139 }

148140

149141 /* Dropdown */

150− .table--deployments td:nth-child(8) {

142+ .table--deployments td:nth-child(7) {

151143

152144 }

153− .table--deployments td:nth-child(8) .drop {

145+

146+ .table--deployments td:nth-child(7) .drop {

154147 margin: -8px;

155148 }

156149

@@ -166,12 +159,11 @@

166159

167160 /* В случае table-layout: fixed; ширины колонкам задаются по ширинам в первой строке */

168161 .table--actions th:nth-child(1) { width: 8%; }

169− .table--actions th:nth-child(2) { width: 20%; }

170− .table--actions th:nth-child(3) { width: 21%; }

171− .table--actions th:nth-child(4) { width: 20%; }

172− .table--actions th:nth-child(5) { width: 7%; }

173− .table--actions th:nth-child(6) { width: 15%; }

174− .table--actions th:nth-child(7) { width: 9%; }

162+ .table--actions th:nth-child(2) { width: 30%; }

163+ .table--actions th:nth-child(3) { width: 31%; }

164+ .table--actions th:nth-child(4) { width: 7%; }

165+ .table--actions th:nth-child(5) { width: 15%; }

166+ .table--actions th:nth-child(6) { width: 9%; }

175167

176168 .table--actions th:first-child,

177169 .table--actions td:first-child {

@@ -197,7 +189,6 @@

197189

198190 /* Image tag */

199191 .table--actions td:nth-child(2) {

200− word-break: break-all;

201192 }

202193

203194 /* Overrides */

octopod-frontend/index.html+1

@@ -3,6 +3,7 @@

33

44<head>

55 <meta charset="UTF-8">

6+ <meta name="theme-color" content="#3671E3">

67</head>

78

89<body>

octopod-frontend/octopod-frontend.cabal+3

@@ -50,6 +50,7 @@ executable frontend

5050 , Frontend.UIKit.Button.Static

5151 , Frontend.UIKit.Button.Action

5252 , Frontend.UIKit.Button.Sort

53+ , Reflex.Dom.Renderable

5354 ghc-options:

5455 -Weverything

5556 -Wno-implicit-prelude

@@ -123,5 +124,7 @@ executable frontend

123124 , witherable

124125 , reflex

125126 , data-default

127+ , free

128+ , parallel

126129 hs-source-dirs: src

127130 default-language: Haskell2010

octopod-frontend/src/Data/Text/Search.hs+97−4

@@ -1,19 +1,33 @@

1+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

2+

13module Data.Text.Search

24 ( fuzzySearch,

35 fuzzySearchMany,

6+ searchMany,

7+ wrapResult,

8+ search,

9+ deSearch,

410 FuzzySearchStringChunk (..),

11+ SearchResult (..),

512 )

613where

714

815import Control.Applicative

16+import Control.Applicative.Free.Fast

17+import Control.Lens

18+import Control.Parallel.Strategies

19+import Control.Searchable

920import Data.Bifunctor

1021import Data.Char

1122import Data.Function

12−import Data.Functor

1323import qualified Data.List as L

14−import Data.Maybe (mapMaybe)

24+import Data.Maybe (catMaybes)

25+import Data.Ord

26+import Data.Semigroup

1527import Data.Text (Text)

1628import qualified Data.Text as T

29+import Reflex.Dom

30+import Reflex.Dom.Renderable

1731

1832type Needle = Text

1933type Haystack = Text

@@ -49,7 +63,7 @@ fuzzySearch n h = case fuzzySearch' n h 0 0 of

4963

5064fuzzySearchMany :: Needle -> [Haystack] -> [(Haystack, [FuzzySearchStringChunk Text])]

5165fuzzySearchMany needle haystacks =

52− fmap fst . L.sortOn snd $

66+ fmap fst . L.sortOn (Down . snd) $

5367 mapMaybe

5468 ( \haystack ->

5569 fuzzySearch needle haystack

@@ -57,5 +71,84 @@ fuzzySearchMany needle haystacks =

5771 )

5872 haystacks

5973

74+searchMany ::

75+ (Searchable Text x, SearchableConstraint Text x SearchResult) =>

76+ Text ->

77+ [x] ->

78+ [Searched x SearchResult]

79+searchMany "" = fmap wrapResult

80+searchMany t =

81+ fmap snd . L.sortOn (Down . fst) . catMaybes

82+ . withStrategy (parListChunk 3 rpar)

83+ . fmap (search t)

84+{-# INLINE searchMany #-}

85+

86+-- | Extract initial structure from search result.

87+deSearch ::

88+ forall x.

89+ (Searchable SearchResult x, SearchableConstraint SearchResult x Text) =>

90+ x ->

91+ Searched x Text

92+deSearch = searchWith @SearchResult @x %~ initialSearchText

93+{-# INLINE deSearch #-}

94+

95+-- | Like 'search', but doesn't search for anything. All 'Text' are marked as not matched.

96+wrapResult :: (Searchable Text x, SearchableConstraint Text x SearchResult) => x -> Searched x SearchResult

97+wrapResult =

98+ runIdentity . searchWith (\t -> Identity $ SearchResult t Nothing)

99+{-# INLINE wrapResult #-}

100+

101+search ::

102+ (Searchable Text x, SearchableConstraint Text x SearchResult) =>

103+ Text ->

104+ x ->

105+ Maybe (Int, Searched x SearchResult)

106+search needle x = runSearchApplicative $ searchWith searchSingle x

107+ where

108+ searchSingle :: Text -> SearchApplicative SearchResult

109+ searchSingle t = case fuzzySearch needle t of

110+ Nothing -> pure $ SearchResult t Nothing

111+ Just (res, score) -> liftAp $ TextSearch t res score

112+{-# INLINE search #-}

113+

114+data SearchResult = SearchResult

115+ { initialSearchText :: !Text

116+ , searchResult :: !(Maybe [FuzzySearchStringChunk Text])

117+ }

118+ deriving stock (Eq, Ord)

119+

120+instance Searchable SearchResult SearchResult where

121+ type Searched SearchResult res = res

122+ searchWith f t = f t

123+ {-# INLINE searchWith #-}

124+

125+instance Renderable SearchResult where

126+ rndr (SearchResult _ (Just cs)) = rndr cs

127+ rndr (SearchResult t Nothing) = rndr t

128+

129+data SearchF x where

130+ TextSearch :: Text -> [FuzzySearchStringChunk Text] -> !Int -> SearchF SearchResult

131+

132+type SearchApplicative = Ap SearchF

133+

134+runSearchApplicative :: SearchApplicative x -> Maybe (Int, x)

135+runSearchApplicative x = case findMaxResult x of

136+ Nothing -> Nothing

137+ Just m ->

138+ Just . (m,) . runIdentity $

139+ runAp

140+ ( \case

141+ TextSearch t res i | i == m -> Identity $ SearchResult t (Just res)

142+ TextSearch t _ _ -> Identity $ SearchResult t Nothing

143+ )

144+ x

145+ where

146+ findMaxResult :: SearchApplicative a -> Maybe Int

147+ findMaxResult = fmap getMax . runAp_ (\(TextSearch _ _ i) -> Just $ Max i)

148+

60149data FuzzySearchStringChunk a = NotMatched !a | Matched !a

61− deriving stock (Show, Eq, Functor)

150+ deriving stock (Show, Eq, Ord, Functor)

151+

152+instance Renderable a => Renderable (FuzzySearchStringChunk a) where

153+ rndr (NotMatched a) = rndr a

154+ rndr (Matched a) = elAttr "span" ("style" =: "text-decoration: underline;") (rndr a)

octopod-frontend/src/Data/WorkingOverrides.hs+25−10

@@ -1,9 +1,12 @@

11module Data.WorkingOverrides

22 ( WorkingOverrides,

33 WorkingOverride,

4− WorkingOverrideKey (..),

4+ WorkingOverride',

5+ WorkingOverrideKey' (..),

6+ WorkingOverrideKey,

57 WorkingOverrideKeyType (..),

6− WorkingOverrideValue (..),

8+ WorkingOverrideValue' (..),

9+ WorkingOverrideValue,

710 destructWorkingOverrides,

811 constructWorkingOverrides,

912 newWorkingOverride,

@@ -17,20 +20,28 @@ import Data.Maybe

1720import Data.Text (Text)

1821import Data.UniqMap

1922

20−type WorkingOverrides = UniqKeyMap WorkingOverride

23+type WorkingOverrides = WorkingOverrides' Text

2124

22−type WorkingOverride = (WorkingOverrideKey, WorkingOverrideValue)

25+type WorkingOverrides' te = UniqKeyMap (WorkingOverride' te)

2326

24−data WorkingOverrideKey = WorkingOverrideKey !WorkingOverrideKeyType !Text

27+type WorkingOverride = WorkingOverride' Text

28+

29+type WorkingOverride' te = (WorkingOverrideKey' te, WorkingOverrideValue' te)

30+

31+type WorkingOverrideKey = WorkingOverrideKey' Text

32+

33+data WorkingOverrideKey' te = WorkingOverrideKey !WorkingOverrideKeyType !te

2534 deriving stock (Show)

2635

2736data WorkingOverrideKeyType = CustomWorkingOverrideKey | DefaultWorkingOverrideKey

2837 deriving stock (Show, Eq)

2938

30−data WorkingOverrideValue

31− = WorkingCustomValue !Text

32− | WorkingDefaultValue !Text

33− | WorkingDeletedValue !(Maybe Text)

39+type WorkingOverrideValue = WorkingOverrideValue' Text

40+

41+data WorkingOverrideValue' te

42+ = WorkingCustomValue !te

43+ | WorkingDefaultValue !te

44+ | WorkingDeletedValue !(Maybe te)

3445 deriving stock (Show)

3546

3647destructWorkingOverrides :: WorkingOverrides -> Overrides l

@@ -51,7 +62,11 @@ destructWorkingOverrides =

5162 getWorkingOverrideValue (WorkingDefaultValue x) = ValueAdded x

5263 getWorkingOverrideValue (WorkingDeletedValue _) = ValueDeleted

5364

54−constructWorkingOverrides :: Maybe (DefaultConfig l) -> Overrides l -> WorkingOverrides

65+constructWorkingOverrides ::

66+ Ord te =>

67+ Maybe (DefaultConfig' te l) ->

68+ Overrides' te l ->

69+ WorkingOverrides' te

5570constructWorkingOverrides (Just (DefaultConfig dCfg)) (Overrides ovsM) =

5671 let custom =

5772 uniqMapFromList

octopod-frontend/src/Frontend/Route.hs+1−1

@@ -33,7 +33,7 @@ data Routes :: Type -> Type where

3333deriving stock instance Show (Routes a)

3434

3535fmap mconcat . sequence $

36− [ makeWrapped ''DeploymentName

36+ [ makeWrapped ''DeploymentName'

3737 , deriveRouteComponent ''Routes

3838 ]

3939

octopod-frontend/src/Frontend/UIKit.hs+14−9

@@ -41,6 +41,7 @@ import Frontend.UIKit.Button.Sort as X

4141import Frontend.UIKit.Button.Static as X

4242import GHC.Generics (Generic)

4343import Reflex.Dom

44+import Reflex.Dom.Renderable

4445import Reflex.Network

4546

4647(.~~) :: ASetter' s a -> a -> s -> s

@@ -276,14 +277,16 @@ nonEditableWorkingOverrideStyleClasses LargeNonEditableWorkingOverrideStyle = "l

276277

277278-- | Widget that shows overrides list. It does not depend on their type.

278279showNonEditableWorkingOverride ::

279− MonadWidget t m =>

280+ (MonadWidget t m, Renderable te) =>

280281 -- | Loading?

281282 Bool ->

283+ -- | Is it fully loaded?

284+ Bool ->

282285 NonEditableWorkingOverrideStyle ->

283286 -- | Overrides list.

284− [WorkingOverride] ->

287+ [WorkingOverride' te] ->

285288 m ()

286−showNonEditableWorkingOverride loading style cfg =

289+showNonEditableWorkingOverride loading loaded style cfg =

287290 divClass

288291 ( destructClasses $

289292 "listing" <> "listing--for-text" <> nonEditableWorkingOverrideStyleClasses style

@@ -292,7 +295,9 @@ showNonEditableWorkingOverride loading style cfg =

292295 case cfg of

293296 [] ->

294297 divClass "listing__item" $

295− elClass "span" "listing--info-text" $ text "no custom configuration"

298+ elClass "span" "listing--info-text" $

299+ text $

300+ if loaded then "no configuration" else "no custom configuration"

296301 _ -> forM_ cfg $ \(WorkingOverrideKey keyType key, val) -> do

297302 let wrapper = case val of

298303 WorkingDeletedValue _ -> divClass "listing__item deleted"

@@ -302,16 +307,16 @@ showNonEditableWorkingOverride loading style cfg =

302307 CustomWorkingOverrideKey -> elClass "span" "listing__key"

303308 DefaultWorkingOverrideKey -> elClass "span" "listing__key default"

304309 keyWrapper $ do

305− text key

310+ rndr key

306311 text ": "

307312

308313 case val of

309− WorkingCustomValue txt -> elClass "span" "listing__value" $ text txt

310− WorkingDefaultValue txt -> elClass "span" "listing__value default" $ text txt

311− WorkingDeletedValue (Just txt) -> elClass "span" "listing__value default" $ text txt

314+ WorkingCustomValue txt -> elClass "span" "listing__value" $ rndr txt

315+ WorkingDefaultValue txt -> elClass "span" "listing__value default" $ rndr txt

316+ WorkingDeletedValue (Just txt) -> elClass "span" "listing__value default" $ rndr txt

312317 WorkingDeletedValue Nothing -> do

313318 elClass "div" "listing__placeholder listing__placeholder__value" $ pure ()

314− elClass "div" "listing__spinner" $ pure ()

319+ when loading $ elClass "div" "listing__spinner" $ pure ()

315320 when loading $

316321 divClass "listing__item" $ do

317322 elClass "div" "listing__placeholder" $ pure ()

octopod-frontend/src/Frontend/Utils.hs+63−45

@@ -29,7 +29,10 @@ module Frontend.Utils

2929 ProgressiveFullConfig (..),

3030 RequestErrorHandler,

3131 deploymentOverridesWidget,

32+ deploymentOverridesWidgetSearched,

3233 applicationOverridesWidget,

34+ applicationOverridesWidgetSearched,

35+ debounceDyn,

3336 )

3437where

3538

@@ -40,11 +43,11 @@ import Control.Monad.Reader

4043import qualified Data.Foldable as F

4144import Data.Functor

4245import Data.Generics.Labels ()

43−import Data.Generics.Sum

4446import qualified Data.Map as M

45−import Data.Maybe (fromMaybe, isNothing)

47+import Data.Maybe (fromMaybe, isJust, isNothing)

4648import Data.Monoid

47−import Data.Text as T (Text, intercalate, null, pack)

49+import Data.Text as T (Text, null, pack)

50+import Data.Text.Search

4851import Data.Time

4952import Data.UniqMap

5053import Data.Unique

@@ -60,6 +63,7 @@ import GHCJS.DOM.EventM (on, target)

6063import GHCJS.DOM.GlobalEventHandlers as Events (click)

6164import GHCJS.DOM.Node as DOM

6265import Reflex.Dom as R

66+import Reflex.Dom.Renderable

6367import Reflex.Network

6468import Servant.Common.Req

6569import Servant.Reflex.Extra

@@ -203,10 +207,10 @@ octopodTextInput clss lbl placeholder val errEv =

203207-- | Widget that can show and hide overrides if there are more than 3. This

204208-- widget is used in the deployments table and the deployment action table.

205209overridesWidget ::

206− MonadWidget t m =>

210+ (MonadWidget t m, Renderable te, Ord te) =>

207211 -- | List of overrides.

208− Overrides l ->

209− (Event t () -> m (Event t (DefaultConfig l))) ->

212+ Overrides' te l ->

213+ (Event t () -> m (Event t (DefaultConfig' te l))) ->

210214 m ()

211215overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo

212216 defMDyn <- getDef firstExpand >>= holdDynMaybe

@@ -218,11 +222,11 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo

218222 do

219223 defM <- defMDyn

220224 pure $

221− showNonEditableWorkingOverride (isNothing defM) RegularNonEditableWorkingOverrideStyle $

225+ showNonEditableWorkingOverride (isNothing defM) (isJust defM) RegularNonEditableWorkingOverrideStyle $

222226 elemsUniq $ constructWorkingOverrides defM ovs

223227 ContractedState ->

224228 let ovsList = elemsUniq $ constructWorkingOverrides Nothing ovs

225− in showNonEditableWorkingOverride False RegularNonEditableWorkingOverrideStyle $

229+ in showNonEditableWorkingOverride False False RegularNonEditableWorkingOverrideStyle $

226230 take 3 ovsList

227231

228232 expandState <-

@@ -231,8 +235,8 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo

231235 { buttonText = do

232236 state <- expandState

233237 pure $ case state of

234− ExpandedState -> "Hide"

235− ContractedState -> "Show all"

238+ ExpandedState -> "Hide default configuration"

239+ ContractedState -> "Show full configuration"

236240 , buttonInitialState = ContractedState

237241 , buttonType = Just ListingExpanderButton

238242 , buttonStyle = RegularExpanderButtonStyle

@@ -241,12 +245,20 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo

241245 pure ()

242246

243247deploymentOverridesWidget ::

244− MonadWidget t m =>

248+ (MonadWidget t m) =>

245249 RequestErrorHandler t m ->

246250 Overrides 'DeploymentLevel ->

247251 m ()

248252deploymentOverridesWidget hReq depOvs =

249− overridesWidget depOvs $ defaultDeploymentOverrides >=> hReq

253+ deploymentOverridesWidgetSearched hReq (wrapResult depOvs)

254+

255+deploymentOverridesWidgetSearched ::

256+ (MonadWidget t m) =>

257+ RequestErrorHandler t m ->

258+ Overrides' SearchResult 'DeploymentLevel ->

259+ m ()

260+deploymentOverridesWidgetSearched hReq depOvs =

261+ overridesWidget depOvs $ (fmap . fmap . fmap) wrapResult $ defaultDeploymentOverrides >=> hReq

250262

251263applicationOverridesWidget ::

252264 MonadWidget t m =>

@@ -255,13 +267,23 @@ applicationOverridesWidget ::

255267 Overrides 'ApplicationLevel ->

256268 m ()

257269applicationOverridesWidget hReq depOvs appOvs =

270+ applicationOverridesWidgetSearched hReq (wrapResult depOvs) (wrapResult appOvs)

271+

272+applicationOverridesWidgetSearched ::

273+ MonadWidget t m =>

274+ RequestErrorHandler t m ->

275+ Overrides' SearchResult 'DeploymentLevel ->

276+ Overrides' SearchResult 'ApplicationLevel ->

277+ m ()

278+applicationOverridesWidgetSearched hReq depOvs appOvs =

258279 overridesWidget appOvs $ \fire -> do

259280 depDefEv <- defaultDeploymentOverrides fire >>= hReq

260281 fmap switchDyn $

261− networkHold (pure never) $

262− depDefEv <&> \depDef -> do

263− pb <- getPostBuild

264− defaultApplicationOverrides (pure $ Right $ applyOverrides depOvs depDef) pb >>= hReq

282+ (fmap . fmap . fmap) wrapResult $

283+ networkHold (pure never) $

284+ depDefEv <&> \depDef -> do

285+ pb <- getPostBuild

286+ defaultApplicationOverrides (pure $ Right $ applyOverrides (deSearch depOvs) depDef) pb >>= hReq

265287

266288-- | Type of notification at the top of pages.

267289data DeploymentPageNotification

@@ -308,14 +330,13 @@ deploymentPopupBody ::

308330 forall t m tag.

309331 MonadWidget t m =>

310332 RequestErrorHandler t m ->

311− Maybe DeploymentTag ->

312333 Overrides 'ApplicationLevel ->

313334 Overrides 'DeploymentLevel ->

314335 -- | \"Edit request\" failure event.

315336 Event t (ReqResult tag CommandResponse) ->

316337 -- | Returns deployment update and validation state.

317338 m (Dynamic t (Maybe DeploymentUpdate))

318−deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo

339+deploymentPopupBody hReq defAppOv defDepOv errEv = mdo

319340 pb <- getPostBuild

320341 (defDepEv, defApp, depCfgEv) <- deploymentConfigProgressiveComponents hReq deploymentOvsDyn

321342 defAppM <- holdClearingWith defApp (unitEv deploymentOvsDyn)

@@ -323,11 +344,8 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo

323344 depKeys <- deploymentOverrideKeys pb >>= hReq

324345

325346 let commandResponseEv = fmapMaybe commandResponse errEv

326− tagErrEv = getTagError commandResponseEv tagDyn

327347 void $ hReq (errEv `R.difference` commandResponseEv)

328348

329− (tagDyn, tOkEv) <- octopodTextInput "tag" "Tag" "Tag" (unDeploymentTag <$> defTag) tagErrEv

330−

331349 let holdDCfg ::

332350 Dynamic t [Text] ->

333351 Dynamic t (Maybe (DefaultConfig l)) ->

@@ -348,29 +366,15 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo

348366 appKeysDyn <- holdDyn [] $ catMaybes appKeys

349367 applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv

350368

351− validDyn <- holdDyn True $ updated tOkEv

352− pure $

353− validDyn >>= \case

354− False -> pure Nothing

355− True -> do

356− depCfg <- deploymentOvsDyn

357− appOvs <- applicationOvsDyn

358− tag' <- DeploymentTag <$> tagDyn

359− pure $

360− Just $

361− DeploymentUpdate

362− { newTag = tag'

363− , appOverrides = appOvs

364− , deploymentOverrides = depCfg

365− }

366− where

367− getTagError crEv tagDyn =

368− let tagErrEv' = fmapMaybe (preview (_Ctor @"ValidationError" . _2)) crEv

369− tagErrEv = ffilter (/= "") $ T.intercalate ". " <$> tagErrEv'

370− badTagText = "Tag should not be empty"

371− badNameEv = badTagText <$ ffilter (== "") (updated tagDyn)

372− in leftmost [tagErrEv, badNameEv]

373−

369+ pure $ do

370+ depCfg <- deploymentOvsDyn

371+ appOvs <- applicationOvsDyn

372+ pure $

373+ Just $

374+ DeploymentUpdate

375+ { appOverrides = appOvs

376+ , deploymentOverrides = depCfg

377+ }

374378deploymentConfigProgressiveComponents ::

375379 MonadWidget t m =>

376380 RequestErrorHandler t m ->

@@ -458,7 +462,6 @@ errorHeader ::

458462 m ()

459463errorHeader appErr = do

460464 divClass "deployment__output notification notification--danger" $ do

461− el "b" $ text "App error: "

462465 dynText appErr

463466

464467-- | Widget with override fields. This widget supports adding and

@@ -603,3 +606,18 @@ unitEv = fmapCheap (const ()) . updated

603606

604607(<&&>) :: (Functor f1, Functor f2) => f1 (f2 a) -> (a -> b) -> f1 (f2 b)

605608x <&&> f = (fmap . fmap) f x

609+

610+debounceDyn ::

611+ ( PerformEvent t m

612+ , TriggerEvent t m

613+ , MonadIO (Performable m)

614+ , MonadHold t m

615+ , MonadFix m

616+ ) =>

617+ NominalDiffTime ->

618+ Dynamic t a ->

619+ m (Dynamic t a)

620+debounceDyn t d = do

621+ currD <- sample . current $ d

622+ ev <- debounce t (updated d)

623+ holdDyn currD ev

octopod-frontend/src/Main.hs+2−1

@@ -92,7 +92,8 @@ headWidget ::

9292 Event t ProjectName ->

9393 m ()

9494headWidget projectNameEv = do

95− elAttr "meta" ("charset" =: "urf8 ") blank

95+ elAttr "meta" ("charset" =: "UTF-8") blank

96+ elAttr "meta" ("name" =: "theme-color" <> "content" =: "#3671E3") blank

9697 elAttr

9798 "meta"

9899 ( "http-equiv" =: "x-ua-compatible"

octopod-frontend/src/Page/Deployment.hs+1−6

@@ -208,9 +208,6 @@ deploymentBody updEv dfiDyn = deploymentBodyWrapper $

208208 divClass "deployment__value" $ do

209209 let createdAtDyn = dfiDyn <^.> field @"updatedAt"

210210 dynText $ formatPosixToDate <$> createdAtDyn

211− deploymentSection "Tag" $ do

212− let tagDyn = dfiDyn <^.> field @"deployment" . field @"tag" . coerced

213− divClass "deployment__widget" $ dynText tagDyn

214211 deploymentSection "Links" $ do

215212 let urlsDyn = dfiDyn <^.> field @"metadata" . to unDeploymentMetadata

216213 divClass "deployment__widget" $

@@ -221,7 +218,7 @@ deploymentBody updEv dfiDyn = deploymentBodyWrapper $

221218 cfgDyn <&> \cfg -> do

222219 let showVars bL l =

223220 divClass "deployment__widget" $

224− showNonEditableWorkingOverride (cfg ^. bL) LargeNonEditableWorkingOverrideStyle $

221+ showNonEditableWorkingOverride (cfg ^. bL) (not $ cfg ^. bL) LargeNonEditableWorkingOverrideStyle $

225222 elemsUniq (cfg ^. l)

226223 deploymentSection "Deployment overrides" $ showVars #depConfigLoading #depConfig

227224 deploymentSection "App overrides" $ showVars #appConfigLoading #appConfig

@@ -259,7 +256,6 @@ actionsTableHead =

259256 el "thead" $

260257 el "tr" $ do

261258 el "th" $ text "Action type"

262− el "th" $ text "Image tag"

263259 el "th" $ text "Deployment overrides"

264260 el "th" $ text "App overrides"

265261 el "th" $ text "Exit code"

@@ -315,7 +311,6 @@ actinRow hReq DeploymentLog {..} = do

315311 "status "

316312 <> if exitCode == 0 then "status--success" else "status--failure"

317313 divClass statusClass blank

318− el "td" $ text $ coerce deploymentTag

319314 el "td" $ deploymentOverridesWidget hReq deploymentDepOverrides

320315 el "td" $ applicationOverridesWidget hReq deploymentDepOverrides deploymentAppOverrides

321316 el "td" $ text $ showT $ exitCode

octopod-frontend/src/Page/Deployments.hs+43−102

@@ -39,6 +39,7 @@ import Page.ClassicPopup

3939import Page.Elements.Links

4040import Page.Popup.EditDeployment

4141import Page.Popup.NewDeployment

42+import Reflex.Dom.Renderable

4243import Reflex.MultiEventWriter.Class

4344import Servant.Reflex.Extra

4445

@@ -88,9 +89,10 @@ deploymentsWidget updAllEv dfis = do

8889 <$ errUpdEv

8990 , DPMClear <$ okUpdEv

9091 ]

91− (showNewDeploymentEv', termDyn) <- deploymentsHeadWidget True okUpdEv

92+ (showNewDeploymentEv', termDyn') <- deploymentsHeadWidget True okUpdEv

93+ termDyn <- debounceDyn 0.3 termDyn'

9294 (okUpdEv, errUpdEv, editEv) <- deploymentsListWidget hReq updAllEv termDyn dfis

93− pure (showNewDeploymentEv', editEv)

95+ pure (showNewDeploymentEv', deSearch <$> editEv)

9496 void $ newDeploymentPopup showNewDeploymentEv never

9597 void $ editDeploymentPopup editEv never

9698

@@ -179,58 +181,24 @@ deploymentsListWidget ::

179181 Dynamic t Text ->

180182 -- | Initial deployment data

181183 [DeploymentFullInfo] ->

182− m (Event t (), Event t (), Event t DeploymentFullInfo)

184+ m (Event t (), Event t (), Event t SearchedDeploymentInfo)

183185deploymentsListWidget hReq updAllEv termDyn ds = dataWidgetWrapper $ mdo

184186 retryEv <- delay 10 errUpdEv

185187 updRespEv <- listEndpoint $ leftmost [updAllEv, () <$ retryEv]

186188 let okUpdEv = fmapMaybe reqSuccess updRespEv

187189 errUpdEv = fmapMaybe reqErrorBody updRespEv

188190 dsDyn <- holdDyn ds okUpdEv

189− let isArchived = isDeploymentArchived . view #deployment

190− filteredDyn = ffor2 termDyn dsDyn $ \term ds' ->

191− mapMaybe (searchDeployments . T.filter (not . isSpace) $ term) ds'

191+ let searchedDyn = ffor2 termDyn dsDyn $ \term ds' ->

192+ searchMany (T.filter (not . isSpace) term) ds'

192193 (archivedDsDyn, activeDsDyn) =

193− splitDynPure $

194− L.partition isArchived

195− <$> filteredDyn

196− searchSorting = termDyn $> Just (SortDesc (view #score))

194+ splitDynPure $ L.partition isDeploymentArchived <$> searchedDyn

195+ searchSorting = termDyn $> Nothing

197196 clickedEv <- elementClick

198197 editEv <- activeDeploymentsWidget hReq searchSorting clickedEv activeDsDyn

199198 archivedDeploymentsWidget hReq searchSorting clickedEv archivedDsDyn

200199 pure (() <$ okUpdEv, () <$ errUpdEv, editEv)

201200

202−data SearchedDeploymentFullInfo = SearchedDeploymentFullInfo

203− { deployment :: DeploymentFullInfo

204− , searchResult :: DeploymentSearchResult

205− , score :: Int

206− }

207− deriving stock (Generic, Show, Eq)

208−

209−-- | Compares deployment fields (name and tag) with a search term.

210−searchDeployments ::

211− -- | Search term.

212− Text ->

213− -- | Deployment data.

214− DeploymentFullInfo ->

215− Maybe SearchedDeploymentFullInfo

216−searchDeployments term d = case (tagResult, nameResult) of

217− (Nothing, Nothing) -> Nothing

218− (Just (res, score), Nothing) ->

219− Just $ SearchedDeploymentFullInfo d (DeploymentTagResult res) score

220− (Nothing, Just (res, score)) ->

221− Just $ SearchedDeploymentFullInfo d (DeploymentNameResult res) score

222− (Just (tRes, tScore), Just (nRes, nScore)) ->

223− if tScore > nScore

224− then Just $ SearchedDeploymentFullInfo d (DeploymentTagResult tRes) tScore

225− else Just $ SearchedDeploymentFullInfo d (DeploymentNameResult nRes) nScore

226− where

227− tagResult = fuzzySearch term . unDeploymentTag $ d ^. field @"deployment" . field @"tag"

228− nameResult = fuzzySearch term . unDeploymentName $ d ^. dfiName

229−

230−data DeploymentSearchResult

231− = DeploymentNameResult [FuzzySearchStringChunk Text]

232− | DeploymentTagResult [FuzzySearchStringChunk Text]

233− deriving stock (Show, Eq)

201+type SearchedDeploymentInfo = DeploymentFullInfo' SearchResult

234202

235203-- | Table with active deployments.

236204activeDeploymentsWidget ::

@@ -239,19 +207,18 @@ activeDeploymentsWidget ::

239207 , MonadReader ProjectConfig m

240208 ) =>

241209 RequestErrorHandler t m ->

242− Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo)) ->

210+ Dynamic t (Maybe (SortDir DeploymentFullInfo)) ->

243211 -- | Event that carries the clicked DOM element. This event is required by

244212 -- `dropdownWidget'`.

245213 Event t ClickedElement ->

246− Dynamic t [SearchedDeploymentFullInfo] ->

214+ Dynamic t [SearchedDeploymentInfo] ->

247215 -- | Returns an event carrying editable deployment

248216 -- to \"edit deployment\" sidebar.

249− m (Event t DeploymentFullInfo)

217+ m (Event t SearchedDeploymentInfo)

250218activeDeploymentsWidget hReq searchSorting clickedEv dsDyn =

251219 divClass "data__primary" $

252220 tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do

253− let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn

254− sorting <- holdDyn Nothing (mergeWith (<|>) [updated colSortDyn, updated searchSorting])

221+ sorting <- holdDyn Nothing (mergeWith (<|>) [updated sortDyn, updated searchSorting])

255222 let emptyDyn' = L.null <$> dsDyn

256223 dsSortedDyn = zipDynWith sortDeployments dsDyn sorting

257224 emptyDyn <- holdUniqDyn emptyDyn'

@@ -262,7 +229,7 @@ activeDeploymentsWidget hReq searchSorting clickedEv dsDyn =

262229 editEvs <- simpleList dsSortedDyn (activeDeploymentWidget hReq clickedEv)

263230 pure $ switchDyn $ leftmost <$> editEvs

264231 True -> do

265− emptyTableBody $ noDeploymentsWidget

232+ emptyTableBody noDeploymentsWidget

266233 pure never

267234 switchHold never editEvEv

268235

@@ -283,28 +250,27 @@ activeDeploymentWidget ::

283250 -- | Event that carries the clicked DOM element. This event is required by

284251 -- `dropdownWidget'`.

285252 Event t ClickedElement ->

286− Dynamic t SearchedDeploymentFullInfo ->

253+ Dynamic t SearchedDeploymentInfo ->

287254 -- | Returns event carrying editable deployment

288255 -- that is required by \"edit deployment\" sidebar.

289− m (Event t DeploymentFullInfo)

256+ m (Event t SearchedDeploymentInfo)

290257activeDeploymentWidget hReq clickedEv dDyn' = do

291258 dDyn <- holdUniqDyn dDyn'

292259 editEvEv <- dyn $

293− ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = d@DeploymentFullInfo {..}} -> do

294− let (name, tag') = displaySearchHighlighting s

295− dName = deployment ^. #name

260+ ffor dDyn $ \d@DeploymentFullInfo {..} -> do

261+ let desearchedDeployment = deSearch d

262+ dName = desearchedDeployment ^. #deployment . #name

296263 (linkEl, dropdownEv) <- el' "tr" $ do

297264 el "td" $ do

298− name

265+ rndr . unDeploymentName $ d ^. #deployment . #name

299266 statusWidget $ constDyn status

300267 el "td" $

301268 divClass "listing" $

302269 forM_ (unDeploymentMetadata metadata) (renderMetadataLink . pure)

303− el "td" tag'

304270 el "td" $

305− deploymentOverridesWidget hReq (deployment ^. field @"deploymentOverrides" . coerced)

271+ deploymentOverridesWidgetSearched hReq (deployment ^. field @"deploymentOverrides" . coerced)

306272 el "td" $

307− applicationOverridesWidget

273+ applicationOverridesWidgetSearched

308274 hReq

309275 (deployment ^. field @"deploymentOverrides" . coerced)

310276 (deployment ^. field @"appOverrides" . coerced)

@@ -314,13 +280,11 @@ activeDeploymentWidget hReq clickedEv dDyn' = do

314280 text $ formatPosixToDate updatedAt

315281 el "td" $ do

316282 let enabled = not . isPending . recordedStatus $ status

317− elId = "deployment_row_" <> unDeploymentName dName

318283 btn =

319284 elAttr

320285 "button"

321286 ( "class" =: "drop__handler"

322287 <> "type" =: "button"

323− <> "id" =: elId

324288 )

325289 $ text "Actions"

326290 body = do

@@ -336,7 +300,7 @@ activeDeploymentWidget hReq clickedEv dDyn' = do

336300 & #buttonText .~~ "Move to archive"

337301 & #buttonEnabled .~~ pure enabled

338302 & #buttonType .~~ Just ArchiveActionButtonType

339− url' <- kubeDashboardUrl (view #deployment <$> dDyn)

303+ url' <- kubeDashboardUrl (pure desearchedDeployment)

340304 void . dyn $

341305 url'

342306 <&> maybe

@@ -366,24 +330,6 @@ activeDeploymentWidget hReq clickedEv dDyn' = do

366330 pure editEv

367331 switchHold never editEvEv

368332

369−displaySearchHighlighting :: DomBuilder t m => SearchedDeploymentFullInfo -> (m (), m ())

370−displaySearchHighlighting

371− SearchedDeploymentFullInfo {searchResult = DeploymentNameResult res, deployment = d} =

372− ( markMatches res

373− , text . unDeploymentTag $ d ^. #deployment . #tag

374− )

375−displaySearchHighlighting

376− SearchedDeploymentFullInfo {searchResult = DeploymentTagResult res, deployment = d} =

377− ( text . unDeploymentName $ d ^. #deployment . #name

378− , markMatches res

379− )

380−

381−markMatches :: DomBuilder t m => [FuzzySearchStringChunk Text] -> m ()

382−markMatches [] = blank

383−markMatches (NotMatched x : xs) = text x >> markMatches xs

384−markMatches (Matched x : xs) =

385− elAttr "span" ("style" =: "text-decoration: underline;") (text x) >> markMatches xs

386−

387333-- | Table with archived deployments.

388334archivedDeploymentsWidget ::

389335 forall t m.

@@ -391,11 +337,11 @@ archivedDeploymentsWidget ::

391337 , SetRoute t (R Routes) m

392338 ) =>

393339 RequestErrorHandler t m ->

394− Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo)) ->

340+ Dynamic t (Maybe (SortDir DeploymentFullInfo)) ->

395341 -- | Event that carries the clicked DOM element. This event is required by

396342 -- `dropdownWidget'`.

397343 Event t ClickedElement ->

398− Dynamic t [SearchedDeploymentFullInfo] ->

344+ Dynamic t [SearchedDeploymentInfo] ->

399345 m ()

400346archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do

401347 showDyn <- toggleButton

@@ -404,8 +350,7 @@ archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do

404350 False -> "data__archive"

405351 elDynClass "div" classDyn $

406352 tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do

407− let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn

408− sorting <- holdDyn Nothing (mergeWith (<|>) [updated colSortDyn, updated searchSorting])

353+ sorting <- holdDyn Nothing (mergeWith (<|>) [updated sortDyn, updated searchSorting])

409354 let emptyDyn' = L.null <$> dsDyn

410355 dsSortedDyn = zipDynWith sortDeployments dsDyn sorting

411356 emptyDyn <- holdUniqDyn emptyDyn'

@@ -416,7 +361,7 @@ archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do

416361 simpleList

417362 dsSortedDyn

418363 (archivedDeploymentWidget hReq clickedEv)

419− True -> emptyTableBody $ noDeploymentsWidget

364+ True -> emptyTableBody noDeploymentsWidget

420365

421366-- | Row with archived deployment.

422367archivedDeploymentWidget ::

@@ -425,24 +370,23 @@ archivedDeploymentWidget ::

425370 ) =>

426371 RequestErrorHandler t m ->

427372 Event t ClickedElement ->

428− Dynamic t SearchedDeploymentFullInfo ->

373+ Dynamic t SearchedDeploymentInfo ->

429374 m ()

430375archivedDeploymentWidget hReq clickedEv dDyn' = do

431376 dDyn <- holdUniqDyn dDyn'

432377 dyn_ $

433− ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = DeploymentFullInfo {..}} -> do

434− let (name, tag') = displaySearchHighlighting s

435− dName = deployment ^. #name

378+ ffor dDyn $ \d@DeploymentFullInfo {..} -> do

379+ let desearchedDeployment = deSearch d

380+ dName = desearchedDeployment ^. #deployment . #name

436381 (linkEl, _) <- el' "tr" $ do

437382 el "td" $ do

438− name

383+ rndr . unDeploymentName $ deployment ^. #name

439384 divClass "status status--archived" $ text "Archived"

440385 el "td" $ text "..."

441− el "td" tag'

442386 el "td" $

443− deploymentOverridesWidget hReq (deployment ^. field @"deploymentOverrides" . coerced)

387+ deploymentOverridesWidgetSearched hReq (deployment ^. field @"deploymentOverrides" . coerced)

444388 el "td" $

445− applicationOverridesWidget

389+ applicationOverridesWidgetSearched

446390 hReq

447391 (deployment ^. field @"deploymentOverrides" . coerced)

448392 (deployment ^. field @"appOverrides" . coerced)

@@ -451,13 +395,11 @@ archivedDeploymentWidget hReq clickedEv dDyn' = do

451395 el "td" $

452396 text $ formatPosixToDate updatedAt

453397 el "td" $ do

454− let elId = "deployment_row_" <> (unDeploymentName dName)

455− btn =

398+ let btn =

456399 elAttr

457400 "button"

458401 ( "class" =: "drop__handler"

459402 <> "type" =: "button"

460− <> "id" =: elId

461403 )

462404 $ text "Actions"

463405 body =

@@ -473,16 +415,16 @@ archivedDeploymentWidget hReq clickedEv dDyn' = do

473415

474416-- | Sort deployments by the supplied condition.

475417sortDeployments ::

476− [SearchedDeploymentFullInfo] ->

418+ [SearchedDeploymentInfo] ->

477419 -- | Sorting condition.

478− Maybe (SortDir SearchedDeploymentFullInfo) ->

479− [SearchedDeploymentFullInfo]

480−sortDeployments items s = L.sortBy sortFunc items

420+ Maybe (SortDir DeploymentFullInfo) ->

421+ [SearchedDeploymentInfo]

422+sortDeployments items Nothing = items

423+sortDeployments items (Just (contramap deSearch -> s)) = L.sortBy sortFunc items

481424 where

482425 sortFunc a b = case s of

483− Just (SortAsc get) -> compare (get a) (get b)

484− Just (SortDesc get) -> compare (get b) (get a)

485− Nothing -> EQ

426+ (SortAsc get) -> compare (get a) (get b)

427+ (SortDesc get) -> compare (get b) (get a)

486428

487429-- | Each constructor contains a getter

488430-- that extracts the field that is used for sorting.

@@ -509,7 +451,6 @@ tableHeader = do

509451 el "tr" $ do

510452 sortHeader (view dfiName) "Name" SortAsc

511453 el "th" $ text "Links"

512− el "th" $ text "Tag"

513454 el "th" $ text "Deployment overrides"

514455 el "th" $ text "App overrides"

515456 sortHeader (view $ field @"createdAt") "Created" SortDesc

octopod-frontend/src/Page/Popup/EditDeployment.hs+7−7

@@ -100,12 +100,12 @@ editDeploymentPopupBody ::

100100 Event t (ReqResult tag CommandResponse) ->

101101 -- | Returns deployment update and validation state.

102102 m (Dynamic t (Maybe DeploymentUpdate))

103−editDeploymentPopupBody dfi errEv = wrapRequestErrors $ \hReq -> do

103+editDeploymentPopupBody dfi errEv = do

104104 divClass "popup__content" $

105105 divClass "deployment" $

106− deploymentPopupBody

107− hReq

108− (dfi ^. #deployment . #tag . coerced . to Just)

109− (dfi ^. #deployment . #appOverrides)

110− (dfi ^. #deployment . #deploymentOverrides)

111− errEv

106+ wrapRequestErrors $ \hReq ->

107+ deploymentPopupBody

108+ hReq

109+ (dfi ^. #deployment . #appOverrides)

110+ (dfi ^. #deployment . #deploymentOverrides)

111+ errEv

octopod-frontend/src/Page/Popup/NewDeployment.hs+9−3

@@ -97,20 +97,26 @@ newDeploymentPopupBody errEv = divClass "popup__content" $

9797 let commandResponseEv = fmapMaybe commandResponse errEv

9898 nameErrEv = getNameError commandResponseEv nameDyn

9999 (nameDyn, validNameDyn) <- octopodTextInput "tag" "Name" "Name" Nothing nameErrEv

100− depDyn <- deploymentPopupBody hReq Nothing mempty mempty errEv

100+ depDyn <- deploymentPopupBody hReq mempty mempty errEv

101101 let dep = do

102102 depDyn >>= \case

103103 Nothing -> pure Nothing

104104 Just du' -> do

105105 name <- DeploymentName <$> nameDyn

106− pure . Just $ Deployment name (du' ^. #newTag) (du' ^. #appOverrides) (du' ^. #deploymentOverrides)

106+ pure . Just $ Deployment name (du' ^. #appOverrides) (du' ^. #deploymentOverrides)

107107 pure $ do

108108 validNameDyn >>= \case

109109 False -> pure Nothing

110110 True -> dep

111111 where

112112 getNameError crEv nameDyn =

113− let nameErrEv' = fmapMaybe (preview (_Ctor @"ValidationError" . _1)) crEv

113+ let nameErrEv' =

114+ fmapMaybe

115+ ( \case

116+ ValidationError nameErr -> Just nameErr

117+ _ -> Nothing

118+ )

119+ crEv

114120 isNameValidDyn = isNameValid . DeploymentName <$> nameDyn

115121 badNameText =

116122 "Deployment name length should be longer than 2 characters \

octopod-frontend/src/Reflex/Dom/Renderable.hsnew file+17

@@ -0,0 +1,17 @@

1+module Reflex.Dom.Renderable

2+ ( Renderable (..),

3+ )

4+where

5+

6+import Data.Text (Text)

7+import Reflex.Dom

8+

9+class Renderable a where

10+ rndr :: DomBuilder t m => a -> m ()

11+

12+instance Renderable Text where

13+ rndr = text

14+

15+instance Renderable a => Renderable [a] where

16+ rndr [] = pure ()

17+ rndr (a : aa) = rndr a >> rndr aa