Removed separate tag field, added config check and unified control script arguments (#109)

* Introduced config check

* Remove tag from frontend and redid all of search

* Added migrations

* Fixed layout

* Fixed search ordering

* Refined markup

* Imporved text for empty overrides

* Refined text

* Unified control scripts

* Formatting

* Fixed octo CLI

* Fixed build

charts/octopod/templates/octopod-configmap.yaml

@@ -16,7 +16,7 @@ data:
   CHECKING_COMMAND: {{ printf "%s/check" (include "controlScriptsPath" .)  | quote }}
   CLEANUP_COMMAND: {{ printf "%s/cleanup" (include "controlScriptsPath" .)  | quote }}
   ARCHIVE_CHECKING_COMMAND: {{ printf "%s/archive_check" (include "controlScriptsPath" .)  | quote }}
-  TAG_CHECKING_COMMAND: {{ printf "%s/tag_check" (include "controlScriptsPath" .)  | quote }}
+  CONFIG_CHECKING_COMMAND: {{ printf "%s/tag_check" (include "controlScriptsPath" .)  | quote }}
   INFO_COMMAND: {{ printf "%s/info" (include "controlScriptsPath" .)  | quote }}
   {{- range $name, $value := .Values.octopod.env }}
   {{ $name }}: {{ $value | quote }}

dev/default.nix

@@ -97,7 +97,11 @@ in
       failScript = pkgs.writeScript "fail.sh" ''
         #!${pkgs.bash}/bin/bash
 
-        exit 1
+        1>&2 echo "You did something wrong :("
+
+        echo "You did something wrong, but you shouldn't see this."
+
+        exit 0
       '';
 
       infoScript = pkgs.writeScript "info.sh" ''
@@ -137,7 +141,7 @@ in
         export CHECKING_COMMAND=${echoScript}
         export CLEANUP_COMMAND=${echoScript}
         export ARCHIVE_CHECKING_COMMAND=${echoScript}
-        export TAG_CHECKING_COMMAND=${echoScript}
+        export CONFIG_CHECKING_COMMAND=${failScript}
         export INFO_COMMAND=${infoScript}
         export NOTIFICATION_COMMAND=${writeScript}
         export DEPLOYMENT_OVERRIDES_COMMAND=${infoScript}

migrations/deploy/move_tag_to_overrides.sql

@@ -0,0 +1,18 @@
+-- Deploy octopod:move_tag_to_overrides to pg
+
+BEGIN;
+
+
+UPDATE deployments as d
+  SET app_overrides = d.app_overrides ||
+    jsonb_build_array(jsonb_build_array('image.tag', jsonb_build_object('tag', 'ValueAdded', 'contents', d.tag)));
+
+ALTER TABLE "deployments" DROP COLUMN "tag";
+
+UPDATE deployment_logs as d
+  SET app_overrides = d.app_overrides ||
+    jsonb_build_array(jsonb_build_array('image.tag', jsonb_build_object('tag', 'ValueAdded', 'contents', d.tag)));
+
+ALTER TABLE "deployment_logs" DROP COLUMN "tag";
+
+COMMIT;

migrations/revert/move_tag_to_overrides.sql

@@ -0,0 +1,62 @@
+-- Revert octopod:move_tag_to_overrides from pg
+BEGIN;
+ALTER TABLE deployments
+ADD COLUMN tag text;
+UPDATE deployments AS d
+SET tag = COALESCE(
+    (
+      WITH appOvs AS (
+        SELECT jsonb_array_elements(d."app_overrides") AS res
+      )
+      SELECT a.res->1->>'contents'
+      FROM appOvs AS a
+      WHERE (a.res->>0) = 'image.tag'
+    ),
+    ''
+  );
+UPDATE deployments AS d
+SET app_overrides = COALESCE(
+    (
+      WITH appOvs AS (
+        SELECT jsonb_array_elements(d."app_overrides") AS res
+      )
+      SELECT jsonb_agg(a.res)
+      FROM appOvs AS a
+      WHERE (a.res->>0) != 'image.tag'
+    ),
+    '[]'
+  );
+ALTER TABLE deployments
+ALTER COLUMN tag
+SET NOT NULL;
+--
+ALTER TABLE deployment_logs
+ADD COLUMN tag text;
+UPDATE deployment_logs AS d
+SET tag = COALESCE(
+    (
+      WITH appOvs AS (
+        SELECT jsonb_array_elements(d."app_overrides") AS res
+      )
+      SELECT a.res->1->>'contents'
+      FROM appOvs AS a
+      WHERE (a.res->>0) = 'image.tag'
+    ),
+    ''
+  );
+UPDATE deployment_logs AS d
+SET app_overrides = COALESCE(
+    (
+      WITH appOvs AS (
+        SELECT jsonb_array_elements(d."app_overrides") AS res
+      )
+      SELECT jsonb_agg(a.res)
+      FROM appOvs AS a
+      WHERE (a.res->>0) != 'image.tag'
+    ),
+    '[]'
+  );
+ALTER TABLE deployment_logs
+ALTER COLUMN tag
+SET NOT NULL;
+COMMIT;

migrations/sqitch.plan

@@ -16,3 +16,4 @@ rename_delete_to_archive_2 2020-11-26T08:28:58Z Typeable LLC <octopod@typeable.i
 add_detailed_failures 2021-02-04T11:01:15Z Typeable LLC <octopod@typeable.io> # Added more failure states
 remove_archived_column 2021-01-28T18:44:54Z Typeable LLC <octopod@typeable.io> # Removed 'archived' column
 migrate_2.0 2021-08-11T17:09:37Z Typeable LLC <octopod@typeable.io> # Migrate to 2.0-style tables. (Less tables)
+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.sql

@@ -0,0 +1,7 @@
+-- Verify octopod:move_tag_to_overrides on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;

octo-cli/src/Octopod/CLI.hs

@@ -64,18 +64,17 @@ runOcto = do
   let clientEnv = mkClientEnv manager env
   flip runReaderT clientEnv $
     case args of
-      Create tName tTag tSetAp tSetDep -> do
+      Create tName tSetAp tSetDep -> do
         appOvs <- either dieT pure $ parseSetOverrides tSetAp
         depOvs <- either dieT pure $ parseSetOverrides tSetDep
-        handleCreate auth $ Deployment (coerce tName) (coerce tTag) appOvs depOvs
+        handleCreate auth $ Deployment (coerce tName) appOvs depOvs
       List -> handleList auth
       Archive tName -> handleArchive auth . coerce $ tName
-      Update tName tTag tSetAp unsetApp tSetD unsetDep -> do
+      Update tName tSetAp unsetApp tSetD unsetDep -> do
         appOvs <- either dieT pure $ parseSetOverrides tSetAp
         depOvs <- either dieT pure $ parseSetOverrides tSetD
         let tName' = coerce tName
-            tTag' = coerce <$> tTag
-        handleUpdate auth tName' tTag' appOvs unsetApp depOvs unsetDep
+        handleUpdate auth tName' appOvs unsetApp depOvs unsetDep
       Info tName ->
         handleInfo auth . coerce $ tName
       Cleanup tName ->
@@ -126,13 +125,12 @@ handleArchive auth dName = do
 handleUpdate ::
   AuthContext AuthHeaderAuth ->
   DeploymentName ->
-  Maybe DeploymentTag ->
   Overrides 'ApplicationLevel ->
   [Text] ->
   Overrides 'DeploymentLevel ->
   [Text] ->
   ReaderT ClientEnv IO ()
-handleUpdate auth dName dTag dNewAppOvs removedAppOvs dNewDepOvs removedDepOvs = do
+handleUpdate auth dName dNewAppOvs removedAppOvs dNewDepOvs removedDepOvs = do
   clientEnv <- ask
   dep <- runClientM' (_fullInfoH auth dName) clientEnv
   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 =
   liftIO $ do
     let dUpdate =
           DeploymentUpdate
-            { newTag = fromMaybe (dep ^. #deployment . #tag) dTag
-            , appOverrides = appOverrides'
+            { appOverrides = appOverrides'
             , deploymentOverrides = deploymentOverrides'
             }
     response <- runClientM (updateH auth dName dUpdate) clientEnv
@@ -268,17 +265,16 @@ handleResponse _ (Left err) =
 decodeError :: LBSC.ByteString -> Text
 decodeError body =
   case decode body of
-    Just (ValidationError nameErrors tagErrors) ->
-      T.concat ((<> "\n") <$> nameErrors) <> T.concat ((<> "\n") <$> tagErrors)
+    Just (ValidationError nameErrors) ->
+      T.concat ((<> "\n") <$> nameErrors)
     Just (AppError errorMsg) -> errorMsg
     Just Success -> "ok"
     _ -> "error: " <> (T.pack . LBSC.unpack $ body)
 
 -- | Pretty-prints the 'info' subcommand result.
 printInfo :: DeploymentInfo -> IO ()
-printInfo (DeploymentInfo (Deployment _ dTag dAppOvs dStOvs) (DeploymentMetadata dMeta) dLogs) = do
+printInfo (DeploymentInfo (Deployment _ dAppOvs dStOvs) (DeploymentMetadata dMeta) dLogs) = do
   T.putStrLn "Current settings:"
-  T.putStrLn $ "tag: " <> coerce dTag
   T.putStrLn $
     "application overrides: "
       <> formatOverrides dAppOvs
@@ -329,7 +325,6 @@ ppDeploymentLogRow dLog =
       ]
     , [dLog ^. field @"actionId" . to unActionId . re _Show . packed]
     , [dLog ^. field @"action" . to actionToText]
-    , [dLog ^. field @"deploymentTag" . coerced]
     , dLog ^. field @"deploymentAppOverrides" . to formatOverrides'
     , dLog ^. field @"deploymentDepOverrides" . to formatOverrides'
     , [dLog ^. field @"exitCode" . re _Show . packed]

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

@@ -14,8 +14,6 @@ data Args
   = Create
       { -- | deployment name
         name :: Text
-      , -- | deployment tag
-        tag :: Text
       , -- | application-level overrides to set
         setAppOverrides :: [Text]
       , -- | deployment-level overrides to set
@@ -29,8 +27,6 @@ data Args
   | Update
       { -- | deployment name
         name :: Text
-      , -- | deployment tag
-        newTag :: Maybe Text
       , -- | application-level overrides to set
         setAppOverrides :: [Text]
       , -- | application-level overrides to unset
@@ -96,7 +92,6 @@ createArgs :: Parser Args
 createArgs =
   Create
     <$> strOption (long "name" <> short 'n' <> help "deployment name")
-    <*> strOption (long "tag" <> short 't' <> help "deployment tag")
     <*> many
       ( strOption
           ( long "set-app-env-override"
@@ -128,7 +123,6 @@ updateArgs :: Parser Args
 updateArgs =
   Update
     <$> strOption (long "name" <> short 'n' <> help "deployment name")
-    <*> optional (strOption (long "tag" <> short 't' <> help "deployment tag"))
     <*> many
       ( strOption
           ( long "set-app-env-override"

octopod-backend/octopod-backend.cabal

@@ -57,6 +57,8 @@ library
                      , ViewPatterns
                      , TupleSections
                      , GADTs
+                     , TypeSynonymInstances
+                     , FlexibleInstances
   exposed-modules:
       Octopod.Server
       Octopod.Server.Args

octopod-backend/src/Octopod/Schema.hs

@@ -25,7 +25,6 @@ deploymentSchema =
         DeploymentSchema
           { id_ = "id"
           , name = "name"
-          , tag = "tag"
           , appOverrides = "app_overrides"
           , deploymentOverrides = "deployment_overrides"
           , createdAt = "created_at"
@@ -41,7 +40,6 @@ deploymentSchema =
 data DeploymentSchema f = DeploymentSchema
   { id_ :: Column f DeploymentId
   , name :: Column f DeploymentName
-  , tag :: Column f DeploymentTag
   , appOverrides :: Column f (Overrides 'ApplicationLevel)
   , deploymentOverrides :: Column f (Overrides 'DeploymentLevel)
   , createdAt :: Column f UTCTime
@@ -62,7 +60,6 @@ data DeploymentLogSchema f = DeploymentLogSchema
   { actionId :: Column f ActionId
   , deploymentId :: Column f DeploymentId
   , action :: Column f Action
-  , deploymentTag :: Column f DeploymentTag
   , exitCode :: Column f Int64
   , createdAt :: Column f UTCTime
   , archived :: Column f Bool
@@ -85,7 +82,6 @@ deploymentLogSchema =
           { actionId = "id"
           , deploymentId = "deployment_id"
           , action = "action"
-          , deploymentTag = "tag"
           , exitCode = "exit_code"
           , createdAt = "created_at"
           , archived = "archived"

octopod-backend/src/Octopod/Server.hs

@@ -36,7 +36,7 @@ import Data.Int
 import qualified Data.Map.Ordered.Strict as OM
 import Data.Maybe
 import Data.Pool
-import Data.Text (pack, unpack, unwords)
+import Data.Text (pack)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Time
@@ -115,7 +115,7 @@ data AppState = AppState
   , -- | archive checking command path
     archiveCheckingCommand :: Command
   , -- | tag checking command path
-    tagCheckingCommand :: Command
+    configCheckingCommand :: Command
   , infoCommand :: Command
   , notificationCommand :: Maybe Command
   , deploymentOverridesCommand :: Command
@@ -178,7 +178,7 @@ runOctopodServer = do
   checkingCmd <- Command . pack <$> getEnvOrDie "CHECKING_COMMAND"
   cleanupCmd <- Command . pack <$> getEnvOrDie "CLEANUP_COMMAND"
   archiveCheckingCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"
-  tagCheckingCmd <- Command . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"
+  tagCheckingCmd <- Command . pack <$> getEnvOrDie "CONFIG_CHECKING_COMMAND"
   infoCmd <- Command . pack <$> getEnvOrDie "INFO_COMMAND"
   dOverridesCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_OVERRIDES_COMMAND"
   dKeysCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_KEYS_COMMAND"
@@ -244,7 +244,7 @@ runOctopodServer = do
           , checkingCommand = checkingCmd
           , cleanupCommand = cleanupCmd
           , archiveCheckingCommand = archiveCheckingCmd
-          , tagCheckingCommand = tagCheckingCmd
+          , configCheckingCommand = tagCheckingCmd
           , infoCommand = infoCmd
           , notificationCommand = notificationCmd
           , deploymentOverridesCommand = dOverridesCmd
@@ -413,7 +413,7 @@ fullInfoH dName = do
     Nothing ->
       throwError
         err404
-          { errBody = validationError ["Name not found"] []
+          { errBody = validationError ["Name not found"]
           }
 
 -- | Handles the 'full_info' request of the octo CLI API.
@@ -454,7 +454,7 @@ createH dep = do
           \under 17 characters and begin with a letter."
     throwError
       err400
-        { errBody = validationError [badNameText] []
+        { errBody = validationError [badNameText]
         }
   t1 <- liftBase getCurrentTime
   failIfImageNotFound dep
@@ -474,7 +474,6 @@ createH dep = do
                         [ DeploymentSchema
                             { id_ = unsafeDefault
                             , name = litExpr $ dep ^. #name
-                            , tag = litExpr $ dep ^. #tag
                             , appOverrides = litExpr $ dep ^. #appOverrides
                             , deploymentOverrides = litExpr $ dep ^. #deploymentOverrides
                             , createdAt = now
@@ -495,7 +494,7 @@ createH dep = do
             | code == unique_violation ->
               throwError
                 err400
-                  { errBody = validationError ["Deployment already exists"] []
+                  { errBody = validationError ["Deployment already exists"]
                   }
           Left _ ->
             throwError err409 {errBody = appError "Some database error"}
@@ -566,8 +565,6 @@ createDeployment dep = do
           , T.unpack . coerce $ namespace st
           , "--name"
           , T.unpack . coerce $ dep ^. #name
-          , "--tag"
-          , T.unpack . coerce $ dep ^. #tag
           ]
           <> fullConfigArgs cfg
   (ec, out, err) <- runCommandArgs creationCommand args
@@ -722,7 +719,7 @@ transitionToStatus dName s = do
   forM_ notificationCmd $ \nCmd ->
     runBgWorker . void $
       runCommandArgs' nCmd
-        =<< notificationCommandArgs dName (dep ^. #tag) oldS newS
+        =<< notificationCommandArgs dName oldS newS
   liftBase $ sendReloadEvent st
 
 assertStatusTransitionPossible ::
@@ -777,22 +774,10 @@ archiveH :: DeploymentName -> AppM CommandResponse
 archiveH dName = do
   failIfGracefulShutdownActivated
   t1 <- liftBase getCurrentTime
-  st <- ask
-  let log = liftBase . logInfo (logger st)
-      args =
-        [ "--project-name"
-        , coerce $ projectName st
-        , "--base-domain"
-        , coerce $ baseDomain st
-        , "--namespace"
-        , coerce $ namespace st
-        , "--name"
-        , coerce dName
-        ]
-      cmd = coerce $ archiveCommand st
   runDeploymentBgWorker (Just ArchivePending) dName (pure ()) $ \() -> do
-    log $ "call " <> unwords (cmd : args)
-    (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
+    (view #deployment -> dep) <- getDeploymentS dName
+    cfg <- getDeploymentConfig dep
+    (ec, out, err) <- runCommandArgs archiveCommand =<< archiveCommandArgs cfg dep
     t2 <- liftBase getCurrentTime
     let elTime = elapsedTime t2 t1
     transitionToStatusS dName $
@@ -831,7 +816,6 @@ updateH dName dUpdate = do
                 , set = \() ds ->
                     ds & #appOverrides .~ litExpr (dUpdate ^. #appOverrides)
                       & #deploymentOverrides .~ litExpr (dUpdate ^. #deploymentOverrides)
-                      & #tag .~ litExpr (dUpdate ^. #newTag)
                 , updateWhere = \() ds -> ds ^. #name ==. litExpr dName
                 , returning = Projection id
                 }
@@ -851,16 +835,12 @@ updateH dName dUpdate = do
             , T.unpack . coerce $ namespace st
             , "--name"
             , T.unpack . coerce $ dName
-            , "--tag"
-            , T.unpack . coerce $ dep ^. #tag
             ]
             <> fullConfigArgs cfg
     (ec, out, err) <- runCommandArgs updateCommand args
     liftBase . log $
       "deployment updated, name: "
         <> coerce dName
-        <> ", tag: "
-        <> coerce (dep ^. #tag)
     t2 <- liftBase getCurrentTime
     let elTime = elapsedTime t2 t1
     transitionToStatusS dName $
@@ -934,25 +914,15 @@ cleanupH dName = do
 
 -- | Helper to cleanup deployment.
 cleanupDeployment ::
-  (MonadBaseControl IO m, MonadReader AppState m) =>
+  (MonadBaseControl IO m, MonadReader AppState m, MonadError ServerError m) =>
   DeploymentName ->
   m ()
 cleanupDeployment dName = do
   st <- ask
   let log = logInfo (logger st)
-      args =
-        [ "--project-name"
-        , coerce $ projectName st
-        , "--base-domain"
-        , coerce $ baseDomain st
-        , "--namespace"
-        , coerce $ namespace st
-        , "--name"
-        , coerce dName
-        ]
-      cmd = coerce $ cleanupCommand st
-  liftBase . log $ "call " <> unwords (cmd : args)
-  (ec, out, err) <- runCommand (unpack cmd) (unpack <$> args)
+  (view #deployment -> dep) <- getDeploymentS dName
+  cfg <- getDeploymentConfig dep
+  (ec, out, err) <- runCommandArgs cleanupCommand =<< cleanupCommandArgs cfg dep
   liftBase $ print out >> print err
   deleteDeploymentLogs dName
   deleteDeployment dName
@@ -1080,7 +1050,6 @@ createDeploymentLog dep act ec dur out err = do
                     { actionId = unsafeDefault
                     , deploymentId = litExpr dId
                     , action = litExpr act
-                    , deploymentTag = litExpr $ dep ^. #tag
                     , exitCode = litExpr $ case ec of
                         ExitSuccess -> 0
                         ExitFailure errCode -> fromIntegral errCode
@@ -1123,20 +1092,20 @@ upsertDeploymentMetadatum dName dMetadata =
 failIfImageNotFound :: Deployment -> AppM ()
 failIfImageNotFound dep = do
   cfg <- getDeploymentConfig dep
-  (ec, _, _) <- runCommandArgs tagCheckingCommand =<< tagCheckCommandArgs cfg dep
+  (ec, _, Stderr err) <- runCommandArgs configCheckingCommand =<< configCheckCommandArgs cfg dep
   case ec of
     ExitSuccess -> pure ()
     ExitFailure _ ->
-      throwError err400 {errBody = validationError [] ["Tag not found"]}
+      throwError err400 {errBody = BSL.fromStrict $ T.encodeUtf8 err}
 
 -- | Helper to create an application-level error.
 appError :: Text -> BSL.ByteString
 appError = encode . AppError
 
 -- | Helper to create a validation-level error.
-validationError :: [Text] -> [Text] -> BSL.ByteString
-validationError nameErrors tagErrors =
-  encode $ ValidationError nameErrors tagErrors
+validationError :: [Text] -> BSL.ByteString
+validationError nameErrors =
+  encode $ ValidationError nameErrors
 
 -- | Helper to send an event to the WS event channel.
 sendReloadEvent :: AppState -> IO ()
@@ -1165,20 +1134,21 @@ runStatusUpdater state = do
         ds <- each deploymentSchema
         where_ $ ds ^. #checkedAt <. litExpr cutoff
         where_ $ ds ^. #status /=. litExpr Archived
-        pure (ds ^. #name, ds ^. #status, now `diffTime` (ds ^. #statusUpdatedAt), ds ^. #tag)
-      checkResult <- for rows' $ \(dName, dStatus, Timestamp -> ts, _) -> do
+        pure (ds ^. #name, ds ^. #status, now `diffTime` (ds ^. #statusUpdatedAt))
+      checkResult <- for rows' $ \(dName, dStatus, Timestamp -> ts) -> do
         let timeout = statusUpdateTimeout state
-        mEc <- case dStatus of
-          ArchivePending -> do
-            (ec, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs dName
-            pure $ Just ec
-          _ -> do
-            getSingleFullInfo dName >>= \case
-              Nothing -> liftBase (logErr $ "Couldn't find deployment: " <> coerce dName) $> Nothing
-              Just (view #deployment -> dep) -> do
-                cfg <- getDeploymentConfig dep
-                (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep
-                pure $ Just ec
+        mEc <-
+          getSingleFullInfo dName >>= \case
+            Nothing -> liftBase (logErr $ "Couldn't find deployment: " <> coerce dName) $> Nothing
+            Just (view #deployment -> dep) -> do
+              cfg <- getDeploymentConfig dep
+              case dStatus of
+                ArchivePending -> do
+                  (ec, _, _) <- runCommandArgs archiveCheckingCommand =<< archiveCheckArgs cfg dep
+                  pure $ Just ec
+                _ -> do
+                  (ec, _, _) <- runCommandArgs checkingCommand =<< checkCommandArgs cfg dep
+                  pure $ Just ec
         pure $ mEc <&> \ec -> (dName, statusTransition ec dStatus ts timeout, dStatus)
       updated <-
         for (catMaybes checkResult) $ \(dName, transitionM, dStatus) ->

octopod-backend/src/Octopod/Server/ControlScriptUtils.hs

@@ -5,7 +5,9 @@
 --This module contains control script utils.
 module Octopod.Server.ControlScriptUtils
   ( infoCommandArgs,
+    archiveCommandArgs,
     unarchiveCommandArgs,
+    cleanupCommandArgs,
     notificationCommandArgs,
     runCommand,
     runCommandWithoutPipes,
@@ -13,7 +15,7 @@ module Octopod.Server.ControlScriptUtils
     runCommandArgs',
     checkCommandArgs,
     archiveCheckArgs,
-    tagCheckCommandArgs,
+    configCheckCommandArgs,
 
     -- * overrides
     defaultDeploymentOverridesArgs,
@@ -67,8 +69,6 @@ genericDeploymentCommandArgs cfg dep = do
       , T.unpack . coerce $ namespace
       , "--name"
       , T.unpack . coerce $ dep ^. #name
-      , "--tag"
-      , T.unpack . coerce $ tag dep
       ]
       <> fullConfigArgs cfg
 
@@ -101,11 +101,20 @@ genericDeploymentCommandArgsNoConfig = do
 infoCommandArgs :: GenericDeploymentCommandArgs m r
 infoCommandArgs = genericDeploymentCommandArgs
 
+archiveCommandArgs :: GenericDeploymentCommandArgs m r
+archiveCommandArgs = genericDeploymentCommandArgs
+
+cleanupCommandArgs :: GenericDeploymentCommandArgs m r
+cleanupCommandArgs = genericDeploymentCommandArgs
+
+archiveCheckArgs :: GenericDeploymentCommandArgs m r
+archiveCheckArgs = genericDeploymentCommandArgs
+
 checkCommandArgs :: GenericDeploymentCommandArgs m r
 checkCommandArgs = genericDeploymentCommandArgs
 
-tagCheckCommandArgs :: GenericDeploymentCommandArgs m r
-tagCheckCommandArgs = genericDeploymentCommandArgs
+configCheckCommandArgs :: GenericDeploymentCommandArgs m r
+configCheckCommandArgs = genericDeploymentCommandArgs
 
 defaultDeploymentOverridesArgs :: GenericDeploymentCommandArgsNoConfig m r
 defaultDeploymentOverridesArgs = genericDeploymentCommandArgsNoConfig
@@ -132,13 +141,12 @@ notificationCommandArgs ::
   , HasType Domain r
   ) =>
   DeploymentName ->
-  DeploymentTag ->
   -- | Previous status
   DeploymentStatus ->
   -- | New status
   DeploymentStatus ->
   m ControlScriptArgs
-notificationCommandArgs dName dTag old new = do
+notificationCommandArgs dName old new = do
   (Namespace namespace) <- asks getTyped
   (ProjectName projectName) <- asks getTyped
   (Domain domain) <- asks getTyped
@@ -152,38 +160,12 @@ notificationCommandArgs dName dTag old new = do
       , T.unpack namespace
       , "--name"
       , T.unpack . coerce $ dName
-      , "--tag"
-      , T.unpack . coerce $ dTag
       , "--old-status"
       , T.unpack $ deploymentStatusToText old
       , "--new-status"
       , T.unpack $ deploymentStatusToText new
       ]
 
-archiveCheckArgs ::
-  ( MonadReader r m
-  , HasType Namespace r
-  , HasType ProjectName r
-  , HasType Domain r
-  ) =>
-  DeploymentName ->
-  m ControlScriptArgs
-archiveCheckArgs dName = do
-  (ProjectName projectName) <- asks getTyped
-  (Domain domain) <- asks getTyped
-  (Namespace namespace) <- asks getTyped
-  return $
-    ControlScriptArgs
-      [ "--project-name"
-      , T.unpack projectName
-      , "--base-domain"
-      , T.unpack domain
-      , "--namespace"
-      , T.unpack namespace
-      , "--name"
-      , T.unpack . coerce $ dName
-      ]
-
 runCommandArgs ::
   (MonadReader r m, MonadBase IO m, HasType TimedFastLogger r) =>
   (r -> Command) ->

octopod-backend/src/Orphans.hs

@@ -23,9 +23,6 @@ deriving newtype instance DBEq DeploymentId
 deriving newtype instance DBType DeploymentName
 deriving newtype instance DBEq DeploymentName
 
-deriving newtype instance DBType DeploymentTag
-deriving newtype instance DBEq DeploymentTag
-
 instance DBType Action where
   typeInformation = parseTypeInformationFromMapping actionText
 

octopod-common/octopod-common.cabal

@@ -19,6 +19,7 @@ library
                      , Common.Utils
                      , Common.Validation
                      , Data.Map.Ordered.Strict.Extra
+                     , Control.Searchable
   -- other-modules:
   -- other-extensions:
   default-extensions:  BlockArguments
@@ -47,6 +48,12 @@ library
                      , EmptyDataDeriving
                      , TupleSections
                      , AllowAmbiguousTypes
+                     , TypeFamilies
+                     , RankNTypes
+                     , MultiParamTypeClasses
+                     , ApplicativeDo
+                     , UndecidableInstances
+                     , FunctionalDependencies
   build-depends:       base
                      , aeson
                      , cassava

octopod-common/src/Common/Types.hs

@@ -8,6 +8,7 @@
 module Common.Types where
 
 import Control.Lens
+import Control.Searchable
 import Data.Aeson hiding (Result)
 import Data.Csv
 import Data.Generics.Labels ()
@@ -35,13 +36,32 @@ instance KnownOverrideLevel 'ApplicationLevel where
 instance KnownOverrideLevel 'DeploymentLevel where
   knownOverrideLevel = DeploymentLevel
 
-data OverrideValue = ValueAdded Text | ValueDeleted
-  deriving (ToJSON, FromJSON) via Snake OverrideValue
+instance Searchable needle t => Searchable needle (OverrideValue' t) where
+  type SearchableConstraint needle (OverrideValue' t) res = SearchableConstraint needle t res
+  type Searched (OverrideValue' t) res = OverrideValue' (Searched t res)
+  searchWith _ ValueDeleted = pure ValueDeleted
+  searchWith f (ValueAdded t) = ValueAdded <$> searchWith f t
+  {-# INLINE searchWith #-}
+
+data OverrideValue' t = ValueAdded t | ValueDeleted
+  deriving (ToJSON, FromJSON) via Snake (OverrideValue' t)
   deriving stock (Eq, Ord, Show, Generic)
 
-newtype DefaultConfig (l :: OverrideLevel) = DefaultConfig (OMap Text Text)
+type OverrideValue = OverrideValue' Text
+
+type DefaultConfig = DefaultConfig' Text
+
+newtype DefaultConfig' te (l :: OverrideLevel) = DefaultConfig (OMap te te)
   deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)
 
+instance Searchable t x => Searchable t (DefaultConfig' x l) where
+  type SearchableConstraint t (DefaultConfig' x l) res = (Ord (Searched x res), SearchableConstraint t x res)
+  type Searched (DefaultConfig' x l) res = DefaultConfig' (Searched x res) l
+  searchWith f (DefaultConfig oMap) = do
+    oMap' <- searchWith f . OM.assocs $ oMap
+    pure $ DefaultConfig $ OM.fromList oMap'
+  {-# INLINE searchWith #-}
+
 lookupDefaultConfig :: DefaultConfig l -> Text -> Maybe Text
 lookupDefaultConfig (DefaultConfig m) k = OM.lookup k m
 
@@ -79,9 +99,19 @@ applyOverrides (Overrides oo) (DefaultConfig dd) =
               ValueDeleted -> False
           )
 
-newtype Overrides (l :: OverrideLevel) = Overrides {unOverrides :: OMap Text OverrideValue}
+instance Searchable t x => Searchable t (Overrides' x l) where
+  type SearchableConstraint t (Overrides' x l) res = (Ord (Searched x res), SearchableConstraint t x res)
+  type Searched (Overrides' x l) res = Overrides' (Searched x res) l
+  searchWith f (Overrides oMap) = do
+    oMap' <- searchWith f . OM.assocs $ oMap
+    pure $ Overrides $ OM.fromList oMap'
+  {-# INLINE searchWith #-}
+
+newtype Overrides' t (l :: OverrideLevel) = Overrides {unOverrides :: OMap t (OverrideValue' t)}
   deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)
 
+type Overrides = Overrides' Text
+
 extractOverrides :: DefaultConfig l -> Config l -> Overrides l
 extractOverrides (DefaultConfig dCfg) (Config cfg) =
   Overrides . OM.fromList $ removed <> present
@@ -115,13 +145,17 @@ instance Monoid (Overrides l) where
 newtype DeploymentId = DeploymentId {unDeploymentId :: Int64}
   deriving stock (Show)
 
-newtype DeploymentName = DeploymentName {unDeploymentName :: Text}
+instance Searchable needle t => Searchable needle (DeploymentName' t) where
+  type SearchableConstraint needle (DeploymentName' t) res = SearchableConstraint needle t res
+  type Searched (DeploymentName' t) res = DeploymentName' (Searched t res)
+  searchWith f (DeploymentName t) = DeploymentName <$> searchWith f t
+  {-# INLINE searchWith #-}
+
+newtype DeploymentName' t = DeploymentName {unDeploymentName :: t}
   deriving newtype
     (Show, Read, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData, Eq, Ord)
 
-newtype DeploymentTag = DeploymentTag {unDeploymentTag :: Text}
-  deriving newtype
-    (Show, FromJSON, ToJSON, ToHttpApiData, FromHttpApiData, Eq)
+type DeploymentName = DeploymentName' Text
 
 data Action = RestoreAction | ArchiveAction | UpdateAction | CreateAction
   deriving stock (Show, Read, Eq, Ord, Generic)
@@ -195,19 +229,36 @@ archivedStatuses = [ArchivePending, Archived]
 isArchivedStatus :: DeploymentStatus -> Bool
 isArchivedStatus = (`elem` archivedStatuses)
 
-data Deployment = Deployment
-  { name :: DeploymentName
-  , tag :: DeploymentTag
-  , appOverrides :: Overrides 'ApplicationLevel
-  , deploymentOverrides :: Overrides 'DeploymentLevel
+data Deployment' t = Deployment
+  { name :: DeploymentName' t
+  , appOverrides :: Overrides' t 'ApplicationLevel
+  , deploymentOverrides :: Overrides' t 'DeploymentLevel
   }
   deriving stock (Generic, Show, Eq)
-  deriving (FromJSON, ToJSON) via Snake Deployment
+  deriving (FromJSON, ToJSON) via Snake (Deployment' t)
+
+instance (Searchable needle t) => Searchable needle (Deployment' t) where
+  type
+    SearchableConstraint needle (Deployment' t) res =
+      (SearchableConstraint needle t res, Ord (Searched t res))
+  type Searched (Deployment' t) res = Deployment' (Searched t res)
+  searchWith f d = do
+    name' <- searchWith f $ d ^. #name
+    appOverrides' <- searchWith f $ d ^. #appOverrides
+    deploymentOverrides' <- searchWith f $ d ^. #deploymentOverrides
+    pure
+      Deployment
+        { name = name'
+        , appOverrides = appOverrides'
+        , deploymentOverrides = deploymentOverrides'
+        }
+  {-# INLINE searchWith #-}
+
+type Deployment = Deployment' Text
 
 data DeploymentLog = DeploymentLog
   { actionId :: ActionId
   , action :: Action
-  , deploymentTag :: DeploymentTag
   , deploymentAppOverrides :: Overrides 'ApplicationLevel
   , deploymentDepOverrides :: Overrides 'DeploymentLevel
   , exitCode :: Int64
@@ -238,17 +289,29 @@ data DeploymentInfo = DeploymentInfo
   deriving stock (Generic, Show)
   deriving (FromJSON, ToJSON) via Snake DeploymentInfo
 
-data DeploymentFullInfo = DeploymentFullInfo
-  { deployment :: Deployment
+instance (Searchable needle t) => Searchable needle (DeploymentFullInfo' t) where
+  type
+    SearchableConstraint needle (DeploymentFullInfo' t) res =
+      (SearchableConstraint needle t res, Ord (Searched t res))
+  type Searched (DeploymentFullInfo' t) res = DeploymentFullInfo' (Searched t res)
+  searchWith f d = do
+    deployment' <- searchWith f $ d ^. #deployment
+    pure $ d & #deployment .~ deployment'
+  {-# INLINE searchWith #-}
+
+data DeploymentFullInfo' t = DeploymentFullInfo
+  { deployment :: Deployment' t
   , status :: PreciseDeploymentStatus
   , metadata :: DeploymentMetadata
   , createdAt :: UTCTime
   , updatedAt :: UTCTime
   }
   deriving stock (Generic, Show, Eq)
-  deriving (FromJSON, ToJSON) via Snake DeploymentFullInfo
+  deriving (FromJSON, ToJSON) via Snake (DeploymentFullInfo' t)
 
-isDeploymentArchived :: DeploymentFullInfo -> Bool
+type DeploymentFullInfo = DeploymentFullInfo' Text
+
+isDeploymentArchived :: DeploymentFullInfo' t -> Bool
 isDeploymentArchived DeploymentFullInfo {status = s} = case s of
   DeploymentNotPending s' -> isArchivedStatus s'
   -- if the deployment is currently undergoing some process,
@@ -256,8 +319,7 @@ isDeploymentArchived DeploymentFullInfo {status = s} = case s of
   DeploymentPending _ -> False
 
 data DeploymentUpdate = DeploymentUpdate
-  { newTag :: DeploymentTag
-  , appOverrides :: Overrides 'ApplicationLevel
+  { appOverrides :: Overrides 'ApplicationLevel
   , deploymentOverrides :: Overrides 'DeploymentLevel
   }
   deriving stock (Generic, Show)
@@ -277,7 +339,6 @@ data CommandResponse
   = Success
   | ValidationError
       { nameField :: [Text]
-      , tagField :: [Text]
       }
   | AppError
       {errorMessage :: Text}

octopod-common/src/Control/Searchable.hs

@@ -0,0 +1,47 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+module Control.Searchable
+  ( Searchable (..),
+  )
+where
+
+import Control.Lens
+import Data.Kind
+import Data.Text (Text)
+
+-- | This says that you can search 'needle's in a 'haystack'. What precisely
+-- "search for" means is defined by a function (the first argument) which
+-- looks at every 'needle' and returns a "search result".
+--
+-- Essentially this is just a glorified 'Traversal' that can have extra
+-- constraints and can leverage the constraint solver.
+--
+-- For a concrete "search" implementation see 'Data.Text.Search' from the
+-- 'octopod-frontend' package.
+class Searchable needle haystack where
+  type SearchableConstraint needle haystack res :: Constraint
+  type SearchableConstraint _ _ _ = ()
+  type Searched haystack res
+  searchWith ::
+    SearchableConstraint needle haystack res =>
+    Traversal haystack (Searched haystack res) needle res
+
+instance Searchable Text Text where
+  type Searched Text res = res
+  searchWith f t = f t
+  {-# INLINE searchWith #-}
+
+instance Searchable needle x => Searchable needle [x] where
+  type SearchableConstraint needle [x] res = SearchableConstraint needle x res
+  type Searched [x] res = [Searched x res]
+  searchWith f = traverse (searchWith f)
+  {-# INLINE searchWith #-}
+
+instance (Searchable needle a, Searchable needle b) => Searchable needle (a, b) where
+  type SearchableConstraint needle (a, b) res = (SearchableConstraint needle a res, SearchableConstraint needle b res)
+  type Searched (a, b) res = (Searched a res, Searched b res)
+  searchWith f (a, b) = do
+    a' <- searchWith f a
+    b' <- searchWith f b
+    pure (a', b')
+  {-# INLINE searchWith #-}

octopod-css/development/layouts/index.html

@@ -62,9 +62,6 @@
                                             <th>
                                                 Links
                                             </th>
-                                            <th>
-                                                Tag
-                                            </th>
                                             <th>
                                                 App overrides
                                             </th>
@@ -100,9 +97,6 @@
                                                     </a>
                                                 </div>
                                             </td>
-                                            <td>
-                                                fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                            </td>
                                             <td>
                                                 <div class="listing listing--for-text">
                                                     <div class="listing__item">
@@ -181,9 +175,6 @@
                                                     </a>
                                                 </div>
                                             </td>
-                                            <td>
-                                                fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                            </td>
                                             <td>
                                                 <div class="listing listing--for-text">
                                                     <div class="listing__item">
@@ -249,9 +240,6 @@
                                                     </a>
                                                 </div>
                                             </td>
-                                            <td>
-                                                fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                            </td>
                                             <td>
                                                 <div class="listing listing--for-text">
                                                     <div class="listing__item">
@@ -320,9 +308,6 @@
                                                     </a>
                                                 </div>
                                             </td>
-                                            <td>
-                                                fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                            </td>
                                             <td>
                                                 <div class="listing listing--for-text">
                                                     <div class="listing__item">
@@ -441,9 +426,6 @@
                                             <td>
                                                 ...
                                             </td>
-                                            <td>
-                                                fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                            </td>
                                             <td>
                                                 <div class="listing listing--for-text">
                                                     <div class="listing__item">
@@ -499,9 +481,6 @@
                                             <td>
                                                 ...
                                             </td>
-                                            <td>
-                                                fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                            </td>
                                             <td>
                                                 <div class="listing listing--for-text">
                                                     <div class="listing__item">

octopod-css/development/layouts/staging.html

@@ -173,9 +173,6 @@
                                                 <th>
                                                     Action type
                                                 </th>
-                                                <th>
-                                                    Image tag
-                                                </th>
                                                 <th>
                                                     App overrides
                                                 </th>
@@ -198,13 +195,12 @@
                                                 <td>
                                                     Create
                                                 </td>
-                                                <td>
-                                                    fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                                </td>
                                                 <td>
                                                     <div class="listing listing--for-text">
                                                         <div class="listing__item">
-                                                            <b>ENVIRONENT:</b> production
+                                                            <b>ENVIRONENT:</b>
+                                                            <div class="listing__placeholder listing__placeholder__value"></div>
+                                                            <div class="listing__spinner"></div>
                                                         </div>
                                                         <div class="listing__item">
                                                             <b>app_api_url:</b> http://my-api.my-domain.com
@@ -247,9 +243,6 @@
                                                 <td>
                                                     Edit
                                                 </td>
-                                                <td>
-                                                    fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                                </td>
                                                 <td>
                                                     <div class="listing listing--for-text">
                                                         <div class="listing__item">
@@ -290,9 +283,6 @@
                                                 <td>
                                                     Update
                                                 </td>
-                                                <td>
-                                                    fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                                </td>
                                                 <td>
                                                     <div class="listing listing--for-text">
                                                         <div class="listing__item">
@@ -333,9 +323,6 @@
                                                 <td>
                                                     Delete
                                                 </td>
-                                                <td>
-                                                    fa3a5bd4cc1134ae259c34d4cf530be0f0996a0b
-                                                </td>
                                                 <td>
                                                     <div class="listing listing--for-text">
                                                         <div class="listing__item">

octopod-css/development/styles/_listing.css

@@ -66,12 +66,13 @@
         .listing__placeholder {
             content: "";
             display: inline-block;
-            height: 14px;
+            height: 12px;
             width: 140px;
             border-radius: 2px;
             background: rgba(143, 143, 143, 0.2);
             margin-right: 4px;
-            margin-top: 3px;
+            margin-top: -5px;
+            margin-bottom: -1px;
         }
 
         .listing__placeholder__value {
@@ -95,7 +96,7 @@
 
 .listing__spinner {
     display: inline-block;
-    vertical-align: top;
+    vertical-align: middle;
     border: none;
     background-color: transparent;
     background-repeat: no-repeat;
@@ -104,7 +105,9 @@
     padding: 0;
     width: 20px;
     height: 20px;
-    cursor: pointer;
+    margin-top: -10px;
+    margin-bottom: -7px;
+    cursor: default;
     text-indent: 200%;
     white-space: nowrap;
     overflow: hidden;
@@ -112,3 +115,14 @@
     background-image: url("../vectors/spot-loader.svg");
     animation: loading 2.2s linear infinite;
 }
+
+.listing.listing--larger .listing__placeholder {
+    height: 14px;
+}
+
+.listing.listing--larger .listing__spinner {
+    background-size: 24px 24px;
+    width: 24px;
+    height: 24px;
+    margin-bottom: -5px;
+}

octopod-css/development/styles/_table.css

@@ -84,12 +84,11 @@
     /* В случае table-layout: fixed; ширины колонкам задаются по ширинам в первой строке */
     .table--deployments th:nth-child(1) { width: 16.1818%; } /* 178px */
     .table--deployments th:nth-child(2) { width: 16.1818%; } /* 178px */
-    .table--deployments th:nth-child(3) { width: 8%; } /* 88px */
-    .table--deployments th:nth-child(4) { width: 20.3636%; } /* 224px */
-    .table--deployments th:nth-child(5) { width: 20.3636%; } /* 224px */
+    .table--deployments th:nth-child(3) { width: 24.3636%; } /* 224px */
+    .table--deployments th:nth-child(4) { width: 24.3636%; } /* 224px */
+    .table--deployments th:nth-child(5) { width: 9.4546%; } /* 104px */
     .table--deployments th:nth-child(6) { width: 9.4546%; } /* 104px */
-    .table--deployments th:nth-child(7) { width: 9.4546%; } /* 104px */
-    .table--deployments th:nth-child(8) { width: 52px; }
+    .table--deployments th:nth-child(7) { width: 52px; }
 
     .table--deployments th:first-child,
     .table--deployments td:first-child {
@@ -119,38 +118,32 @@
 
     }
 
-    /* Tag */
-    .table--deployments td:nth-child(3) {
-        white-space: nowrap;
-        overflow: hidden;
-        text-overflow: ellipsis;
-    }
-
     /* App overrides */
-    .table--deployments td:nth-child(4) {
+    .table--deployments td:nth-child(3) {
 
     }
 
     /* Deployment overrides */
-    .table--deployments td:nth-child(5) {
+    .table--deployments td:nth-child(4) {
 
     }
 
     /* Created */
-    .table--deployments td:nth-child(6) {
+    .table--deployments td:nth-child(5) {
         white-space: nowrap;
     }
 
     /* Changed */
-    .table--deployments td:nth-child(7) {
+    .table--deployments td:nth-child(6) {
         white-space: nowrap;
     }
 
     /* Dropdown */
-    .table--deployments td:nth-child(8) {
+    .table--deployments td:nth-child(7) {
 
     }
-        .table--deployments td:nth-child(8) .drop {
+
+        .table--deployments td:nth-child(7) .drop {
             margin: -8px;
         }
 
@@ -166,12 +159,11 @@
 
     /* В случае table-layout: fixed; ширины колонкам задаются по ширинам в первой строке */
     .table--actions th:nth-child(1) { width: 8%; }
-    .table--actions th:nth-child(2) { width: 20%; }
-    .table--actions th:nth-child(3) { width: 21%; }
-    .table--actions th:nth-child(4) { width: 20%; }
-    .table--actions th:nth-child(5) { width: 7%; }
-    .table--actions th:nth-child(6) { width: 15%; }
-    .table--actions th:nth-child(7) { width: 9%; }
+    .table--actions th:nth-child(2) { width: 30%; }
+    .table--actions th:nth-child(3) { width: 31%; }
+    .table--actions th:nth-child(4) { width: 7%; }
+    .table--actions th:nth-child(5) { width: 15%; }
+    .table--actions th:nth-child(6) { width: 9%; }
 
     .table--actions th:first-child,
     .table--actions td:first-child {
@@ -197,7 +189,6 @@
 
     /* Image tag */
     .table--actions td:nth-child(2) {
-        word-break: break-all;
     }
 
     /* Overrides */

octopod-frontend/index.html

@@ -3,6 +3,7 @@
 
 <head>
   <meta charset="UTF-8">
+  <meta name="theme-color" content="#3671E3">
 </head>
 
 <body>

octopod-frontend/octopod-frontend.cabal

@@ -50,6 +50,7 @@ executable frontend
                      , Frontend.UIKit.Button.Static
                      , Frontend.UIKit.Button.Action
                      , Frontend.UIKit.Button.Sort
+                     , Reflex.Dom.Renderable
   ghc-options:
     -Weverything
     -Wno-implicit-prelude
@@ -123,5 +124,7 @@ executable frontend
                      , witherable
                      , reflex
                      , data-default
+                     , free
+                     , parallel
   hs-source-dirs:      src
   default-language:    Haskell2010

octopod-frontend/src/Data/Text/Search.hs

@@ -1,19 +1,33 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
 module Data.Text.Search
   ( fuzzySearch,
     fuzzySearchMany,
+    searchMany,
+    wrapResult,
+    search,
+    deSearch,
     FuzzySearchStringChunk (..),
+    SearchResult (..),
   )
 where
 
 import Control.Applicative
+import Control.Applicative.Free.Fast
+import Control.Lens
+import Control.Parallel.Strategies
+import Control.Searchable
 import Data.Bifunctor
 import Data.Char
 import Data.Function
-import Data.Functor
 import qualified Data.List as L
-import Data.Maybe (mapMaybe)
+import Data.Maybe (catMaybes)
+import Data.Ord
+import Data.Semigroup
 import Data.Text (Text)
 import qualified Data.Text as T
+import Reflex.Dom
+import Reflex.Dom.Renderable
 
 type Needle = Text
 type Haystack = Text
@@ -49,7 +63,7 @@ fuzzySearch n h = case fuzzySearch' n h 0 0 of
 
 fuzzySearchMany :: Needle -> [Haystack] -> [(Haystack, [FuzzySearchStringChunk Text])]
 fuzzySearchMany needle haystacks =
-  fmap fst . L.sortOn snd $
+  fmap fst . L.sortOn (Down . snd) $
     mapMaybe
       ( \haystack ->
           fuzzySearch needle haystack
@@ -57,5 +71,84 @@ fuzzySearchMany needle haystacks =
       )
       haystacks
 
+searchMany ::
+  (Searchable Text x, SearchableConstraint Text x SearchResult) =>
+  Text ->
+  [x] ->
+  [Searched x SearchResult]
+searchMany "" = fmap wrapResult
+searchMany t =
+  fmap snd . L.sortOn (Down . fst) . catMaybes
+    . withStrategy (parListChunk 3 rpar)
+    . fmap (search t)
+{-# INLINE searchMany #-}
+
+-- | Extract initial structure from search result.
+deSearch ::
+  forall x.
+  (Searchable SearchResult x, SearchableConstraint SearchResult x Text) =>
+  x ->
+  Searched x Text
+deSearch = searchWith @SearchResult @x %~ initialSearchText
+{-# INLINE deSearch #-}
+
+-- | Like 'search', but doesn't search for anything. All 'Text' are marked as not matched.
+wrapResult :: (Searchable Text x, SearchableConstraint Text x SearchResult) => x -> Searched x SearchResult
+wrapResult =
+  runIdentity . searchWith (\t -> Identity $ SearchResult t Nothing)
+{-# INLINE wrapResult #-}
+
+search ::
+  (Searchable Text x, SearchableConstraint Text x SearchResult) =>
+  Text ->
+  x ->
+  Maybe (Int, Searched x SearchResult)
+search needle x = runSearchApplicative $ searchWith searchSingle x
+  where
+    searchSingle :: Text -> SearchApplicative SearchResult
+    searchSingle t = case fuzzySearch needle t of
+      Nothing -> pure $ SearchResult t Nothing
+      Just (res, score) -> liftAp $ TextSearch t res score
+{-# INLINE search #-}
+
+data SearchResult = SearchResult
+  { initialSearchText :: !Text
+  , searchResult :: !(Maybe [FuzzySearchStringChunk Text])
+  }
+  deriving stock (Eq, Ord)
+
+instance Searchable SearchResult SearchResult where
+  type Searched SearchResult res = res
+  searchWith f t = f t
+  {-# INLINE searchWith #-}
+
+instance Renderable SearchResult where
+  rndr (SearchResult _ (Just cs)) = rndr cs
+  rndr (SearchResult t Nothing) = rndr t
+
+data SearchF x where
+  TextSearch :: Text -> [FuzzySearchStringChunk Text] -> !Int -> SearchF SearchResult
+
+type SearchApplicative = Ap SearchF
+
+runSearchApplicative :: SearchApplicative x -> Maybe (Int, x)
+runSearchApplicative x = case findMaxResult x of
+  Nothing -> Nothing
+  Just m ->
+    Just . (m,) . runIdentity $
+      runAp
+        ( \case
+            TextSearch t res i | i == m -> Identity $ SearchResult t (Just res)
+            TextSearch t _ _ -> Identity $ SearchResult t Nothing
+        )
+        x
+  where
+    findMaxResult :: SearchApplicative a -> Maybe Int
+    findMaxResult = fmap getMax . runAp_ (\(TextSearch _ _ i) -> Just $ Max i)
+
 data FuzzySearchStringChunk a = NotMatched !a | Matched !a
-  deriving stock (Show, Eq, Functor)
+  deriving stock (Show, Eq, Ord, Functor)
+
+instance Renderable a => Renderable (FuzzySearchStringChunk a) where
+  rndr (NotMatched a) = rndr a
+  rndr (Matched a) = elAttr "span" ("style" =: "text-decoration: underline;") (rndr a)

octopod-frontend/src/Data/WorkingOverrides.hs

@@ -1,9 +1,12 @@
 module Data.WorkingOverrides
   ( WorkingOverrides,
     WorkingOverride,
-    WorkingOverrideKey (..),
+    WorkingOverride',
+    WorkingOverrideKey' (..),
+    WorkingOverrideKey,
     WorkingOverrideKeyType (..),
-    WorkingOverrideValue (..),
+    WorkingOverrideValue' (..),
+    WorkingOverrideValue,
     destructWorkingOverrides,
     constructWorkingOverrides,
     newWorkingOverride,
@@ -17,20 +20,28 @@ import Data.Maybe
 import Data.Text (Text)
 import Data.UniqMap
 
-type WorkingOverrides = UniqKeyMap WorkingOverride
+type WorkingOverrides = WorkingOverrides' Text
 
-type WorkingOverride = (WorkingOverrideKey, WorkingOverrideValue)
+type WorkingOverrides' te = UniqKeyMap (WorkingOverride' te)
 
-data WorkingOverrideKey = WorkingOverrideKey !WorkingOverrideKeyType !Text
+type WorkingOverride = WorkingOverride' Text
+
+type WorkingOverride' te = (WorkingOverrideKey' te, WorkingOverrideValue' te)
+
+type WorkingOverrideKey = WorkingOverrideKey' Text
+
+data WorkingOverrideKey' te = WorkingOverrideKey !WorkingOverrideKeyType !te
   deriving stock (Show)
 
 data WorkingOverrideKeyType = CustomWorkingOverrideKey | DefaultWorkingOverrideKey
   deriving stock (Show, Eq)
 
-data WorkingOverrideValue
-  = WorkingCustomValue !Text
-  | WorkingDefaultValue !Text
-  | WorkingDeletedValue !(Maybe Text)
+type WorkingOverrideValue = WorkingOverrideValue' Text
+
+data WorkingOverrideValue' te
+  = WorkingCustomValue !te
+  | WorkingDefaultValue !te
+  | WorkingDeletedValue !(Maybe te)
   deriving stock (Show)
 
 destructWorkingOverrides :: WorkingOverrides -> Overrides l
@@ -51,7 +62,11 @@ destructWorkingOverrides =
     getWorkingOverrideValue (WorkingDefaultValue x) = ValueAdded x
     getWorkingOverrideValue (WorkingDeletedValue _) = ValueDeleted
 
-constructWorkingOverrides :: Maybe (DefaultConfig l) -> Overrides l -> WorkingOverrides
+constructWorkingOverrides ::
+  Ord te =>
+  Maybe (DefaultConfig' te l) ->
+  Overrides' te l ->
+  WorkingOverrides' te
 constructWorkingOverrides (Just (DefaultConfig dCfg)) (Overrides ovsM) =
   let custom =
         uniqMapFromList

octopod-frontend/src/Frontend/Route.hs

@@ -33,7 +33,7 @@ data Routes :: Type -> Type where
 deriving stock instance Show (Routes a)
 
 fmap mconcat . sequence $
-  [ makeWrapped ''DeploymentName
+  [ makeWrapped ''DeploymentName'
   , deriveRouteComponent ''Routes
   ]
 

octopod-frontend/src/Frontend/UIKit.hs

@@ -41,6 +41,7 @@ import Frontend.UIKit.Button.Sort as X
 import Frontend.UIKit.Button.Static as X
 import GHC.Generics (Generic)
 import Reflex.Dom
+import Reflex.Dom.Renderable
 import Reflex.Network
 
 (.~~) :: ASetter' s a -> a -> s -> s
@@ -276,14 +277,16 @@ nonEditableWorkingOverrideStyleClasses LargeNonEditableWorkingOverrideStyle = "l
 
 -- | Widget that shows overrides list. It does not depend on their type.
 showNonEditableWorkingOverride ::
-  MonadWidget t m =>
+  (MonadWidget t m, Renderable te) =>
   -- | Loading?
   Bool ->
+  -- | Is it fully loaded?
+  Bool ->
   NonEditableWorkingOverrideStyle ->
   -- | Overrides list.
-  [WorkingOverride] ->
+  [WorkingOverride' te] ->
   m ()
-showNonEditableWorkingOverride loading style cfg =
+showNonEditableWorkingOverride loading loaded style cfg =
   divClass
     ( destructClasses $
         "listing" <> "listing--for-text" <> nonEditableWorkingOverrideStyleClasses style
@@ -292,7 +295,9 @@ showNonEditableWorkingOverride loading style cfg =
       case cfg of
         [] ->
           divClass "listing__item" $
-            elClass "span" "listing--info-text" $ text "no custom configuration"
+            elClass "span" "listing--info-text" $
+              text $
+                if loaded then "no configuration" else "no custom configuration"
         _ -> forM_ cfg $ \(WorkingOverrideKey keyType key, val) -> do
           let wrapper = case val of
                 WorkingDeletedValue _ -> divClass "listing__item deleted"
@@ -302,16 +307,16 @@ showNonEditableWorkingOverride loading style cfg =
                   CustomWorkingOverrideKey -> elClass "span" "listing__key"
                   DefaultWorkingOverrideKey -> elClass "span" "listing__key default"
             keyWrapper $ do
-              text key
+              rndr key
               text ": "
 
             case val of
-              WorkingCustomValue txt -> elClass "span" "listing__value" $ text txt
-              WorkingDefaultValue txt -> elClass "span" "listing__value default" $ text txt
-              WorkingDeletedValue (Just txt) -> elClass "span" "listing__value default" $ text txt
+              WorkingCustomValue txt -> elClass "span" "listing__value" $ rndr txt
+              WorkingDefaultValue txt -> elClass "span" "listing__value default" $ rndr txt
+              WorkingDeletedValue (Just txt) -> elClass "span" "listing__value default" $ rndr txt
               WorkingDeletedValue Nothing -> do
                 elClass "div" "listing__placeholder listing__placeholder__value" $ pure ()
-                elClass "div" "listing__spinner" $ pure ()
+                when loading $ elClass "div" "listing__spinner" $ pure ()
       when loading $
         divClass "listing__item" $ do
           elClass "div" "listing__placeholder" $ pure ()

octopod-frontend/src/Frontend/Utils.hs

@@ -29,7 +29,10 @@ module Frontend.Utils
     ProgressiveFullConfig (..),
     RequestErrorHandler,
     deploymentOverridesWidget,
+    deploymentOverridesWidgetSearched,
     applicationOverridesWidget,
+    applicationOverridesWidgetSearched,
+    debounceDyn,
   )
 where
 
@@ -40,11 +43,11 @@ import Control.Monad.Reader
 import qualified Data.Foldable as F
 import Data.Functor
 import Data.Generics.Labels ()
-import Data.Generics.Sum
 import qualified Data.Map as M
-import Data.Maybe (fromMaybe, isNothing)
+import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Monoid
-import Data.Text as T (Text, intercalate, null, pack)
+import Data.Text as T (Text, null, pack)
+import Data.Text.Search
 import Data.Time
 import Data.UniqMap
 import Data.Unique
@@ -60,6 +63,7 @@ import GHCJS.DOM.EventM (on, target)
 import GHCJS.DOM.GlobalEventHandlers as Events (click)
 import GHCJS.DOM.Node as DOM
 import Reflex.Dom as R
+import Reflex.Dom.Renderable
 import Reflex.Network
 import Servant.Common.Req
 import Servant.Reflex.Extra
@@ -203,10 +207,10 @@ octopodTextInput clss lbl placeholder val errEv =
 -- | Widget that can show and hide overrides if there are more than 3. This
 -- widget is used in the deployments table and the deployment action table.
 overridesWidget ::
-  MonadWidget t m =>
+  (MonadWidget t m, Renderable te, Ord te) =>
   -- | List of overrides.
-  Overrides l ->
-  (Event t () -> m (Event t (DefaultConfig l))) ->
+  Overrides' te l ->
+  (Event t () -> m (Event t (DefaultConfig' te l))) ->
   m ()
 overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
   defMDyn <- getDef firstExpand >>= holdDynMaybe
@@ -218,11 +222,11 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
             do
               defM <- defMDyn
               pure $
-                showNonEditableWorkingOverride (isNothing defM) RegularNonEditableWorkingOverrideStyle $
+                showNonEditableWorkingOverride (isNothing defM) (isJust defM) RegularNonEditableWorkingOverrideStyle $
                   elemsUniq $ constructWorkingOverrides defM ovs
       ContractedState ->
         let ovsList = elemsUniq $ constructWorkingOverrides Nothing ovs
-         in showNonEditableWorkingOverride False RegularNonEditableWorkingOverrideStyle $
+         in showNonEditableWorkingOverride False False RegularNonEditableWorkingOverrideStyle $
               take 3 ovsList
 
   expandState <-
@@ -231,8 +235,8 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
         { buttonText = do
             state <- expandState
             pure $ case state of
-              ExpandedState -> "Hide"
-              ContractedState -> "Show all"
+              ExpandedState -> "Hide default configuration"
+              ContractedState -> "Show full configuration"
         , buttonInitialState = ContractedState
         , buttonType = Just ListingExpanderButton
         , buttonStyle = RegularExpanderButtonStyle
@@ -241,12 +245,20 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
   pure ()
 
 deploymentOverridesWidget ::
-  MonadWidget t m =>
+  (MonadWidget t m) =>
   RequestErrorHandler t m ->
   Overrides 'DeploymentLevel ->
   m ()
 deploymentOverridesWidget hReq depOvs =
-  overridesWidget depOvs $ defaultDeploymentOverrides >=> hReq
+  deploymentOverridesWidgetSearched hReq (wrapResult depOvs)
+
+deploymentOverridesWidgetSearched ::
+  (MonadWidget t m) =>
+  RequestErrorHandler t m ->
+  Overrides' SearchResult 'DeploymentLevel ->
+  m ()
+deploymentOverridesWidgetSearched hReq depOvs =
+  overridesWidget depOvs $ (fmap . fmap . fmap) wrapResult $ defaultDeploymentOverrides >=> hReq
 
 applicationOverridesWidget ::
   MonadWidget t m =>
@@ -255,13 +267,23 @@ applicationOverridesWidget ::
   Overrides 'ApplicationLevel ->
   m ()
 applicationOverridesWidget hReq depOvs appOvs =
+  applicationOverridesWidgetSearched hReq (wrapResult depOvs) (wrapResult appOvs)
+
+applicationOverridesWidgetSearched ::
+  MonadWidget t m =>
+  RequestErrorHandler t m ->
+  Overrides' SearchResult 'DeploymentLevel ->
+  Overrides' SearchResult 'ApplicationLevel ->
+  m ()
+applicationOverridesWidgetSearched hReq depOvs appOvs =
   overridesWidget appOvs $ \fire -> do
     depDefEv <- defaultDeploymentOverrides fire >>= hReq
     fmap switchDyn $
-      networkHold (pure never) $
-        depDefEv <&> \depDef -> do
-          pb <- getPostBuild
-          defaultApplicationOverrides (pure $ Right $ applyOverrides depOvs depDef) pb >>= hReq
+      (fmap . fmap . fmap) wrapResult $
+        networkHold (pure never) $
+          depDefEv <&> \depDef -> do
+            pb <- getPostBuild
+            defaultApplicationOverrides (pure $ Right $ applyOverrides (deSearch depOvs) depDef) pb >>= hReq
 
 -- | Type of notification at the top of pages.
 data DeploymentPageNotification
@@ -308,14 +330,13 @@ deploymentPopupBody ::
   forall t m tag.
   MonadWidget t m =>
   RequestErrorHandler t m ->
-  Maybe DeploymentTag ->
   Overrides 'ApplicationLevel ->
   Overrides 'DeploymentLevel ->
   -- | \"Edit request\" failure event.
   Event t (ReqResult tag CommandResponse) ->
   -- | Returns deployment update and validation state.
   m (Dynamic t (Maybe DeploymentUpdate))
-deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
+deploymentPopupBody hReq defAppOv defDepOv errEv = mdo
   pb <- getPostBuild
   (defDepEv, defApp, depCfgEv) <- deploymentConfigProgressiveComponents hReq deploymentOvsDyn
   defAppM <- holdClearingWith defApp (unitEv deploymentOvsDyn)
@@ -323,11 +344,8 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
   depKeys <- deploymentOverrideKeys pb >>= hReq
 
   let commandResponseEv = fmapMaybe commandResponse errEv
-      tagErrEv = getTagError commandResponseEv tagDyn
   void $ hReq (errEv `R.difference` commandResponseEv)
 
-  (tagDyn, tOkEv) <- octopodTextInput "tag" "Tag" "Tag" (unDeploymentTag <$> defTag) tagErrEv
-
   let holdDCfg ::
         Dynamic t [Text] ->
         Dynamic t (Maybe (DefaultConfig l)) ->
@@ -348,29 +366,15 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
   appKeysDyn <- holdDyn [] $ catMaybes appKeys
   applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
 
-  validDyn <- holdDyn True $ updated tOkEv
-  pure $
-    validDyn >>= \case
-      False -> pure Nothing
-      True -> do
-        depCfg <- deploymentOvsDyn
-        appOvs <- applicationOvsDyn
-        tag' <- DeploymentTag <$> tagDyn
-        pure $
-          Just $
-            DeploymentUpdate
-              { newTag = tag'
-              , appOverrides = appOvs
-              , deploymentOverrides = depCfg
-              }
-  where
-    getTagError crEv tagDyn =
-      let tagErrEv' = fmapMaybe (preview (_Ctor @"ValidationError" . _2)) crEv
-          tagErrEv = ffilter (/= "") $ T.intercalate ". " <$> tagErrEv'
-          badTagText = "Tag should not be empty"
-          badNameEv = badTagText <$ ffilter (== "") (updated tagDyn)
-       in leftmost [tagErrEv, badNameEv]
-
+  pure $ do
+    depCfg <- deploymentOvsDyn
+    appOvs <- applicationOvsDyn
+    pure $
+      Just $
+        DeploymentUpdate
+          { appOverrides = appOvs
+          , deploymentOverrides = depCfg
+          }
 deploymentConfigProgressiveComponents ::
   MonadWidget t m =>
   RequestErrorHandler t m ->
@@ -458,7 +462,6 @@ errorHeader ::
   m ()
 errorHeader appErr = do
   divClass "deployment__output notification notification--danger" $ do
-    el "b" $ text "App error: "
     dynText appErr
 
 -- | Widget with override fields. This widget supports adding and
@@ -603,3 +606,18 @@ unitEv = fmapCheap (const ()) . updated
 
 (<&&>) :: (Functor f1, Functor f2) => f1 (f2 a) -> (a -> b) -> f1 (f2 b)
 x <&&> f = (fmap . fmap) f x
+
+debounceDyn ::
+  ( PerformEvent t m
+  , TriggerEvent t m
+  , MonadIO (Performable m)
+  , MonadHold t m
+  , MonadFix m
+  ) =>
+  NominalDiffTime ->
+  Dynamic t a ->
+  m (Dynamic t a)
+debounceDyn t d = do
+  currD <- sample . current $ d
+  ev <- debounce t (updated d)
+  holdDyn currD ev

octopod-frontend/src/Main.hs

@@ -92,7 +92,8 @@ headWidget ::
   Event t ProjectName ->
   m ()
 headWidget projectNameEv = do
-  elAttr "meta" ("charset" =: "urf8 ") blank
+  elAttr "meta" ("charset" =: "UTF-8") blank
+  elAttr "meta" ("name" =: "theme-color" <> "content" =: "#3671E3") blank
   elAttr
     "meta"
     ( "http-equiv" =: "x-ua-compatible"

octopod-frontend/src/Page/Deployment.hs

@@ -208,9 +208,6 @@ deploymentBody updEv dfiDyn = deploymentBodyWrapper $
         divClass "deployment__value" $ do
           let createdAtDyn = dfiDyn <^.> field @"updatedAt"
           dynText $ formatPosixToDate <$> createdAtDyn
-    deploymentSection "Tag" $ do
-      let tagDyn = dfiDyn <^.> field @"deployment" . field @"tag" . coerced
-      divClass "deployment__widget" $ dynText tagDyn
     deploymentSection "Links" $ do
       let urlsDyn = dfiDyn <^.> field @"metadata" . to unDeploymentMetadata
       divClass "deployment__widget" $
@@ -221,7 +218,7 @@ deploymentBody updEv dfiDyn = deploymentBodyWrapper $
         cfgDyn <&> \cfg -> do
           let showVars bL l =
                 divClass "deployment__widget" $
-                  showNonEditableWorkingOverride (cfg ^. bL) LargeNonEditableWorkingOverrideStyle $
+                  showNonEditableWorkingOverride (cfg ^. bL) (not $ cfg ^. bL) LargeNonEditableWorkingOverrideStyle $
                     elemsUniq (cfg ^. l)
           deploymentSection "Deployment overrides" $ showVars #depConfigLoading #depConfig
           deploymentSection "App overrides" $ showVars #appConfigLoading #appConfig
@@ -259,7 +256,6 @@ actionsTableHead =
   el "thead" $
     el "tr" $ do
       el "th" $ text "Action type"
-      el "th" $ text "Image tag"
       el "th" $ text "Deployment overrides"
       el "th" $ text "App overrides"
       el "th" $ text "Exit code"
@@ -315,7 +311,6 @@ actinRow hReq DeploymentLog {..} = do
             "status "
               <> if exitCode == 0 then "status--success" else "status--failure"
       divClass statusClass blank
-    el "td" $ text $ coerce deploymentTag
     el "td" $ deploymentOverridesWidget hReq deploymentDepOverrides
     el "td" $ applicationOverridesWidget hReq deploymentDepOverrides deploymentAppOverrides
     el "td" $ text $ showT $ exitCode

octopod-frontend/src/Page/Deployments.hs

@@ -39,6 +39,7 @@ import Page.ClassicPopup
 import Page.Elements.Links
 import Page.Popup.EditDeployment
 import Page.Popup.NewDeployment
+import Reflex.Dom.Renderable
 import Reflex.MultiEventWriter.Class
 import Servant.Reflex.Extra
 
@@ -88,9 +89,10 @@ deploymentsWidget updAllEv dfis = do
               <$ errUpdEv
           , DPMClear <$ okUpdEv
           ]
-      (showNewDeploymentEv', termDyn) <- deploymentsHeadWidget True okUpdEv
+      (showNewDeploymentEv', termDyn') <- deploymentsHeadWidget True okUpdEv
+      termDyn <- debounceDyn 0.3 termDyn'
       (okUpdEv, errUpdEv, editEv) <- deploymentsListWidget hReq updAllEv termDyn dfis
-      pure (showNewDeploymentEv', editEv)
+      pure (showNewDeploymentEv', deSearch <$> editEv)
   void $ newDeploymentPopup showNewDeploymentEv never
   void $ editDeploymentPopup editEv never
 
@@ -179,58 +181,24 @@ deploymentsListWidget ::
   Dynamic t Text ->
   -- | Initial deployment data
   [DeploymentFullInfo] ->
-  m (Event t (), Event t (), Event t DeploymentFullInfo)
+  m (Event t (), Event t (), Event t SearchedDeploymentInfo)
 deploymentsListWidget hReq updAllEv termDyn ds = dataWidgetWrapper $ mdo
   retryEv <- delay 10 errUpdEv
   updRespEv <- listEndpoint $ leftmost [updAllEv, () <$ retryEv]
   let okUpdEv = fmapMaybe reqSuccess updRespEv
       errUpdEv = fmapMaybe reqErrorBody updRespEv
   dsDyn <- holdDyn ds okUpdEv
-  let isArchived = isDeploymentArchived . view #deployment
-      filteredDyn = ffor2 termDyn dsDyn $ \term ds' ->
-        mapMaybe (searchDeployments . T.filter (not . isSpace) $ term) ds'
+  let searchedDyn = ffor2 termDyn dsDyn $ \term ds' ->
+        searchMany (T.filter (not . isSpace) term) ds'
       (archivedDsDyn, activeDsDyn) =
-        splitDynPure $
-          L.partition isArchived
-            <$> filteredDyn
-      searchSorting = termDyn $> Just (SortDesc (view #score))
+        splitDynPure $ L.partition isDeploymentArchived <$> searchedDyn
+      searchSorting = termDyn $> Nothing
   clickedEv <- elementClick
   editEv <- activeDeploymentsWidget hReq searchSorting clickedEv activeDsDyn
   archivedDeploymentsWidget hReq searchSorting clickedEv archivedDsDyn
   pure (() <$ okUpdEv, () <$ errUpdEv, editEv)
 
-data SearchedDeploymentFullInfo = SearchedDeploymentFullInfo
-  { deployment :: DeploymentFullInfo
-  , searchResult :: DeploymentSearchResult
-  , score :: Int
-  }
-  deriving stock (Generic, Show, Eq)
-
--- | Compares deployment fields (name and tag) with a search term.
-searchDeployments ::
-  -- | Search term.
-  Text ->
-  -- | Deployment data.
-  DeploymentFullInfo ->
-  Maybe SearchedDeploymentFullInfo
-searchDeployments term d = case (tagResult, nameResult) of
-  (Nothing, Nothing) -> Nothing
-  (Just (res, score), Nothing) ->
-    Just $ SearchedDeploymentFullInfo d (DeploymentTagResult res) score
-  (Nothing, Just (res, score)) ->
-    Just $ SearchedDeploymentFullInfo d (DeploymentNameResult res) score
-  (Just (tRes, tScore), Just (nRes, nScore)) ->
-    if tScore > nScore
-      then Just $ SearchedDeploymentFullInfo d (DeploymentTagResult tRes) tScore
-      else Just $ SearchedDeploymentFullInfo d (DeploymentNameResult nRes) nScore
-  where
-    tagResult = fuzzySearch term . unDeploymentTag $ d ^. field @"deployment" . field @"tag"
-    nameResult = fuzzySearch term . unDeploymentName $ d ^. dfiName
-
-data DeploymentSearchResult
-  = DeploymentNameResult [FuzzySearchStringChunk Text]
-  | DeploymentTagResult [FuzzySearchStringChunk Text]
-  deriving stock (Show, Eq)
+type SearchedDeploymentInfo = DeploymentFullInfo' SearchResult
 
 -- | Table with active deployments.
 activeDeploymentsWidget ::
@@ -239,19 +207,18 @@ activeDeploymentsWidget ::
   , MonadReader ProjectConfig m
   ) =>
   RequestErrorHandler t m ->
-  Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo)) ->
+  Dynamic t (Maybe (SortDir DeploymentFullInfo)) ->
   -- | Event that carries the clicked DOM element. This event is required by
   -- `dropdownWidget'`.
   Event t ClickedElement ->
-  Dynamic t [SearchedDeploymentFullInfo] ->
+  Dynamic t [SearchedDeploymentInfo] ->
   -- | Returns an event carrying editable deployment
   -- to \"edit deployment\" sidebar.
-  m (Event t DeploymentFullInfo)
+  m (Event t SearchedDeploymentInfo)
 activeDeploymentsWidget hReq searchSorting clickedEv dsDyn =
   divClass "data__primary" $
     tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do
-      let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn
-      sorting <- holdDyn Nothing (mergeWith (<|>) [updated colSortDyn, updated searchSorting])
+      sorting <- holdDyn Nothing (mergeWith (<|>) [updated sortDyn, updated searchSorting])
       let emptyDyn' = L.null <$> dsDyn
           dsSortedDyn = zipDynWith sortDeployments dsDyn sorting
       emptyDyn <- holdUniqDyn emptyDyn'
@@ -262,7 +229,7 @@ activeDeploymentsWidget hReq searchSorting clickedEv dsDyn =
               editEvs <- simpleList dsSortedDyn (activeDeploymentWidget hReq clickedEv)
               pure $ switchDyn $ leftmost <$> editEvs
             True -> do
-              emptyTableBody $ noDeploymentsWidget
+              emptyTableBody noDeploymentsWidget
               pure never
       switchHold never editEvEv
 
@@ -283,28 +250,27 @@ activeDeploymentWidget ::
   -- | Event that carries the clicked DOM element. This event is required by
   -- `dropdownWidget'`.
   Event t ClickedElement ->
-  Dynamic t SearchedDeploymentFullInfo ->
+  Dynamic t SearchedDeploymentInfo ->
   -- | Returns event carrying editable deployment
   -- that is required by \"edit deployment\" sidebar.
-  m (Event t DeploymentFullInfo)
+  m (Event t SearchedDeploymentInfo)
 activeDeploymentWidget hReq clickedEv dDyn' = do
   dDyn <- holdUniqDyn dDyn'
   editEvEv <- dyn $
-    ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = d@DeploymentFullInfo {..}} -> do
-      let (name, tag') = displaySearchHighlighting s
-          dName = deployment ^. #name
+    ffor dDyn $ \d@DeploymentFullInfo {..} -> do
+      let desearchedDeployment = deSearch d
+          dName = desearchedDeployment ^. #deployment . #name
       (linkEl, dropdownEv) <- el' "tr" $ do
         el "td" $ do
-          name
+          rndr . unDeploymentName $ d ^. #deployment . #name
           statusWidget $ constDyn status
         el "td" $
           divClass "listing" $
             forM_ (unDeploymentMetadata metadata) (renderMetadataLink . pure)
-        el "td" tag'
         el "td" $
-          deploymentOverridesWidget hReq (deployment ^. field @"deploymentOverrides" . coerced)
+          deploymentOverridesWidgetSearched hReq (deployment ^. field @"deploymentOverrides" . coerced)
         el "td" $
-          applicationOverridesWidget
+          applicationOverridesWidgetSearched
             hReq
             (deployment ^. field @"deploymentOverrides" . coerced)
             (deployment ^. field @"appOverrides" . coerced)
@@ -314,13 +280,11 @@ activeDeploymentWidget hReq clickedEv dDyn' = do
           text $ formatPosixToDate updatedAt
         el "td" $ do
           let enabled = not . isPending . recordedStatus $ status
-              elId = "deployment_row_" <> unDeploymentName dName
               btn =
                 elAttr
                   "button"
                   ( "class" =: "drop__handler"
                       <> "type" =: "button"
-                      <> "id" =: elId
                   )
                   $ text "Actions"
               body = do
@@ -336,7 +300,7 @@ activeDeploymentWidget hReq clickedEv dDyn' = do
                       & #buttonText .~~ "Move to archive"
                       & #buttonEnabled .~~ pure enabled
                       & #buttonType .~~ Just ArchiveActionButtonType
-                url' <- kubeDashboardUrl (view #deployment <$> dDyn)
+                url' <- kubeDashboardUrl (pure desearchedDeployment)
                 void . dyn $
                   url'
                     <&> maybe
@@ -366,24 +330,6 @@ activeDeploymentWidget hReq clickedEv dDyn' = do
       pure editEv
   switchHold never editEvEv
 
-displaySearchHighlighting :: DomBuilder t m => SearchedDeploymentFullInfo -> (m (), m ())
-displaySearchHighlighting
-  SearchedDeploymentFullInfo {searchResult = DeploymentNameResult res, deployment = d} =
-    ( markMatches res
-    , text . unDeploymentTag $ d ^. #deployment . #tag
-    )
-displaySearchHighlighting
-  SearchedDeploymentFullInfo {searchResult = DeploymentTagResult res, deployment = d} =
-    ( text . unDeploymentName $ d ^. #deployment . #name
-    , markMatches res
-    )
-
-markMatches :: DomBuilder t m => [FuzzySearchStringChunk Text] -> m ()
-markMatches [] = blank
-markMatches (NotMatched x : xs) = text x >> markMatches xs
-markMatches (Matched x : xs) =
-  elAttr "span" ("style" =: "text-decoration: underline;") (text x) >> markMatches xs
-
 -- | Table with archived deployments.
 archivedDeploymentsWidget ::
   forall t m.
@@ -391,11 +337,11 @@ archivedDeploymentsWidget ::
   , SetRoute t (R Routes) m
   ) =>
   RequestErrorHandler t m ->
-  Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo)) ->
+  Dynamic t (Maybe (SortDir DeploymentFullInfo)) ->
   -- | Event that carries the clicked DOM element. This event is required by
   -- `dropdownWidget'`.
   Event t ClickedElement ->
-  Dynamic t [SearchedDeploymentFullInfo] ->
+  Dynamic t [SearchedDeploymentInfo] ->
   m ()
 archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do
   showDyn <- toggleButton
@@ -404,8 +350,7 @@ archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do
         False -> "data__archive"
   elDynClass "div" classDyn $
     tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do
-      let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn
-      sorting <- holdDyn Nothing (mergeWith (<|>) [updated colSortDyn, updated searchSorting])
+      sorting <- holdDyn Nothing (mergeWith (<|>) [updated sortDyn, updated searchSorting])
       let emptyDyn' = L.null <$> dsDyn
           dsSortedDyn = zipDynWith sortDeployments dsDyn sorting
       emptyDyn <- holdUniqDyn emptyDyn'
@@ -416,7 +361,7 @@ archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do
               simpleList
                 dsSortedDyn
                 (archivedDeploymentWidget hReq clickedEv)
-          True -> emptyTableBody $ noDeploymentsWidget
+          True -> emptyTableBody noDeploymentsWidget
 
 -- | Row with archived deployment.
 archivedDeploymentWidget ::
@@ -425,24 +370,23 @@ archivedDeploymentWidget ::
   ) =>
   RequestErrorHandler t m ->
   Event t ClickedElement ->
-  Dynamic t SearchedDeploymentFullInfo ->
+  Dynamic t SearchedDeploymentInfo ->
   m ()
 archivedDeploymentWidget hReq clickedEv dDyn' = do
   dDyn <- holdUniqDyn dDyn'
   dyn_ $
-    ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = DeploymentFullInfo {..}} -> do
-      let (name, tag') = displaySearchHighlighting s
-          dName = deployment ^. #name
+    ffor dDyn $ \d@DeploymentFullInfo {..} -> do
+      let desearchedDeployment = deSearch d
+          dName = desearchedDeployment ^. #deployment . #name
       (linkEl, _) <- el' "tr" $ do
         el "td" $ do
-          name
+          rndr . unDeploymentName $ deployment ^. #name
           divClass "status status--archived" $ text "Archived"
         el "td" $ text "..."
-        el "td" tag'
         el "td" $
-          deploymentOverridesWidget hReq (deployment ^. field @"deploymentOverrides" . coerced)
+          deploymentOverridesWidgetSearched hReq (deployment ^. field @"deploymentOverrides" . coerced)
         el "td" $
-          applicationOverridesWidget
+          applicationOverridesWidgetSearched
             hReq
             (deployment ^. field @"deploymentOverrides" . coerced)
             (deployment ^. field @"appOverrides" . coerced)
@@ -451,13 +395,11 @@ archivedDeploymentWidget hReq clickedEv dDyn' = do
         el "td" $
           text $ formatPosixToDate updatedAt
         el "td" $ do
-          let elId = "deployment_row_" <> (unDeploymentName dName)
-              btn =
+          let btn =
                 elAttr
                   "button"
                   ( "class" =: "drop__handler"
                       <> "type" =: "button"
-                      <> "id" =: elId
                   )
                   $ text "Actions"
               body =
@@ -473,16 +415,16 @@ archivedDeploymentWidget hReq clickedEv dDyn' = do
 
 -- | Sort deployments by the supplied condition.
 sortDeployments ::
-  [SearchedDeploymentFullInfo] ->
+  [SearchedDeploymentInfo] ->
   -- | Sorting condition.
-  Maybe (SortDir SearchedDeploymentFullInfo) ->
-  [SearchedDeploymentFullInfo]
-sortDeployments items s = L.sortBy sortFunc items
+  Maybe (SortDir DeploymentFullInfo) ->
+  [SearchedDeploymentInfo]
+sortDeployments items Nothing = items
+sortDeployments items (Just (contramap deSearch -> s)) = L.sortBy sortFunc items
   where
     sortFunc a b = case s of
-      Just (SortAsc get) -> compare (get a) (get b)
-      Just (SortDesc get) -> compare (get b) (get a)
-      Nothing -> EQ
+      (SortAsc get) -> compare (get a) (get b)
+      (SortDesc get) -> compare (get b) (get a)
 
 -- | Each constructor contains a getter
 -- that extracts the field that is used for sorting.
@@ -509,7 +451,6 @@ tableHeader = do
     el "tr" $ do
       sortHeader (view dfiName) "Name" SortAsc
       el "th" $ text "Links"
-      el "th" $ text "Tag"
       el "th" $ text "Deployment overrides"
       el "th" $ text "App overrides"
       sortHeader (view $ field @"createdAt") "Created" SortDesc

octopod-frontend/src/Page/Popup/EditDeployment.hs

@@ -100,12 +100,12 @@ editDeploymentPopupBody ::
   Event t (ReqResult tag CommandResponse) ->
   -- | Returns deployment update and validation state.
   m (Dynamic t (Maybe DeploymentUpdate))
-editDeploymentPopupBody dfi errEv = wrapRequestErrors $ \hReq -> do
+editDeploymentPopupBody dfi errEv = do
   divClass "popup__content" $
     divClass "deployment" $
-      deploymentPopupBody
-        hReq
-        (dfi ^. #deployment . #tag . coerced . to Just)
-        (dfi ^. #deployment . #appOverrides)
-        (dfi ^. #deployment . #deploymentOverrides)
-        errEv
+      wrapRequestErrors $ \hReq ->
+        deploymentPopupBody
+          hReq
+          (dfi ^. #deployment . #appOverrides)
+          (dfi ^. #deployment . #deploymentOverrides)
+          errEv

octopod-frontend/src/Page/Popup/NewDeployment.hs

@@ -97,20 +97,26 @@ newDeploymentPopupBody errEv = divClass "popup__content" $
       let commandResponseEv = fmapMaybe commandResponse errEv
           nameErrEv = getNameError commandResponseEv nameDyn
       (nameDyn, validNameDyn) <- octopodTextInput "tag" "Name" "Name" Nothing nameErrEv
-      depDyn <- deploymentPopupBody hReq Nothing mempty mempty errEv
+      depDyn <- deploymentPopupBody hReq mempty mempty errEv
       let dep = do
             depDyn >>= \case
               Nothing -> pure Nothing
               Just du' -> do
                 name <- DeploymentName <$> nameDyn
-                pure . Just $ Deployment name (du' ^. #newTag) (du' ^. #appOverrides) (du' ^. #deploymentOverrides)
+                pure . Just $ Deployment name (du' ^. #appOverrides) (du' ^. #deploymentOverrides)
       pure $ do
         validNameDyn >>= \case
           False -> pure Nothing
           True -> dep
   where
     getNameError crEv nameDyn =
-      let nameErrEv' = fmapMaybe (preview (_Ctor @"ValidationError" . _1)) crEv
+      let nameErrEv' =
+            fmapMaybe
+              ( \case
+                  ValidationError nameErr -> Just nameErr
+                  _ -> Nothing
+              )
+              crEv
           isNameValidDyn = isNameValid . DeploymentName <$> nameDyn
           badNameText =
             "Deployment name length should be longer than 2 characters \

octopod-frontend/src/Reflex/Dom/Renderable.hs

@@ -0,0 +1,17 @@
+module Reflex.Dom.Renderable
+  ( Renderable (..),
+  )
+where
+
+import Data.Text (Text)
+import Reflex.Dom
+
+class Renderable a where
+  rndr :: DomBuilder t m => a -> m ()
+
+instance Renderable Text where
+  rndr = text
+
+instance Renderable a => Renderable [a] where
+  rndr [] = pure ()
+  rndr (a : aa) = rndr a >> rndr aa