Show the payment table with server side paging

1 files changed, 126 insertions, 189 deletions

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