Implementing client side validation

6 files changed, 124 insertions, 74 deletions

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