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/Table.hs | 315 ++++++++++++++++----------------------- 1 file changed, 126 insertions(+), 189 deletions(-) (limited to 'client/src/View/Payment/Table.hs') diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0793836..dde5168 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,209 +4,146 @@ module View.Payment.Table , Out(..) ) where -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 Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Currency, - Frequency (Punctual), Payment (..), - PaymentCategory (..), SavedPayment, - User (..), UserId) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified View.Payment.Clone as Clone -import qualified View.Payment.Delete as Delete -import qualified View.Payment.Edit as Edit -import View.Payment.Init (Init (..)) - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon +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 Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, Payment (..), + PaymentCategory (..), SavedPayment, + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Payment.Form as Form data In t = In - { _in_init :: Init - , _in_currency :: Currency + { _in_users :: [User] , _in_currentUser :: UserId - , _in_currentPage :: Dynamic t Int - , _in_payments :: Dynamic t [Payment] - , _in_perPage :: Int - , _in_paymentCategories :: Dynamic t [PaymentCategory] , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] + , _in_paymentCategories :: [PaymentCategory] } data Out t = Out - { _out_addPayment :: Event t SavedPayment - , _out_editPayment :: Event t SavedPayment - , _out_deletePayment :: Event t Payment + { _out_add :: Event t SavedPayment + , _out_edit :: Event t SavedPayment + , _out_delete :: Event t Payment } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - R.divClass "table" $ do - - (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do - R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name - R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost - R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User - R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category - R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - - result <- - (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories)) - - return $ - ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result - ) - - ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ - R.text $ Msg.get Msg.Payment_Empty - - return $ Out - { _out_addPayment = addPayment - , _out_editPayment = editPayment - , _out_deletePayment = deletePayment - } - - where - init = _in_init input - currency = _in_currency input - currentUser = _in_currentUser input - currentPage = _in_currentPage input - payments = _in_payments input - paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage - paymentCategories = _in_paymentCategories input - -getPaymentRange :: Int -> [Payment] -> Int -> [Payment] -getPaymentRange perPage payments currentPage = - take perPage - . drop ((currentPage - 1) * perPage) - . reverse - . L.sortOn _payment_date - $ payments - -paymentRow - :: forall t m. MonadWidget t m - => Init - -> Currency - -> UserId - -> Dynamic t [PaymentCategory] - -> Dynamic t Payment - -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) -paymentRow init currency currentUser paymentCategories payment = - R.divClass "row" $ do - - R.divClass "cell name" $ - R.dynText $ fmap _payment_name payment - - R.divClass "cell cost" $ - R.dynText $ fmap (Format.price currency . _payment_cost) payment - - let user = R.ffor payment (\p -> - CM.findUser (_payment_user p) (_init_users init)) - - R.divClass "cell user" $ - R.dynText $ flip fmap user $ \mbUser -> case mbUser of - Just u -> _user_name u - _ -> "" - - let category = do - p <- payment - pcs <- paymentCategories - return $ findCategory (_init_categories init) pcs (_payment_name p) - - R.divClass "cell category" $ do - - let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of - Just c -> M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - Nothing -> M.singleton "display" "none" - - R.elDynAttr "span" attrs $ - R.dynText $ R.ffor category $ \case - Just c -> _category_name c - _ -> "" - - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment - R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - - let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category - - clonePayment <- - R.divClass "cell button" $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.clone) - - paymentCloned <- - Modal.view $ Modal.In - { Modal._in_show = clonePayment - , Modal._in_content = - Clone.view $ Clone.In - { Clone._in_show = clonePayment - , Clone._in_categories = _init_categories init - , Clone._in_paymentCategories = paymentCategories - , Clone._in_payment = payment - , Clone._in_category = categoryId - } - } - let isFromCurrentUser = - R.ffor - payment - (\p -> _payment_user p == currentUser) - - editPayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.edit) - - paymentEdited <- - Modal.view $ Modal.In - { Modal._in_show = editPayment - , Modal._in_content = - Edit.view $ Edit.In - { Edit._in_show = editPayment - , Edit._in_categories = _init_categories init - , Edit._in_paymentCategories = paymentCategories - , Edit._in_payment = payment - , Edit._in_category = categoryId - } + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_cell = + cell + (_in_users input) + (_in_categories input) + (_in_paymentCategories input) + (_in_currency input) + , Table._in_cloneModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Clone payment } - - deletePayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - (Button.defaultIn Icon.delete) - { Button._in_class = R.constDyn "deletePayment" - }) - - paymentDeleted <- - Modal.view $ Modal.In - { Modal._in_show = deletePayment - , Modal._in_content = - Delete.view $ Delete.In - { Delete._in_payment = payment - } + , Table._in_editModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Edit payment } - - return $ (paymentCloned, paymentEdited, paymentDeleted) + , Table._in_deleteModal = \payment -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) + e + return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | CostHeader + | UserHeader + | CategoryHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Payment_Name +headerLabel CostHeader = Msg.get Msg.Payment_Cost +headerLabel UserHeader = Msg.get Msg.Payment_User +headerLabel CategoryHeader = Msg.get Msg.Payment_Category +headerLabel DateHeader = Msg.get Msg.Payment_Date + +cell + :: forall t m. MonadWidget t m + => [User] + -> [Category] + -> [PaymentCategory] + -> Currency + -> Header + -> Payment + -> m () +cell users categories paymentCategories currency header payment = + case header of + NameHeader -> + R.text $ _payment_name payment + + CostHeader -> + R.text . Format.price currency . _payment_cost $ payment + + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users + + CategoryHeader -> + let + category = + findCategory categories paymentCategories (_payment_name payment) + + attrs = + case category of + Just c -> + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + + Nothing -> + M.singleton "display" "none" + in + R.elAttr "span" attrs $ + R.text $ + Maybe.fromMaybe "" (_category_name <$> category) + + DateHeader -> + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do -- cgit v1.2.3