Make payment edition to work on the frontend

7 files changed, 97 insertions, 39 deletions

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 7b65c52..a4f6a74 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,24 @@
 module Util.Ajax
   ( postJson
+  , putJson
   , delete
   ) where
 
-import           Control.Arrow      (left)
-import           Data.Aeson         (FromJSON, ToJSON)
-import qualified Data.Aeson         as Aeson
-import           Data.Default       (def)
-import qualified Data.Map.Lazy      as LM
-import           Data.Text          (Text)
-import qualified Data.Text          as T
-import qualified Data.Text.Encoding as T
-import           Reflex.Dom         (Dynamic, Event, IsXhrPayload, MonadWidget,
-                                     XhrRequest, XhrRequestConfig (..),
-                                     XhrResponse, XhrResponseHeaders (..))
-import qualified Reflex.Dom         as R
+import           Control.Arrow        (left)
+import           Data.Aeson           (FromJSON, ToJSON)
+import qualified Data.Aeson           as Aeson
+import           Data.ByteString      (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Default         (def)
+import qualified Data.Map.Lazy        as LM
+import           Data.Text            (Text)
+import qualified Data.Text            as T
+import qualified Data.Text.Encoding   as T
+import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
+                                       MonadWidget, XhrRequest,
+                                       XhrRequestConfig (..), XhrResponse,
+                                       XhrResponseHeaders (..))
+import qualified Reflex.Dom           as R
 
 postJson
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
@@ -23,7 +27,16 @@ postJson
   -> m (Event t (Either Text b))
 postJson url input =
   fmap getJsonResult <$>
-    R.performRequestAsync (R.postJson url <$> input)
+    R.performRequestAsync (jsonRequest "POST" url <$> input)
+
+putJson
+  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text b))
+putJson url input =
+  fmap getJsonResult <$>
+    R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
 delete
   :: forall t m a. (MonadWidget t m)
@@ -31,8 +44,9 @@ delete
   -> Event t ()
   -> m (Event t (Either Text Text))
 delete url fire = do
-  response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
-  return $ fmap getResult response
+  fmap getResult <$>
+    (R.performRequestAsync $
+      R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
 
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
 getJsonResult response =
@@ -50,7 +64,22 @@ getResult response =
     _ -> Left "NoKey"
 
 request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
-request method url sendData =
+request method url payload =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = payload
+      }
+  in
+    R.xhrRequest method url config
+
+jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString
+jsonRequest method url payload =
   let
     config = XhrRequestConfig
       { _xhrRequestConfig_headers = def
@@ -59,7 +88,7 @@ request method url sendData =
       , _xhrRequestConfig_responseType = def
       , _xhrRequestConfig_responseHeaders = def
       , _xhrRequestConfig_withCredentials = False
-      , _xhrRequestConfig_sendData = sendData
+      , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload
       }
   in
     R.xhrRequest method url config
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index ab83447..f2a5071 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -35,21 +35,25 @@ widget paymentIn = do
   R.elClass "main" "payment" $ do
     rec
       let init = _paymentIn_init paymentIn
+
           paymentsPerPage = 7
-          savedPayments = R.leftmost
+
+          addPayment = R.leftmost
             [ _headerOut_addPayment header
             , _tableOut_addPayment table
             ]
 
-      payments <- getPayments
+      payments <- reducePayments
         (_init_payments init)
-        (_savedPayment_payment <$> savedPayments)
+        (_savedPayment_payment <$> addPayment)
+        (_savedPayment_payment <$> _tableOut_editPayment table)
         (_tableOut_deletePayment table)
 
-      paymentCategories <- getPaymentCategories
+      paymentCategories <- reducePaymentCategories
         (_init_paymentCategories init)
-        (_savedPayment_paymentCategory <$> savedPayments)
         payments
+        (_savedPayment_paymentCategory <$> addPayment)
+        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
         (_tableOut_deletePayment table)
 
       (searchNameEvent, searchName) <-
@@ -93,28 +97,38 @@ debounceSearchName searchName = do
   dynamic <- R.holdDyn "" event
   return (event, dynamic)
 
-getPayments
+reducePayments
   :: forall t m. MonadWidget t m
   => [Payment]
-  -> Event t Payment
-  -> Event t Payment
+  -> Event t Payment -- add payment
+  -> Event t Payment -- edit payment
+  -> Event t Payment -- delete payment
   -> m (Dynamic t [Payment])
-getPayments initPayments addPayment deletePayment =
+reducePayments initPayments addPayment editPayment deletePayment =
   R.foldDyn id initPayments $ R.leftmost
     [ (:) <$> addPayment
+    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
     , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
     ]
 
-getPaymentCategories
+reducePaymentCategories
   :: forall t m. MonadWidget t m
   => [PaymentCategory]
-  -> Event t PaymentCategory  -- add payment category
   -> Dynamic t [Payment]      -- payments
+  -> Event t PaymentCategory  -- add payment category
+  -> Event t PaymentCategory  -- edit payment category
   -> Event t Payment          -- delete payment
   -> m (Dynamic t [PaymentCategory])
-getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment =
+reducePaymentCategories
+  initPaymentCategories
+  payments
+  addPaymentCategory
+  editPaymentCategory
+  deletePayment
+    =
   R.foldDyn id initPaymentCategories $ R.leftmost
     [ (:) <$> addPaymentCategory
+    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
     , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
     ]
   where
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 88806bc..e83dba9 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -46,6 +46,7 @@ view input cancel = do
       , Form._input_category = -1
       , Form._input_frequency = frequency
       , Form._input_mkPayload = CreatePayment
+      , Form._input_httpMethod = Form.Post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 5624f6c..922e89c 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -49,6 +49,7 @@ view input cancel = do
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
       , Form._input_mkPayload = CreatePayment
+      , Form._input_httpMethod = Form.Post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 5020e57..9c11af0 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -44,6 +44,7 @@ view input cancel = do
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
       , Form._input_mkPayload = EditPayment (_payment_id payment)
+      , Form._input_httpMethod = Form.Put
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index ba54957..9889638 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,6 +1,7 @@
 module View.Payment.Form
   ( view
   , Input(..)
+  , HttpMethod(..)
   , Output(..)
   ) where
 
@@ -46,8 +47,11 @@ data Input t p = Input
   , _input_category          :: CategoryId
   , _input_frequency         :: Frequency
   , _input_mkPayload         :: Text -> Int -> Day -> CategoryId -> Frequency -> p
+  , _input_httpMethod        :: HttpMethod
   }
 
+data HttpMethod = Put | Post
+
 data Output t = Output
   { _output_hide       :: Event t ()
   , _output_addPayment :: Event t SavedPayment
@@ -139,7 +143,7 @@ view input = do
                 })
 
             (addPayment, waiting) <- WaitFor.waitFor
-              (Ajax.postJson "/payment")
+              (ajax "/payment")
               (ValidationUtil.fireValidation payment confirm)
 
           return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
@@ -150,14 +154,19 @@ view input = do
         }
 
   where
-    frequencies = M.fromList
-      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
-      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
-      ]
+    frequencies =
+      M.fromList
+        [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+        , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+        ]
 
     categories = M.fromList . flip map (_input_categories input) $ \c ->
       (_category_id c, _category_name c)
 
+    ajax =
+      case _input_httpMethod input of
+        Post -> Ajax.postJson
+        Put  -> Ajax.putJson
 
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
 findCategory paymentName =
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index f2b8870..40bc864 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -44,6 +44,7 @@ data TableIn t = TableIn
 
 data TableOut t = TableOut
   { _tableOut_addPayment    :: Event t SavedPayment
+  , _tableOut_editPayment   :: Event t SavedPayment
   , _tableOut_deletePayment :: Event t Payment
   }
 
@@ -51,7 +52,7 @@ widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    (addPayment, deletePayment) <- R.divClass "lines" $ 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
@@ -66,8 +67,9 @@ widget tableIn = do
         (R.simpleList paymentRange (paymentRow init paymentCategories))
 
       return $
-        ( R.switch . R.current . fmap (R.leftmost . map fst) $ result
-        , R.switch . R.current . fmap (R.leftmost . map snd) $ result
+        ( 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" $
@@ -75,6 +77,7 @@ widget tableIn = do
 
     return $ TableOut
       { _tableOut_addPayment = addPayment
+      , _tableOut_editPayment = editPayment
       , _tableOut_deletePayment = deletePayment
       }
 
@@ -98,7 +101,7 @@ paymentRow
   => Init
   -> Dynamic t [PaymentCategory]
   -> Dynamic t Payment
-  -> m (Event t SavedPayment, Event t Payment)
+  -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
 
@@ -200,7 +203,7 @@ paymentRow init paymentCategories payment =
               }
         }
 
-    return $ (paymentCloned, paymentDeleted)
+    return $ (paymentCloned, paymentEdited, paymentDeleted)
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do