diff options
Diffstat (limited to 'client/src/View/Payment/Form.hs')
| -rw-r--r-- | client/src/View/Payment/Form.hs | 165 |
1 files changed, 165 insertions, 0 deletions
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs new file mode 100644 index 0000000..ba54957 --- /dev/null +++ b/client/src/View/Payment/Form.hs @@ -0,0 +1,165 @@ +module View.Payment.Form + ( view + , Input(..) + , Output(..) + ) where + +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) +import qualified Data.List as L +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 qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadHold, + MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CategoryId, + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), 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 + { _input_cancel :: Event t () + , _input_headerLabel :: Text + , _input_categories :: [Category] + , _input_paymentCategories :: [PaymentCategory] + , _input_name :: Text + , _input_cost :: Text + , _input_date :: Day + , _input_category :: CategoryId + , _input_frequency :: Frequency + , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + } + +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 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_value <$> (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_value <$> (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 = (/= -1) + , _selectIn_validate = confirm + }) + + let payment = do + n <- _inputOut_value name + c <- cost + d <- date + cat <- category + return ((_input_mkPayload input) + <$> ValidationUtil.nelError n + <*> ValidationUtil.nelError c + <*> ValidationUtil.nelError 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.postJson "/payment") + (ValidationUtil.fireValidation payment confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) + + return Output + { _output_hide = R.leftmost [ cancel, () <$ addPayment ] + , _output_addPayment = addPayment + } + + where + frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_input_categories input) $ \c -> + (_category_id c, _category_name c) + + +findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId +findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) |