From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Aug 2019 21:53:30 +0200 Subject: Use updated payment categories from payment add in payment’s table --- README.md | 20 ++++++------- client/src/Component/Input.hs | 4 +-- client/src/View/Payment.hs | 30 ++++++++++++++----- client/src/View/Payment/Add.hs | 22 ++++++++------ client/src/View/Payment/Header.hs | 22 +++++++------- client/src/View/Payment/Table.hs | 31 +++++++++++--------- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/CreatedPayment.hs | 17 +++++++++++ server/src/Controller/Payment.hs | 6 ++-- server/src/Persistence/PaymentCategory.hs | 48 ++++++++++++++++++++----------- 11 files changed, 130 insertions(+), 72 deletions(-) create mode 100644 common/src/Common/Model/CreatedPayment.hs 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 -- cgit v1.2.3