@@ -40,10 +40,14 @@ import Common.Types as CT
4040import Control.Lens
4141import Control.Monad
4242import Control.Monad.Reader
43+import Control.Monad.State.Strict
4344import qualified Data.Foldable as F
4445import Data.Functor
4546import Data.Generics.Labels ()
47+import Data.List.NonEmpty (NonEmpty)
4648import qualified Data.Map as M
49+import Data.Map.Monoidal.Strict (MonoidalMap)
50+import qualified Data.Map.Monoidal.Strict as MM
4751import Data.Maybe (fromMaybe, isJust, isNothing)
4852import Data.Monoid
4953import Data.Text as T (Text, null, pack)
@@ -62,6 +66,7 @@ import GHCJS.DOM.Element as DOM
6266import GHCJS.DOM.EventM (on, target)
6367import GHCJS.DOM.GlobalEventHandlers as Events (click)
6468import GHCJS.DOM.Node as DOM
69+import Generic.Data (Generically (..))
6570import Reflex.Dom as R
6671import Reflex.Dom.Renderable
6772import Reflex.Network
@@ -234,8 +239,8 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
234239 expanderButton
235240 ExpanderButtonConfig
236241 { buttonText = do
237− state <- expandState
238− pure $ case state of
242+ s <- expandState
243+ pure $ case s of
239244 ExpandedState -> "Hide default configuration"
240245 ContractedState -> "Show full configuration"
241246 , buttonInitialState = ContractedState
@@ -351,31 +356,38 @@ deploymentPopupBody hReq defAppOv defDepOv errEv = mdo
351356 Dynamic t [Text] ->
352357 Dynamic t (Maybe (DefaultConfig l)) ->
353358 Overrides l ->
354− m (Dynamic t (Overrides l))
359+ m (Dynamic t (Overrides l), Dynamic t Bool)
355360 holdDCfg values dCfgDyn ovs = mdo
356361 ovsDyn <- holdDyn ovs ovsEv
357362 x <- attachDyn (current ovsDyn) dCfgDyn
358− ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs') >>= switchHold never >>= debounce 0.5
359− pure ovsDyn
363+ res <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs')
364+ ovsEv <- switchHold never (fst <$> res) >>= debounce 0.5
365+ isValid <- join <$> holdDyn (pure True) (snd <$> res)
366+ pure (ovsDyn, isValid)
360367
361368 depKeysDyn <- holdDyn [] depKeys
362− deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv
369+ (deploymentOvsDyn, depValidDyn) <- deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv
363370
364371 appKeys <- waitForValuePromptly depCfgEv $ \deploymentCfg -> do
365372 pb' <- getPostBuild
366373 applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
367374 appKeysDyn <- holdDyn [] $ catMaybes appKeys
368− applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
375+ (applicationOvsDyn, appValidDyn) <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
369376
370377 pure $ do
371− depCfg <- deploymentOvsDyn
372− appOvs <- applicationOvsDyn
373− pure $
374− Just $
375− DeploymentUpdate
376− { appOverrides = appOvs
377− , deploymentOverrides = depCfg
378− }
378+ depValid <- depValidDyn
379+ appValid <- appValidDyn
380+ if depValid && appValid
381+ then do
382+ depCfg <- deploymentOvsDyn
383+ appOvs <- applicationOvsDyn
384+ pure $
385+ Just $
386+ DeploymentUpdate
387+ { appOverrides = appOvs
388+ , deploymentOverrides = depCfg
389+ }
390+ else pure Nothing
379391deploymentConfigProgressiveComponents ::
380392 MonadWidget t m =>
381393 RequestErrorHandler t m ->
@@ -475,7 +487,7 @@ envVarsInput ::
475487 -- | Initial deployment overrides.
476488 Overrides l ->
477489 -- | Updated deployment overrides.
478− m (Event t (Overrides l))
490+ m (Event t (Overrides l), Dynamic t Bool)
479491envVarsInput values dCfg ovs = mdo
480492 envsDyn <- foldDyn appEndo (constructWorkingOverrides dCfg ovs) $ leftmost [addEv, updEv]
481493 let addEv = clickEv $> Endo (fst . insertUniqStart newWorkingOverride)
@@ -487,16 +499,57 @@ envVarsInput values dCfg ovs = mdo
487499 , buttonType = Just AddDashButtonType
488500 , buttonStyle = OverridesDashButtonStyle
489501 }
502+ let workingOverridesWithErrors = validateWorkingOverrides . uniqMap <$> envsDyn
503+ isValid = all ((== mempty) . snd) <$> workingOverridesWithErrors
490504 updEv <-
491505 switchDyn . fmap F.fold
492506 <$> listWithKey
493− (uniqMap <$> envsDyn)
507+ workingOverridesWithErrors
494508 (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput values x)
495509 let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
496510 case dCfg of
497511 Just _ -> pure ()
498512 Nothing -> loadingOverrides
499− pure . updated $ destructWorkingOverrides <$> envsDyn
513+ pure (updated $ destructWorkingOverrides <$> envsDyn, isValid)
514+
515+validateWorkingOverrides ::
516+ forall f.
517+ Traversable f =>
518+ f WorkingOverride ->
519+ f (WorkingOverride, OverrideErrors)
520+validateWorkingOverrides overrides =
521+ let (result, keyOccurrences :: MonoidalMap Text (Sum Int)) =
522+ flip runState mempty $ forM overrides \override@(WorkingOverrideKey _ key, value') -> do
523+ modify (<> MM.singleton key (Sum 1))
524+ pure . (override,) . mconcat $
525+ [ case MM.lookup key keyOccurrences of
526+ Just (Sum n)
527+ | n > 1 ->
528+ overrideKeyErrors "You can not use the same key multiple times."
529+ _ -> mempty
530+ , if T.null key
531+ then overrideKeyErrors "Keys can not be empty."
532+ else mempty
533+ , case value' of
534+ WorkingCustomValue "" -> overrideValueErrors "Values can not be empty."
535+ WorkingCustomValue _ -> mempty
536+ WorkingDefaultValue _ -> mempty
537+ WorkingDeletedValue _ -> mempty
538+ ]
539+ in result
540+
541+data OverrideErrors = OverrideErrors
542+ { keyErrors :: Maybe (NonEmpty Text)
543+ , valueErrors :: Maybe (NonEmpty Text)
544+ }
545+ deriving stock (Generic, Eq)
546+ deriving (Semigroup, Monoid) via Generically OverrideErrors
547+
548+overrideKeyErrors :: Text -> OverrideErrors
549+overrideKeyErrors x = mempty {keyErrors = Just $ pure x}
550+
551+overrideValueErrors :: Text -> OverrideErrors
552+overrideValueErrors x = mempty {valueErrors = Just $ pure x}
500553
501554-- | Widget for entering a key-value pair. The updated overrides list is
502555-- written to the 'EventWriter'.
@@ -505,14 +558,14 @@ envVarInput ::
505558 -- | The key values to suggest to the user
506559 Dynamic t [Text] ->
507560 -- | Current variable key and value.
508− Dynamic t WorkingOverride ->
561+ Dynamic t (WorkingOverride, OverrideErrors) ->
509562 m (Event t UserOverrideAction)
510563envVarInput values val = do
511− let kDyn = val <&> \(WorkingOverrideKey _ x, _) -> x
564+ let kDyn = val <&> fst <&> \(WorkingOverrideKey _ x, _) -> x
512565 -- Either <override present> <override deleted>
513566 d <-
514567 eitherDyn $
515− val <&> snd <&> \case
568+ val <&> snd . fst <&> \case
516569 WorkingCustomValue v -> Right (v, EditedOverrideFieldType)
517570 WorkingDefaultValue v -> Right (v, DefaultOverrideFieldType)
518571 WorkingDeletedValue v -> Left v
@@ -525,17 +578,17 @@ envVarInput values val = do
525578 values
526579 OverrideField
527580 { fieldValue = kDyn
528− , fieldError = never
581+ , fieldError = keyErrors . snd <$> val
529582 , fieldDisabled =
530− val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
583+ val <&> fst <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
531584 , fieldType =
532− val <&> \(WorkingOverrideKey t _, _) -> case t of
585+ val <&> fst <&> \(WorkingOverrideKey t _, _) -> case t of
533586 CustomWorkingOverrideKey -> EditedOverrideFieldType
534587 DefaultWorkingOverrideKey -> DefaultOverrideFieldType
535588 }
536589 OverrideField
537590 { fieldValue = vDyn
538− , fieldError = never
591+ , fieldError = valueErrors . snd <$> val
539592 , fieldDisabled = pure False
540593 , fieldType = vTypeDyn
541594 }