aboutsummaryrefslogtreecommitdiff
path: root/client
diff options
context:
space:
mode:
Diffstat (limited to 'client')
-rw-r--r--client/client.cabal2
-rw-r--r--client/src/Component.hs1
-rw-r--r--client/src/View/Income/Add.hs36
-rw-r--r--client/src/View/Income/Form.hs113
-rw-r--r--client/src/View/Income/Header.hs55
-rw-r--r--client/src/View/Income/Income.hs21
-rw-r--r--client/src/View/Income/Table.hs17
-rw-r--r--client/src/View/Payment/Delete.hs1
-rw-r--r--client/src/View/Payment/Header.hs14
9 files changed, 221 insertions, 39 deletions
diff --git a/client/client.cabal b/client/client.cabal
index 06e77e0..bfcfc59 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -65,6 +65,8 @@ Executable client
Util.WaitFor
View.App
View.Header
+ View.Income.Add
+ View.Income.Form
View.Income.Header
View.Income.Income
View.Income.Table
diff --git a/client/src/Component.hs b/client/src/Component.hs
index 4c51750..b715a83 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -4,7 +4,6 @@ import Component.Button as X
import Component.Form as X
import Component.Input as X
import Component.Link as X
-import Component.Modal as X
import Component.Pages as X
import Component.Select as X
import Component.Table as X
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
new file mode 100644
index 0000000..d83bb51
--- /dev/null
+++ b/client/src/View/Income/Add.hs
@@ -0,0 +1,36 @@
+module View.Income.Add
+ ( view
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Time.Clock as Time
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (CreateIncomeForm (..), Income)
+import qualified Common.Msg as Msg
+import qualified Common.Util.Time as TimeUtil
+import qualified Component.Modal as Modal
+import qualified Util.Reflex as ReflexUtil
+import View.Income.Form (FormIn (..), FormOut (..))
+import qualified View.Income.Form as Form
+
+view :: forall t m. MonadWidget t m => Modal.Content t m Income
+view cancel = do
+
+ currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+ form <- R.dyn $
+ return $ Form.view $ FormIn
+ { _formIn_cancel = cancel
+ , _formIn_headerLabel = Msg.get Msg.Income_AddLong
+ , _formIn_amount = ""
+ , _formIn_date = currentDay
+ , _formIn_mkPayload = CreateIncomeForm
+ , _formIn_httpMethod = Form.Post
+ }
+
+ hide <- ReflexUtil.flatten (_formOut_hide <$> form)
+ addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form)
+
+ return (hide, addIncome)
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
new file mode 100644
index 0000000..b8a9094
--- /dev/null
+++ b/client/src/View/Income/Form.hs
@@ -0,0 +1,113 @@
+module View.Income.Form
+ ( view
+ , FormIn(..)
+ , HttpMethod(..)
+ , FormOut(..)
+ ) where
+
+import Data.Aeson (ToJSON)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Calendar (Day)
+import qualified Data.Time.Calendar as Calendar
+import qualified Data.Validation as V
+import Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Income)
+import qualified Common.Msg as Msg
+import qualified Common.Validation.Income as IncomeValidation
+import Component (ButtonIn (..), InputIn (..),
+ InputOut (..))
+import qualified Component as Component
+import qualified Util.Ajax as Ajax
+import qualified Util.Either as EitherUtil
+import qualified Util.Validation as ValidationUtil
+import qualified Util.WaitFor as WaitFor
+
+data FormIn t i = FormIn
+ { _formIn_cancel :: Event t ()
+ , _formIn_headerLabel :: Text
+ , _formIn_amount :: Text
+ , _formIn_date :: Day
+ , _formIn_mkPayload :: Text -> Text -> i
+ , _formIn_httpMethod :: HttpMethod
+ }
+
+data HttpMethod = Put | Post
+
+data FormOut t = FormOut
+ { _formOut_hide :: Event t ()
+ , _formOut_addIncome :: Event t Income
+ }
+
+view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t)
+view formIn = do
+ R.divClass "form" $ do
+ R.divClass "formHeader" $
+ R.text (_formIn_headerLabel formIn)
+
+ R.divClass "formContent" $ do
+ rec
+ let reset = R.leftmost
+ [ "" <$ cancel
+ , "" <$ addIncome
+ , "" <$ _formIn_cancel formIn
+ ]
+
+ amount <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Income_Amount
+ , _inputIn_initialValue = _formIn_amount formIn
+ , _inputIn_validation = IncomeValidation.amount
+ })
+ (_formIn_amount formIn <$ reset)
+ confirm)
+
+ let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
+
+ date <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Income_Date
+ , _inputIn_initialValue = initialDate
+ , _inputIn_inputType = "date"
+ , _inputIn_hasResetButton = False
+ , _inputIn_validation = IncomeValidation.date
+ })
+ (initialDate <$ reset)
+ confirm)
+
+ let income = do
+ a <- amount
+ d <- date
+ return . V.Success $ (_formIn_mkPayload formIn) a d
+
+ (addIncome, 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" })
+
+ confirm <- Component._buttonOut_clic <$> (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+ { _buttonIn_class = R.constDyn "confirm"
+ , _buttonIn_waiting = waiting
+ , _buttonIn_submit = True
+ })
+
+ (addIncome, waiting) <- WaitFor.waitFor
+ (ajax "/api/income")
+ (ValidationUtil.fireValidation income confirm)
+
+ return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm)
+
+ return FormOut
+ { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ]
+ , _formOut_addIncome = addIncome
+ }
+
+ where
+ ajax =
+ case _formIn_httpMethod formIn of
+ Post -> Ajax.postJson
+ Put -> Ajax.putJson
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index b7170c9..e384161 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -1,33 +1,46 @@
module View.Income.Header
( view
, HeaderIn(..)
+ , HeaderOut(..)
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import qualified Data.Time.Clock as Clock
-import Reflex.Dom (MonadWidget)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Income (..), Init (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
+import Component (ButtonOut (..))
+import qualified Component
+import qualified Component.Modal as Modal
import qualified Util.Date as DateUtil
+import qualified View.Income.Add as Add
-data HeaderIn = HeaderIn
- { _headerIn_init :: Init
+data HeaderIn t = HeaderIn
+ { _headerIn_init :: Init
+ , _headerIn_incomes :: Dynamic t [Income]
}
-view :: forall t m. MonadWidget t m => HeaderIn -> m ()
+data HeaderOut t = HeaderOut
+ { _headerOut_addIncome :: Event t Income
+ }
+
+view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
view headerIn =
R.divClass "withMargin" $ do
currentTime <- liftIO Clock.getCurrentTime
- Maybe.fromMaybe R.blank $
- flip fmap useIncomesFrom $ \since ->
+ R.dyn . R.ffor useIncomesFrom $ \case
+ (Nothing, _) ->
+ R.blank
+
+ (Just since, incomes) ->
R.el "div" $ do
R.el "h1" $ do
@@ -38,23 +51,39 @@ view headerIn =
flip mapM_ (_init_users init) $ \user ->
R.el "li" $
R.text $ do
- let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init)
+ let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes
T.intercalate " "
[ _user_name user
, "−"
, Format.price (_init_currency init) $
- CM.cumulativeIncomesSince currentTime since incomes
+ CM.cumulativeIncomesSince currentTime since userIncomes
]
- R.divClass "titleButton" $
+ R.divClass "titleButton" $ do
R.el "h1" $
R.text $
Msg.get Msg.Income_MonthlyNet
+ addIncome <- _buttonOut_clic <$>
+ (Component.button . Component.defaultButtonIn . R.text $
+ Msg.get Msg.Income_AddLong)
+
+ addIncome <- Modal.view $ Modal.Input
+ { Modal._input_show = addIncome
+ , Modal._input_content = Add.view
+ }
+
+ return $ HeaderOut
+ { _headerOut_addIncome = addIncome
+ }
+
where
init = _headerIn_init headerIn
- useIncomesFrom = CM.useIncomesFrom
- (map _user_id $_init_users init)
- (_init_incomes init)
- (_init_payments init)
+ useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes ->
+ ( CM.useIncomesFrom
+ (map _user_id $_init_users init)
+ incomes
+ (_init_payments init)
+ , incomes
+ )
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index b0c6f0b..167aedf 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -3,11 +3,11 @@ module View.Income.Income
, IncomeIn(..)
) where
-import Reflex.Dom (MonadWidget)
+import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Init)
-import View.Income.Header (HeaderIn (..))
+import Common.Model (Init (..))
+import View.Income.Header (HeaderIn (..), HeaderOut (..))
import qualified View.Income.Header as Header
import View.Income.Table (IncomeTableIn (..))
import qualified View.Income.Table as Table
@@ -20,12 +20,21 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m ()
view incomeIn =
R.elClass "main" "income" $ do
- Header.view $ HeaderIn
- { _headerIn_init = _incomeIn_init incomeIn
- }
+ rec
+
+ incomes <- R.foldDyn
+ (:)
+ (_init_incomes . _incomeIn_init $ incomeIn)
+ (_headerOut_addIncome header)
+
+ header <- Header.view $ HeaderIn
+ { _headerIn_init = _incomeIn_init incomeIn
+ , _headerIn_incomes = incomes
+ }
Table.view $ IncomeTableIn
{ _tableIn_init = _incomeIn_init incomeIn
+ , _tableIn_incomes = incomes
}
return ()
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 2e8f4e6..5363ca5 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -6,7 +6,7 @@ module View.Income.Table
import qualified Data.List as L
import qualified Data.Maybe as Maybe
import Data.Text (Text)
-import Reflex.Dom (MonadWidget)
+import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Income (..), Init (..), User (..))
@@ -16,22 +16,17 @@ import qualified Common.View.Format as Format
import Component (TableIn (..))
import qualified Component
-data IncomeTableIn = IncomeTableIn
- { _tableIn_init :: Init
+data IncomeTableIn t = IncomeTableIn
+ { _tableIn_init :: Init
+ , _tableIn_incomes :: Dynamic t [Income]
}
-view :: forall t m. MonadWidget t m => IncomeTableIn -> m ()
+view :: forall t m. MonadWidget t m => IncomeTableIn t -> m ()
view tableIn = do
Component.table $ TableIn
{ _tableIn_headerLabel = headerLabel
- , _tableIn_rows =
- R.constDyn
- . reverse
- . L.sortOn _income_date
- . _init_incomes
- . _tableIn_init
- $ tableIn
+ , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date
, _tableIn_cell = cell (_tableIn_init tableIn)
, _tableIn_perPage = 7
, _tableIn_resetPage = R.never
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 521c1a7..dc7e395 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -13,6 +13,7 @@ import qualified Common.Msg as Msg
import Component (ButtonIn (..), ButtonOut (..))
import qualified Component as Component
import qualified Component.Modal as Modal
+import qualified Component.Modal as Modal
import qualified Util.Ajax as Ajax
import qualified Util.Either as EitherUtil
import qualified Util.WaitFor as WaitFor
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 6ed3b0e..9db4c7c 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -111,16 +111,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
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
- , _buttonIn_waiting = R.never
- , _buttonIn_tabIndex = Nothing
- , _buttonIn_submit = False
- })
+ addPayment <- _buttonOut_clic <$>
+ (Component.button $
+ (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add))
+ { _buttonIn_class = R.constDyn "addPayment"
+ })
Modal.view $ Modal.Input
- { Modal._input_show = addPaymentClic
+ { Modal._input_show = addPayment
, Modal._input_content = Add.view $ Add.Input
{ Add._input_categories = categories
, Add._input_paymentCategories = paymentCategories
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:24:12 +0000