From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- client/client.cabal | 8 ++- client/src/Component/Input.hs | 114 +++++++++++++++++++++++----------- client/src/Component/Modal.hs | 19 +++--- client/src/Component/Select.hs | 61 +++++++++++++----- client/src/Util/Validation.hs | 37 +++++++++++ client/src/View/App.hs | 3 +- client/src/View/Payment.hs | 2 +- client/src/View/Payment/Add.hs | 127 ++++++++++++++++++++++++-------------- client/src/View/Payment/Header.hs | 16 ++--- client/src/View/Payment/Pages.hs | 2 +- client/src/View/SignIn.hs | 48 ++++++++------ 11 files changed, 302 insertions(+), 135 deletions(-) create mode 100644 client/src/Util/Validation.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 26ad2ec..af71f2d 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -21,8 +21,8 @@ Executable client RecursiveDo Build-depends: - aeson - , base >=4.9 && <5 + aeson + , base >= 4.11 && < 5 , bytestring , common , containers @@ -32,8 +32,10 @@ Executable client , reflex-dom , text , time + , validation other-modules: + Component Component.Button Component.Form Component.Input @@ -42,7 +44,9 @@ Executable client Icon Util.Ajax Util.Dom + Util.Either Util.List + Util.Validation Util.WaitFor View.App View.Header diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 57018a6..67f97c0 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -5,59 +5,91 @@ module Component.Input , defaultInputIn ) where -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&), - (.~)) -import qualified Reflex.Dom as R - -import Component.Button (ButtonIn (..), ButtonOut (..)) -import qualified Component.Button as Button +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, + (&), (.~)) +import qualified Reflex.Dom as R + +import qualified Common.Util.Validation as ValidationUtil +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button import qualified Icon -data InputIn = InputIn +data InputIn a = InputIn { _inputIn_hasResetButton :: Bool , _inputIn_label :: Text , _inputIn_initialValue :: Text , _inputIn_inputType :: Text + , _inputIn_validation :: Text -> Validation Text a } -defaultInputIn :: InputIn +defaultInputIn :: InputIn Text defaultInputIn = InputIn { _inputIn_hasResetButton = True , _inputIn_label = "" , _inputIn_initialValue = "" , _inputIn_inputType = "text" + , _inputIn_validation = V.Success } -data InputOut t = InputOut - { _inputOut_value :: Dynamic t Text +data InputOut t a = InputOut + { _inputOut_raw :: Dynamic t Text + , _inputOut_value :: Dynamic t (Maybe (Validation Text a)) , _inputOut_enter :: Event t () } input :: forall t m a b. MonadWidget t m - => InputIn - -> Event t a -- reset - -> m (InputOut t) -input inputIn reset = - R.divClass "textInput" $ do - rec - let resetValue = R.leftmost - [ fmap (const "") reset - , fmap (const "") resetClic - ] - - attributes = R.ffor value (\v -> - if T.null v && _inputIn_inputType inputIn /= "date" - then M.empty - else M.singleton "class" "filled") - - value = R._textInput_value textInput + => InputIn a + -> Event t Text -- reset + -> Event t b -- validate + -> m (InputOut t a) +input inputIn reset validate = do + rec + let resetValue = R.leftmost + [ R.traceEvent "reset" reset + , fmap (const "") resetClic + ] + + inputAttr = R.ffor value (\v -> + if T.null v && _inputIn_inputType inputIn /= "date" + then M.empty + else M.singleton "class" "filled") + + value = R._textInput_value textInput + + containerAttr = R.ffor validatedValue (\v -> + M.singleton "class" $ T.intercalate " " + [ "textInput" + , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else "" + ]) + + -- Clear validation errors after reset + delayedReset <- R.delay (0.1 :: NominalDiffTime) reset + + validatedValue <- R.holdDyn Nothing $ R.attachWith + (\v (clearValidation, validateEmpty) -> + if clearValidation + then Nothing + else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v))) + (R.current value) + (R.leftmost + [ const (False, True) <$> resetClic + , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) + , const (False, False) <$> validate + , const (True, False) <$> R.traceEvent "delayedReset" delayedReset + ]) + + (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do textInput <- R.textInput $ R.def - & R.attributes .~ attributes + & R.attributes .~ inputAttr & R.setValue .~ resetValue & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) @@ -75,9 +107,19 @@ input inputIn reset = else return R.never - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + R.divClass "errorMessage" $ + R.dynText . fmap validationError $ validatedValue + + return (textInput, resetClic) + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ InputOut + { _inputOut_raw = value + , _inputOut_value = validatedValue + , _inputOut_enter = enter + } - return $ InputOut - { _inputOut_value = value - , _inputOut_enter = enter - } +validationError :: Maybe (Validation Text a) -> Text +validationError (Just (Failure e)) = e +validationError _ = "" diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index b86fee0..d7943a9 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -23,11 +23,12 @@ data ModalIn t m a = ModalIn , _modalIn_content :: m a } -data ModalOut a = ModalOut +data ModalOut t a = ModalOut { _modalOut_content :: a + , _modalOut_hide :: Event t () } -modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) +modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) modal modalIn = do rec let showEvent = R.leftmost @@ -48,6 +49,7 @@ modal modalIn = do return $ ModalOut { _modalOut_content = content + , _modalOut_hide = curtainClick } getAttributes :: Bool -> LM.Map Text Text @@ -67,12 +69,13 @@ performShowEffects showEvent elem = do let showEffects = flip fmap showEvent (\show -> do - if show - then - do - Node.appendChild body elem - Element.setClassName body ("modal" :: JSString) - else + if show then + do + Node.appendChild body elem + Element.setClassName body ("modal" :: JSString) + else + do + Node.removeChild body elem Element.setClassName body ("" :: JSString) ) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 7cb6726..9f671d3 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -5,34 +5,65 @@ module Component.Select ) where import Data.Map (Map) +import qualified Data.Map as M import Data.Text (Text) +import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -data (Reflex t) => SelectIn t a = SelectIn +import qualified Common.Msg as Msg + +data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a , _selectIn_values :: Dynamic t (Map a Text) - , _selectIn_reset :: Event t () + , _selectIn_reset :: Event t b + , _selectIn_isValid :: a -> Bool + , _selectIn_validate :: Event t c } data SelectOut t a = SelectOut { _selectOut_value :: Dynamic t a } -select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a) -select selectIn = - R.divClass "selectInput" $ do - R.el "label" $ R.text (_selectIn_label selectIn) +select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) +select selectIn = do + rec + let containerAttr = R.ffor hasError (\e -> + M.singleton "class" $ T.intercalate " " + [ "selectInput" + , if e then "error" else "" + ]) + + hasError <- R.holdDyn False $ R.attachWith + (\v clearError -> not clearError && not (_selectIn_isValid selectIn v)) + (R.current value) + (R.leftmost + [ const False <$> _selectIn_validate selectIn + , const True <$> _selectIn_reset selectIn + ]) + + value <- R.elDynAttr "div" containerAttr $ do + R.el "label" $ R.text (_selectIn_label selectIn) + + let initialValue = _selectIn_initialValue selectIn + + value <- R._dropdown_value <$> + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + + errorMessage <- R.holdDyn "" $ R.attachWith + (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") + (R.current value) + (_selectIn_validate selectIn) - let initialValue = _selectIn_initialValue selectIn + R.divClass "errorMessage" . R.dynText $ + R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "") - value <- R._dropdown_value <$> - R.dropdown - initialValue - (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + return value - return SelectOut - { _selectOut_value = value - } + return SelectOut + { _selectOut_value = value + } diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs new file mode 100644 index 0000000..e2a3dcb --- /dev/null +++ b/client/src/Util/Validation.hs @@ -0,0 +1,37 @@ +module Util.Validation + ( fireValidation + , fireMaybe + , nelError + ) where + +import Control.Monad (join) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL +import Data.Text (Text) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as Validation +import Reflex.Dom (Dynamic, Event, Reflex) +import qualified Reflex.Dom as R + +nelError :: Validation a b -> Validation (NonEmpty a) b +nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success + +fireValidation + :: forall t a b c. Reflex t + => Dynamic t (Maybe (Validation a b)) + -> Event t c + -> Event t b +fireValidation value validate = + R.fmapMaybe + (join . fmap (Validation.validation (const Nothing) Just)) + (R.tag (R.current value) validate) + +fireMaybe + :: forall t a b. Reflex t + => Dynamic t (Maybe a) + -> Event t b + -> Event t a +fireMaybe value validate = + R.fmapMaybe + id + (R.tag (R.current value) validate) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 9aa6c57..6435297 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -16,7 +16,8 @@ import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = - R.mainWidget $ do + R.mainWidget $ R.divClass "app" $ do + headerOut <- Header.view $ HeaderIn { _headerIn_initResult = initResult } diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 5245e72..007471d 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -30,7 +30,7 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do - R.divClass "payment" $ do + R.elClass "main" "payment" $ do rec let init = _paymentIn_init paymentIn paymentsPerPage = 7 diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 061eeeb..62b26a3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,31 +4,34 @@ module View.Payment.Add , AddOut(..) ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import qualified Data.Text as T -import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R -import qualified Text.Read as T - -import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data AddIn t = AddIn { _addIn_categories :: [Category] - , _addIn_show :: Event t () + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -43,48 +46,84 @@ view addIn = do R.divClass "addContent" $ do rec + let reset = R.leftmost + [ const "" <$> cancel + , const "" <$> addedPayment + , const "" <$> _addIn_cancel addIn + ] + name <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_validation = PaymentValidation.name + }) + reset + validate) cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_validation = PaymentValidation.cost + }) + reset + validate) - currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + currentDay <- do + d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_initialValue = currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date }) - (const () <$ addedPayment)) + (const currentDay <$> reset) + validate) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = const True + , _selectIn_validate = validate }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = 0 + , _selectIn_initialValue = -1 , _selectIn_values = R.constDyn categories - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = \id -> id /= -1 + , _selectIn_validate = validate }) - let payment = CreatePayment - <$> name - <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost - <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date - <*> category - <*> frequency - - (addedPayment, cancel) <- R.divClass "buttons" $ do + let payment = do + n <- name + c <- cost + d <- date + cat <- category + f <- frequency + pure $ do + n' <- n + c' <- c + d' <- d + pure $ CreatePayment + <$> ValidationUtil.nelError n' + <*> ValidationUtil.nelError c' + <*> ValidationUtil.nelError d' + <*> ValidationUtil.nelError (V.Success cat) + <*> ValidationUtil.nelError (V.Success f) + + (addedPayment, cancel, validate) <- R.divClass "buttons" $ do rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" @@ -94,13 +133,9 @@ view addIn = do (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - (R.tag (R.current payment) validate) - - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) return AddOut { _addOut_cancel = cancel diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 6fbaecf..56441eb 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -97,18 +97,19 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- fmap _modalOut_content . Component.modal $ ModalIn + modalOut <- Component.modal $ ModalIn { _modalIn_show = addPaymentClic , _modalIn_hide = R.leftmost $ - [ _addOut_cancel modalOut - , fmap (const ()) . _addOut_addedPayment $ modalOut + [ _addOut_cancel addOut + , fmap (const ()) . _addOut_addedPayment $ addOut ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories - , _addIn_show = addPaymentClic + , _addIn_cancel = _modalOut_hide modalOut } } - return (_addOut_addedPayment modalOut) + let addOut = _modalOut_content modalOut + return (_addOut_addedPayment addOut) searchLine :: forall t m. MonadWidget t m @@ -116,9 +117,10 @@ searchLine -> m (Dynamic t Text, Dynamic t Frequency) searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input + searchName <- _inputOut_raw <$> (Component.input ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) - reset) + (const "" <$> reset) + R.never) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 57d67ac..cbe7b50 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -47,7 +47,7 @@ pageButtons total perPage reset = do , pageClic , nextPageClic , lastPageClic - , (const 1) <$> reset + , 1 <$ reset ] firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 428997e..6fbf6d6 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -3,20 +3,24 @@ module View.SignIn , view ) where -import qualified Data.Either as Either -import Data.Text (Text) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Data.Validation (Validation) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (SignIn (SignIn)) -import qualified Common.Msg as Msg +import Common.Model (SignInForm (SignInForm)) +import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation -import Component (ButtonIn (..), ButtonOut (..), InputIn (..), - InputOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as WaitFor +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -29,19 +33,27 @@ view signInMessage = Component.form $ do rec input <- (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) - (R.ffilter Either.isRight signInResult)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_validation = SignInValidation.email + }) + (const "" <$> R.ffilter Either.isRight signInResult) + validate) - button <- Component.button $ + validate <- _buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) { _buttonIn_class = R.constDyn "validate" , _buttonIn_waiting = waiting , _buttonIn_submit = True - } + }) + + let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) + (Ajax.postJson "/askSignIn") + (ValidationUtil.fireMaybe + ((\f -> const f <$> SignInValidation.signIn f) <$> form) + validate) showSignInResult signInMessage signInResult -- cgit v1.2.3