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/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 ++++++++------ 6 files changed, 124 insertions(+), 74 deletions(-) (limited to 'client/src/View') 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