diff options
Diffstat (limited to 'client/src/View/Payment/Form.hs')
| -rw-r--r-- | client/src/View/Payment/Form.hs | 205 |
1 files changed, 90 insertions, 115 deletions
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 |