Implementing client side validation

11 files changed, 302 insertions, 135 deletions

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