From 6846403b7fb811f3ffc2ec126c959a9e445deee1 Mon Sep 17 00:00:00 2001 From: iko Date: Wed, 29 Sep 2021 23:23:44 +0300 Subject: [PATCH] frontend hotfixes (#120) * Fixed override editing * Fixed debouncing overrides --- dev/default.nix | 15 ++++++-- octopod-frontend/src/Data/WorkingOverrides.hs | 7 +++- octopod-frontend/src/Frontend/UIKit.hs | 3 +- octopod-frontend/src/Frontend/Utils.hs | 36 ++++++++++--------- 4 files changed, 41 insertions(+), 20 deletions(-) diff --git a/dev/default.nix b/dev/default.nix index e3cf966..bc4d9c7 100644 --- a/dev/default.nix +++ b/dev/default.nix @@ -115,6 +115,17 @@ in exit 0 ''; + keysScript = pkgs.writeScript "keys.sh" '' + #!${pkgs.bash}/bin/bash + + sleep 4 + + echo "key" + echo "key2" + + exit 0 + ''; + writeScript = pkgs.writeScript "write.sh" '' #!${pkgs.bash}/bin/bash @@ -145,9 +156,9 @@ in export INFO_COMMAND=${infoScript} export NOTIFICATION_COMMAND=${writeScript} export DEPLOYMENT_CONFIG_COMMAND=${infoScript} - export DEPLOYMENT_KEYS_COMMAND=${infoScript} + export DEPLOYMENT_KEYS_COMMAND=${keysScript} export APPLICATION_CONFIG_COMMAND=${infoScript} - export APPLICATION_KEYS_COMMAND=${infoScript} + export APPLICATION_KEYS_COMMAND=${keysScript} export UNARCHIVE_COMMAND=${writeScript} export POWER_AUTHORIZATION_HEADER="123" export CACHE_INVALIDATION_TIME="60" diff --git a/octopod-frontend/src/Data/WorkingOverrides.hs b/octopod-frontend/src/Data/WorkingOverrides.hs index 4c81276..836b303 100644 --- a/octopod-frontend/src/Data/WorkingOverrides.hs +++ b/octopod-frontend/src/Data/WorkingOverrides.hs @@ -47,7 +47,12 @@ data WorkingOverrideValue' te destructWorkingOverrides :: WorkingOverrides -> Overrides l destructWorkingOverrides = Overrides - . OM.fromList + . foldr + ( \pair@(k, v) m -> case OM.lookup k m of + Just _ | v == ValueDeleted -> m + _ -> m OM.|> pair + ) + OM.empty . mapMaybe ( \case (WorkingOverrideKey CustomWorkingOverrideKey k, getWorkingOverrideValue -> v) -> Just (k, v) diff --git a/octopod-frontend/src/Frontend/UIKit.hs b/octopod-frontend/src/Frontend/UIKit.hs index 81a99dc..a5d1194 100644 --- a/octopod-frontend/src/Frontend/UIKit.hs +++ b/octopod-frontend/src/Frontend/UIKit.hs @@ -84,6 +84,7 @@ data OverrideField t = OverrideField data OverrideFieldType = DefaultOverrideFieldType | EditedOverrideFieldType + deriving stock (Show) overrideFieldTypeClasses :: OverrideFieldType -> Classes overrideFieldTypeClasses DefaultOverrideFieldType = "input--default" @@ -109,7 +110,7 @@ overrideField overrideKeyValues keyDyn valueDyn = do (pure []) (valueDyn ^. #fieldDisabled) ( do - t <- keyDyn ^. #fieldType + t <- valueDyn ^. #fieldType pure $ "overrides__value" <> overrideFieldTypeClasses t ) "value" diff --git a/octopod-frontend/src/Frontend/Utils.hs b/octopod-frontend/src/Frontend/Utils.hs index 59f01cf..517fa84 100644 --- a/octopod-frontend/src/Frontend/Utils.hs +++ b/octopod-frontend/src/Frontend/Utils.hs @@ -344,7 +344,7 @@ deploymentPopupBody :: m (Dynamic t (Maybe DeploymentUpdate)) deploymentPopupBody hReq defAppOv defDepOv errEv = mdo pb <- getPostBuild - (defDepEv, defApp, depCfgEv) <- deploymentConfigProgressiveComponents hReq deploymentOvsDyn + (defDepEv, defApp, depCfgEv) <- deploymentConfigProgressiveComponents hReq deploymentOvsDynDebounced defAppM <- holdClearingWith defApp (unitEv deploymentOvsDyn) defDep <- holdDynMaybe defDepEv depKeys <- deploymentOverrideKeys pb >>= hReq @@ -356,23 +356,26 @@ deploymentPopupBody hReq defAppOv defDepOv errEv = mdo Dynamic t [Text] -> Dynamic t (Maybe (DefaultConfig l)) -> Overrides l -> - m (Dynamic t (Overrides l), Dynamic t Bool) + m (Dynamic t (Overrides l), Dynamic t (Overrides l), Dynamic t Bool) holdDCfg values dCfgDyn ovs = mdo ovsDyn <- holdDyn ovs ovsEv + ovsDynDebounced <- holdDyn ovs ovsEvDebounced x <- attachDyn (current ovsDyn) dCfgDyn res <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs') - ovsEv <- switchHold never (fst <$> res) >>= debounce 0.5 + ovsEv <- switchHold never (fst <$> res) + ovsEvDebounced <- debounce 2 ovsEv isValid <- join <$> holdDyn (pure True) (snd <$> res) - pure (ovsDyn, isValid) + pure (ovsDyn, ovsDynDebounced, isValid) depKeysDyn <- holdDyn [] depKeys - (deploymentOvsDyn, depValidDyn) <- deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv + (deploymentOvsDyn, deploymentOvsDynDebounced, depValidDyn) <- + deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv appKeys <- waitForValuePromptly depCfgEv $ \deploymentCfg -> do pb' <- getPostBuild applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing appKeysDyn <- holdDyn [] $ catMaybes appKeys - (applicationOvsDyn, appValidDyn) <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv + (applicationOvsDyn, _, appValidDyn) <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv pure $ do depValid <- depValidDyn @@ -388,6 +391,7 @@ deploymentPopupBody hReq defAppOv defDepOv errEv = mdo , deploymentOverrides = depCfg } else pure Nothing + deploymentConfigProgressiveComponents :: MonadWidget t m => RequestErrorHandler t m -> @@ -520,7 +524,9 @@ validateWorkingOverrides :: validateWorkingOverrides overrides = let (result, keyOccurrences :: MonoidalMap Text (Sum Int)) = flip runState mempty $ forM overrides \override@(WorkingOverrideKey _ key, value') -> do - modify (<> MM.singleton key (Sum 1)) + case value' of + WorkingDeletedValue _ -> pure () + _ -> modify (<> MM.singleton key (Sum 1)) pure . (override,) . mconcat $ [ case MM.lookup key keyOccurrences of Just (Sum n) @@ -623,19 +629,17 @@ performUserOverrideAction f i (UpdateValue v) = Endo $ 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 _ i (UpdateKey k) = Endo $ + updateUniq i $ + \(_, v) -> (WorkingOverrideKey CustomWorkingOverrideKey k, v) performUserOverrideAction f i DeleteOverride = Endo $ \m -> case f of Nothing -> updateUniq i (\(k, _) -> (k, WorkingDeletedValue Nothing)) m - Just f' -> case lookupUniq i m of + Just _ -> 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 + Just (WorkingOverrideKey DefaultWorkingOverrideKey k, _) -> + updateUniq i (const (WorkingOverrideKey DefaultWorkingOverrideKey k, WorkingDeletedValue (f >>= ($ k)))) m + Just (WorkingOverrideKey CustomWorkingOverrideKey _, _) -> deleteUniq i m holdDynMaybe :: (Reflex t, MonadHold t m) => Event t a -> m (Dynamic t (Maybe a)) holdDynMaybe ev = holdDyn Nothing $ fmapCheap Just ev