Finish payment add modal

8 files changed, 128 insertions, 90 deletions

diff --git a/README.md b/README.md
index 39b5135..39dd428 100644
--- a/README.md
+++ b/README.md
@@ -60,10 +60,9 @@ See [application.conf](application.conf).
 
 ### Payment view
 
-- I should not be able to delete payment of another person
-- When removing / modifying a payment, remove the payment category if there is no other payment with the same name
-- Use dynamic payments in exceeding payers computation
-- Check monthly payment functions
+- When removing / modifying a payment, remove the payment category if there is
+  no other payment with the same name
+- Check monthly payment UX
 - Edit a payment.
 - Clone a payment.
 
@@ -84,17 +83,17 @@ See [application.conf](application.conf).
 - HTTP error message
 - Use only one loader
 - Login with email and password
-- Adjust login design.
-- smooth search.
 - search payments by:
     - category,
     - date.
 
 ### Code
 
+- Add tests about exceedingPayers
 - Move up element ids security (editOwn is actually at db level).
 - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields)
 
 ### Tooling
 
+- use Obelisk
 - migration diff (use flyway?).
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index d679f9b..abdc51c 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -40,7 +40,7 @@ defaultInputIn = InputIn
 
 data InputOut t a = InputOut
   { _inputOut_raw   :: Dynamic t Text
-  , _inputOut_value :: Dynamic t (Maybe (Validation Text a))
+  , _inputOut_value :: Dynamic t (Validation Text a)
   , _inputOut_enter :: Event t ()
   }
 
@@ -64,27 +64,14 @@ input inputIn reset validate = do
 
         value =  R._textInput_value textInput
 
-        containerAttr = R.ffor validatedValue (\v ->
+        containerAttr = R.ffor inputError (\e ->
           M.singleton "class" $ T.intercalate " "
             [ "textInput"
-            , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else ""
+            , if Maybe.isJust e 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) <$> delayedReset
-        ])
+    let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v))
+    inputError <- getInputError valueWithValidation validate
 
     (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
 
@@ -108,7 +95,7 @@ input inputIn reset validate = do
             return R.never
 
       R.divClass "errorMessage" $
-        R.dynText . fmap validationError $ validatedValue
+        R.dynText . fmap (Maybe.fromMaybe "") $ inputError
 
       return (textInput, resetClic)
 
@@ -116,10 +103,46 @@ input inputIn reset validate = do
 
   return $ InputOut
     { _inputOut_raw = value
-    , _inputOut_value = validatedValue
+    , _inputOut_value = fmap snd valueWithValidation
     , _inputOut_enter = enter
     }
 
-validationError :: Maybe (Validation Text a) -> Text
-validationError (Just (Failure e)) = e
-validationError _                  = ""
+getInputError
+  :: forall t m a b c. MonadWidget t m
+  => Dynamic t (Text, Validation Text a)
+  -> Event t c
+  -> m (Dynamic t (Maybe Text))
+getInputError validatedValue validate = do
+  let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue
+      errorEvent = R.updated errorDynamic
+  delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent
+  fmap (fmap fst) $ R.foldDyn
+    (\event (err, hasBeenResetted) ->
+      case event of
+        ModifiedEvent t ->
+          (Nothing, T.null t)
+
+        ValidateEvent e ->
+          (e, False)
+
+        DelayEvent e ->
+          if hasBeenResetted then
+            (Nothing, False)
+          else
+            (e, False)
+    )
+    (Nothing, False)
+    (R.leftmost
+      [ fmap (\(t, _) -> ModifiedEvent t) errorEvent
+      , fmap (\(_, e) -> DelayEvent e) delayedError
+      , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate
+      ])
+
+validationError :: (Validation Text a) -> Maybe Text
+validationError (Failure e) = Just e
+validationError _           = Nothing
+
+data InputEvent
+  = ModifiedEvent Text
+  | DelayEvent (Maybe Text)
+  | ValidateEvent (Maybe Text)
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 43a8a6e..01ed37a 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -4,14 +4,17 @@ module Component.Select
   , 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
+import           Data.Map        (Map)
+import qualified Data.Map        as M
+import qualified Data.Maybe      as Maybe
+import           Data.Text       (Text)
+import qualified Data.Text       as T
+import           Data.Validation (Validation (Failure, Success))
+import           Reflex.Dom      (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom      as R
 
-import qualified Common.Msg as Msg
+import qualified Common.Msg      as Msg
+import qualified Util.Validation as ValidationUtil
 
 data (Reflex t) => SelectIn t a b c = SelectIn
   { _selectIn_label        :: Text
@@ -24,25 +27,33 @@ data (Reflex t) => SelectIn t a b c = SelectIn
   }
 
 data SelectOut t a = SelectOut
-  { _selectOut_value :: Dynamic t a
+  { _selectOut_value :: Dynamic t (Validation Text a)
   }
 
 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 ->
+    let containerAttr = R.ffor showedError (\e ->
           M.singleton "class" $ T.intercalate " "
             [ "selectInput"
-            , if e then "error" else ""
+            , if Maybe.isJust 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
-        ])
+        validatedValue =
+          R.ffor value (\v ->
+            if _selectIn_isValid selectIn v then
+              Success v
+            else
+              Failure (Msg.get Msg.Form_NonEmpty))
+
+        maybeError =
+          fmap ValidationUtil.maybeError validatedValue
+
+    showedError <- R.holdDyn Nothing $ R.leftmost
+      [ const Nothing <$> _selectIn_reset selectIn
+      , R.updated maybeError
+      , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
+      ]
 
     value <- R.elDynAttr "div" containerAttr $ do
       R.el "label" $ R.text (_selectIn_label selectIn)
@@ -60,16 +71,11 @@ select selectIn = do
           (_selectIn_values selectIn)
           (R.def { R._dropdownConfig_setValue = setValue })
 
-      errorMessage <- R.holdDyn "" $ R.attachWith
-        (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!")
-        (R.current value)
-        (_selectIn_validate selectIn)
-
       R.divClass "errorMessage" . R.dynText $
-        R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "")
+        R.ffor showedError (Maybe.fromMaybe "")
 
       return value
 
   return SelectOut
-    { _selectOut_value = value
+    { _selectOut_value = validatedValue
     }
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index fc13f36..f9545a4 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,6 +1,7 @@
 module Util.Validation
   ( nelError
   , toMaybe
+  , maybeError
   , fireValidation
   , fireMaybe
   ) where
@@ -21,14 +22,18 @@ toMaybe :: Validation a b -> Maybe b
 toMaybe (Success s) = Just s
 toMaybe (Failure _) = Nothing
 
+maybeError :: Validation a b -> Maybe a
+maybeError (Success _) = Nothing
+maybeError (Failure e) = Just e
+
 fireValidation
   :: forall t a b c. Reflex t
-  => Dynamic t (Maybe (Validation a b))
+  => Dynamic t (Validation a b)
   -> Event t c
   -> Event t b
 fireValidation value validate =
   R.fmapMaybe
-    (join . fmap (Validation.validation (const Nothing) Just))
+    (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
 
 fireMaybe
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 05eedab..ae20079 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -53,6 +53,7 @@ widget paymentIn = do
 
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
+        , _headerIn_payments = payments
         , _headerIn_searchPayments = searchPayments
         , _headerIn_paymentCategories = paymentCategories
         }
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index d023613..e0772f7 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -66,7 +66,7 @@ view addIn = do
             , _inputIn_validation = PaymentValidation.name
             })
           reset
-          validate
+          confirm
 
         cost <- _inputOut_value <$> (Component.input
           (Component.defaultInputIn
@@ -74,7 +74,7 @@ view addIn = do
             , _inputIn_validation = PaymentValidation.cost
             })
           reset
-          validate)
+          confirm)
 
         now <- liftIO Time.getCurrentTime
 
@@ -91,7 +91,7 @@ view addIn = do
             , _inputIn_validation = PaymentValidation.date
             })
           (const currentDay <$> reset)
-          validate)
+          confirm)
 
         frequency <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Frequency
@@ -100,7 +100,7 @@ view addIn = do
           , _selectIn_values = R.constDyn frequencies
           , _selectIn_reset = reset
           , _selectIn_isValid = const True
-          , _selectIn_validate = validate
+          , _selectIn_validate = confirm
           })
 
         let setCategory =
@@ -115,7 +115,7 @@ view addIn = do
           , _selectIn_values = R.constDyn categories
           , _selectIn_reset = reset
           , _selectIn_isValid = \id -> id /= -1
-          , _selectIn_validate = validate
+          , _selectIn_validate = confirm
           })
 
         let payment = do
@@ -124,24 +124,20 @@ view addIn = do
               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)
-
-        (addPayment, cancel, validate) <- R.divClass "buttons" $ do
+              return (CreatePayment
+                <$> ValidationUtil.nelError n
+                <*> ValidationUtil.nelError c
+                <*> ValidationUtil.nelError d
+                <*> ValidationUtil.nelError cat
+                <*> ValidationUtil.nelError f)
+
+        (addPayment, cancel, confirm) <- 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 $
+            confirm <- Component._buttonOut_clic <$> (Component.button $
               (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
                 { _buttonIn_class = R.constDyn "confirm"
                 , _buttonIn_waiting = waiting
@@ -150,9 +146,9 @@ view addIn = do
 
             (addPayment, waiting) <- WaitFor.waitFor
               (Ajax.postJson "/payment")
-              (ValidationUtil.fireValidation payment validate)
+              (ValidationUtil.fireValidation payment confirm)
 
-          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate)
+          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
 
       return AddOut
         { _addOut_cancel = cancel
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 5cc362a..73517f0 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -36,6 +36,7 @@ import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
   { _headerIn_init              :: Init
+  , _headerIn_payments          :: Dynamic t [Payment]
   , _headerIn_searchPayments    :: Dynamic t [Payment]
   , _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
   }
@@ -49,7 +50,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency
+    addPayment <- payerAndAdd incomes payments users categories paymentCategories currency
     let resetSearchName = fmap (const ()) $ addPayment
     (searchName, searchFrequency)  <- searchLine resetSearchName
 
@@ -64,7 +65,7 @@ widget headerIn =
     init = _headerIn_init headerIn
     incomes = _init_incomes init
     initPayments = _init_payments init
-    punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments
+    payments = _headerIn_payments headerIn
     users = _init_users init
     categories = _init_categories init
     currency = _init_currency init
@@ -73,7 +74,7 @@ widget headerIn =
 payerAndAdd
   :: forall t m. MonadWidget t m
   => [Income]
-  -> [Payment]
+  -> Dynamic t [Payment]
   -> [User]
   -> [Category]
   -> Dynamic t [PaymentCategory]
@@ -82,17 +83,23 @@ payerAndAdd
 payerAndAdd incomes payments users categories paymentCategories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
+
+    let exceedingPayers =
+          R.ffor payments $ \ps ->
+            CM.getExceedingPayers time users incomes $
+              filter ((==) Punctual . _payment_frequency) ps
+
     R.divClass "exceedingPayers" $
-      forM_
-        (CM.getExceedingPayers time users incomes payments)
-        (\p ->
-          R.elClass "span" "exceedingPayer" $ do
-            R.elClass "span" "userName" $
-              R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users
-            R.elClass "span" "amount" $ do
-              R.text "+ "
-              R.text . Format.price currency $ _exceedingPayer_amount p
-        )
+      R.simpleList exceedingPayers $ \exceedingPayer ->
+        R.elClass "span" "exceedingPayer" $ do
+          R.elClass "span" "userName" $
+            R.dynText . R.ffor exceedingPayer $ \ep ->
+              fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
+          R.elClass "span" "amount" $ do
+            R.text "+ "
+            R.dynText . R.ffor exceedingPayer $ \ep ->
+              Format.price currency $ _exceedingPayer_amount ep
+
     addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
@@ -100,6 +107,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do
       , _buttonIn_tabIndex = Nothing
       , _buttonIn_submit = False
       })
+
     rec
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = addPaymentClic
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index e95fa74..4eb0523 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -189,8 +189,8 @@ m l Form_InvalidColor =
 
 m l Form_InvalidDate =
   case l of
-    English -> "DD/MM/YYYY required"
-    French  -> "JJ/MM/AAAA requis"
+    English -> "Date required"
+    French  -> "Date requise"
 
 m l Form_InvalidInt =
   case l of