aboutsummaryrefslogtreecommitdiff
path: root/client/src/View/Payment
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View/Payment')
-rw-r--r--client/src/View/Payment/Add.hs3
-rw-r--r--client/src/View/Payment/Clone.hs3
-rw-r--r--client/src/View/Payment/Edit.hs3
-rw-r--r--client/src/View/Payment/Form.hs205
4 files changed, 96 insertions, 118 deletions
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 28c0148..163a200 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -17,6 +17,7 @@ import Common.Model (Category (..), CreatePaymentForm (..),
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
@@ -45,7 +46,7 @@ view input cancel = do
, Form._input_category = -1
, Form._input_frequency = frequency
, Form._input_mkPayload = CreatePaymentForm
- , Form._input_httpMethod = Form.Post
+ , Form._input_ajax = Ajax.post
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 60694ca..2fa27f3 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -17,6 +17,7 @@ import Common.Model (Category (..), CategoryId,
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
@@ -48,7 +49,7 @@ view input cancel = do
, Form._input_category = category
, Form._input_frequency = _payment_frequency payment
, Form._input_mkPayload = CreatePaymentForm
- , Form._input_httpMethod = Form.Post
+ , Form._input_ajax = Ajax.post
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 0361602..77841ce 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -14,6 +14,7 @@ import Common.Model (Category (..), CategoryId,
SavedPayment (..))
import qualified Common.Msg as Msg
import qualified Component.Modal as Modal
+import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
@@ -43,7 +44,7 @@ view input cancel = do
, Form._input_category = category
, Form._input_frequency = _payment_frequency payment
, Form._input_mkPayload = EditPaymentForm (_payment_id payment)
- , Form._input_httpMethod = Form.Put
+ , Form._input_ajax = Ajax.put
}
hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index c817831..1f068fd 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,23 +1,21 @@
module View.Payment.Form
( view
, Input(..)
- , HttpMethod(..)
, Output(..)
) where
-import Control.Monad (join)
-import Control.Monad.IO.Class (liftIO)
import Data.Aeson (ToJSON)
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.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
+import Data.Validation (Validation)
import qualified Data.Validation as V
-import Reflex.Dom (Dynamic, Event, MonadHold,
- MonadWidget, Reflex)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Text.Read as T
@@ -27,16 +25,13 @@ import Common.Model (Category (..), CategoryId,
SavedPayment (..))
import qualified Common.Msg as Msg
import qualified Common.Validation.Payment as PaymentValidation
-import Component (ButtonIn (..), InputIn (..),
- InputOut (..), SelectIn (..),
- SelectOut (..))
+import Component (InputIn (..), InputOut (..),
+ ModalFormIn (..), ModalFormOut (..),
+ SelectIn (..), SelectOut (..))
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 Input t p = Input
+data Input m t a = Input
{ _input_cancel :: Event t ()
, _input_headerLabel :: Text
, _input_categories :: [Category]
@@ -46,114 +41,99 @@ data Input t p = Input
, _input_date :: Day
, _input_category :: CategoryId
, _input_frequency :: Frequency
- , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> p
- , _input_httpMethod :: HttpMethod
+ , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a
+ , _input_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
}
-data HttpMethod = Put | Post
-
data Output t = Output
{ _output_hide :: Event t ()
, _output_addPayment :: Event t SavedPayment
}
-view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t)
+view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t)
view input = do
- R.divClass "form" $ do
- R.divClass "formHeader" $
- R.text (_input_headerLabel input)
-
- R.divClass "formContent" $ do
- rec
- let reset = R.leftmost
- [ "" <$ cancel
- , "" <$ addPayment
- , "" <$ _input_cancel input
- ]
-
- name <- Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Name
- , _inputIn_initialValue = _input_name input
- , _inputIn_validation = PaymentValidation.name
- })
- (_input_name input <$ reset)
- confirm
-
- cost <- _inputOut_raw <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Cost
- , _inputIn_initialValue = _input_cost input
- , _inputIn_validation = PaymentValidation.cost
- })
- (_input_cost input <$ reset)
- confirm)
-
- let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
-
- date <- _inputOut_raw <$> (Component.input
- (Component.defaultInputIn
- { _inputIn_label = Msg.get Msg.Payment_Date
- , _inputIn_initialValue = initialDate
- , _inputIn_inputType = "date"
- , _inputIn_hasResetButton = False
- , _inputIn_validation = PaymentValidation.date
- })
- (initialDate <$ reset)
- confirm)
-
- let setCategory =
- R.fmapMaybe id . R.updated $
- R.ffor (_inputOut_raw name) $ \name ->
- findCategory name (_input_paymentCategories input)
-
- category <- _selectOut_value <$> (Component.select $ SelectIn
- { _selectIn_label = Msg.get Msg.Payment_Category
- , _selectIn_initialValue = _input_category input
- , _selectIn_value = setCategory
- , _selectIn_values = R.constDyn categories
- , _selectIn_reset = _input_category input <$ reset
- , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
- , _selectIn_validate = confirm
- })
-
- let payment = do
- n <- _inputOut_value name
- c <- cost
- d <- date
- cat <- category
- return ((_input_mkPayload input)
- <$> ValidationUtil.nelError n
- <*> V.Success c
- <*> V.Success d
- <*> ValidationUtil.nelError cat
- <*> V.Success (_input_frequency input))
-
- (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" })
-
- 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
- })
-
- (addPayment, waiting) <- WaitFor.waitFor
- (ajax "/api/payment")
- (ValidationUtil.fireValidation payment confirm)
-
- return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
-
- return Output
- { _output_hide = R.leftmost [ cancel, () <$ addPayment ]
- , _output_addPayment = addPayment
- }
+ rec
+ let reset = R.leftmost
+ [ "" <$ _modalFormOut_cancel modalForm
+ , "" <$ _modalFormOut_validate modalForm
+ , "" <$ _input_cancel input
+ ]
+
+ modalForm <- Component.modalForm $ ModalFormIn
+ { _modalFormIn_headerLabel = _input_headerLabel input
+ , _modalFormIn_ajax = _input_ajax input "/api/payment"
+ , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm)
+ }
+
+ return $ Output
+ { _output_hide = _modalFormOut_hide modalForm
+ , _output_addPayment = _modalFormOut_validate modalForm
+ }
where
+ form
+ :: Event t String
+ -> Event t ()
+ -> m (Dynamic t (Validation (NonEmpty Text) a))
+ form reset confirm = do
+ name <- Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Name
+ , _inputIn_initialValue = _input_name input
+ , _inputIn_validation = PaymentValidation.name
+ })
+ (_input_name input <$ reset)
+ confirm
+
+ cost <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Cost
+ , _inputIn_initialValue = _input_cost input
+ , _inputIn_validation = PaymentValidation.cost
+ })
+ (_input_cost input <$ reset)
+ confirm)
+
+ let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
+
+ date <- _inputOut_raw <$> (Component.input
+ (Component.defaultInputIn
+ { _inputIn_label = Msg.get Msg.Payment_Date
+ , _inputIn_initialValue = initialDate
+ , _inputIn_inputType = "date"
+ , _inputIn_hasResetButton = False
+ , _inputIn_validation = PaymentValidation.date
+ })
+ (initialDate <$ reset)
+ confirm)
+
+ let setCategory =
+ R.fmapMaybe id . R.updated $
+ R.ffor (_inputOut_raw name) $ \name ->
+ findCategory name (_input_paymentCategories input)
+
+ category <- _selectOut_value <$> (Component.select $ SelectIn
+ { _selectIn_label = Msg.get Msg.Payment_Category
+ , _selectIn_initialValue = _input_category input
+ , _selectIn_value = setCategory
+ , _selectIn_values = R.constDyn categories
+ , _selectIn_reset = _input_category input <$ reset
+ , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
+ , _selectIn_validate = confirm
+ })
+
+ return $ do
+ n <- _inputOut_value name
+ c <- cost
+ d <- date
+ cat <- category
+ return ((_input_mkPayload input)
+ <$> ValidationUtil.nelError n
+ <*> V.Success c
+ <*> V.Success d
+ <*> ValidationUtil.nelError cat
+ <*> V.Success (_input_frequency input))
+
frequencies =
M.fromList
[ (Punctual, Msg.get Msg.Payment_PunctualMale)
@@ -163,11 +143,6 @@ view input = do
categories = M.fromList . flip map (_input_categories input) $ \c ->
(_category_id c, _category_name c)
- ajax =
- case _input_httpMethod input of
- Post -> Ajax.post
- Put -> Ajax.put
-
findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
findCategory paymentName =
fmap _paymentCategory_category