Implementing client side validation

1 files changed, 46 insertions, 15 deletions

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
+    }