Implementing client side validation

3 files changed, 91 insertions, 54 deletions

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