Make payment edition to work on the frontend

12 files changed, 157 insertions, 97 deletions

diff --git a/ISSUES.md b/ISSUES.md
new file mode 100644
index 0000000..9ee077d
--- /dev/null
+++ b/ISSUES.md
@@ -0,0 +1,51 @@
+# Fix
+
+- When clicking on an input label, focus to the input
+
+# Payment view
+
+- Remove unused payment category after payment edit on frontend
+- Remove old validation, use client validation on the backend
+- Add icon tooltip ?
+- auto focus on first input when payment modal is open
+
+# Income view
+
+…
+
+# Category view
+
+…
+
+# Stat view
+
+…
+
+# Features
+
+- HTTP error message
+- Use only one loader
+- Login with email and password
+- search payments by:
+    - category,
+    - date.
+
+# Code
+
+- remove client warning messages
+- Use BEM style
+- Move the CSS out from the index page
+- Test exceedingPayers
+- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields)
+
+# DB
+
+- Add DB indexes
+
+# Tooling
+
+- deploy command
+- migration diff (use flyway?).
+- use ghcid
+- set up fast deploy
+- pin nixpkgs
diff --git a/README.md b/README.md
index bc9e98c..6e1c675 100644
--- a/README.md
+++ b/README.md
@@ -56,55 +56,6 @@ See [application.conf](application.conf).
 - [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html)
 - [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html)
 
-## TODO
+## Issues
 
-### Fix
-
-- When clicking on an input label, focus to the input
-
-### Payment view
-
-- Edit a payment
-- Possibly remove payment category after payment edit (frontend)
-- Remove old validation, use client validation on the backend
-- Add icon tooltip ?
-
-### Income view
-
-…
-
-### Category view
-
-…
-
-### Stat view
-
-…
-
-#### Bonus
-
-- HTTP error message
-- Use only one loader
-- Login with email and password
-- search payments by:
-    - category,
-    - date.
-
-### Code
-
-- remove client warning messages
-- Use BEM style
-- Move the CSS out from the index page
-- Add tests about exceedingPayers
-- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields)
-
-### DB
-
-- Add DB indexes
-
-### Tooling
-
-- deploy command
-- migration diff (use flyway?).
-- utiliser ghcid
-- set up fast deploy
+See [ISSUES.md](ISSUES.md).
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
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index c700240..38c1c19 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -47,10 +47,10 @@ edit (EditPayment paymentId name cost date category frequency) =
     result <- liftIO . Query.run $ do
       editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
       case editedPayment of
-        Just p -> do
+        Just (old, new) -> do
           pc <- PaymentCategoryPersistence.save name category
-          PaymentCategoryPersistence.deleteIfUnused name
-          return $ Just (p, pc)
+          PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
+          return $ Just (new, pc)
         Nothing ->
           return Nothing
     case result of
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index b3f2b2e..bcd7eb8 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -129,13 +129,13 @@ createMany payments =
       (map InsertRow payments)
   )
 
-edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment)
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment))
 edit userId paymentId name cost date frequency =
   Query (\conn -> do
     mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
       SQLite.query
         conn
-        "SELECT * FROM payment WHERE id = ? and userId = ?"
+        "SELECT * FROM payment WHERE id = ? and user_id = ?"
         (paymentId, userId)
     case mbPayment of
       Just payment -> do
@@ -163,7 +163,7 @@ edit userId paymentId name cost date frequency =
           , paymentId
           , userId
           )
-        return . Just $ Payment
+        return . Just . (,) payment $ Payment
           { _payment_id        = paymentId
           , _payment_user      = userId
           , _payment_name      = name
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 7dc363c..46be7f5 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -84,6 +84,6 @@ deleteIfUnused name =
   Query (\conn ->
     SQLite.execute
       conn
-      "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)"
+      "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)"
       (name, name)
   ) >> return ()