Add income

8 files changed, 219 insertions, 39 deletions

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