mirror of
https://github.com/typeable/octopod.git
synced 2024-09-11 14:56:38 +03:00
Added override validation to the frontend (#115)
This commit is contained in:
parent
3047ac3cfa
commit
bdcae3555b
@ -126,5 +126,7 @@ executable frontend
|
||||
, data-default
|
||||
, free
|
||||
, parallel
|
||||
, generic-data
|
||||
, monoidal-containers
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
@ -4,6 +4,7 @@ module Frontend.UIKit
|
||||
loadingCommonWidget,
|
||||
errorCommonWidget,
|
||||
octopodTextInput',
|
||||
octopodTextInputDyn,
|
||||
loadingOverride,
|
||||
loadingOverrides,
|
||||
overrideField,
|
||||
@ -27,7 +28,10 @@ import Data.Align
|
||||
import Data.Default
|
||||
import Data.Functor
|
||||
import Data.Generics.Labels ()
|
||||
import Data.List.NonEmpty
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isNothing, maybeToList)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Search
|
||||
import Data.These
|
||||
@ -71,7 +75,7 @@ errorCommonWidget =
|
||||
|
||||
data OverrideField t = OverrideField
|
||||
{ fieldValue :: Dynamic t Text
|
||||
, fieldError :: Event t Text
|
||||
, fieldError :: Dynamic t (Maybe (NonEmpty Text))
|
||||
, fieldDisabled :: Dynamic t Bool
|
||||
, fieldType :: Dynamic t OverrideFieldType
|
||||
}
|
||||
@ -88,8 +92,8 @@ overrideFieldTypeClasses EditedOverrideFieldType = mempty
|
||||
overrideField :: MonadWidget t m => Dynamic t [Text] -> OverrideField t -> OverrideField t -> m (Dynamic t Text, Dynamic t Text, Event t ())
|
||||
overrideField overrideKeyValues keyDyn valueDyn = do
|
||||
elDiv "overrides__item" $ do
|
||||
(keyInp, _) <-
|
||||
octopodTextInput'
|
||||
keyInp <-
|
||||
octopodTextInputDyn
|
||||
overrideKeyValues
|
||||
(keyDyn ^. #fieldDisabled)
|
||||
( do
|
||||
@ -100,8 +104,8 @@ overrideField overrideKeyValues keyDyn valueDyn = do
|
||||
(keyDyn ^. #fieldValue)
|
||||
(keyDyn ^. #fieldError)
|
||||
let keyTextDyn = value keyInp
|
||||
(value -> valTextDyn, _) <-
|
||||
octopodTextInput'
|
||||
(value -> valTextDyn) <-
|
||||
octopodTextInputDyn
|
||||
(pure [])
|
||||
(valueDyn ^. #fieldDisabled)
|
||||
( do
|
||||
@ -174,6 +178,33 @@ octopodTextInput' ::
|
||||
Event t Text ->
|
||||
m (InputElement EventResult GhcjsDomSpace t, Dynamic t Bool)
|
||||
octopodTextInput' valuesDyn disabledDyn clssDyn placeholder inValDyn' errEv = mdo
|
||||
errDyn <-
|
||||
holdDyn Nothing $
|
||||
leftmost
|
||||
[ Just . pure <$> errEv
|
||||
, Nothing <$ updated (value inp)
|
||||
]
|
||||
inp <- octopodTextInputDyn valuesDyn disabledDyn clssDyn placeholder inValDyn' errDyn
|
||||
pure (inp, isNothing <$> errDyn)
|
||||
|
||||
-- | The only text input field that is used in project forms. This input
|
||||
-- provides automatic error message hiding after user starts typing.
|
||||
octopodTextInputDyn ::
|
||||
MonadWidget t m =>
|
||||
-- | Value to suggest
|
||||
(Dynamic t [Text]) ->
|
||||
-- | Disabled?
|
||||
Dynamic t Bool ->
|
||||
-- | Input field classes.
|
||||
Dynamic t Classes ->
|
||||
-- | Placeholder for input field.
|
||||
Text ->
|
||||
-- | Init value.
|
||||
(Dynamic t Text) ->
|
||||
-- | Event carrying the error message.
|
||||
Dynamic t (Maybe (NonEmpty Text)) ->
|
||||
m (InputElement EventResult GhcjsDomSpace t)
|
||||
octopodTextInputDyn valuesDyn disabledDyn clssDyn placeholder inValDyn' errDyn = mdo
|
||||
inValDyn <- holdUniqDyn inValDyn'
|
||||
let valDyn = value inp
|
||||
inValEv =
|
||||
@ -184,19 +215,12 @@ octopodTextInput' valuesDyn disabledDyn clssDyn placeholder inValDyn' errEv = md
|
||||
These inV currV | inV /= currV -> Just inV
|
||||
_ -> Nothing
|
||||
)
|
||||
isValid <-
|
||||
holdDyn True $
|
||||
leftmost
|
||||
[ False <$ errEv
|
||||
, True <$ updated valDyn
|
||||
]
|
||||
|
||||
errorClassesDyn <-
|
||||
holdDyn mempty $
|
||||
leftmost
|
||||
[ "input--error" <$ errEv
|
||||
, mempty <$ updated valDyn
|
||||
]
|
||||
let errorClassesDyn = do
|
||||
err <- errDyn
|
||||
case err of
|
||||
Just _ -> "input--error"
|
||||
Nothing -> mempty
|
||||
|
||||
let classDyn = do
|
||||
errClasses <- errorClassesDyn
|
||||
@ -226,11 +250,10 @@ octopodTextInput' valuesDyn disabledDyn clssDyn placeholder inValDyn' errEv = md
|
||||
M.singleton "disabled" $
|
||||
if disabled' then Just "disabled" else Nothing
|
||||
)
|
||||
widgetHold_ blank $
|
||||
leftmost
|
||||
[ divClass "input__output" . text <$> errEv
|
||||
, blank <$ updated valDyn
|
||||
]
|
||||
void $
|
||||
simpleList ((maybeToList >=> NE.toList) <$> errDyn) $ \err ->
|
||||
divClass "input__output" $ dynText err
|
||||
|
||||
delayedFalseFocus <- delayFalse $ _inputElement_hasFocus inp'
|
||||
selectedValue' <- networkView >=> switchHoldPromptly never $ do
|
||||
hasFocus <- delayedFalseFocus
|
||||
@ -252,7 +275,7 @@ octopodTextInput' valuesDyn disabledDyn clssDyn placeholder inValDyn' errEv = md
|
||||
pure $ domEvent Click resEl $> initialText
|
||||
_ -> pure $ pure never
|
||||
pure (inp', selectedValue')
|
||||
pure (inp, isValid)
|
||||
pure inp
|
||||
|
||||
delayFalse :: (MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => Dynamic t Bool -> m (Dynamic t Bool)
|
||||
delayFalse x = do
|
||||
|
@ -40,10 +40,14 @@ import Common.Types as CT
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State.Strict
|
||||
import qualified Data.Foldable as F
|
||||
import Data.Functor
|
||||
import Data.Generics.Labels ()
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Map as M
|
||||
import Data.Map.Monoidal.Strict (MonoidalMap)
|
||||
import qualified Data.Map.Monoidal.Strict as MM
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing)
|
||||
import Data.Monoid
|
||||
import Data.Text as T (Text, null, pack)
|
||||
@ -62,6 +66,7 @@ import GHCJS.DOM.Element as DOM
|
||||
import GHCJS.DOM.EventM (on, target)
|
||||
import GHCJS.DOM.GlobalEventHandlers as Events (click)
|
||||
import GHCJS.DOM.Node as DOM
|
||||
import Generic.Data (Generically (..))
|
||||
import Reflex.Dom as R
|
||||
import Reflex.Dom.Renderable
|
||||
import Reflex.Network
|
||||
@ -234,8 +239,8 @@ overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
|
||||
expanderButton
|
||||
ExpanderButtonConfig
|
||||
{ buttonText = do
|
||||
state <- expandState
|
||||
pure $ case state of
|
||||
s <- expandState
|
||||
pure $ case s of
|
||||
ExpandedState -> "Hide default configuration"
|
||||
ContractedState -> "Show full configuration"
|
||||
, buttonInitialState = ContractedState
|
||||
@ -351,31 +356,38 @@ deploymentPopupBody hReq defAppOv defDepOv errEv = mdo
|
||||
Dynamic t [Text] ->
|
||||
Dynamic t (Maybe (DefaultConfig l)) ->
|
||||
Overrides l ->
|
||||
m (Dynamic t (Overrides l))
|
||||
m (Dynamic t (Overrides l), Dynamic t Bool)
|
||||
holdDCfg values dCfgDyn ovs = mdo
|
||||
ovsDyn <- holdDyn ovs ovsEv
|
||||
x <- attachDyn (current ovsDyn) dCfgDyn
|
||||
ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs') >>= switchHold never >>= debounce 0.5
|
||||
pure ovsDyn
|
||||
res <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs')
|
||||
ovsEv <- switchHold never (fst <$> res) >>= debounce 0.5
|
||||
isValid <- join <$> holdDyn (pure True) (snd <$> res)
|
||||
pure (ovsDyn, isValid)
|
||||
|
||||
depKeysDyn <- holdDyn [] depKeys
|
||||
deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv
|
||||
(deploymentOvsDyn, 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 <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
|
||||
(applicationOvsDyn, appValidDyn) <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
|
||||
|
||||
pure $ do
|
||||
depCfg <- deploymentOvsDyn
|
||||
appOvs <- applicationOvsDyn
|
||||
pure $
|
||||
Just $
|
||||
DeploymentUpdate
|
||||
{ appOverrides = appOvs
|
||||
, deploymentOverrides = depCfg
|
||||
}
|
||||
depValid <- depValidDyn
|
||||
appValid <- appValidDyn
|
||||
if depValid && appValid
|
||||
then do
|
||||
depCfg <- deploymentOvsDyn
|
||||
appOvs <- applicationOvsDyn
|
||||
pure $
|
||||
Just $
|
||||
DeploymentUpdate
|
||||
{ appOverrides = appOvs
|
||||
, deploymentOverrides = depCfg
|
||||
}
|
||||
else pure Nothing
|
||||
deploymentConfigProgressiveComponents ::
|
||||
MonadWidget t m =>
|
||||
RequestErrorHandler t m ->
|
||||
@ -475,7 +487,7 @@ envVarsInput ::
|
||||
-- | Initial deployment overrides.
|
||||
Overrides l ->
|
||||
-- | Updated deployment overrides.
|
||||
m (Event t (Overrides l))
|
||||
m (Event t (Overrides l), Dynamic t Bool)
|
||||
envVarsInput values dCfg ovs = mdo
|
||||
envsDyn <- foldDyn appEndo (constructWorkingOverrides dCfg ovs) $ leftmost [addEv, updEv]
|
||||
let addEv = clickEv $> Endo (fst . insertUniqStart newWorkingOverride)
|
||||
@ -487,16 +499,57 @@ envVarsInput values dCfg ovs = mdo
|
||||
, buttonType = Just AddDashButtonType
|
||||
, buttonStyle = OverridesDashButtonStyle
|
||||
}
|
||||
let workingOverridesWithErrors = validateWorkingOverrides . uniqMap <$> envsDyn
|
||||
isValid = all ((== mempty) . snd) <$> workingOverridesWithErrors
|
||||
updEv <-
|
||||
switchDyn . fmap F.fold
|
||||
<$> listWithKey
|
||||
(uniqMap <$> envsDyn)
|
||||
workingOverridesWithErrors
|
||||
(\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput values x)
|
||||
let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
|
||||
case dCfg of
|
||||
Just _ -> pure ()
|
||||
Nothing -> loadingOverrides
|
||||
pure . updated $ destructWorkingOverrides <$> envsDyn
|
||||
pure (updated $ destructWorkingOverrides <$> envsDyn, isValid)
|
||||
|
||||
validateWorkingOverrides ::
|
||||
forall f.
|
||||
Traversable f =>
|
||||
f WorkingOverride ->
|
||||
f (WorkingOverride, OverrideErrors)
|
||||
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))
|
||||
pure . (override,) . mconcat $
|
||||
[ case MM.lookup key keyOccurrences of
|
||||
Just (Sum n)
|
||||
| n > 1 ->
|
||||
overrideKeyErrors "You can not use the same key multiple times."
|
||||
_ -> mempty
|
||||
, if T.null key
|
||||
then overrideKeyErrors "Keys can not be empty."
|
||||
else mempty
|
||||
, case value' of
|
||||
WorkingCustomValue "" -> overrideValueErrors "Values can not be empty."
|
||||
WorkingCustomValue _ -> mempty
|
||||
WorkingDefaultValue _ -> mempty
|
||||
WorkingDeletedValue _ -> mempty
|
||||
]
|
||||
in result
|
||||
|
||||
data OverrideErrors = OverrideErrors
|
||||
{ keyErrors :: Maybe (NonEmpty Text)
|
||||
, valueErrors :: Maybe (NonEmpty Text)
|
||||
}
|
||||
deriving stock (Generic, Eq)
|
||||
deriving (Semigroup, Monoid) via Generically OverrideErrors
|
||||
|
||||
overrideKeyErrors :: Text -> OverrideErrors
|
||||
overrideKeyErrors x = mempty {keyErrors = Just $ pure x}
|
||||
|
||||
overrideValueErrors :: Text -> OverrideErrors
|
||||
overrideValueErrors x = mempty {valueErrors = Just $ pure x}
|
||||
|
||||
-- | Widget for entering a key-value pair. The updated overrides list is
|
||||
-- written to the 'EventWriter'.
|
||||
@ -505,14 +558,14 @@ envVarInput ::
|
||||
-- | The key values to suggest to the user
|
||||
Dynamic t [Text] ->
|
||||
-- | Current variable key and value.
|
||||
Dynamic t WorkingOverride ->
|
||||
Dynamic t (WorkingOverride, OverrideErrors) ->
|
||||
m (Event t UserOverrideAction)
|
||||
envVarInput values val = do
|
||||
let kDyn = val <&> \(WorkingOverrideKey _ x, _) -> x
|
||||
let kDyn = val <&> fst <&> \(WorkingOverrideKey _ x, _) -> x
|
||||
-- Either <override present> <override deleted>
|
||||
d <-
|
||||
eitherDyn $
|
||||
val <&> snd <&> \case
|
||||
val <&> snd . fst <&> \case
|
||||
WorkingCustomValue v -> Right (v, EditedOverrideFieldType)
|
||||
WorkingDefaultValue v -> Right (v, DefaultOverrideFieldType)
|
||||
WorkingDeletedValue v -> Left v
|
||||
@ -525,17 +578,17 @@ envVarInput values val = do
|
||||
values
|
||||
OverrideField
|
||||
{ fieldValue = kDyn
|
||||
, fieldError = never
|
||||
, fieldError = keyErrors . snd <$> val
|
||||
, fieldDisabled =
|
||||
val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
|
||||
val <&> fst <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
|
||||
, fieldType =
|
||||
val <&> \(WorkingOverrideKey t _, _) -> case t of
|
||||
val <&> fst <&> \(WorkingOverrideKey t _, _) -> case t of
|
||||
CustomWorkingOverrideKey -> EditedOverrideFieldType
|
||||
DefaultWorkingOverrideKey -> DefaultOverrideFieldType
|
||||
}
|
||||
OverrideField
|
||||
{ fieldValue = vDyn
|
||||
, fieldError = never
|
||||
, fieldError = valueErrors . snd <$> val
|
||||
, fieldDisabled = pure False
|
||||
, fieldType = vTypeDyn
|
||||
}
|
||||
|
Loading…
Reference in New Issue
Block a user