diff options
| -rw-r--r-- | README.md | 11 | ||||
| -rw-r--r-- | client/src/Component/Input.hs | 69 | ||||
| -rw-r--r-- | client/src/Component/Select.hs | 54 | ||||
| -rw-r--r-- | client/src/Util/Validation.hs | 9 | ||||
| -rw-r--r-- | client/src/View/Payment.hs | 1 | ||||
| -rw-r--r-- | client/src/View/Payment/Add.hs | 36 | ||||
| -rw-r--r-- | client/src/View/Payment/Header.hs | 34 | ||||
| -rw-r--r-- | common/src/Common/Message/Translation.hs | 4 |
8 files changed, 128 insertions, 90 deletions
@@ -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 |