Show the payment table with server side paging

1 files changed, 93 insertions, 44 deletions

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)