Added override keys and default overrides scripts (#88)

* Refactored CS args * format * WIP * Call scripts from backend * Refactored frontend * Added defaults to frontend * Delay request * Added keys * things somewhat work * things update * Loading state * better loop breaking * Added bad loading animation * Overrides are now stable * Default values are now properly restored * added sleep * Removed unused functions * wip: cleaned up api * Added Data.UniqMap * Cleaned up actions * Extracted working overrides * Minor refactoring * new items appear at the top * Use the CSV parser * Disabled default key text fields
2024-10-05 19:27:24 +03:00 · 2021-09-07 14:01:06 +03:00 · 2021-09-07 14:01:06 +03:00 · 4ce72d3408
commit 4ce72d3408
parent 082c50399d
14 changed files with 721 additions and 407 deletions
--- a/dev/default.nix
+++ b/dev/default.nix
@ -103,6 +103,8 @@ in
      infoScript = pkgs.writeScript "info.sh" ''
        #!${pkgs.bash}/bin/bash

+        sleep 1
+
        echo "key,value"
        echo "key2,value2"

@ -138,6 +140,10 @@ in
        export TAG_CHECKING_COMMAND=${echoScript}
        export INFO_COMMAND=${infoScript}
        export NOTIFICATION_COMMAND=${writeScript}
+        export DEPLOYMENT_OVERRIDES_COMMAND=${infoScript}
+        export DEPLOYMENT_KEYS_COMMAND=${infoScript}
+        export APPLICATION_OVERRIDES_COMMAND=${infoScript}
+        export APPLICATION_KEYS_COMMAND=${infoScript}
        export POWER_AUTHORIZATION_HEADER="123"
        ${hsPkgs.octopod-backend.components.exes.octopod-exe}/bin/octopod-exe \
            --port 4443 \
--- a/octopod-api/octopod-api.cabal
+++ b/octopod-api/octopod-api.cabal
@ -36,6 +36,7 @@ library
    servant,
    octopod-common,
    servant-auth,
+    text,
  if !impl(ghcjs)
    build-depends:
      servant-websockets,
--- a/octopod-api/src/Octopod/API.hs
+++ b/octopod-api/src/Octopod/API.hs
@ -1,20 +1,19 @@
-{-|
-Module      : Octopod.API
-Description : Backend endpoints.
-
-This module contains backend endpoints.
-}
-
-
+-- |
+--Module      : Octopod.API
+--Description : Backend endpoints.
+--
+--This module contains backend endpoints.
 module Octopod.API
-  ( module Octopod.API.WebSocket
-  , API
-  ) where
+  ( module Octopod.API.WebSocket,
+    API,
+  )
+where

-import           Servant.API
+import Servant.API

-import           Common.Types
-import           Octopod.API.WebSocket
+import Common.Types
+import Data.Text (Text)
+import Octopod.API.WebSocket

 type CaptureName = Capture "name" DeploymentName

@ -30,35 +29,53 @@ type StatusEndpoint c = c :> "status" :> Get '[JSON] CurrentDeploymentStatus
 type RestoreEndpoint c =
  c :> "restore" :> Patch '[JSON] CommandResponse

+type DefaultDeploymentOverrideKeys =
+  "deployment_override_keys" :> Get '[JSON] [Text]
+type DefaultDeploymentOverrides =
+  "deployment_overrides" :> Get '[JSON] (DefaultConfig 'DeploymentLevel)
+type DefaultApplicationOverrideKeys =
+  "application_override_keys"
+    :> ReqBody '[JSON] (Config 'DeploymentLevel)
+    :> Post '[JSON] [Text]
+type DefaultApplicationOverrides =
+  "application_overrides"
+    :> ReqBody '[JSON] (Config 'DeploymentLevel)
+    :> Post '[JSON] (DefaultConfig 'ApplicationLevel)
+
 type PingEndpoint = "ping" :> GetNoContent
 type ProjectNameEndpoint =
  "project_name" :> Get '[JSON] ProjectName

 type DeploymentAPI' c =
-  "api" :> "v1" :>
-    ( "deployments" :>
-      (    ListEndpoint
-      -- endpoint to get deployment list
-      :<|> CreateEndpoint
-      -- endpoint to create a new deployment
-      :<|> ArchiveEndpoint c
-      -- endpoint to archive existing deployment
-      :<|> UpdateEndpoint c
-      -- endpoint to update exists deployment
-      :<|> InfoEndpoint c
-      -- endpoint to get deployment info
-      :<|> FullInfoEndpoint c
-      -- endpoint to get deployment full info
-      :<|> StatusEndpoint c
-      -- endpoint to get deployment status
-      :<|> RestoreEndpoint c
-      -- endpoint to restore deployment
-      )
-    :<|> PingEndpoint
-    -- endpoint to liveness probe
-    :<|> ProjectNameEndpoint
-    -- endpoint to get project name
-    )
+  "api" :> "v1"
+    :> ( DefaultDeploymentOverrideKeys
+          :<|> DefaultDeploymentOverrides
+          :<|> DefaultApplicationOverrideKeys
+          :<|> DefaultApplicationOverrides
+          :<|> ( "deployments"
+                  :> ( ListEndpoint
+                        -- endpoint to get deployment list
+                        :<|> CreateEndpoint
+                        -- endpoint to create a new deployment
+                        :<|> ArchiveEndpoint c
+                        -- endpoint to archive existing deployment
+                        :<|> UpdateEndpoint c
+                        -- endpoint to update exists deployment
+                        :<|> InfoEndpoint c
+                        -- endpoint to get deployment info
+                        :<|> FullInfoEndpoint c
+                        -- endpoint to get deployment full info
+                        :<|> StatusEndpoint c
+                        -- endpoint to get deployment status
+                        :<|> RestoreEndpoint c
+                        -- endpoint to restore deployment
+                     )
+                  :<|> PingEndpoint
+                  -- endpoint to liveness probe
+                  :<|> ProjectNameEndpoint
+                  -- endpoint to get project name
+               )
+       )

 -- | API for frontend
 type API = DeploymentAPI' CaptureName
--- a/octopod-backend/octopod-backend.cabal
+++ b/octopod-backend/octopod-backend.cabal
@ -109,6 +109,7 @@ library
    , hasql
    , hasql-transaction
    , ordered-containers
+    , vector
  default-language: Haskell2010

 executable octopod-exe
--- a/octopod-backend/src/Octopod/Server.hs
+++ b/octopod-backend/src/Octopod/Server.hs
@ -24,6 +24,7 @@ import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Lazy.Char8 as BSLC
 import Data.Coerce
 import Data.Conduit (ConduitT, yield)
+import qualified Data.Csv as C
 import Data.Foldable
 import Data.Functor
 import Data.Generics.Labels ()
@ -38,6 +39,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Time
 import Data.Traversable
+import qualified Data.Vector as V
 import Hasql.Connection
 import qualified Hasql.Session as HasQL
 import Hasql.Statement
@ -108,6 +110,10 @@ data AppState = AppState
    tagCheckingCommand :: Command
  , infoCommand :: Command
  , notificationCommand :: Maybe Command
+  , deploymentOverridesCommand :: Command
+  , deploymentOverrideKeysCommand :: Command
+  , applicationOverridesCommand :: Command
+  , applicationOverrideKeysCommand :: Command
  , -- | Deployments currently being processed which has not yet been
    -- recorded in the database.
    lockedDeployments :: LockedDeployments
@ -153,14 +159,18 @@ runOctopodServer = do
  ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"
  archRetention <- ArchiveRetention . fromIntegral . read @Int <$> getEnvOrDie "ARCHIVE_RETENTION"
  stUpdateTimeout <- Timeout . CalendarDiffTime 0 . fromIntegral . read @Int <$> getEnvOrDie "STATUS_UPDATE_TIMEOUT"
-  creationCmd <- coerce . pack <$> getEnvOrDie "CREATION_COMMAND"
-  updateCmd <- coerce . pack <$> getEnvOrDie "UPDATE_COMMAND"
-  archiveCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_COMMAND"
-  checkingCmd <- coerce . pack <$> getEnvOrDie "CHECKING_COMMAND"
-  cleanupCmd <- coerce . pack <$> getEnvOrDie "CLEANUP_COMMAND"
-  archiveCheckingCmd <- coerce . pack <$> getEnvOrDie "ARCHIVE_CHECKING_COMMAND"
-  tagCheckingCmd <- coerce . pack <$> getEnvOrDie "TAG_CHECKING_COMMAND"
-  infoCmd <- coerce . pack <$> getEnvOrDie "INFO_COMMAND"
+  creationCmd <- Command . pack <$> getEnvOrDie "CREATION_COMMAND"
+  updateCmd <- Command . pack <$> getEnvOrDie "UPDATE_COMMAND"
+  archiveCmd <- Command . pack <$> getEnvOrDie "ARCHIVE_COMMAND"
+  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"
+  infoCmd <- Command . pack <$> getEnvOrDie "INFO_COMMAND"
+  dOverridesCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_OVERRIDES_COMMAND"
+  dKeysCmd <- Command . pack <$> getEnvOrDie "DEPLOYMENT_KEYS_COMMAND"
+  aOverridesCmd <- Command . pack <$> getEnvOrDie "APPLICATION_OVERRIDES_COMMAND"
+  aKeysCmd <- Command . pack <$> getEnvOrDie "APPLICATION_KEYS_COMMAND"
  powerAuthorizationHeader <- AuthHeader . BSC.pack <$> getEnvOrDie "POWER_AUTHORIZATION_HEADER"
  notificationCmd <-
    (fmap . fmap) (Command . pack) $
@ -198,6 +208,10 @@ runOctopodServer = do
          tagCheckingCmd
          infoCmd
          notificationCmd
+          dOverridesCmd
+          dKeysCmd
+          aOverridesCmd
+          aKeysCmd
          lockedDs
      app' = app appSt
      wsApp' = wsApp channel
@ -253,15 +267,48 @@ app s = serve api $ hoistServer api (nt s) server
 -- | Request handlers of the Web UI API application.
 server :: ServerT API AppM
 server =
-  ( listH :<|> createH :<|> archiveH :<|> updateH
-      :<|> infoH
-      :<|> fullInfoH
-      :<|> statusH
-      :<|> restoreH
-  )
+  defaultDeploymentKeysH
+    :<|> defaultDeploymentOverridesH
+    :<|> defaultApplicationKeysH
+    :<|> defaultApplicationOverridesH
+    :<|> ( listH :<|> createH :<|> archiveH :<|> updateH
+            :<|> infoH
+            :<|> fullInfoH
+            :<|> statusH
+            :<|> restoreH
+         )
    :<|> pingH
    :<|> projectNameH

+decodeCSVDefaultConfig :: BSL.ByteString -> Either String (DefaultConfig l)
+decodeCSVDefaultConfig bs = do
+  x <- C.decode C.NoHeader bs
+  pure $ DefaultConfig . OM.fromList . V.toList $ x
+
+either500S :: MonadError ServerError m => Either String x -> m x
+either500S (Right x) = pure x
+either500S (Left err) = throwError err500 {errBody = BSLC.pack err}
+
+defaultDeploymentKeysH :: AppM [Text]
+defaultDeploymentKeysH = do
+  (_, Stdout out, _) <- deploymentOverrideKeys >>= runCommandArgs deploymentOverrideKeysCommand
+  pure $ T.lines out
+
+defaultDeploymentOverridesH :: AppM (DefaultConfig 'DeploymentLevel)
+defaultDeploymentOverridesH = do
+  (_, Stdout out, _) <- defaultDeploymentOverridesArgs >>= runCommandArgs deploymentOverridesCommand
+  either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
+
+defaultApplicationKeysH :: Config 'DeploymentLevel -> AppM [Text]
+defaultApplicationKeysH cfg = do
+  (_, Stdout out, _) <- applicationOverrideKeys cfg >>= runCommandArgs applicationOverrideKeysCommand
+  pure $ T.lines out
+
+defaultApplicationOverridesH :: Config 'DeploymentLevel -> AppM (DefaultConfig 'ApplicationLevel)
+defaultApplicationOverridesH cfg = do
+  (_, Stdout out, _) <- defaultApplicationOverridesArgs cfg >>= runCommandArgs applicationOverridesCommand
+  either500S $ decodeCSVDefaultConfig . BSL.fromStrict . T.encodeUtf8 $ out
+
 -- | Application with the octo CLI API.
 powerApp :: AuthHeader -> AppState -> IO Application
 powerApp h s = do
--- a/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs
+++ b/octopod-backend/src/Octopod/Server/ControlScriptUtils.hs
@ -14,6 +14,12 @@ module Octopod.Server.ControlScriptUtils
    archiveCheckArgs,
    tagCheckCommandArgs,

+    -- * overrides
+    defaultDeploymentOverridesArgs,
+    deploymentOverrideKeys,
+    defaultApplicationOverridesArgs,
+    applicationOverrideKeys,
+
    -- * Helpers
    fullConfigArgs,
    overridesArgs,
@ -35,8 +41,7 @@ import System.Log.FastLogger
 import System.Process.Typed
 import Types

-- | Creates command arguments for the 'info' deployment control script.
-infoCommandArgs ::
+type GenericDeploymentCommandArgs m r =
  ( MonadReader r m
  , HasType Namespace r
  , HasType ProjectName r
@ -45,7 +50,9 @@ infoCommandArgs ::
  FullDefaultConfig ->
  Deployment ->
  m ControlScriptArgs
-infoCommandArgs dCfg dep = do
+
+genericDeploymentCommandArgs :: GenericDeploymentCommandArgs m r
+genericDeploymentCommandArgs dCfg dep = do
  (Namespace namespace) <- asks getTyped
  (ProjectName projectName) <- asks getTyped
  (Domain domain) <- asks getTyped
@ -64,6 +71,56 @@ infoCommandArgs dCfg dep = do
      ]
      <> fullConfigArgs dCfg dep

+type GenericDeploymentCommandArgsNoConfig m r =
+  ( MonadReader r m
+  , HasType Namespace r
+  , HasType ProjectName r
+  , HasType Domain r
+  ) =>
+  m ControlScriptArgs
+
+genericDeploymentCommandArgsNoConfig :: GenericDeploymentCommandArgsNoConfig m r
+genericDeploymentCommandArgsNoConfig = do
+  (Namespace namespace) <- asks getTyped
+  (ProjectName projectName) <- asks getTyped
+  (Domain domain) <- asks getTyped
+  return $
+    ControlScriptArgs
+      [ "--project-name"
+      , T.unpack . coerce $ projectName
+      , "--base-domain"
+      , T.unpack . coerce $ domain
+      , "--namespace"
+      , T.unpack . coerce $ namespace
+      ]
+
+infoCommandArgs :: GenericDeploymentCommandArgs m r
+infoCommandArgs = genericDeploymentCommandArgs
+
+checkCommandArgs :: GenericDeploymentCommandArgs m r
+checkCommandArgs = genericDeploymentCommandArgs
+
+tagCheckCommandArgs :: GenericDeploymentCommandArgs m r
+tagCheckCommandArgs = genericDeploymentCommandArgs
+
+defaultDeploymentOverridesArgs :: GenericDeploymentCommandArgsNoConfig m r
+defaultDeploymentOverridesArgs = genericDeploymentCommandArgsNoConfig
+
+deploymentOverrideKeys :: GenericDeploymentCommandArgsNoConfig m r
+deploymentOverrideKeys = genericDeploymentCommandArgsNoConfig
+
+defaultApplicationOverridesArgs ::
+  Config 'DeploymentLevel ->
+  GenericDeploymentCommandArgsNoConfig m r
+defaultApplicationOverridesArgs cfg =
+  (overridesArgs cfg <>) <$> genericDeploymentCommandArgsNoConfig
+
+applicationOverrideKeys ::
+  Config 'DeploymentLevel ->
+  GenericDeploymentCommandArgsNoConfig m r
+applicationOverrideKeys cfg =
+  (overridesArgs cfg <>) <$> genericDeploymentCommandArgsNoConfig
+
 notificationCommandArgs ::
  ( MonadReader r m
  , HasType Namespace r
@ -99,62 +156,6 @@ notificationCommandArgs dName dTag old new = do
      , T.unpack $ deploymentStatusToText new
      ]

-checkCommandArgs ::
-  ( MonadReader r m
-  , HasType Namespace r
-  , HasType ProjectName r
-  , HasType Domain r
-  ) =>
-  FullDefaultConfig ->
-  Deployment ->
-  m ControlScriptArgs
-checkCommandArgs dCfg dep = do
-  (Namespace namespace) <- asks getTyped
-  (ProjectName projectName) <- asks getTyped
-  (Domain domain) <- asks getTyped
-  return $
-    ControlScriptArgs
-      [ "--project-name"
-      , T.unpack . coerce $ projectName
-      , "--base-domain"
-      , T.unpack . coerce $ domain
-      , "--namespace"
-      , T.unpack . coerce $ namespace
-      , "--name"
-      , T.unpack . coerce $ dep ^. #name
-      , "--tag"
-      , T.unpack . coerce $ tag dep
-      ]
-      <> fullConfigArgs dCfg dep
-
-tagCheckCommandArgs ::
-  ( MonadReader r m
-  , HasType Namespace r
-  , HasType ProjectName r
-  , HasType Domain r
-  ) =>
-  FullDefaultConfig ->
-  Deployment ->
-  m ControlScriptArgs
-tagCheckCommandArgs dCfg dep = do
-  (Namespace namespace) <- asks getTyped
-  (ProjectName projectName) <- asks getTyped
-  (Domain domain) <- asks getTyped
-  return $
-    ControlScriptArgs
-      [ "--project-name"
-      , T.unpack . coerce $ projectName
-      , "--base-domain"
-      , T.unpack . coerce $ domain
-      , "--namespace"
-      , T.unpack . coerce $ namespace
-      , "--name"
-      , T.unpack . coerce $ dep ^. #name
-      , "--tag"
-      , T.unpack . coerce $ tag dep
-      ]
-      <> fullConfigArgs dCfg dep
-
 archiveCheckArgs ::
  ( MonadReader r m
  , HasType Namespace r
--- a/octopod-common/src/Common/Types.hs
+++ b/octopod-common/src/Common/Types.hs
@ -42,6 +42,9 @@ data OverrideValue = ValueAdded Text | ValueDeleted
 newtype DefaultConfig (l :: OverrideLevel) = DefaultConfig (OMap Text Text)
  deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)

+lookupDefaultConfig :: DefaultConfig l -> Text -> Maybe Text
+lookupDefaultConfig (DefaultConfig m) k = OM.lookup k m
+
 newtype Config (l :: OverrideLevel) = Config {unConfig :: OMap Text Text}
  deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)

@ -79,6 +82,27 @@ applyOverrides (Overrides oo) (DefaultConfig dd) =
 newtype Overrides (l :: OverrideLevel) = Overrides {unOverrides :: OMap Text OverrideValue}
  deriving newtype (Eq, Ord, Show, ToJSON, FromJSON)

+extractOverrides :: DefaultConfig l -> Config l -> Overrides l
+extractOverrides (DefaultConfig dCfg) (Config cfg) =
+  Overrides . OM.fromList $ removed <> present
+  where
+    present :: [(Text, OverrideValue)]
+    present = mapMaybe processPresent . OM.assocs $ cfg
+
+    processPresent :: (Text, Text) -> Maybe (Text, OverrideValue)
+    processPresent (k, v) = case OM.lookup k dCfg of
+      Just v' | v == v' -> Nothing
+      _ -> Just (k, ValueAdded v)
+
+    processRemoved :: (Text, Text) -> Maybe (Text, OverrideValue)
+    processRemoved (k, _) =
+      if OM.member k cfg
+        then Nothing
+        else Just (k, ValueDeleted)
+
+    removed :: [(Text, OverrideValue)]
+    removed = mapMaybe processRemoved . OM.assocs $ dCfg
+
 ov :: Text -> OverrideValue -> Overrides l
 ov k v = Overrides $ OM.singleton (k, v)

--- a/octopod-frontend/octopod-frontend.cabal
+++ b/octopod-frontend/octopod-frontend.cabal
@ -39,6 +39,8 @@ executable frontend
                     , Page.Elements.Links
                     , Reflex.MultiEventWriter.Class
                     , Data.Text.Search
+                     , Data.UniqMap
+                     , Data.WorkingOverrides
  ghc-options:
    -Weverything
    -Wno-implicit-prelude
@ -84,6 +86,7 @@ executable frontend
                     , AllowAmbiguousTypes
                     , OverloadedLabels
                     , ViewPatterns
+                     , ApplicativeDo
  build-depends:       aeson
                     , base
                     , bytestring
@ -106,5 +109,7 @@ executable frontend
                     , semialign
                     , these
                     , ordered-containers
+                     , witherable
+                     , reflex
  hs-source-dirs:      src
  default-language:    Haskell2010
--- a/octopod-frontend/src/Data/UniqMap.hs
+++ b/octopod-frontend/src/Data/UniqMap.hs
@ -0,0 +1,55 @@
+module Data.UniqMap
+  ( UniqKeyMap,
+    uniqMap,
+    insertUniqEnd,
+    insertUniqStart,
+    deleteUniq,
+    updateUniq,
+    elemsUniq,
+    emptyUniqKeyMap,
+    uniqMapFromList,
+    lookupUniq,
+  )
+where
+
+import qualified Data.List as L
+import Data.Map.Strict as M
+
+data UniqKeyMap v = UniqKeyMap !(Map Int v) !Int !Int
+  deriving stock (Show)
+
+lookupUniq :: Int -> UniqKeyMap v -> Maybe v
+lookupUniq k (UniqKeyMap m _ _) = M.lookup k m
+{-# INLINE lookupUniq #-}
+
+uniqMap :: UniqKeyMap v -> Map Int v
+uniqMap (UniqKeyMap m _ _) = m
+{-# INLINE uniqMap #-}
+
+insertUniqEnd :: v -> UniqKeyMap v -> (UniqKeyMap v, Int)
+insertUniqEnd v (UniqKeyMap m s e) = (UniqKeyMap (insert e v m) s (e + 1), e)
+{-# INLINE insertUniqEnd #-}
+
+insertUniqStart :: v -> UniqKeyMap v -> (UniqKeyMap v, Int)
+insertUniqStart v (UniqKeyMap m s e) = (UniqKeyMap (insert s v m) (s - 1) e, s)
+{-# INLINE insertUniqStart #-}
+
+deleteUniq :: Int -> UniqKeyMap v -> UniqKeyMap v
+deleteUniq k (UniqKeyMap m s e) = UniqKeyMap (delete k m) s e
+{-# INLINE deleteUniq #-}
+
+updateUniq :: Int -> (v -> v) -> UniqKeyMap v -> UniqKeyMap v
+updateUniq k f (UniqKeyMap m s e) = UniqKeyMap (adjust f k m) s e
+{-# INLINE updateUniq #-}
+
+elemsUniq :: UniqKeyMap v -> [v]
+elemsUniq (UniqKeyMap m _ _) = elems m
+{-# INLINE elemsUniq #-}
+
+emptyUniqKeyMap :: UniqKeyMap v
+emptyUniqKeyMap = UniqKeyMap mempty 0 1
+{-# INLINE emptyUniqKeyMap #-}
+
+uniqMapFromList :: [v] -> UniqKeyMap v
+uniqMapFromList = L.foldl' (\m v -> fst $ insertUniqEnd v m) emptyUniqKeyMap
+{-# INLINE uniqMapFromList #-}
--- a/octopod-frontend/src/Data/WorkingOverrides.hs
+++ b/octopod-frontend/src/Data/WorkingOverrides.hs
@ -0,0 +1,90 @@
+module Data.WorkingOverrides
+  ( WorkingOverrides,
+    WorkingOverride,
+    WorkingOverrideKey (..),
+    WorkingOverrideKeyType (..),
+    WorkingOverrideValue (..),
+    destructWorkingOverrides,
+    constructWorkingOverrides,
+    newWorkingOverride,
+  )
+where
+
+import Common.Types
+import qualified Data.List as L
+import qualified Data.Map.Ordered.Strict as OM
+import Data.Maybe
+import Data.Text (Text)
+import Data.UniqMap
+
+type WorkingOverrides = UniqKeyMap WorkingOverride
+
+type WorkingOverride = (WorkingOverrideKey, WorkingOverrideValue)
+
+data WorkingOverrideKey = WorkingOverrideKey !WorkingOverrideKeyType !Text
+  deriving stock (Show)
+
+data WorkingOverrideKeyType = CustomWorkingOverrideKey | DefaultWorkingOverrideKey
+  deriving stock (Show, Eq)
+
+data WorkingOverrideValue
+  = WorkingCustomValue !Text
+  | WorkingDefaultValue !Text
+  | WorkingDeletedValue !(Maybe Text)
+  deriving stock (Show)
+
+destructWorkingOverrides :: WorkingOverrides -> Overrides l
+destructWorkingOverrides =
+  Overrides
+    . OM.fromList
+    . mapMaybe
+      ( \case
+          (WorkingOverrideKey CustomWorkingOverrideKey k, getWorkingOverrideValue -> v) -> Just (k, v)
+          (WorkingOverrideKey _ k, WorkingCustomValue v) -> Just (k, ValueAdded v)
+          (WorkingOverrideKey _ k, WorkingDeletedValue _) -> Just (k, ValueDeleted)
+          (WorkingOverrideKey DefaultWorkingOverrideKey _, WorkingDefaultValue _) -> Nothing
+      )
+    . elemsUniq
+  where
+    getWorkingOverrideValue :: WorkingOverrideValue -> OverrideValue
+    getWorkingOverrideValue (WorkingCustomValue x) = ValueAdded x
+    getWorkingOverrideValue (WorkingDefaultValue x) = ValueAdded x
+    getWorkingOverrideValue (WorkingDeletedValue _) = ValueDeleted
+
+constructWorkingOverrides :: Maybe (DefaultConfig l) -> Overrides l -> WorkingOverrides
+constructWorkingOverrides (Just (DefaultConfig dCfg)) (Overrides ovsM) =
+  let custom =
+        uniqMapFromList
+          . mapMaybe
+            ( \(k, v) ->
+                let k' = WorkingOverrideKey (if OM.member k dCfg then DefaultWorkingOverrideKey else CustomWorkingOverrideKey) k
+                 in case v of
+                      ValueAdded x -> Just (k', WorkingCustomValue x)
+                      ValueDeleted -> (k',) . WorkingDeletedValue . Just <$> OM.lookup k dCfg
+            )
+          . OM.assocs
+          $ ovsM
+   in L.foldl'
+        ( \m (k, v) ->
+            if OM.member k ovsM
+              then m
+              else
+                fst $
+                  insertUniqEnd (WorkingOverrideKey DefaultWorkingOverrideKey k, WorkingDefaultValue v) m
+        )
+        custom
+        (OM.assocs dCfg)
+constructWorkingOverrides Nothing (Overrides ovsM) =
+  uniqMapFromList
+    . fmap
+      ( \(k, v) ->
+          let k' = WorkingOverrideKey CustomWorkingOverrideKey k
+           in case v of
+                ValueAdded x -> (k', WorkingCustomValue x)
+                ValueDeleted -> (k', WorkingDeletedValue Nothing)
+      )
+    . OM.assocs
+    $ ovsM
+
+newWorkingOverride :: WorkingOverride
+newWorkingOverride = (WorkingOverrideKey CustomWorkingOverrideKey "", WorkingCustomValue "")
--- a/octopod-frontend/src/Frontend/API.hs
+++ b/octopod-frontend/src/Frontend/API.hs
@ -8,7 +8,11 @@
 --are generated from the servant API) and functions that work with request
 --results.
 module Frontend.API
-  ( apiClients,
+  ( deploymentOverrideKeys,
+    defaultDeploymentOverrides,
+    applicationOverrideKeys,
+    defaultApplicationOverrides,
+    apiClients,
    listEndpoint,
    createEndpoint,
    archiveEndpoint,
@ -65,6 +69,24 @@ apiClients =
          & xhrRequest_url %~ (T.append url)
    host = SR.BasePath "/"

+deploymentOverrideKeys ::
+  MonadWidget t m =>
+  Event t () ->
+  m (Event t (ReqResult () [Text]))
+defaultDeploymentOverrides ::
+  MonadWidget t m =>
+  Event t () ->
+  m (Event t (ReqResult () (DefaultConfig 'DeploymentLevel)))
+applicationOverrideKeys ::
+  MonadWidget t m =>
+  Dynamic t (Either Text (Config 'DeploymentLevel)) ->
+  Event t () ->
+  m (Event t (ReqResult () [Text]))
+defaultApplicationOverrides ::
+  MonadWidget t m =>
+  Dynamic t (Either Text (Config 'DeploymentLevel)) ->
+  Event t () ->
+  m (Event t (ReqResult () (DefaultConfig 'ApplicationLevel)))
 listEndpoint ::
  MonadWidget t m =>
  Event t () ->
@ -113,15 +135,19 @@ projectName ::
  MonadWidget t m =>
  Event t () ->
  m (Event t (ReqResult () ProjectName))
-( listEndpoint
-    :<|> createEndpoint
-    :<|> archiveEndpoint
-    :<|> updateEndpoint
-    :<|> infoEndpoint
-    :<|> fullInfoEndpoint
-    :<|> statusEndpoint
-    :<|> restoreEndpoint
-  )
+deploymentOverrideKeys
+  :<|> defaultDeploymentOverrides
+  :<|> applicationOverrideKeys
+  :<|> defaultApplicationOverrides
+  :<|> ( listEndpoint
+          :<|> createEndpoint
+          :<|> archiveEndpoint
+          :<|> updateEndpoint
+          :<|> infoEndpoint
+          :<|> fullInfoEndpoint
+          :<|> statusEndpoint
+          :<|> restoreEndpoint
+        )
  :<|> pingEndpoint
  :<|> projectName = apiClients

--- a/octopod-frontend/src/Frontend/Utils.hs
+++ b/octopod-frontend/src/Frontend/Utils.hs
@ -1,29 +1,60 @@
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-
 -- |
 --Module      : Frontend.Utils
 --Description : Client utils and helpers.
 --
 --This module contains common types, functions and operators that are used by
 --frontend modules.
-module Frontend.Utils where
+module Frontend.Utils
+  ( sidebar,
+    buttonClass,
+    buttonClassEnabled,
+    wrapRequestErrors,
+    octopodTextInput,
+    deploymentPopupBody,
+    ClickedElement (..),
+    pageNotification,
+    aButtonClassEnabled,
+    buttonClassEnabled',
+    kubeDashboardUrl,
+    loadingCommonWidget,
+    errorCommonWidget,
+    aButtonDynClass',
+    formatPosixToDate,
+    overridesWidget,
+    aButtonClass',
+    statusWidget,
+    elementClick,
+    showT,
+    DeploymentPageNotification (..),
+    formatPosixToDateTime,
+    dropdownWidget,
+    dropdownWidget',
+    buttonDynClass,
+  )
+where

 import Common.Types as CT
 import Control.Lens
 import Control.Monad
 import Control.Monad.Reader
+import Data.Align
+import qualified Data.Foldable as F
 import Data.Functor
 import Data.Generics.Labels ()
-import qualified Data.List as L
+import Data.Generics.Sum
 import Data.Map (Map)
 import qualified Data.Map as M
 import qualified Data.Map.Ordered.Strict as OM
 import Data.Maybe (fromMaybe)
 import Data.Monoid
-import Data.Proxy (Proxy (..))
-import Data.Text as T (Text, null, pack)
+import Data.Text as T (Text, intercalate, null, pack)
+import Data.These
 import Data.Time
-import Data.Time.Clock.POSIX
+import Data.UniqMap
+import Data.Unique
+import Data.Witherable
+import Data.WorkingOverrides
+import Frontend.API
 import Frontend.GHCJS
 import GHCJS.DOM
 import GHCJS.DOM.Element as DOM
@ -31,6 +62,9 @@ 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.Network
+import Servant.Common.Req
+import Servant.Reflex.Extra

 -- | Wrapper for @Maybe DOM.Element@. It's used by 'elementClick'.
 newtype ClickedElement = ClickedElement {unClickedElement :: Maybe DOM.Element}
@ -206,22 +240,6 @@ buttonClassEnabled' cl lbl dDyn disClass = do
      text lbl
  return $ domEvent Click bEl

-- | Version of 'buttonClass' for links that should look like buttons.
-aButtonClass ::
-  (DomBuilder t m, PostBuild t m) =>
-  -- | Classes.
-  Text ->
-  -- | Label text.
-  Text ->
-  m (Event t ())
-aButtonClass cl lbl = do
-  (bEl, _) <-
-    elDynAttr'
-      "a"
-      (constDyn $ "class" =: cl)
-      $ text lbl
-  return $ domEvent Click bEl
-
 -- | Version of 'buttonClass' for links that should look like buttons.
 aButtonClass' ::
  (DomBuilder t m, PostBuild t m) =>
@ -240,22 +258,6 @@ aButtonClass' cl lbl eAttrs = do
      $ text lbl
  return $ domEvent Click bEl

-- | Version of 'buttonDynClass' for links that should look like
-- buttons.
-aButtonDynClass ::
-  (DomBuilder t m, PostBuild t m) =>
-  -- | Classes.
-  Dynamic t Text ->
-  -- | Label text.
-  Dynamic t Text ->
-  m (Event t ())
-aButtonDynClass clDyn lblDyn = do
-  let attrDyn = ffor clDyn $ \cl -> "class" =: cl
-  (bEl, _) <-
-    elDynAttr' "a" attrDyn $
-      dynText lblDyn
-  return $ domEvent Click bEl
-
 -- | Version of 'buttonDynClass' for links that should look like
 -- buttons.
 aButtonDynClass' ::
@ -297,86 +299,6 @@ aButtonClassEnabled cl lbl dDyn = do
      text lbl
  return $ domEvent Click bEl

-- | Converter from posix seconds to `UTCTime`.
-intToUTCTime :: Int -> UTCTime
-intToUTCTime = posixSecondsToUTCTime . realToFrac
-
-- | Taken from <https://gist.github.com/3noch/134b1ee7fa48c347be9d164c3fac4ef7>
--
-- Like 'elDynAttr'' but configures "prevent default" on the given event.
-elDynAttrWithPreventDefaultEvent' ::
-  forall a en m t.
-  (DomBuilder t m, PostBuild t m) =>
-  -- | Event on the element to configure with 'preventDefault'
-  EventName en ->
-  -- | Element tag
-  Text ->
-  -- | Element attributes
-  Dynamic t (Map Text Text) ->
-  -- | Child of element
-  m a ->
-  -- | An element and the result of the child
-  m (R.Element EventResult (DomBuilderSpace m) t, a)
-elDynAttrWithPreventDefaultEvent' ev =
-  elDynAttrWithModifyConfig'
-    ( \elCfg ->
-        elCfg & elementConfig_eventSpec
-          %~ addEventSpecFlags
-            (Proxy :: Proxy (DomBuilderSpace m))
-            ev
-            (const preventDefault)
-    )
-
-- | Taken from <https://gist.github.com/3noch/134b1ee7fa48c347be9d164c3fac4ef7>
--
-- Like 'elDynAttr'' but configures "stop propagation" on the given event.
-elDynAttrWithStopPropagationEvent' ::
-  forall a en m t.
-  (DomBuilder t m, PostBuild t m) =>
-  -- | Event on the element to configure with 'preventDefault'
-  EventName en ->
-  -- | Element tag
-  Text ->
-  -- | Element attributes
-  Dynamic t (Map Text Text) ->
-  -- | Child of element
-  m a ->
-  -- | An element and the result of the child
-  m (R.Element EventResult (DomBuilderSpace m) t, a)
-elDynAttrWithStopPropagationEvent' ev =
-  elDynAttrWithModifyConfig'
-    ( \elCfg ->
-        elCfg & elementConfig_eventSpec
-          %~ addEventSpecFlags
-            (Proxy :: Proxy (DomBuilderSpace m))
-            ev
-            (const stopPropagation)
-    )
-
-- | Taken from <https://gist.github.com/3noch/134b1ee7fa48c347be9d164c3fac4ef7>
--
-- Like 'elDynAttr'' but allows you to modify the element configuration.
--
-- Special thanks to @luigy:
-- <https://gist.github.com/luigy/b49ce04de8462e594c9c2b5b455ae5a5#file-foo-hs>
-elDynAttrWithModifyConfig' ::
-  (DomBuilder t m, PostBuild t m) =>
-  ( ElementConfig EventResult t (DomBuilderSpace m) ->
-    ElementConfig EventResult t (DomBuilderSpace m)
-  ) ->
-  Text ->
-  Dynamic t (Map Text Text) ->
-  m a ->
-  m (R.Element EventResult (DomBuilderSpace m) t, a)
-elDynAttrWithModifyConfig' f elementTag attrs child = do
-  modifyAttrs <- dynamicAttributesToModifyAttributes attrs
-  let cfg =
-        def & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs
-  result <- R.element elementTag (f cfg) child
-  postBuild <- getPostBuild
-  notReadyUntil postBuild
-  pure result
-
 -- | Formats posix seconds to date in iso8601.
 formatPosixToDate :: FormatTime t => t -> Text
 formatPosixToDate = pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
@ -419,22 +341,33 @@ octopodTextInput clss lbl placeholder val errEv =
  elClass "section" "deployment__section" $ do
    elClass "h3" "deployment__sub-heading" $ text lbl
    elClass "div" "deployment__widget" $
-      octopodTextInput' clss placeholder val errEv
+      octopodTextInput' (pure False) clss placeholder (pure . fromMaybe "" $ val) errEv

 -- | The only text input field that is used in project forms. This input
 -- provides automatic error message hiding after user starts typing.
 octopodTextInput' ::
  MonadWidget t m =>
+  -- | Disabled?
+  Dynamic t Bool ->
  -- | Input field classes.
  Text ->
  -- | Placeholder for input field.
  Text ->
  -- | Possible init value.
-  Maybe Text ->
+  (Dynamic t Text) ->
  -- | Event carrying the error message.
  Event t Text ->
  m (Dynamic t Text, Dynamic t Bool)
-octopodTextInput' clss placeholder val errEv = mdo
+octopodTextInput' disabledDyn clss placeholder inValDyn' errEv = mdo
+  inValDyn <- holdUniqDyn inValDyn'
+  let inValEv =
+        align (updated inValDyn) (updated valDyn)
+          & fmapMaybe
+            ( \case
+                This x -> Just x
+                These inV currV | inV /= currV -> Just inV
+                _ -> Nothing
+            )
  let inpClass = " input"
      inpErrClass = " input input--error"
  isValid <-
@ -449,6 +382,8 @@ octopodTextInput' clss placeholder val errEv = mdo
        [ (clss <> inpErrClass) <$ errEv
        , (clss <> inpClass) <$ updated valDyn
        ]
+  inVal <- sample . current $ inValDyn
+  disabled <- sample . current $ disabledDyn
  valDyn <- elDynClass "div" classDyn $ do
    inp <-
      inputElement $
@ -458,7 +393,18 @@ octopodTextInput' clss placeholder val errEv = mdo
                  <> "class" =: "input__widget"
                  <> "placeholder" =: placeholder
               )
-          & inputElementConfig_initialValue .~ fromMaybe "" val
+          & inputElementConfig_setValue .~ inValEv
+          & inputElementConfig_initialValue .~ inVal
+          & inputElementConfig_elementConfig . elementConfig_initialAttributes
+            %~ (if disabled then M.insert "disabled" "disabled" else id)
+          & inputElementConfig_elementConfig . elementConfig_modifyAttributes
+            <>~ updated
+              ( do
+                  disabled' <- disabledDyn
+                  pure $
+                    M.singleton "disabled" $
+                      if disabled' then Just "disabled" else Nothing
+              )
    widgetHold_ blank $
      leftmost
        [ divClass "input__output" . text <$> errEv
@ -506,7 +452,7 @@ overridesWidget (Overrides (OM.assocs -> envs)) = divClass "listing listing--for
            "listing__more expander"
        btnTextDyn =
          ifThenElseDyn showDyn "Hide" $
-            "Show all (" <> (showT $ envLength) <> ")"
+            "Show all (" <> showT envLength <> ")"
    toggleEv <- buttonDynClass btnClassDyn btnTextDyn
    blank
  where
@ -574,86 +520,227 @@ kubeDashboardUrl deploymentInfo = do
  let name = unDeploymentName . view (#deployment . #name) <$> deploymentInfo
  return $ name <&> (\n -> (<> n) <$> template)

+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
+  pb <- getPostBuild
+  defDep <- defaultDeploymentOverrides pb >>= hReq >>= holdDynMaybe
+  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 (Maybe (DefaultConfig l)) -> Overrides l -> m (Dynamic t (Overrides l))
+      holdDCfg dCfgDyn ovs = mdo
+        ovsDyn <- holdDyn ovs ovsEv
+        x <- attachDyn (current ovsDyn) dCfgDyn
+        ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput dCfg ovs') >>= switchHold never
+        pure ovsDyn
+      holdDKeys n keysDyn = do
+        let loading = loadingCommonWidget
+        popUpSection n $
+          widgetHold_ loading $
+            keysDyn <&> \case
+              Just keys -> el "ul" $
+                forM_ keys $ \key -> el "li" $ text key
+              Nothing -> loading
+
+  deploymentOvsDyn <- popUpSection "Deployment overrides" $ holdDCfg defDep defDepOv
+  holdDKeys "Deployment keys" (Just <$> depKeys)
+  readyDeploymentCfgDebounced <- debounce 0.5 . catMaybes $
+    updated $ do
+      defDep >>= \case
+        Nothing -> pure Nothing
+        Just depDCfg -> do
+          depOv <- deploymentOvsDyn
+          pure $ Just $ applyOverrides depOv depDCfg
+  defApp <-
+    waitForValuePromptly
+      readyDeploymentCfgDebounced
+      ( \deploymentCfg -> do
+          pb' <- getPostBuild
+          defaultApplicationOverrides (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
+      )
+      >>= holdDyn Nothing
+  appKeys <- waitForValuePromptly readyDeploymentCfgDebounced $ \deploymentCfg -> do
+    pb' <- getPostBuild
+    applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
+  applicationOvsDyn <- popUpSection "App overrides" $ holdDCfg defApp defAppOv
+  holdDKeys "App keys" appKeys
+
+  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]
+
+waitForValuePromptly :: (MonadHold t m, Adjustable t m) => Event t x -> (x -> m (Event t y)) -> m (Event t y)
+waitForValuePromptly ev f = fmap switchPromptlyDyn $ networkHold (pure never) $ f <$> ev
+
+type RequestErrorHandler t m = forall tag a. Event t (ReqResult tag a) -> m (Event t a)
+
+wrapRequestErrors ::
+  MonadWidget t m =>
+  ( forall w.
+    Semigroup w =>
+    RequestErrorHandler t (EventWriterT t w m) ->
+    EventWriterT t w m x
+  ) ->
+  m x
+wrapRequestErrors f = mdo
+  errs <- foldDyn (flip (<>)) mempty ev
+  void $ list (patchMapNewElementsMap <$> errs) errorHeader
+  (x, ev :: Event t (PatchMap Unique Text)) <- runEventWriterT $
+    f $ \reqEv -> do
+      k <- liftIO newUnique
+      tellEvent $ fmapCheap (PatchMap . M.singleton k . reqErrorBody) reqEv
+      pure $ fmapMaybeCheap reqSuccess reqEv
+  pure x
+
+-- | The widget used to display errors.
+errorHeader ::
+  MonadWidget t m =>
+  -- | Message text.
+  Dynamic t Text ->
+  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
 -- removing key-value pairs.
 envVarsInput ::
  forall l t m.
  MonadWidget t m =>
-  -- | Overrides header.
-  Text ->
-  -- | Current deployment overrides.
+  Maybe (DefaultConfig l) ->
+  -- | Initial deployment overrides.
  Overrides l ->
  -- | Updated deployment overrides.
-  m (Dynamic t (Overrides l))
-envVarsInput overridesHeader (Overrides evs) = do
-  elClass "section" "deployment__section" $ do
-    elClass "h3" "deployment__sub-heading" $ text overridesHeader
-    elClass "div" "deployment__widget" $
-      elClass "div" "overrides" $ mdo
-        let initEnvs =
-              L.foldl'
-                ( \m -> \case
-                    (k, ValueAdded v) -> fst $ insertUniq (k, v) m
-                    (_, ValueDeleted) -> m
-                )
-                emptyUniqKeyMap
-                . OM.assocs
-                $ evs
-            toOverrides :: [Override] -> Overrides l
-            toOverrides = Overrides . OM.fromList . (fmap . fmap) ValueAdded
-            emptyVar = ("", "")
-            addEv = clickEv $> Endo (fst . insertUniq emptyVar)
-        envsDyn <- foldDyn appEndo initEnvs $ leftmost [addEv, updEv]
-        (_, updEv) <- runEventWriterT $ listWithKey (uniqMap <$> envsDyn) envVarInput
-        let addingIsEnabled = all ((not . T.null) . fst) . elemsUniq <$> envsDyn
-        clickEv <-
-          buttonClassEnabled'
-            "overrides__add dash dash--add"
-            "Add an override"
-            addingIsEnabled
-            "dash--disabled"
-        pure $ toOverrides . elemsUniq <$> envsDyn
+  m (Event t (Overrides l))
+envVarsInput dCfg ovs = mdo
+  envsDyn <- foldDyn appEndo (constructWorkingOverrides dCfg ovs) $ leftmost [addEv, updEv]
+  let addEv = clickEv $> Endo (fst . insertUniqStart newWorkingOverride)
+  clickEv <-
+    buttonClassEnabled'
+      "overrides__add dash dash--add"
+      "Add an override"
+      addingIsEnabled
+      "dash--disabled"
+  updEv <-
+    switchDyn . fmap F.fold
+      <$> listWithKey
+        (uniqMap <$> envsDyn)
+        (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput x)
+  let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
+  case dCfg of
+    Just _ -> pure ()
+    Nothing -> loadingCommonWidget
+  pure . updated $ destructWorkingOverrides <$> envsDyn
+
+popUpSection :: DomBuilder t m => Text -> m a -> m a
+popUpSection n m = elClass "section" "deployment__section" $ do
+  elClass "h3" "deployment__sub-heading" $ text n
+  elClass "div" "deployment__widget" $
+    elClass "div" "overrides" m

 -- | Widget for entering a key-value pair. The updated overrides list is
 -- written to the 'EventWriter'.
 envVarInput ::
-  (EventWriter t (Endo (UniqKeyMap Override)) m, MonadWidget t m) =>
-  -- | Index of variable in overrides list.
-  Int ->
+  (MonadWidget t m) =>
  -- | Current variable key and value.
-  Dynamic t Override ->
-  m ()
-envVarInput i epDyn = do
-  ep <- sample $ current epDyn
+  Dynamic t WorkingOverride ->
+  m (Event t UserOverrideAction)
+envVarInput val = do
+  let v =
+        val <&> snd <&> \case
+          WorkingCustomValue x -> x
+          WorkingDefaultValue x -> x
+          WorkingDeletedValue (Just x) -> x
+          WorkingDeletedValue Nothing -> "<loading deleted>"
+      k = val <&> \(WorkingOverrideKey _ x, _) -> x
+      disabledKey = val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
+
  divClass "overrides__item" $ do
-    (keyDyn, _) <-
-      octopodTextInput' "overrides__key" "key" (Just $ fst ep) never
-    (valDyn, _) <-
-      octopodTextInput' "overrides__value" "value" (Just $ snd ep) never
+    (keyTextDyn, _) <-
+      octopodTextInput' disabledKey "overrides__key" "key" k never
+    (valTextDyn, _) <-
+      octopodTextInput' (pure False) "overrides__value" "value" v never
    closeEv <- buttonClass "overrides__delete spot spot--cancel" "Delete"
-    let envEv = updated $ zipDynWith (,) keyDyn valDyn
-        deleteEv = Endo (deleteUniq i) <$ closeEv
-        updEv = Endo . updateUniq i . const <$> envEv
-    tellEvent $ leftmost [deleteEv, updEv]
+    pure $
+      leftmost
+        [ UpdateKey <$> updated keyTextDyn
+        , UpdateValue <$> updated valTextDyn
+        , closeEv $> DeleteOverride
+        ]

-data UniqKeyMap v = UniqKeyMap (Map Int v) Int
+data UserOverrideAction = UpdateKey !Text | UpdateValue !Text | DeleteOverride

-uniqMap :: UniqKeyMap v -> Map Int v
-uniqMap (UniqKeyMap m _) = m
+performUserOverrideAction ::
+  Maybe (Text -> Maybe Text) ->
+  Int ->
+  UserOverrideAction ->
+  Endo WorkingOverrides
+performUserOverrideAction f i (UpdateValue v) = Endo $
+  updateUniq i $ \(k@(WorkingOverrideKey _ kt), _) ->
+    ( k
+    , case f >>= ($ kt) of
+        Just v' | v == v' -> WorkingDefaultValue v
+        _ -> WorkingCustomValue v
+    )
+performUserOverrideAction f i (UpdateKey k) = Endo $ updateUniq i $ \(_, v) -> (WorkingOverrideKey t k, v)
+  where
+    t = case f >>= ($ k) of
+      Nothing -> CustomWorkingOverrideKey
+      Just _ -> DefaultWorkingOverrideKey
+performUserOverrideAction f i DeleteOverride = Endo $ \m ->
+  case f of
+    Nothing -> updateUniq i (\(k, _) -> (k, WorkingDeletedValue Nothing)) m
+    Just f' -> case lookupUniq i m of
+      Nothing -> m
+      Just (WorkingOverrideKey _ k, _) -> case f' k of
+        Nothing -> deleteUniq i m
+        Just v -> updateUniq i (const (WorkingOverrideKey DefaultWorkingOverrideKey k, WorkingDeletedValue (Just v))) m

-insertUniq :: v -> UniqKeyMap v -> (UniqKeyMap v, Int)
-insertUniq v (UniqKeyMap m x) = (UniqKeyMap (M.insert x v m) (x + 1), x)
+holdDynMaybe :: (Reflex t, MonadHold t m) => Event t a -> m (Dynamic t (Maybe a))
+holdDynMaybe ev = holdDyn Nothing $ fmapCheap Just ev

-deleteUniq :: Int -> UniqKeyMap v -> UniqKeyMap v
-deleteUniq k (UniqKeyMap m x) = UniqKeyMap (M.delete k m) x
+immediateNothing :: (PostBuild t m) => Event t a -> m (Event t (Maybe a))
+immediateNothing ev = do
+  pb <- getPostBuild
+  pure $ leftmost [pb $> Nothing, fmapCheap Just ev]

-updateUniq :: Int -> (v -> v) -> UniqKeyMap v -> UniqKeyMap v
-updateUniq k f (UniqKeyMap m x) = UniqKeyMap (M.adjust f k m) x
-
-elemsUniq :: UniqKeyMap v -> [v]
-elemsUniq (UniqKeyMap m _) = M.elems m
-
-emptyUniqKeyMap :: UniqKeyMap v
-emptyUniqKeyMap = UniqKeyMap mempty 0
-
-type Override = (Text, Text)
+attachDyn :: (Reflex t, MonadHold t m) => Behavior t a -> Dynamic t b -> m (Dynamic t (a, b))
+attachDyn b d = do
+  currD <- sample . current $ d
+  currB <- sample b
+  holdDyn (currB, currD) (attach b $ updated d)
--- a/octopod-frontend/src/Page/Popup/EditDeployment.hs
+++ b/octopod-frontend/src/Page/Popup/EditDeployment.hs
@ -5,24 +5,22 @@
 --This module contains the definition of the "edit deployment" sidebar.
 module Page.Popup.EditDeployment (editDeploymentPopup) where

-import Control.Lens (coerced, preview, to, (^.), _2)
+import Control.Lens
 import Control.Monad
 import Data.Coerce
 import Data.Functor
-import Data.Generics.Product
 import Data.Generics.Sum
 import Data.Monoid
-import qualified Data.Text as T
 import Reflex.Dom as R hiding (mapMaybe)
 import Prelude as P

 import Common.Types
 import Common.Utils
-import Data.Text (Text)
+import Data.Maybe
 import Frontend.API
 import Frontend.Utils
+import Reflex.Network
 import Servant.Reflex
-import Servant.Reflex.Extra

 -- | The root function for \"edit deployment\" sidebar.
 editDeploymentPopup ::
@ -37,12 +35,15 @@ editDeploymentPopup showEv hideEv = sidebar showEv hideEv $ \dfi -> mdo
  divClass "popup__body" $ mdo
    let dname = dfi ^. dfiName
    (closeEv', saveEv) <- editDeploymentPopupHeader dname enabledDyn
-    (deploymentDyn, validDyn) <- editDeploymentPopupBody dfi respEv
+    deploymentMDyn <- editDeploymentPopupBody dfi respEv
    respEv <-
-      updateEndpoint
-        (constDyn $ Right dname)
-        (Right <$> deploymentDyn)
-        saveEv
+      holdDyn (pure never) >=> networkView >=> switchHold never $
+        tagMaybe (current deploymentMDyn) saveEv <&> \dep -> do
+          pb <- getPostBuild
+          updateEndpoint
+            (constDyn $ Right dname)
+            (pure $ Right dep)
+            pb
    sentDyn <-
      holdDyn False $
        leftmost
@ -52,7 +53,7 @@ editDeploymentPopup showEv hideEv = sidebar showEv hideEv $ \dfi -> mdo
    let successEv =
          fmapMaybe (preview (_Ctor @"Success") <=< commandResponse) respEv
        closeEv = leftmost [closeEv', successEv]
-        enabledDyn = zipDynWith (&&) (not <$> sentDyn) validDyn
+        enabledDyn = zipDynWith (&&) (not <$> sentDyn) (isJust <$> deploymentMDyn)
    pure (updated sentDyn, closeEv)

 -- | The header of the sidebar contains the deployment name and control buttons:
@ -84,45 +85,13 @@ editDeploymentPopupBody ::
  -- | \"Edit request\" failure event.
  Event t (ReqResult tag CommandResponse) ->
  -- | Returns deployment update and validation state.
-  m (Dynamic t DeploymentUpdate, Dynamic t Bool)
-editDeploymentPopupBody dfi errEv = divClass "popup__content" $
-  divClass "deployment" $ mdo
-    let commandResponseEv = fmapMaybe commandResponse errEv
-        appErrEv = R.difference (fmapMaybe reqErrorBody errEv) commandResponseEv
-        dfiTag = dfi ^. field @"deployment" . field @"tag" . coerced . to Just
-        dfiAppVars = dfi ^. field @"deployment" . field @"appOverrides" . coerced
-        dfiDeploymentVars =
-          dfi ^. field @"deployment" . field @"deploymentOverrides" . coerced
-        tagErrEv = getTagError commandResponseEv tagDyn
-    errorHeader appErrEv
-    (tagDyn, tOkEv) <- octopodTextInput "tag" "Tag" "Tag" dfiTag tagErrEv
-    appVarsDyn <- envVarsInput "App overrides" dfiAppVars
-    deploymentVarsDyn <- envVarsInput "Deployment overrides" dfiDeploymentVars
-    validDyn <- holdDyn True $ updated tOkEv
-    pure
-      ( DeploymentUpdate
-          <$> (DeploymentTag <$> tagDyn)
-          <*> appVarsDyn
-          <*> deploymentVarsDyn
-      , validDyn
-      )
-  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]
-
-- | The widget used to display errors.
-errorHeader ::
-  MonadWidget t m =>
-  -- | Message text.
-  Event t Text ->
-  m ()
-errorHeader appErrEv = do
-  widgetHold_ blank $
-    appErrEv <&> \appErr -> do
-      divClass "deployment__output notification notification--danger" $ do
-        el "b" $ text "App error: "
-        text appErr
+  m (Dynamic t (Maybe DeploymentUpdate))
+editDeploymentPopupBody dfi errEv = wrapRequestErrors $ \hReq -> do
+  divClass "popup__content" $
+    divClass "deployment" $
+      deploymentPopupBody
+        hReq
+        (dfi ^. #deployment . #tag . coerced . to Just)
+        (dfi ^. #deployment . #appOverrides)
+        (dfi ^. #deployment . #deploymentOverrides)
+        errEv
--- a/octopod-frontend/src/Page/Popup/NewDeployment.hs
+++ b/octopod-frontend/src/Page/Popup/NewDeployment.hs
@ -5,21 +5,22 @@
 --This module contains the definition of \"new deployment\" sidebar.
 module Page.Popup.NewDeployment (newDeploymentPopup) where

-import Control.Lens (preview, _1, _2)
+import Control.Lens
 import Control.Monad
 import Data.Functor
 import Data.Generics.Sum
 import Data.Monoid
-import Data.Text as T (Text, intercalate)
+import qualified Data.Text as T
 import Reflex.Dom as R
 import Prelude as P

 import Common.Types
 import Common.Validation (isNameValid)
+import Data.Maybe
 import Frontend.API
 import Frontend.Utils
+import Reflex.Network
 import Servant.Reflex
-import Servant.Reflex.Extra

 -- | The root function for \"new deployment\" sidebar.
 newDeploymentPopup ::
@ -34,8 +35,14 @@ newDeploymentPopup showEv hideEv = void $
    const $ mdo
      divClass "popup__body" $ mdo
        (closeEv', saveEv) <- newDeploymentPopupHeader enabledDyn
-        (deploymentDyn, validDyn) <- newDeploymentPopupBody respEv
-        respEv <- createEndpoint (Right <$> deploymentDyn) saveEv
+        deploymentMDyn <- newDeploymentPopupBody respEv
+        respEv <-
+          holdDyn (pure never) >=> networkView >=> switchHold never $
+            tagMaybe (current deploymentMDyn) saveEv <&> \dep -> do
+              pb <- getPostBuild
+              createEndpoint
+                (pure $ Right dep)
+                pb
        sentDyn <-
          holdDyn False $
            leftmost
@ -45,7 +52,7 @@ newDeploymentPopup showEv hideEv = void $
        let successEv =
              fmapMaybe (preview (_Ctor @"Success") <=< commandResponse) respEv
            closeEv = leftmost [closeEv', successEv]
-            enabledDyn = zipDynWith (&&) (not <$> sentDyn) validDyn
+            enabledDyn = zipDynWith (&&) (not <$> sentDyn) (isJust <$> deploymentMDyn)
        pure (never, closeEv)

 -- | The header of sidebar contains control buttons: \"Save\" and \"Close\".
@ -71,27 +78,24 @@ newDeploymentPopupBody ::
  -- | Request failure event.
  Event t (ReqResult tag CommandResponse) ->
  -- | Returns new deployment and validation states.
-  m (Dynamic t Deployment, Dynamic t Bool)
+  m (Dynamic t (Maybe Deployment))
 newDeploymentPopupBody errEv = divClass "popup__content" $
-  divClass "deployment" $ mdo
-    let commandResponseEv = fmapMaybe commandResponse errEv
-        appErrEv = R.difference (fmapMaybe reqErrorBody errEv) commandResponseEv
-        nameErrEv = getNameError commandResponseEv nameDyn
-        tagErrEv = getTagError commandResponseEv tagDyn
-    errorHeader appErrEv
-    (nameDyn, nOkDyn) <- octopodTextInput "tag" "Name" "Name" Nothing nameErrEv
-    (tagDyn, tOkDyn) <- octopodTextInput "tag" "Tag" "Tag" Nothing tagErrEv
-    appVarsDyn <- envVarsInput "App overrides" mempty
-    deploymentVarsDyn <- envVarsInput "Deployment overrides" mempty
-    validDyn <- holdDyn False $ updated $ zipDynWith (&&) nOkDyn tOkDyn
-    pure
-      ( Deployment
-          <$> (DeploymentName <$> nameDyn)
-          <*> (DeploymentTag <$> tagDyn)
-          <*> appVarsDyn
-          <*> deploymentVarsDyn
-      , validDyn
-      )
+  divClass "deployment" $
+    wrapRequestErrors $ \hReq -> mdo
+      let commandResponseEv = fmapMaybe commandResponse errEv
+          nameErrEv = getNameError commandResponseEv nameDyn
+      (nameDyn, validNameDyn) <- octopodTextInput "tag" "Name" "Name" Nothing nameErrEv
+      depDyn <- deploymentPopupBody hReq Nothing 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 $ do
+        validNameDyn >>= \case
+          False -> pure Nothing
+          True -> dep
  where
    getNameError crEv nameDyn =
      let nameErrEv' = fmapMaybe (preview (_Ctor @"ValidationError" . _1)) crEv
@ -102,22 +106,3 @@ newDeploymentPopupBody errEv = divClass "popup__content" $
          badNameEv = badNameText <$ (ffilter not $ updated isNameValidDyn)
          nameErrEv = ffilter (/= "") $ T.intercalate ". " <$> nameErrEv'
       in leftmost [nameErrEv, badNameEv]
-    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]
-
-- | The widget used to display errors.
-errorHeader ::
-  MonadWidget t m =>
-  -- | Message text.
-  Event t Text ->
-  m ()
-errorHeader appErrEv = do
-  widgetHold_ blank $
-    appErrEv <&> \appErr -> do
-      divClass "deployment__output notification notification--danger" $ do
-        el "b" $ text "App error: "
-        text appErr