Use updated payment categories from payment add in payment’s table

11 files changed, 130 insertions, 72 deletions

diff --git a/README.md b/README.md
index 83a172c..a102f87 100644
--- a/README.md
+++ b/README.md
@@ -1,5 +1,4 @@
-Shared Cost
-===========
+# Shared Cost
 
 Share costs with a group of people:
 
@@ -8,8 +7,7 @@ Share costs with a group of people:
 - Statistics by month,
 - Weekly activity sent by email.
 
-Getting started
----------------
+## Getting started
 
 Install nix:
 
@@ -43,20 +41,22 @@ Later, stop the environment with:
 ./make stop
 ```
 
-Dist
-----
+## Dist
 
 ```
 make dist
 ```
 
-Configuration
--------------
+## Configuration
 
 See [application.conf](application.conf).
 
-TODO
-----
+## Documentation
+
+- [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
 
 ### Interface
 
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 67f97c0..d679f9b 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -53,7 +53,7 @@ input
 input inputIn reset validate = do
   rec
     let resetValue = R.leftmost
-          [ R.traceEvent "reset" reset
+          [ reset
           , fmap (const "") resetClic
           ]
 
@@ -83,7 +83,7 @@ input inputIn reset validate = do
         [ const (False, True) <$> resetClic
         , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput)
         , const (False, False) <$> validate
-        , const (True, False) <$> R.traceEvent "delayedReset" delayedReset
+        , const (True, False) <$> delayedReset
         ])
 
     (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 007471d..f614936 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -10,7 +10,8 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Frequency, Init (..), Payment (..),
+import           Common.Model        (CreatedPayment (..), Frequency, Init (..),
+                                      Payment (..), PaymentCategory (..),
                                       PaymentId)
 import qualified Common.Util.Text    as T
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
@@ -37,8 +38,12 @@ widget paymentIn = do
 
       payments <- getPayments
         (_init_payments init)
-        (_headerOut_addedPayment header)
-        (_tableOut_deletedPayment table)
+        (_createdPayment_payment <$> _headerOut_addPayment header)
+        (_tableOut_deletePayment table)
+
+      paymentCategories <- getPaymentCategories
+        (_init_paymentCategories init)
+        (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
 
       let searchPayments =
             getSearchPayments
@@ -56,6 +61,7 @@ widget paymentIn = do
         , _tableIn_currentPage = _pagesOut_currentPage pages
         , _tableIn_payments = searchPayments
         , _tableIn_perPage = paymentsPerPage
+        , _tableIn_paymentCategories = paymentCategories
         }
 
       pages <- Pages.widget $ PagesIn
@@ -63,7 +69,7 @@ widget paymentIn = do
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
             [ fmap (const ()) . R.updated . _headerOut_searchName $ header
-            , fmap (const ()) . _headerOut_addedPayment $ header
+            , fmap (const ()) . _headerOut_addPayment $ header
             ]
         }
 
@@ -75,10 +81,20 @@ getPayments
   -> Event t Payment
   -> Event t PaymentId
   -> m (Dynamic t [Payment])
-getPayments initPayments addedPayment deletedPayment =
+getPayments initPayments addPayment deletePayment =
   R.foldDyn id initPayments $ R.leftmost
-    [ flip fmap addedPayment (:)
-    , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    [ (:) <$> addPayment
+    , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    ]
+
+getPaymentCategories
+  :: forall t m. MonadWidget t m
+  => [PaymentCategory]
+  -> Event t PaymentCategory
+  -> m (Dynamic t [PaymentCategory])
+getPaymentCategories initPaymentCategories addPaymentCategory =
+  R.foldDyn id initPaymentCategories $ R.leftmost
+    [ (:) <$> addPaymentCategory
     ]
 
 getSearchPayments
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 62b26a3..2970394 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -16,7 +16,8 @@ import qualified Reflex.Dom                as R
 import qualified Text.Read                 as T
 
 import           Common.Model              (Category (..), CreatePayment (..),
-                                            Frequency (..), Payment (..))
+                                            CreatedPayment (..), Frequency (..),
+                                            Payment (..), PaymentCategory (..))
 import qualified Common.Msg                as Msg
 import qualified Common.Util.Time          as Time
 import qualified Common.Validation.Payment as PaymentValidation
@@ -35,8 +36,9 @@ data AddIn t = AddIn
   }
 
 data AddOut t = AddOut
-  { _addOut_cancel       :: Event t ()
-  , _addOut_addedPayment :: Event t Payment
+  { _addOut_cancel             :: Event t ()
+  , _addOut_addPayment         :: Event t CreatedPayment
+  , _addOut_addPaymentCategory :: Event t PaymentCategory
   }
 
 view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
@@ -48,7 +50,7 @@ view addIn = do
       rec
         let reset = R.leftmost
               [ const "" <$> cancel
-              , const "" <$> addedPayment
+              , const "" <$> addPayment
               , const "" <$> _addIn_cancel addIn
               ]
 
@@ -68,8 +70,10 @@ view addIn = do
           reset
           validate)
 
+        now <- liftIO Time.getCurrentTime
+
         currentDay <- do
-          d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+          d <- liftIO $ Time.timeToDay now
           return . T.pack . Calendar.showGregorian $ d
 
         date <- _inputOut_value <$> (Component.input
@@ -118,7 +122,7 @@ view addIn = do
                   <*> ValidationUtil.nelError (V.Success cat)
                   <*> ValidationUtil.nelError (V.Success f)
 
-        (addedPayment, cancel, validate) <- R.divClass "buttons" $ do
+        (addPayment, cancel, validate) <- R.divClass "buttons" $ do
           rec
             cancel <- Component._buttonOut_clic <$> (Component.button $
               (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
@@ -131,15 +135,15 @@ view addIn = do
                 , _buttonIn_submit = True
                 })
 
-            (result, waiting) <- WaitFor.waitFor
+            (addPayment, waiting) <- WaitFor.waitFor
               (Ajax.postJson "/payment")
               (ValidationUtil.fireValidation payment validate)
 
-          return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate)
+          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate)
 
       return AddOut
         { _addOut_cancel = cancel
-        , _addOut_addedPayment = addedPayment
+        , _addOut_addPayment = addPayment
         }
 
   where
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 56441eb..c49b284 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -17,10 +17,10 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Category, Currency,
-                                         ExceedingPayer (..), Frequency (..),
-                                         Income (..), Init (..), Payment (..),
-                                         User (..))
+import           Common.Model           (Category, CreatedPayment (..),
+                                         Currency, ExceedingPayer (..),
+                                         Frequency (..), Income (..), Init (..),
+                                         Payment (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -41,14 +41,14 @@ data HeaderIn t = HeaderIn
 data HeaderOut t = HeaderOut
   { _headerOut_searchName      :: Dynamic t Text
   , _headerOut_searchFrequency :: Dynamic t Frequency
-  , _headerOut_addedPayment    :: Event t Payment
+  , _headerOut_addPayment      :: Event t CreatedPayment
   }
 
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addedPayment <- payerAndAdd incomes punctualPayments users categories currency
-    let resetSearchName = fmap (const ()) $ addedPayment
+    addPayment <- payerAndAdd incomes punctualPayments users categories currency
+    let resetSearchName = fmap (const ()) $ addPayment
     (searchName, searchFrequency)  <- searchLine resetSearchName
 
     infos (_headerIn_searchPayments headerIn) users currency
@@ -56,7 +56,7 @@ widget headerIn =
     return $ HeaderOut
       { _headerOut_searchName = searchName
       , _headerOut_searchFrequency = searchFrequency
-      , _headerOut_addedPayment = addedPayment
+      , _headerOut_addPayment = addPayment
       }
   where
     init = _headerIn_init headerIn
@@ -74,7 +74,7 @@ payerAndAdd
   -> [User]
   -> [Category]
   -> Currency
-  -> m (Event t Payment)
+  -> m (Event t CreatedPayment)
 payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
@@ -101,7 +101,7 @@ payerAndAdd incomes payments users categories currency = do
         { _modalIn_show    = addPaymentClic
         , _modalIn_hide = R.leftmost $
             [ _addOut_cancel addOut
-            , fmap (const ()) . _addOut_addedPayment $ addOut
+            , fmap (const ()) . _addOut_addPayment $ addOut
             ]
         , _modalIn_content = Add.view $ AddIn
             { _addIn_categories = categories
@@ -109,7 +109,7 @@ payerAndAdd incomes payments users categories currency = do
             }
         }
       let addOut = _modalOut_content modalOut
-    return (_addOut_addedPayment addOut)
+    return (_addOut_addPayment addOut)
 
 searchLine
   :: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index ba16bf5..6432274 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -29,21 +29,22 @@ import qualified Icon
 import qualified Util.Dom            as Dom
 
 data TableIn t = TableIn
-  { _tableIn_init        :: Init
-  , _tableIn_currentPage :: Dynamic t Int
-  , _tableIn_payments    :: Dynamic t [Payment]
-  , _tableIn_perPage     :: Int
+  { _tableIn_init              :: Init
+  , _tableIn_currentPage       :: Dynamic t Int
+  , _tableIn_payments          :: Dynamic t [Payment]
+  , _tableIn_perPage           :: Int
+  , _tableIn_paymentCategories :: Dynamic t [PaymentCategory]
   }
 
 data TableOut t = TableOut
-  { _tableOut_deletedPayment :: Event t PaymentId
+  { _tableOut_deletePayment :: Event t PaymentId
   }
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    deletedPayment <- R.divClass "lines" $ do
+    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
@@ -53,13 +54,14 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init))
+      (R.switch . R.current . fmap R.leftmost) <$>
+        (R.simpleList paymentRange (paymentRow init paymentCategories))
 
     Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
     return $ TableOut
-      { _tableOut_deletedPayment = deletedPayment
+      { _tableOut_deletePayment = deletePayment
       }
 
   where
@@ -67,6 +69,7 @@ widget tableIn = do
     currentPage = _tableIn_currentPage tableIn
     payments = _tableIn_payments tableIn
     paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
+    paymentCategories = _tableIn_paymentCategories tableIn
 
 getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
 getPaymentRange perPage payments currentPage =
@@ -76,8 +79,8 @@ getPaymentRange perPage payments currentPage =
     . L.sortOn _payment_date
     $ payments
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId)
-paymentRow init payment =
+paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId)
+paymentRow init 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 (_init_currency init) . _payment_cost) $  payment
@@ -88,10 +91,10 @@ paymentRow init payment =
         Just u -> _user_name u
         _      -> ""
 
-    let category = flip fmap payment $ \p -> findCategory
-          (_init_categories init)
-          (_init_paymentCategories init)
-          (_payment_name p)
+    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
diff --git a/common/common.cabal b/common/common.cabal
index 9881c64..b7e0416 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -29,6 +29,7 @@ Library
   Exposed-modules:
     Common.Model
     Common.Model.CreatePayment
+    Common.Model.CreatedPayment
     Common.Model.Email
     Common.Model.Payment
     Common.Model.SignInForm
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index b0e0491..64db890 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -2,6 +2,7 @@ module Common.Model (module X) where
 
 import           Common.Model.Category        as X
 import           Common.Model.CreateCategory  as X
+import           Common.Model.CreatedPayment  as X
 import           Common.Model.CreateIncome    as X
 import           Common.Model.CreatePayment   as X
 import           Common.Model.Currency        as X
diff --git a/common/src/Common/Model/CreatedPayment.hs b/common/src/Common/Model/CreatedPayment.hs
new file mode 100644
index 0000000..c1bba29
--- /dev/null
+++ b/common/src/Common/Model/CreatedPayment.hs
@@ -0,0 +1,17 @@
+module Common.Model.CreatedPayment
+  ( CreatedPayment(..)
+  ) where
+
+import           Data.Aeson                   (FromJSON, ToJSON)
+import           GHC.Generics                 (Generic)
+
+import           Common.Model.Payment         (Payment)
+import           Common.Model.PaymentCategory (PaymentCategory)
+
+data CreatedPayment = CreatedPayment
+  { _createdPayment_payment         :: Payment
+  , _createdPayment_paymentCategory :: PaymentCategory
+  } deriving (Show, Generic)
+
+instance FromJSON CreatedPayment
+instance ToJSON CreatedPayment
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index fb7fcb2..e82fd49 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -10,6 +10,7 @@ import qualified Network.HTTP.Types.Status   as Status
 import           Web.Scotty
 
 import           Common.Model                (CreatePayment (..),
+                                              CreatedPayment (..),
                                               EditPayment (..), PaymentId,
                                               User (..))
 import qualified Model.Query                 as Query
@@ -30,8 +31,9 @@ create createPayment@(CreatePayment name cost date category frequency) =
     case CreatePaymentValidation.validate createPayment of
       Nothing ->
         (liftIO . Query.run $ do
-          PaymentCategoryPersistence.save name category
-          PaymentPersistence.create (_user_id user) name cost date frequency
+          pc <- PaymentCategoryPersistence.save name category
+          p <- PaymentPersistence.create (_user_id user) name cost date frequency
+          return $ CreatedPayment p pc
         ) >>= json
       Just validationError ->
         do
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 1e377b1..1cfd702 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -4,7 +4,7 @@ module Persistence.PaymentCategory
   , save
   ) where
 
-import           Data.Maybe             (isJust, listToMaybe)
+import qualified Data.Maybe             as Maybe
 import           Data.Text              (Text)
 import qualified Data.Text              as T
 import           Data.Time.Clock        (getCurrentTime)
@@ -40,27 +40,41 @@ listByCategory cat =
       SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
   )
 
-save :: Text -> CategoryId -> Query ()
+save :: Text -> CategoryId -> Query PaymentCategory
 save newName categoryId =
   Query (\conn -> do
     now <- getCurrentTime
-    hasPaymentCategory <- isJust <$> listToMaybe <$>
+    paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$>
       (SQLite.query
         conn
         "SELECT * FROM payment_category WHERE name = ?"
-        (Only (formatPaymentName newName)) :: IO [Row])
-    if hasPaymentCategory
-      then
-        SQLite.execute
-          conn
-          "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
-          (categoryId, now, formatPaymentName newName)
-      else do
-        SQLite.execute
-          conn
-          "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
-          (formatPaymentName newName, categoryId, now)
+        (Only formattedNewName))
+    case paymentCategory of
+      Just pc ->
+        do
+          SQLite.execute
+            conn
+            "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
+            (categoryId, now, formattedNewName)
+          return $ PaymentCategory
+            (_paymentCategory_id pc)
+            formattedNewName
+            categoryId
+            (_paymentCategory_createdAt pc)
+            (Just now)
+      Nothing ->
+        do
+          SQLite.execute
+            conn
+            "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
+            (formattedNewName, categoryId, now)
+          paymentCategoryId <- SQLite.lastInsertRowId conn
+          return $ PaymentCategory
+            paymentCategoryId
+            formattedNewName
+            categoryId
+            now
+            Nothing
   )
   where
-    formatPaymentName :: Text -> Text
-    formatPaymentName = T.unaccent . T.toLower
+    formattedNewName = T.unaccent . T.toLower $ newName