From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 6 Nov 2019 19:44:15 +0100 Subject: Show the payment table with server side paging --- client/src/View/Payment/Form.hs | 137 +++++++++++++++++++++++++++------------- 1 file changed, 93 insertions(+), 44 deletions(-) (limited to 'client/src/View/Payment/Form.hs') diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 29768aa..99b0848 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,10 +1,12 @@ module View.Payment.Form ( view , In(..) - , Out(..) + , Operation(..) ) where -import Data.Aeson (ToJSON) +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 @@ -13,6 +15,7 @@ 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.Time.Clock as Clock import Data.Validation (Validation) import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -20,103 +23,98 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), Frequency (..), Payment (..), PaymentCategory (..), SavedPayment (..)) 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.Validation as ValidationUtil -data In m t a = In - { _in_cancel :: Event t () - , _in_headerLabel :: Text - , _in_categories :: [Category] +data In = In + { _in_categories :: [Category] , _in_paymentCategories :: [PaymentCategory] - , _in_name :: Text - , _in_cost :: Text - , _in_date :: Day - , _in_category :: CategoryId - , _in_frequency :: Frequency - , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a - , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) + , _in_operation :: Operation } -data Out t = Out - { _output_hide :: Event t () - , _output_addPayment :: Event t SavedPayment - } +data Operation + = New Frequency + | Clone Payment + | Edit Payment -view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) -view input = do +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view input cancel = do rec let reset = R.leftmost [ "" <$ ModalForm._out_cancel modalForm , "" <$ ModalForm._out_validate modalForm - , "" <$ _in_cancel input + , "" <$ cancel ] modalForm <- ModalForm.view $ ModalForm.In - { ModalForm._in_headerLabel = _in_headerLabel input - , ModalForm._in_ajax = _in_ajax input "/api/payment" + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Out - { _output_hide = ModalForm._out_hide modalForm - , _output_addPayment = ModalForm._out_validate modalForm - } + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) where + form :: Event t String -> Event t () - -> m (Dynamic t (Validation (NonEmpty Text) a)) + -> 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 = _in_name input + , Input._in_initialValue = name , Input._in_validation = PaymentValidation.name }) - (_in_name input <$ reset) + (name <$ reset) confirm cost <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Cost - , Input._in_initialValue = _in_cost input + , Input._in_initialValue = cost , Input._in_validation = PaymentValidation.cost }) - (_in_cost input <$ reset) + (cost <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _in_date $ input + d <- date date <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = initialDate + , Input._in_initialValue = d , Input._in_inputType = "date" , Input._in_hasResetButton = False , Input._in_validation = PaymentValidation.date }) - (initialDate <$ reset) + (d <$ reset) confirm) let setCategory = R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) $ \name -> - findCategory name (_in_paymentCategories input) + R.ffor (Input._out_raw name) findCategory category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category - , Select._in_initialValue = _in_category input + , Select._in_initialValue = category , Select._in_value = setCategory , Select._in_values = R.constDyn categories - , Select._in_reset = _in_category input <$ reset + , Select._in_reset = category <$ reset , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) , Select._in_validate = confirm }) @@ -126,12 +124,12 @@ view input = do c <- cost d <- date cat <- category - return ((_in_mkPayload input) + return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success (_in_frequency input)) + <*> V.Success frequency) frequencies = M.fromList @@ -142,7 +140,58 @@ view input = do categories = M.fromList . flip map (_in_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) + 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 + + category = + case op of + New _ -> -1 + Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + + frequency = + case op of + New f -> f + 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 + + findCategory :: Text -> Maybe CategoryId + findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + $ (_in_paymentCategories input) -- cgit v1.2.3