aboutsummaryrefslogtreecommitdiff
path: root/client/src/View/Income
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View/Income')
-rw-r--r--client/src/View/Income/Form.hs119
-rw-r--r--client/src/View/Income/Header.hs77
-rw-r--r--client/src/View/Income/Income.hs75
-rw-r--r--client/src/View/Income/Reducer.hs59
-rw-r--r--client/src/View/Income/Table.hs93
5 files changed, 423 insertions, 0 deletions
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
new file mode 100644
index 0000000..59f6a0d
--- /dev/null
+++ b/client/src/View/Income/Form.hs
@@ -0,0 +1,119 @@
+module View.Income.Form
+ ( view
+ , In(..)
+ , Operation(..)
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (Value)
+import qualified Data.Aeson as Aeson
+import qualified Data.Maybe as Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Time.Calendar as Calendar
+import qualified Data.Time.Clock as Time
+import Data.Validation (Validation)
+import qualified Data.Validation as V
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (CreateIncomeForm (..),
+ EditIncomeForm (..), Income (..))
+import qualified Common.Msg as Msg
+import qualified Common.Util.Time as TimeUtil
+import qualified Common.Validation.Income as IncomeValidation
+import qualified Component.Input as Input
+import qualified Component.Modal as Modal
+import qualified Component.ModalForm as ModalForm
+import qualified Util.Ajax as Ajax
+
+data In = In
+ { _in_operation :: Operation
+ }
+
+data Operation
+ = New
+ | Clone Income
+ | Edit Income
+
+view :: forall t m a. MonadWidget t m => In -> 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/income"
+ , 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 Text Value))
+ form reset confirm = do
+ amount <- Input._out_raw <$> (Input.view
+ (Input.defaultIn
+ { Input._in_label = Msg.get Msg.Income_Amount
+ , Input._in_initialValue = amount
+ , Input._in_validation = IncomeValidation.amount
+ })
+ (amount <$ reset)
+ confirm)
+
+ currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+ let initialDate = T.pack . Calendar.showGregorian $ date currentDay
+
+ date <- Input._out_raw <$> (Input.view
+ (Input.defaultIn
+ { Input._in_label = Msg.get Msg.Income_Date
+ , Input._in_initialValue = initialDate
+ , Input._in_inputType = "date"
+ , Input._in_hasResetButton = False
+ , Input._in_validation = IncomeValidation.date
+ })
+ (initialDate <$ reset)
+ confirm)
+
+ return $ do
+ a <- amount
+ d <- date
+ return . V.Success $ mkPayload a d
+
+ op = _in_operation input
+
+ amount =
+ case op of
+ New -> ""
+ Clone i -> T.pack . show . _income_amount $ i
+ Edit i -> T.pack . show . _income_amount $ i
+
+ date currentDay =
+ case op of
+ Edit i -> _income_date i
+ _ -> currentDay
+
+ ajax =
+ case op of
+ Edit _ -> Ajax.put
+ _ -> Ajax.post
+
+ headerLabel =
+ case op of
+ Edit _ -> Msg.get Msg.Income_Edit
+ _ -> Msg.get Msg.Income_AddLong
+
+ mkPayload =
+ case op of
+ Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b
+ _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
new file mode 100644
index 0000000..a26e16a
--- /dev/null
+++ b/client/src/View/Income/Header.hs
@@ -0,0 +1,77 @@
+module View.Income.Header
+ ( view
+ , In(..)
+ , Out(..)
+ ) 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.Clock as Clock
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Currency, Income (..),
+ IncomeHeader (..), User (..))
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import qualified Common.View.Format as Format
+
+import qualified Component.Button as Button
+import qualified Component.Modal as Modal
+import qualified View.Income.Form as Form
+
+data In t = In
+ { _in_users :: [User]
+ , _in_header :: IncomeHeader
+ , _in_currency :: Currency
+ }
+
+data Out t = Out
+ { _out_add :: Event t ()
+ }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input =
+ R.divClass "withMargin" $ do
+
+ currentTime <- liftIO Clock.getCurrentTime
+
+ case _incomeHeader_since $ _in_header input of
+ Nothing ->
+ R.blank
+
+ Just since ->
+ R.el "div" $ do
+
+ R.el "h1" $ do
+ R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since))
+
+ R.el "ul" $
+ flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) ->
+ R.el "li" $
+ R.text $
+ T.intercalate " "
+ [ Maybe.fromMaybe "" . fmap _user_name $ CM.findUser userId (_in_users input)
+ , "−"
+ , Format.price (_in_currency input) amount
+ ]
+
+ R.divClass "titleButton" $ do
+ R.el "h1" $
+ R.text $
+ Msg.get Msg.Income_MonthlyNet
+
+ addIncome <- Button._out_clic <$>
+ (Button.view . Button.defaultIn . R.text $
+ Msg.get Msg.Income_AddLong)
+
+ addIncome <- Modal.view $ Modal.In
+ { Modal._in_show = addIncome
+ , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
+ }
+
+ return $ Out
+ { _out_add = addIncome
+ }
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
new file mode 100644
index 0000000..7be8091
--- /dev/null
+++ b/client/src/View/Income/Income.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+module View.Income.Income
+ ( view
+ , In(..)
+ ) where
+
+import Data.Aeson (FromJSON)
+import qualified Data.Maybe as Maybe
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Currency, Income (..), IncomePage (..),
+ User, UserId)
+
+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 Util.Reflex as ReflexUtil
+import qualified View.Income.Header as Header
+import qualified View.Income.Reducer as Reducer
+import qualified View.Income.Table as Table
+
+data In t = In
+ { _in_users :: [User]
+ , _in_currentUser :: UserId
+ , _in_currency :: Currency
+ }
+
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input = do
+ rec
+ incomePage <- Reducer.reducer $ Reducer.In
+ { Reducer._in_page = page
+ , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome]
+ , Reducer._in_editIncome = editIncome
+ , Reducer._in_deleteIncome = deleteIncome
+ }
+
+ let eventFromResult :: forall a. ((Header.Out t, 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
+
+ page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
+ headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
+ tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
+ editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
+ deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
+
+ result <- Loadable.viewShowValueWhileLoading incomePage $
+ \(IncomePage page header incomes count) -> do
+ header <- Header.view $ Header.In
+ { Header._in_users = _in_users input
+ , Header._in_header = header
+ , Header._in_currency = _in_currency input
+ }
+
+ table <- Table.view $ Table.In
+ { Table._in_currentUser = _in_currentUser input
+ , Table._in_currency = _in_currency input
+ , Table._in_incomes = incomes
+ , Table._in_users = _in_users input
+ }
+
+ pages <- Pages.view $ Pages.In
+ { Pages._in_total = R.constDyn count
+ , Pages._in_perPage = Reducer.perPage
+ , Pages._in_page = page
+ }
+
+ return (header, table, pages)
+
+ return ()
diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs
new file mode 100644
index 0000000..ea9f664
--- /dev/null
+++ b/client/src/View/Income/Reducer.hs
@@ -0,0 +1,59 @@
+module View.Income.Reducer
+ ( perPage
+ , reducer
+ , In(..)
+ ) where
+
+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 (IncomePage)
+
+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_addIncome :: Event t a
+ , _in_editIncome :: Event t b
+ , _in_deleteIncome :: Event t c
+ }
+
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage))
+reducer input = do
+
+ postBuild <- R.getPostBuild
+
+ currentPage <- R.holdDyn 1 (_in_page input)
+
+ let loadPage =
+ R.leftmost
+ [ 1 <$ postBuild
+ , _in_page input
+ , 1 <$ _in_addIncome input
+ , R.tag (R.current currentPage) (_in_editIncome input)
+ , R.tag (R.current currentPage) (_in_deleteIncome input)
+ ]
+
+ getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+
+ R.holdDyn
+ Loading
+ (R.leftmost
+ [ Loading <$ loadPage
+ , Loadable.fromEither <$> getResult
+ ])
+
+ where
+ pageUrl p =
+ "api/incomes?page="
+ <> (T.pack . show $ p)
+ <> "&perPage="
+ <> (T.pack . show $ perPage)
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
new file mode 100644
index 0000000..7b7940d
--- /dev/null
+++ b/client/src/View/Income/Table.hs
@@ -0,0 +1,93 @@
+module View.Income.Table
+ ( view
+ , In(..)
+ , Out(..)
+ ) where
+
+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 (Currency, Income (..), 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 Util.Ajax as Ajax
+import qualified Util.Either as EitherUtil
+import qualified View.Income.Form as Form
+
+data In t = In
+ { _in_currentUser :: UserId
+ , _in_currency :: Currency
+ , _in_incomes :: [Income]
+ , _in_users :: [User]
+ }
+
+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
+ , Table._in_rows = _in_incomes input
+ , Table._in_cell = cell (_in_users input) (_in_currency input)
+ , Table._in_cloneModal = \income ->
+ Form.view $ Form.In
+ { Form._in_operation = Form.Clone income
+ }
+ , Table._in_editModal = \income ->
+ Form.view $ Form.In
+ { Form._in_operation = Form.Edit income
+ }
+ , Table._in_deleteModal = \income ->
+ ConfirmDialog.view $ ConfirmDialog.In
+ { ConfirmDialog._in_header = Msg.get Msg.Income_DeleteConfirm
+ , ConfirmDialog._in_confirm = \e -> do
+ res <- Ajax.delete
+ (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income])
+ e
+ return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+ }
+ , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId
+ , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId
+ }
+
+ return $ Out
+ { _out_add = Table._out_add table
+ , _out_edit = Table._out_edit table
+ , _out_delete = Table._out_delete table
+ }
+
+data Header
+ = UserHeader
+ | AmountHeader
+ | DateHeader
+ deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel UserHeader = Msg.get Msg.Income_Name
+headerLabel DateHeader = Msg.get Msg.Income_Date
+headerLabel AmountHeader = Msg.get Msg.Income_Amount
+
+cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m ()
+cell users currency header income =
+ case header of
+ UserHeader ->
+ R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
+
+ DateHeader ->
+ R.text . Format.longDay . _income_date $ income
+
+ AmountHeader ->
+ R.text . Format.price currency . _income_amount $ income
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 13:09:06 +0000