diff options
Diffstat (limited to 'client/src/View/Payment')
| -rw-r--r-- | client/src/View/Payment/Form.hs | 199 | ||||
| -rw-r--r-- | client/src/View/Payment/HeaderForm.hs | 85 | ||||
| -rw-r--r-- | client/src/View/Payment/HeaderInfos.hs | 94 | ||||
| -rw-r--r-- | client/src/View/Payment/Payment.hs | 101 | ||||
| -rw-r--r-- | client/src/View/Payment/Reducer.hs | 110 | ||||
| -rw-r--r-- | client/src/View/Payment/Table.hs | 143 |
6 files changed, 732 insertions, 0 deletions
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs new file mode 100644 index 0000000..6c31fad --- /dev/null +++ b/client/src/View/Payment/Form.hs @@ -0,0 +1,199 @@ +module View.Payment.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty) +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.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Payment as PaymentValidation + +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Component.Select as Select +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil + +data In t = In + { _in_categories :: [Category] + , _in_operation :: Operation t + , _in_frequency :: Frequency + } + +data Operation t + = New + | Clone Payment + | Edit Payment + +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m +view input cancel = do + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation (NonEmpty Text) Value)) + form reset confirm = do + name <- Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Name + , Input._in_initialValue = name + , Input._in_validation = PaymentValidation.name + }) + (name <$ reset) + confirm + + cost <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Cost + , Input._in_initialValue = cost + , Input._in_validation = PaymentValidation.cost + }) + (cost <$ reset) + confirm) + + currentDate <- date + + date <- + case frequency of + Punctual -> do + Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = currentDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date + }) + (currentDate <$ reset) + confirm) + Monthly -> + return . R.constDyn $ currentDate + + setCategory <- + R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (return . R.ffilter (\name -> T.length name >= 3)) + >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) + >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) + + category <- Select._out_value <$> (Select.view $ Select.In + { Select._in_label = Msg.get Msg.Payment_Category + , Select._in_initialValue = category + , Select._in_value = setCategory + , Select._in_values = R.constDyn categories + , Select._in_reset = category <$ reset + , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) + , Select._in_validate = confirm + }) + + return $ do + n <- Input._out_value name + c <- cost + d <- date + cat <- category + return (mkPayload + <$> ValidationUtil.nelError n + <*> V.Success c + <*> V.Success d + <*> ValidationUtil.nelError cat + <*> V.Success frequency) + + frequencies = + M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_in_categories input) $ \c -> + (_category_id c, _category_name c) + + category = + case op of + New -> -1 + Clone p -> _payment_category p + Edit p -> _payment_category p + + op = _in_operation input + + name = + case op of + New -> "" + Clone p -> _payment_name p + Edit p -> _payment_name p + + cost = + case op of + New -> "" + Clone p -> T.pack . show . _payment_cost $ p + Edit p -> T.pack . show . _payment_cost $ p + + date = do + currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay + return . T.pack . Calendar.showGregorian $ + case op of + New -> currentDay + Clone p -> currentDay + Edit p -> _payment_date p + + frequency = + case op of + New -> _in_frequency input + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p + + headerLabel = + case op of + New -> Msg.get Msg.Payment_Add + Clone _ -> Msg.get Msg.Payment_CloneLong + Edit _ -> Msg.get Msg.Payment_EditLong + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + mkPayload = + case op of + Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e + _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..1915841 --- /dev/null +++ b/client/src/View/Payment/HeaderForm.hs @@ -0,0 +1,85 @@ +module View.Payment.HeaderForm + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, Currency, Frequency (..), + Income (..), Payment (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.Select as Select +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data In t = In + { _in_reset :: Event t () + , _in_categories :: [Category] + } + +data Out t = Out + { _out_search :: Event t Text + , _out_frequency :: Event t Frequency + , _out_addPayment :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = + R.divClass "g-PaymentHeaderForm" $ do + + (searchName, frequency) <- R.el "div" $ do + + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + frequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + return (searchName, frequency) + + addPaymentButton <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" + }) + + addPayment <- + (R.dyn . R.ffor frequency $ \frequency -> + Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.New + , Form._in_frequency = frequency + } + }) >>= ReflexUtil.flatten + + return $ Out + { _out_search = R.updated searchName + , _out_frequency = R.updated frequency + , _out_addPayment = addPayment + } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..f84ee1f --- /dev/null +++ b/client/src/View/Payment/HeaderInfos.hs @@ -0,0 +1,94 @@ +module View.Payment.HeaderInfos + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, ExceedingPayer (..), + Payment (..), PaymentHeader (..), + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +data In t = In + { _in_users :: [User] + , _in_currency :: Currency + , _in_header :: PaymentHeader + , _in_paymentCount :: Int + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = + R.divClass "g-PaymentHeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) + + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) + + where + header = _in_header input + +exceedingPayers + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> [ExceedingPayer] + -> m () +exceedingPayers users currency payers = + R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $ + flip mapM_ payers $ \payer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text $ + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount payer + +infos + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> Map UserId Int + -> Int + -> m () +infos users currency repartition paymentCount = + R.divClass "g-PaymentHeaderInfos__Repartition" $ do + + R.elClass "span" "total" $ do + R.text $ + Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency (M.foldl (+) 0 repartition)) + + R.elClass "span" "partition" . R.text $ + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . M.toList + $ repartition + in T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs new file mode 100644 index 0000000..26444d7 --- /dev/null +++ b/client/src/View/Payment/Payment.hs @@ -0,0 +1,101 @@ +module View.Payment.Payment + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentId, + PaymentPage (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderForm as HeaderForm +import qualified View.Payment.HeaderInfos as HeaderInfos +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table + +data In t = In + { _in_currentUser :: UserId + , _in_users :: [User] + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + + categories <- AjaxUtil.getNow "api/allCategories" + + R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do + + rec + paymentPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_search = HeaderForm._out_search form + , Reducer._in_frequency = HeaderForm._out_frequency form + , Reducer._in_addPayment = addPayment + , Reducer._in_editPayment = editPayment + , Reducer._in_deletePayment = deletePayment + } + + let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + let addPayment = + R.leftmost + [ tableAddPayment + , HeaderForm._out_addPayment form + ] + + page <- eventFromResult $ Pages._out_newPage . snd + tableAddPayment <- eventFromResult $ Table._out_add . fst + editPayment <- eventFromResult $ Table._out_edit . fst + deletePayment <- eventFromResult $ Table._out_delete . fst + + form <- HeaderForm.view $ HeaderForm.In + { HeaderForm._in_reset = () <$ addPayment + , HeaderForm._in_categories = categories + } + + result <- Loadable.viewShowValueWhileLoading paymentPage $ + \(PaymentPage page frequency header payments count) -> do + + HeaderInfos.view $ HeaderInfos.In + { HeaderInfos._in_users = _in_users input + , HeaderInfos._in_currency = _in_currency input + , HeaderInfos._in_header = header + , HeaderInfos._in_paymentCount = count + } + + table <- Table.view $ Table.In + { Table._in_users = _in_users input + , Table._in_currentUser = _in_currentUser input + , Table._in_categories = categories + , Table._in_currency = _in_currency input + , Table._in_payments = payments + , Table._in_frequency = frequency + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (table, pages) + + return () + + return () diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs new file mode 100644 index 0000000..3fe59b2 --- /dev/null +++ b/client/src/View/Payment/Reducer.hs @@ -0,0 +1,110 @@ +module View.Payment.Reducer + ( perPage + , reducer + , In(..) + , Params(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Frequency (..), PaymentPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_search :: Event t Text + , _in_frequency :: Event t Frequency + , _in_addPayment :: Event t a + , _in_editPayment :: Event t b + , _in_deletePayment :: Event t c + } + +data Params = Params + { _params_page :: Int + , _params_search :: Text + , _params_frequency :: Frequency + } deriving (Show) + +initParams = Params 1 "" Punctual + +data Msg + = Page Int + | Search Text + | Frequency Common.Model.Frequency + | ResetSearch + deriving Show + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer input = do + + postBuild <- R.getPostBuild + + debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input) + + params <- R.foldDynMaybe + (\msg params -> case msg of + Page page -> + Just $ params { _params_page = page } + + Search "" -> + if _params_search params == "" then + Nothing + + else + Just $ initParams { _params_frequency = _params_frequency params } + + Search search -> + Just $ params { _params_search = search, _params_page = _params_page initParams } + + Frequency frequency -> + Just $ params { _params_frequency = frequency, _params_page = _params_page initParams } + + ResetSearch -> + Just $ initParams { _params_frequency = _params_frequency params } + ) + initParams + (R.leftmost + [ Page <$> _in_page input + , Search <$> debouncedSearch + , Frequency <$> _in_frequency input + , ResetSearch <$ _in_addPayment input + ]) + + let paramsEvent = + R.leftmost + [ initParams <$ postBuild + , R.updated params + , R.tag (R.current params) (_in_editPayment input) + , R.tag (R.current params) (_in_deletePayment input) + ] + + getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ paramsEvent + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl (Params page search frequency) = + "api/payments?page=" + <> (T.pack . show $ page) + <> "&perPage=" + <> (T.pack . show $ perPage) + <> "&search=" + <> search + <> "&frequency=" + <> (T.pack $ show frequency) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs new file mode 100644 index 0000000..bfa0fb9 --- /dev/null +++ b/client/src/View/Payment/Table.hs @@ -0,0 +1,143 @@ +module View.Payment.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, + Frequency (..), Payment (..), + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Payment.Form as Form + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] + , _in_frequency :: Frequency + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel (_in_frequency input) + , Table._in_rows = _in_payments input + , Table._in_cell = + cell + (_in_users input) + (_in_categories input) + (_in_frequency input) + (_in_currency input) + , Table._in_cloneModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.Clone payment + , Form._in_frequency = _in_frequency input + } + , Table._in_editModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.Edit payment + , Form._in_frequency = _in_frequency input + } + , Table._in_deleteModal = \payment -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_canEdit = (== (_in_currentUser input)) . _payment_user + , Table._in_canDelete = (== (_in_currentUser input)) . _payment_user + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | CostHeader + | UserHeader + | CategoryHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Frequency -> Header -> Text +headerLabel _ NameHeader = Msg.get Msg.Payment_Name +headerLabel _ CostHeader = Msg.get Msg.Payment_Cost +headerLabel _ UserHeader = Msg.get Msg.Payment_User +headerLabel _ CategoryHeader = Msg.get Msg.Payment_Category +headerLabel Punctual DateHeader = Msg.get Msg.Payment_Date +headerLabel Monthly DateHeader = "" + +cell + :: forall t m. MonadWidget t m + => [User] + -> [Category] + -> Frequency + -> Currency + -> Header + -> Payment + -> m () +cell users categories frequency currency header payment = + case header of + NameHeader -> + R.text $ _payment_name payment + + CostHeader -> + R.text . Format.price currency . _payment_cost $ payment + + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users + + CategoryHeader -> + let + category = + L.find ((== (_payment_category payment)) . _category_id) categories + in + Maybe.fromMaybe R.blank . flip fmap category $ \c -> + Tag.view $ Tag.In + { Tag._in_text = _category_name c + , Tag._in_color = _category_color c + } + + DateHeader -> + if frequency == Punctual then + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment + else + R.blank |