diff options
Diffstat (limited to 'client/src/View/Payment/Form.hs')
| -rw-r--r-- | client/src/View/Payment/Form.hs | 199 |
1 files changed, 199 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..6c31fad --- /dev/null +++ b/client/src/View/Payment/Form.hs @@ -0,0 +1,199 @@ +module View.Payment.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +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 (NominalDiffTime) +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Payment as PaymentValidation + +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Component.Select as Select +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil + +data In t = In + { _in_categories :: [Category] + , _in_operation :: Operation t + , _in_frequency :: Frequency + } + +data Operation t + = New + | Clone Payment + | Edit Payment + +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m +view input cancel = do + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation (NonEmpty Text) Value)) + form reset confirm = do + name <- Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Name + , Input._in_initialValue = name + , Input._in_validation = PaymentValidation.name + }) + (name <$ reset) + confirm + + cost <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Cost + , Input._in_initialValue = cost + , Input._in_validation = PaymentValidation.cost + }) + (cost <$ reset) + confirm) + + currentDate <- date + + date <- + case frequency of + Punctual -> do + Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = currentDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date + }) + (currentDate <$ reset) + confirm) + Monthly -> + return . R.constDyn $ currentDate + + setCategory <- + R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (return . R.ffilter (\name -> T.length name >= 3)) + >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) + >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) + + category <- Select._out_value <$> (Select.view $ Select.In + { Select._in_label = Msg.get Msg.Payment_Category + , Select._in_initialValue = category + , Select._in_value = setCategory + , Select._in_values = R.constDyn categories + , Select._in_reset = category <$ reset + , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) + , Select._in_validate = confirm + }) + + return $ do + n <- Input._out_value name + c <- cost + d <- date + cat <- category + return (mkPayload + <$> ValidationUtil.nelError n + <*> V.Success c + <*> V.Success d + <*> ValidationUtil.nelError cat + <*> V.Success frequency) + + frequencies = + M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_in_categories input) $ \c -> + (_category_id c, _category_name c) + + category = + case op of + New -> -1 + Clone p -> _payment_category p + Edit p -> _payment_category p + + op = _in_operation input + + name = + case op of + New -> "" + Clone p -> _payment_name p + Edit p -> _payment_name p + + cost = + case op of + New -> "" + Clone p -> T.pack . show . _payment_cost $ p + Edit p -> T.pack . show . _payment_cost $ p + + date = do + currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay + return . T.pack . Calendar.showGregorian $ + case op of + New -> currentDay + Clone p -> currentDay + Edit p -> _payment_date p + + frequency = + case op of + New -> _in_frequency input + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p + + headerLabel = + case op of + New -> Msg.get Msg.Payment_Add + Clone _ -> Msg.get Msg.Payment_CloneLong + Edit _ -> Msg.get Msg.Payment_EditLong + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + mkPayload = + case op of + Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e + _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e |