aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoris2019-11-17 18:08:28 +0100
committerJoris2019-11-17 18:08:28 +0100
commitc0ea63f8c1a8c7123b78798cec99726b113fb1f3 (patch)
tree0b92f7e0c125c067a5f1ccafe6a1f04f1edfae86
parent4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 (diff)
Optimize and refactor payments
Diffstat
-rw-r--r--client/src/Loadable.hs3
-rw-r--r--client/src/Util/Ajax.hs5
-rw-r--r--client/src/Util/Either.hs2
-rw-r--r--client/src/Util/List.hs13
-rw-r--r--client/src/View/Payment/Form.hs52
-rw-r--r--client/src/View/Payment/HeaderForm.hs69
-rw-r--r--client/src/View/Payment/HeaderInfos.hs28
-rw-r--r--client/src/View/Payment/Payment.hs177
-rw-r--r--client/src/View/Payment/Reducer.hs83
-rw-r--r--client/src/View/Payment/Table.hs31
-rw-r--r--common/common.cabal3
-rw-r--r--common/src/Common/Message/Translation.hs2
-rw-r--r--common/src/Common/Model.hs3
-rw-r--r--common/src/Common/Model/Payment.hs2
-rw-r--r--common/src/Common/Model/PaymentCategory.hs25
-rw-r--r--common/src/Common/Model/PaymentPage.hs17
-rw-r--r--common/src/Common/Model/SavedPayment.hs17
-rw-r--r--common/src/Common/Util/Text.hs1
-rw-r--r--default.nix2
-rw-r--r--server/migrations/2.sql21
-rw-r--r--server/server.cabal6
-rw-r--r--server/src/Controller/Category.hs27
-rw-r--r--server/src/Controller/Income.hs17
-rw-r--r--server/src/Controller/Payment.hs137
-rw-r--r--server/src/Design/Form.hs1
-rw-r--r--server/src/Design/View/Payment.hs6
-rw-r--r--server/src/Design/View/Payment/HeaderForm.hs40
-rw-r--r--server/src/Design/View/Payment/HeaderInfos.hs (renamed from server/src/Design/View/Payment/Header.hs)36
-rw-r--r--server/src/Job/WeeklyReport.hs23
-rw-r--r--server/src/Main.hs14
-rw-r--r--server/src/Model/SignIn.hs4
-rw-r--r--server/src/Payer.hs (renamed from common/src/Common/Model/Payer.hs)80
-rw-r--r--server/src/Persistence/Category.hs10
-rw-r--r--server/src/Persistence/Income.hs59
-rw-r--r--server/src/Persistence/Payment.hs214
-rw-r--r--server/src/Persistence/PaymentCategory.hs89
-rw-r--r--server/src/Persistence/User.hs4
-rw-r--r--server/src/Util/List.hs13
-rw-r--r--server/src/View/Mail/WeeklyReport.hs22
39 files changed, 636 insertions, 722 deletions
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index f57b99c..2b9008a 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -16,6 +16,7 @@ data Loadable t
= Loading
| Error Text
| Loaded t
+ deriving Show
instance Functor Loadable where
fmap f Loading = Loading
@@ -46,6 +47,6 @@ fromEvent =
Loading
view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
-view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
+view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
view _ (Error e) = R.text e >> return Nothing
view f (Loaded x) = Just <$> f x
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 47f4f3c..dc56701 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -16,6 +16,7 @@ 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 Data.Time.Clock (NominalDiffTime)
import Reflex.Dom (Dynamic, Event, IsXhrPayload,
MonadWidget, XhrRequest,
XhrRequestConfig (..), XhrResponse,
@@ -28,7 +29,9 @@ import qualified Loadable
getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
getNow url = do
postBuild <- R.getPostBuild
- get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent
+ get (url <$ postBuild)
+ >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise
+ >>= Loadable.fromEvent
get
:: forall t m a. (MonadWidget t m, FromJSON a)
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
index 2910d95..e76bc8a 100644
--- a/client/src/Util/Either.hs
+++ b/client/src/Util/Either.hs
@@ -2,6 +2,6 @@ module Util.Either
( eitherToMaybe
) where
-eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe :: forall a b. Either a b -> Maybe b
eitherToMaybe (Right b) = Just b
eitherToMaybe _ = Nothing
diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
deleted file mode 100644
index 4e22ba8..0000000
--- a/client/src/Util/List.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Util.List
- ( groupBy
- ) where
-
-import Control.Arrow ((&&&))
-import Data.Function (on)
-import qualified Data.List as L
-
-groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
-groupBy f =
- map (f . head &&& id)
- . L.groupBy ((==) `on` f)
- . L.sortBy (compare `on` f)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 99b0848..6c3c1e8 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -4,6 +4,7 @@ module View.Payment.Form
, Operation(..)
) where
+import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value)
import qualified Data.Aeson as Aeson
@@ -13,6 +14,7 @@ import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time (NominalDiffTime)
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
import qualified Data.Time.Clock as Clock
@@ -25,9 +27,7 @@ import qualified Text.Read as T
import Common.Model (Category (..), CategoryId,
CreatePaymentForm (..),
EditPaymentForm (..),
- Frequency (..), Payment (..),
- PaymentCategory (..),
- SavedPayment (..))
+ Frequency (..), Payment (..))
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Common.Validation.Payment as PaymentValidation
@@ -37,20 +37,20 @@ 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.Either as EitherUtil
import qualified Util.Validation as ValidationUtil
-data In = In
- { _in_categories :: [Category]
- , _in_paymentCategories :: [PaymentCategory]
- , _in_operation :: Operation
+data In t = In
+ { _in_categories :: [Category]
+ , _in_operation :: Operation t
}
-data Operation
- = New Frequency
+data Operation t
+ = New (Dynamic t Frequency)
| Clone Payment
| Edit Payment
-view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment
+view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment
view input cancel = do
rec
let reset = R.leftmost
@@ -105,9 +105,10 @@ view input cancel = do
(d <$ reset)
confirm)
- let setCategory =
- R.fmapMaybe id . R.updated $
- R.ffor (Input._out_raw name) findCategory
+ setCategory <-
+ R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name)
+ >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>)))
+ >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe))
category <- Select._out_value <$> (Select.view $ Select.In
{ Select._in_label = Msg.get Msg.Payment_Category
@@ -124,12 +125,13 @@ view input cancel = do
c <- cost
d <- date
cat <- category
+ f <- frequency
return (mkPayload
<$> ValidationUtil.nelError n
<*> V.Success c
<*> V.Success d
<*> ValidationUtil.nelError cat
- <*> V.Success frequency)
+ <*> V.Success f)
frequencies =
M.fromList
@@ -140,6 +142,12 @@ view input cancel = do
categories = M.fromList . flip map (_in_categories input) $ \c ->
(_category_id c, _category_name c)
+ category =
+ case op of
+ New _ -> -1
+ Clone p -> _payment_category p
+ Edit p -> _payment_category p
+
op = _in_operation input
name =
@@ -162,17 +170,11 @@ view input cancel = do
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
+ Clone p -> R.constDyn $ _payment_frequency p
+ Edit p -> R.constDyn $ _payment_frequency p
headerLabel =
case op of
@@ -189,9 +191,3 @@ view input cancel = do
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)
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
index 07a6b81..c8ca4d9 100644
--- a/client/src/View/Payment/HeaderForm.hs
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -1,5 +1,7 @@
module View.Payment.HeaderForm
( view
+ , In(..)
+ , Out(..)
) where
import qualified Data.Map as M
@@ -8,10 +10,8 @@ import qualified Data.Validation as V
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Category, Currency, ExceedingPayer (..),
- Frequency (..), Income (..), Payment (..),
- PaymentCategory, SavedPayment (..),
- User (..))
+import Common.Model (Category, Currency, Frequency (..),
+ Income (..), Payment (..), User (..))
import qualified Common.Msg as Msg
import qualified Component.Button as Button
@@ -21,39 +21,43 @@ import qualified Component.Select as Select
import qualified View.Payment.Form as Form
data In t = In
- { _in_reset :: Event t ()
- , _in_categories :: [Category]
- , _in_paymentCategories :: [PaymentCategory]
+ { _in_reset :: Event t ()
+ , _in_categories :: [Category]
}
-data Out = Out
- { _out_name :: Event t Text
+data Out t = Out
+ { _out_search :: Event t Text
, _out_frequency :: Event t Frequency
- , _out_addPayment :: Event t SavedPayment
+ , _out_addPayment :: Event t Payment
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input = do
- R.divClass "g-HeaderForm" $ do
- searchName <- Input._out_raw <$> (Input.view
- ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
- ("" <$ _in_reset input)
- R.never)
+view input =
+ R.divClass "g-PaymentHeaderForm" $ do
- let frequencies = M.fromList
- [ (Punctual, Msg.get Msg.Payment_PunctualMale)
- , (Monthly, Msg.get Msg.Payment_MonthlyMale)
- ]
+ (searchName, frequency) <- R.el "div" $ do
- searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
- { Select._in_label = ""
- , Select._in_initialValue = Punctual
- , Select._in_value = R.never
- , Select._in_values = R.constDyn frequencies
- , Select._in_reset = R.never
- , Select._in_isValid = V.Success
- , Select._in_validate = R.never
- })
+ searchName <- Input._out_raw <$> (Input.view
+ ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
+ ("" <$ _in_reset input)
+ R.never)
+
+ let frequencies = M.fromList
+ [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+ , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+ ]
+
+ frequency <- Select._out_raw <$> (Select.view $ Select.In
+ { Select._in_label = ""
+ , Select._in_initialValue = Punctual
+ , Select._in_value = R.never
+ , Select._in_values = R.constDyn frequencies
+ , Select._in_reset = R.never
+ , Select._in_isValid = V.Success
+ , Select._in_validate = R.never
+ })
+
+ return (searchName, frequency)
addPaymentButton <- Button._out_clic <$>
(Button.view $
@@ -66,13 +70,12 @@ view input = do
, Modal._in_content =
Form.view $ Form.In
{ Form._in_categories = _in_categories input
- , Form._in_paymentCategories = _in_paymentCategories input
- , Form._in_operation = Form.New searchFrequency
+ , Form._in_operation = Form.New frequency
}
}
return $ Out
- { _out_name = searchName
- , _out_frequency = searchFrequency
+ { _out_search = R.updated searchName
+ , _out_frequency = R.updated frequency
, _out_addPayment = addPayment
}
diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs
index 12facc4..f84ee1f 100644
--- a/client/src/View/Payment/HeaderInfos.hs
+++ b/client/src/View/Payment/HeaderInfos.hs
@@ -16,13 +16,11 @@ import qualified Reflex.Dom as R
import Common.Model (Currency, ExceedingPayer (..),
Payment (..), PaymentHeader (..),
- SavedPayment (..), User (..), UserId)
+ User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
-import qualified Util.List as L
-
data In t = In
{ _in_users :: [User]
, _in_currency :: Currency
@@ -32,17 +30,17 @@ data In t = In
view :: forall t m. MonadWidget t m => In t -> m ()
view input =
- R.divClass "g-HeaderInfos" $ do
- exceedingPayers
- (_in_users input)
- (_in_currency input)
- (_paymentHeader_exceedingPayers header)
+ R.divClass "g-PaymentHeaderInfos" $ do
+ exceedingPayers
+ (_in_users input)
+ (_in_currency input)
+ (_paymentHeader_exceedingPayers header)
- infos
- (_in_users input)
- (_in_currency input)
- (_paymentHeader_repartition header)
- (_in_paymentCount input)
+ infos
+ (_in_users input)
+ (_in_currency input)
+ (_paymentHeader_repartition header)
+ (_in_paymentCount input)
where
header = _in_header input
@@ -54,7 +52,7 @@ exceedingPayers
-> [ExceedingPayer]
-> m ()
exceedingPayers users currency payers =
- R.divClass "g-HeaderInfos__ExceedingPayers" $
+ R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $
flip mapM_ payers $ \payer ->
R.elClass "span" "exceedingPayer" $ do
R.elClass "span" "userName" $
@@ -72,7 +70,7 @@ infos
-> Int
-> m ()
infos users currency repartition paymentCount =
- R.divClass "g-HeaderInfos__Repartition" $ do
+ R.divClass "g-PaymentHeaderInfos__Repartition" $ do
R.elClass "span" "total" $ do
R.text $
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index f47b627..6bc1614 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -3,6 +3,7 @@ module View.Payment.Payment
, In(..)
) where
+import Control.Monad.IO.Class (liftIO)
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
@@ -12,9 +13,8 @@ import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
import Common.Model (Currency, Frequency, Income (..),
- Payment (..), PaymentCategory (..),
- PaymentId, PaymentPage (..),
- SavedPayment (..), User, UserId)
+ Payment (..), PaymentId,
+ PaymentPage (..), User, UserId)
import qualified Common.Util.Text as T
import qualified Component.Pages as Pages
@@ -22,8 +22,8 @@ import Loadable (Loadable (..))
import qualified Loadable
import qualified Util.Ajax as AjaxUtil
import qualified Util.Reflex as ReflexUtil
+import qualified View.Payment.HeaderForm as HeaderForm
import qualified View.Payment.HeaderInfos as HeaderInfos
--- import qualified View.Payment.HeaderForm as HeaderForm
import qualified View.Payment.Reducer as Reducer
import qualified View.Payment.Table as Table
@@ -36,15 +36,16 @@ data In t = In
view :: forall t m. MonadWidget t m => In t -> m ()
view input = do
- categoriesEvent <- (AjaxUtil.getNow "api/categories")
+ categories <- AjaxUtil.getNow "api/categories"
- R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do
+ R.dyn . R.ffor categories . Loadable.view $ \categories -> do
rec
payments <- Reducer.reducer $ Reducer.In
- { Reducer._in_newPage = newPage
- , Reducer._in_currentPage = currentPage
- , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment]
+ { Reducer._in_page = page
+ , Reducer._in_search = HeaderForm._out_search form
+ , Reducer._in_frequency = HeaderForm._out_frequency form
+ , Reducer._in_addPayment = addPayment
, Reducer._in_editPayment = editPayment
, Reducer._in_deletePayment = deletePayment
}
@@ -52,16 +53,25 @@ view input = do
let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
- newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
- currentPage <- R.holdDyn 1 newPage
- -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
- let headerAddPayment = R.never
+ let addPayment =
+ R.leftmost
+ [ tableAddPayment
+ , HeaderForm._out_addPayment form
+ ]
+
+ page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
- result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
- flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do
+ form <- HeaderForm.view $ HeaderForm.In
+ { HeaderForm._in_reset = () <$ addPayment
+ , HeaderForm._in_categories = categories
+ }
+
+ result <- R.dyn . R.ffor payments $
+ Loadable.view $ \(PaymentPage page header payments count) -> do
+
HeaderInfos.view $ HeaderInfos.In
{ HeaderInfos._in_users = _in_users input
, HeaderInfos._in_currency = _in_currency input
@@ -75,13 +85,12 @@ view input = do
, Table._in_categories = categories
, Table._in_currency = _in_currency input
, Table._in_payments = payments
- , Table._in_paymentCategories = paymentCategories
}
pages <- Pages.view $ Pages.In
{ Pages._in_total = R.constDyn count
, Pages._in_perPage = Reducer.perPage
- , Pages._in_page = p
+ , Pages._in_page = page
}
return ((), table, pages)
@@ -89,137 +98,3 @@ view input = do
return ()
return ()
-
-
--- view :: forall t m. MonadWidget t m => In t -> m ()
--- view input = do
--- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
---
--- R.elClass "main" "payment" $ do
--- rec
--- let addPayment = R.leftmost
--- -- [ Header._out_addPayment header
--- [ Table2._out_addPayment table
--- ]
---
--- paymentsPerPage = 7
---
--- payments <- reducePayments
--- (_init_payments init)
--- (_savedPayment_payment <$> addPayment)
--- (_savedPayment_payment <$> Table2._out_editPayment table)
--- (Table2._out_deletePayment table)
---
--- paymentCategories <- reducePaymentCategories
--- (_init_paymentCategories init)
--- payments
--- (_savedPayment_paymentCategory <$> addPayment)
--- (_savedPayment_paymentCategory <$> Table2._out_editPayment table)
--- (Table2._out_deletePayment table)
---
--- -- (searchNameEvent, searchName) <-
--- -- debounceSearchName (Header._out_searchName header)
---
--- -- let searchPayments =
--- -- getSearchPayments searchName (Header._out_searchFrequency header) payments
---
--- -- header <- Header.view $ Header.In
--- -- { Header._in_init = init
--- -- , Header._in_currency = _in_currency input
--- -- , Header._in_payments = payments
--- -- , Header._in_searchPayments = searchPayments
--- -- , Header._in_paymentCategories = paymentCategories
--- -- }
---
--- table <- Table2.view $ Table2.In
--- { Table2._in_init = init
--- , Table2._in_currency = _in_currency input
--- , Table2._in_currentUser = _in_currentUser input
--- , Table2._in_currentPage = Pages2._out_currentPage pages
--- , Table2._in_payments = payments
--- , Table2._in_perPage = paymentsPerPage
--- , Table2._in_paymentCategories = paymentCategories
--- }
---
--- pages <- Pages2.view $ Pages2.In
--- { Pages2._in_total = length <$> payments
--- , Pages2._in_perPage = paymentsPerPage
--- , Pages2._in_reset = R.never
--- -- [ () <$ searchNameEvent
--- -- [ () <$ Header._out_addPayment header
--- -- ]
--- }
---
--- pure ()
---
--- return ()
---
--- -- debounceSearchName
--- -- :: forall t m. MonadWidget t m
--- -- => Dynamic t Text
--- -- -> m (Event t Text, Dynamic t Text)
--- -- debounceSearchName searchName = do
--- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
--- -- dynamic <- R.holdDyn "" event
--- -- return (event, dynamic)
---
--- reducePayments
--- :: forall t m. MonadWidget t m
--- => [Payment]
--- -> Event t Payment -- add payment
--- -> Event t Payment -- edit payment
--- -> Event t Payment -- delete payment
--- -> m (Dynamic t [Payment])
--- 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))
--- ]
---
--- reducePaymentCategories
--- :: forall t m. MonadWidget t m
--- => [PaymentCategory]
--- -> 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])
--- 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
--- deletePaymentName =
--- R.attachWithMaybe
--- (\ps p ->
--- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
--- Nothing
--- else
--- Just (_payment_name p))
--- (R.current payments)
--- deletePayment
--- lowerName = T.toLower . _payment_name
---
--- -- getSearchPayments
--- -- :: forall t. Reflex t
--- -- => Dynamic t Text
--- -- -> Dynamic t Frequency
--- -- -> Dynamic t [Payment]
--- -- -> Dynamic t [Payment]
--- -- getSearchPayments name frequency payments = do
--- -- n <- name
--- -- f <- frequency
--- -- ps <- payments
--- -- pure $ flip filter ps (\p ->
--- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
--- -- && (_payment_frequency p == f)
--- -- ))
diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
index 0c70f8a..0b6c041 100644
--- a/client/src/View/Payment/Reducer.hs
+++ b/client/src/View/Payment/Reducer.hs
@@ -2,14 +2,16 @@ module View.Payment.Reducer
( perPage
, reducer
, In(..)
+ , Params(..)
) where
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time (NominalDiffTime)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (PaymentPage)
+import Common.Model (Frequency (..), PaymentPage)
import Loadable (Loadable (..))
import qualified Loadable as Loadable
@@ -19,48 +21,99 @@ perPage :: Int
perPage = 7
data In t a b c = In
- { _in_newPage :: Event t Int
- , _in_currentPage :: Dynamic t Int
+ { _in_page :: Event t Int
+ , _in_search :: Event t Text
+ , _in_frequency :: Event t Frequency
, _in_addPayment :: Event t a
, _in_editPayment :: Event t b
, _in_deletePayment :: Event t c
}
data Action
- = LoadPage Int
+ = LoadPage
| GetResult (Either Text PaymentPage)
+data Params = Params
+ { _params_page :: Int
+ , _params_search :: Text
+ , _params_frequency :: Frequency
+ } deriving (Show)
+
+initParams = Params 1 "" Punctual
+
+data Msg
+ = Page Int
+ | Search Text
+ | Frequency Common.Model.Frequency
+ | ResetSearch
+ deriving Show
+
reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
reducer input = do
postBuild <- R.getPostBuild
- let loadPage =
+ debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input)
+
+ params <- R.foldDynMaybe
+ (\msg params -> case msg of
+ Page page ->
+ Just $ params { _params_page = page }
+
+ Search "" ->
+ if _params_search params == "" then
+ Nothing
+
+ else
+ Just $ initParams { _params_frequency = _params_frequency params }
+
+ Search search ->
+ Just $ params { _params_search = search, _params_page = _params_page initParams }
+
+ Frequency frequency ->
+ Just $ params { _params_frequency = frequency }
+
+ ResetSearch ->
+ Just $ initParams { _params_frequency = _params_frequency params }
+ )
+ initParams
+ (R.leftmost
+ [ Page <$> _in_page input
+ , Search <$> debouncedSearch
+ , Frequency <$> _in_frequency input
+ , ResetSearch <$ _in_addPayment input
+ ])
+
+ let paramsEvent =
R.leftmost
- [ 1 <$ postBuild
- , _in_newPage input
- , 1 <$ _in_addPayment input
- , R.tag (R.current $ _in_currentPage input) (_in_editPayment input)
- , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input)
+ [ initParams <$ postBuild
+ , R.updated params
+ , R.tag (R.current params) (_in_editPayment input)
+ , R.tag (R.current params) (_in_deletePayment input)
]
- getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+ getResult <- AjaxUtil.get (pageUrl <$> paramsEvent)
+
R.foldDyn
(\action _ -> case action of
- LoadPage _ -> Loading
+ LoadPage -> Loading
GetResult (Left err) -> Error err
GetResult (Right payments) -> Loaded payments
)
Loading
(R.leftmost
- [ LoadPage <$> loadPage
+ [ LoadPage <$ paramsEvent
, GetResult <$> getResult
])
where
- pageUrl p =
+ pageUrl (Params page search frequency) =
"api/payments?page="
- <> (T.pack . show $ p)
+ <> (T.pack . show $ page)
<> "&perPage="
<> (T.pack . show $ perPage)
+ <> "&search="
+ <> search
+ <> "&frequency="
+ <> (T.pack $ show frequency)
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index dde5168..59ac890 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,7 +13,6 @@ import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Category (..), Currency, Payment (..),
- PaymentCategory (..), SavedPayment,
User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
@@ -26,17 +25,16 @@ import qualified Util.Either as EitherUtil
import qualified View.Payment.Form as Form
data In t = In
- { _in_users :: [User]
- , _in_currentUser :: UserId
- , _in_categories :: [Category]
- , _in_currency :: Currency
- , _in_payments :: [Payment]
- , _in_paymentCategories :: [PaymentCategory]
+ { _in_users :: [User]
+ , _in_currentUser :: UserId
+ , _in_categories :: [Category]
+ , _in_currency :: Currency
+ , _in_payments :: [Payment]
}
data Out t = Out
- { _out_add :: Event t SavedPayment
- , _out_edit :: Event t SavedPayment
+ { _out_add :: Event t Payment
+ , _out_edit :: Event t Payment
, _out_delete :: Event t Payment
}
@@ -50,18 +48,15 @@ view input = do
cell
(_in_users input)
(_in_categories input)
- (_in_paymentCategories input)
(_in_currency input)
, Table._in_cloneModal = \payment ->
Form.view $ Form.In
{ Form._in_categories = _in_categories input
- , Form._in_paymentCategories = _in_paymentCategories input
, Form._in_operation = Form.Clone payment
}
, Table._in_editModal = \payment ->
Form.view $ Form.In
{ Form._in_categories = _in_categories input
- , Form._in_paymentCategories = _in_paymentCategories input
, Form._in_operation = Form.Edit payment
}
, Table._in_deleteModal = \payment ->
@@ -101,12 +96,11 @@ cell
:: forall t m. MonadWidget t m
=> [User]
-> [Category]
- -> [PaymentCategory]
-> Currency
-> Header
-> Payment
-> m ()
-cell users categories paymentCategories currency header payment =
+cell users categories currency header payment =
case header of
NameHeader ->
R.text $ _payment_name payment
@@ -120,7 +114,7 @@ cell users categories paymentCategories currency header payment =
CategoryHeader ->
let
category =
- findCategory categories paymentCategories (_payment_name payment)
+ L.find ((== (_payment_category payment)) . _category_id) categories
attrs =
case category of
@@ -144,10 +138,3 @@ cell users categories paymentCategories currency header payment =
R.elClass "span" "longDate" $
R.text . Format.longDay . _payment_date $ payment
-
-findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
-findCategory categories paymentCategories paymentName = do
- paymentCategory <- L.find
- ((== T.toLower paymentName) . _paymentCategory_name)
- paymentCategories
- L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
diff --git a/common/common.cabal b/common/common.cabal
index 75d6cc8..17a0ee1 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -35,7 +35,6 @@ Library
Common.Model.CreatePaymentForm
Common.Model.Email
Common.Model.Payment
- Common.Model.SavedPayment
Common.Model.SignInForm
Common.Model.User
Common.Msg
@@ -66,7 +65,5 @@ Library
Common.Model.IncomePage
Common.Model.Init
Common.Model.InitResult
- Common.Model.Payer
- Common.Model.PaymentCategory
Common.Model.PaymentHeader
Common.Model.PaymentPage
diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs
index 25e9f4b..a86a371 100644
--- a/common/src/Common/Message/Translation.hs
+++ b/common/src/Common/Message/Translation.hs
@@ -702,7 +702,7 @@ m l WeeklyReport_Title =
m l NotFound_Message =
case l of
English -> "There is nothing here!"
- French -> "Vous vous êtes perdu."
+ French -> "Il n’y a rien à voir ici."
m l NotFound_LinkMessage =
case l of
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index fdeac36..00d30f6 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -17,11 +17,8 @@ import Common.Model.IncomeHeader as X
import Common.Model.IncomePage as X
import Common.Model.Init as X
import Common.Model.InitResult as X
-import Common.Model.Payer as X
import Common.Model.Payment as X
-import Common.Model.PaymentCategory as X
import Common.Model.PaymentHeader as X
import Common.Model.PaymentPage as X
-import Common.Model.SavedPayment as X
import Common.Model.SignInForm as X
import Common.Model.User as X
diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs
index 37a090d..c232fc7 100644
--- a/common/src/Common/Model/Payment.hs
+++ b/common/src/Common/Model/Payment.hs
@@ -10,6 +10,7 @@ import Data.Time (UTCTime)
import Data.Time.Calendar (Day)
import GHC.Generics (Generic)
+import Common.Model.Category (CategoryId)
import Common.Model.Frequency
import Common.Model.User (UserId)
@@ -21,6 +22,7 @@ data Payment = Payment
, _payment_name :: Text
, _payment_cost :: Int
, _payment_date :: Day
+ , _payment_category :: CategoryId
, _payment_frequency :: Frequency
, _payment_createdAt :: UTCTime
, _payment_editedAt :: Maybe UTCTime
diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs
deleted file mode 100644
index 2a559ce..0000000
--- a/common/src/Common/Model/PaymentCategory.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Common.Model.PaymentCategory
- ( PaymentCategoryId
- , PaymentCategory(..)
- ) where
-
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Int (Int64)
-import Data.Text (Text)
-import Data.Time (UTCTime)
-import GHC.Generics (Generic)
-
-import Common.Model.Category (CategoryId)
-
-type PaymentCategoryId = Int64
-
-data PaymentCategory = PaymentCategory
- { _paymentCategory_id :: PaymentCategoryId
- , _paymentCategory_name :: Text
- , _paymentCategory_category :: CategoryId
- , _paymentCategory_createdAt :: UTCTime
- , _paymentCategory_editedAt :: Maybe UTCTime
- } deriving (Show, Generic)
-
-instance FromJSON PaymentCategory
-instance ToJSON PaymentCategory
diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs
index 76c7511..3b18bb6 100644
--- a/common/src/Common/Model/PaymentPage.hs
+++ b/common/src/Common/Model/PaymentPage.hs
@@ -2,18 +2,17 @@ module Common.Model.PaymentPage
( PaymentPage(..)
) where
-import Data.Aeson (FromJSON, ToJSON)
-import GHC.Generics (Generic)
+import Data.Aeson (FromJSON, ToJSON)
+import GHC.Generics (Generic)
-import Common.Model.Payment (Payment)
-import Common.Model.PaymentCategory (PaymentCategory)
-import Common.Model.PaymentHeader (PaymentHeader)
+import Common.Model.Payment (Payment)
+import Common.Model.PaymentHeader (PaymentHeader)
data PaymentPage = PaymentPage
- { _paymentPage_header :: PaymentHeader
- , _paymentPage_payments :: [Payment]
- , _paymentPage_paymentCategories :: [PaymentCategory]
- , _paymentPage_totalCount :: Int
+ { _paymentPage_page :: Int
+ , _paymentPage_header :: PaymentHeader
+ , _paymentPage_payments :: [Payment]
+ , _paymentPage_totalCount :: Int
} deriving (Show, Generic)
instance FromJSON PaymentPage
diff --git a/common/src/Common/Model/SavedPayment.hs b/common/src/Common/Model/SavedPayment.hs
deleted file mode 100644
index f45c479..0000000
--- a/common/src/Common/Model/SavedPayment.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Common.Model.SavedPayment
- ( SavedPayment(..)
- ) where
-
-import Data.Aeson (FromJSON, ToJSON)
-import GHC.Generics (Generic)
-
-import Common.Model.Payment (Payment)
-import Common.Model.PaymentCategory (PaymentCategory)
-
-data SavedPayment = SavedPayment
- { _savedPayment_payment :: Payment
- , _savedPayment_paymentCategory :: PaymentCategory
- } deriving (Show, Generic)
-
-instance FromJSON SavedPayment
-instance ToJSON SavedPayment
diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs
index d7f1db4..0f9c187 100644
--- a/common/src/Common/Util/Text.hs
+++ b/common/src/Common/Util/Text.hs
@@ -1,6 +1,7 @@
module Common.Util.Text
( search
, formatSearch
+ , unaccent
) where
import Data.Text (Text)
diff --git a/default.nix b/default.nix
index 977af02..7969fc7 100644
--- a/default.nix
+++ b/default.nix
@@ -4,6 +4,8 @@ let
reflex-platform = import (pkgs.fetchFromGitHub {
owner = "reflex-frp";
repo = "reflex-platform";
+
+ # Mon Jul 29 15:48:55 2019 -0400
rev = "51e02339704b7502e63bccf10a72fa4dda744b17";
sha256 = "1mkimidf755968xzbm3z222xgpdvgg6xmmrfppv1hw0rap5w53iw";
}) {};
diff --git a/server/migrations/2.sql b/server/migrations/2.sql
index 1c829ec..efed046 100644
--- a/server/migrations/2.sql
+++ b/server/migrations/2.sql
@@ -21,3 +21,24 @@ DELETE FROM
payment_category
WHERE
name NOT IN (SELECT DISTINCT lower(name) FROM payment);
+
+-- Add category id to payment table
+
+PRAGMA foreign_keys = 0;
+
+ALTER TABLE payment ADD COLUMN "category" INTEGER NOT NULL REFERENCES "category" DEFAULT -1;
+
+PRAGMA foreign_keys = 1;
+
+UPDATE
+ payment
+SET
+ category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name))
+WHERE
+ EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name))
+
+DELETE FROM payment WHERE category = -1;
+
+-- Remove
+
+DROP TABLE payment_category
diff --git a/server/server.cabal b/server/server.cabal
index b4d9e08..7056b3f 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -81,7 +81,8 @@ Executable server
Design.View.Pages
Design.View.Payment
Design.View.Payment.Form
- Design.View.Payment.Header
+ Design.View.Payment.HeaderForm
+ Design.View.Payment.HeaderInfos
Design.View.SignIn
Design.View.Stat
Design.View.Table
@@ -104,16 +105,15 @@ Executable server
Model.Query
Model.SignIn
Model.UUID
+ Payer
Persistence.Category
Persistence.Frequency
Persistence.Income
Persistence.Payment
- Persistence.PaymentCategory
Persistence.User
Resource
Secure
SendMail
- Util.List
Util.Time
Validation.Income
Validation.Payment
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index e536caa..8fbc8c8 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -5,19 +5,18 @@ module Controller.Category
, delete
) where
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty hiding (delete)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty hiding (delete)
-import Common.Model (CategoryId, CreateCategory (..),
- EditCategory (..))
-import qualified Common.Msg as Msg
+import Common.Model (CategoryId, CreateCategory (..),
+ EditCategory (..))
+import qualified Common.Msg as Msg
-import Json (jsonId)
-import qualified Model.Query as Query
-import qualified Persistence.Category as CategoryPersistence
-import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
+import Json (jsonId)
+import qualified Model.Query as Query
+import qualified Persistence.Category as CategoryPersistence
import qualified Secure
list :: ActionM ()
@@ -45,10 +44,8 @@ delete :: CategoryId -> ActionM ()
delete categoryId =
Secure.loggedAction (\_ -> do
deleted <- liftIO . Query.run $ do
- paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId
- if null paymentCategories
- then CategoryPersistence.delete categoryId
- else return False
+ -- TODO: delete only if no payment has this category
+ CategoryPersistence.delete categoryId
if deleted
then
status ok200
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 127e3b3..75d0133 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,6 +1,5 @@
module Controller.Income
( list
- , deprecatedList
, create
, edit
, delete
@@ -17,12 +16,12 @@ import Common.Model (CreateIncomeForm (..),
EditIncomeForm (..), Income (..),
IncomeHeader (..), IncomeId,
IncomePage (..), User (..))
-import qualified Common.Model as CM
import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
import Model.EditIncome (EditIncome (..))
import qualified Model.Query as Query
+import qualified Payer as Payer
import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.User as UserPersistence
@@ -37,18 +36,18 @@ list page perPage =
count <- IncomePersistence.count
users <- UserPersistence.list
- firstPayment <- PaymentPersistence.firstPunctualDay
- allIncomes <- IncomePersistence.listAll
+ paymentRange <- PaymentPersistence.getRange
+ allIncomes <- IncomePersistence.listAll -- TODO optimize
let since =
- CM.useIncomesFrom (map _user_id users) allIncomes firstPayment
+ Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange)
let byUser =
case since of
Just s ->
M.fromList . flip map users $ \user ->
( _user_id user
- , CM.cumulativeIncomesSince currentTime s $
+ , Payer.cumulativeIncomesSince currentTime s $
filter ((==) (_user_id user) . _income_userId) allIncomes
)
@@ -59,12 +58,6 @@ list page perPage =
return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json
)
-deprecatedList :: ActionM ()
-deprecatedList =
- Secure.loggedAction (\_ ->
- (liftIO . Query.run $ IncomePersistence.listAll) >>= json
- )
-
create :: CreateIncomeForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index f685f2e..d4d086e 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,75 +1,70 @@
module Controller.Payment
( list
- , listPaymentCategories
, create
, edit
, delete
+ , searchCategory
) where
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Map as M
-import qualified Data.Time.Clock as Clock
-import Data.Validation (Validation (Failure, Success))
-import qualified Network.HTTP.Types.Status as Status
-import Web.Scotty (ActionM)
-import qualified Web.Scotty as S
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Text (Text)
+import qualified Data.Time.Calendar as Calendar
+import qualified Data.Time.Clock as Clock
+import Data.Validation (Validation (Failure, Success))
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
-import Common.Model (Category (..),
- CreatePaymentForm (..),
- EditPaymentForm (..),
- Frequency (Punctual),
- Payment (..), PaymentHeader (..),
- PaymentId, PaymentPage (..),
- SavedPayment (..), User (..))
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Controller.Helper as ControllerHelper
-import Model.CreatePayment (CreatePayment (..))
-import Model.EditPayment (EditPayment (..))
-import qualified Model.Query as Query
-import qualified Persistence.Category as CategoryPersistence
-import qualified Persistence.Income as IncomePersistence
-import qualified Persistence.Payment as PaymentPersistence
-import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
-import qualified Persistence.User as UserPersistence
+import Common.Model (Category (..), CreatePaymentForm (..),
+ EditPaymentForm (..), Frequency,
+ PaymentHeader (..), PaymentId,
+ PaymentPage (..), User (..))
+import qualified Common.Msg as Msg
+
+import qualified Controller.Helper as ControllerHelper
+import Model.CreatePayment (CreatePayment (..))
+import Model.EditPayment (EditPayment (..))
+import qualified Model.Query as Query
+import qualified Payer as Payer
+import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.User as UserPersistence
import qualified Secure
-import qualified Util.List as L
-import qualified Validation.Payment as PaymentValidation
+import qualified Validation.Payment as PaymentValidation
-list :: Int -> Int -> ActionM ()
-list page perPage =
+list :: Frequency -> Int -> Int -> Text -> ActionM ()
+list frequency page perPage search =
Secure.loggedAction (\_ -> do
currentTime <- liftIO Clock.getCurrentTime
(liftIO . Query.run $ do
- count <- PaymentPersistence.count
- payments <- PaymentPersistence.listActivePage page perPage
- paymentCategories <- PaymentCategoryPersistence.list
+ count <- PaymentPersistence.count frequency search
+ payments <- PaymentPersistence.listActivePage frequency page perPage search
users <- UserPersistence.list
- incomes <- IncomePersistence.listAll
- allPayments <- PaymentPersistence.listActive Punctual
+ incomes <- IncomePersistence.listAll -- TODO optimize
+
+ paymentRange <- PaymentPersistence.getRange
+
+ searchRepartition <-
+ case paymentRange of
+ Just (from, to) ->
+ PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to)
+ Nothing ->
+ return M.empty
- let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments
+ (preIncomeRepartition, postIncomeRepartition) <-
+ PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
- repartition =
- M.fromList
- . map (\(u, xs) -> (u, sum . map snd $ xs))
- . L.groupBy fst
- . map (\p -> (_payment_user p, _payment_cost p))
- $ allPayments
+ let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange)
header = PaymentHeader
{ _paymentHeader_exceedingPayers = exceedingPayers
- , _paymentHeader_repartition = repartition
+ , _paymentHeader_repartition = searchRepartition
}
- return $ PaymentPage header payments paymentCategories count) >>= S.json
- )
-
-listPaymentCategories :: ActionM ()
-listPaymentCategories =
- Secure.loggedAction (\_ ->
- (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json
+ return $ PaymentPage page header payments count) >>= S.json
)
create :: CreatePaymentForm -> ActionM ()
@@ -78,10 +73,8 @@ create form =
(liftIO . Query.run $ do
cs <- map _category_id <$> CategoryPersistence.list
case PaymentValidation.createPayment cs form of
- Success (CreatePayment name cost date category frequency) -> do
- pc <- PaymentCategoryPersistence.save name category
- p <- PaymentPersistence.create (_user_id user) name cost date frequency
- return . Right $ SavedPayment p pc
+ Success (CreatePayment name cost date category frequency) ->
+ Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency
Failure validationError ->
return $ Left validationError
) >>= ControllerHelper.jsonOrBadRequest
@@ -94,14 +87,11 @@ edit form =
cs <- map _category_id <$> CategoryPersistence.list
case PaymentValidation.editPayment cs form of
Success (EditPayment paymentId name cost date category frequency) -> do
- editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
- case editedPayment of
- Just (old, new) -> do
- pc <- PaymentCategoryPersistence.save name category
- PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
- return . Right $ SavedPayment new pc
- Nothing ->
- return . Left $ Msg.get Msg.Error_PaymentEdit
+ editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency
+ if Maybe.isJust editedPayment then
+ return . Right $ editedPayment
+ else
+ return . Left $ Msg.get Msg.Error_PaymentEdit
Failure validationError ->
return $ Left validationError
) >>= ControllerHelper.jsonOrBadRequest
@@ -109,18 +99,13 @@ edit form =
delete :: PaymentId -> ActionM ()
delete paymentId =
- Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ do
- payment <- PaymentPersistence.find paymentId
- case payment of
- Just p | _payment_user p == _user_id user -> do
- PaymentPersistence.delete (_user_id user) paymentId
- PaymentCategoryPersistence.deleteIfUnused (_payment_name p)
- return True
- _ ->
- return False
- if deleted then
- S.status Status.ok200
- else
- S.status Status.badRequest400
+ Secure.loggedAction (\user ->
+ liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId
+ )
+
+searchCategory :: Text -> ActionM ()
+searchCategory paymentName =
+ Secure.loggedAction (\_ -> do
+ (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName))
+ >>= S.json
)
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index 506343d..5713bfe 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -77,7 +77,6 @@ design = do
backgroundColor transparent
".selectInput" ? do
- marginBottom (em 2)
".label" ? do
color Color.silver
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 27b4ef3..d563f5d 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,8 +4,10 @@ module Design.View.Payment
import Clay
-import qualified Design.View.Payment.Header as Header
+import qualified Design.View.Payment.HeaderForm as HeaderForm
+import qualified Design.View.Payment.HeaderInfos as HeaderInfos
design :: Css
design = do
- ".g-HeaderInfos" ? Header.design
+ HeaderForm.design
+ HeaderInfos.design
diff --git a/server/src/Design/View/Payment/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs
new file mode 100644
index 0000000..6081443
--- /dev/null
+++ b/server/src/Design/View/Payment/HeaderForm.hs
@@ -0,0 +1,40 @@
+module Design.View.Payment.HeaderForm
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
+
+design :: Css
+design = do
+
+ ".g-PaymentHeaderForm" ? do
+ marginBottom (em 2)
+ marginLeft (pct Constants.blockPercentMargin)
+ marginRight (pct Constants.blockPercentMargin)
+ display flex
+ justifyContent spaceBetween
+ alignItems center
+ Media.mobile $ flexDirection column
+
+ ".textInput" ? do
+ display inlineBlock
+ marginBottom (px 0)
+
+ Media.tabletDesktop $ marginRight (px 30)
+ Media.mobile $ do
+ marginBottom (em 1)
+ width (pct 100)
+
+ ".selectInput" ? do
+ Media.tabletDesktop $ display inlineBlock
+ Media.mobile $ marginBottom (em 2)
+
+ ".addPayment" ? do
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ Media.mobile $ width (pct 100)
+ flexShrink 0
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/HeaderInfos.hs
index 49c1a09..acb393b 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/HeaderInfos.hs
@@ -1,4 +1,4 @@
-module Design.View.Payment.Header
+module Design.View.Payment.HeaderInfos
( design
) where
@@ -12,12 +12,14 @@ import qualified Design.Media as Media
design :: Css
design = do
- Media.desktop $ marginBottom (em 2)
- Media.mobileTablet $ marginBottom (em 1)
- marginLeft (pct Constants.blockPercentMargin)
- marginRight (pct Constants.blockPercentMargin)
- ".g-HeaderInfos__ExceedingPayers" ? do
+ ".g-PaymentHeaderInfos" ? do
+ Media.desktop $ marginBottom (em 2)
+ Media.mobileTablet $ marginBottom (em 1)
+ marginLeft (pct Constants.blockPercentMargin)
+ marginRight (pct Constants.blockPercentMargin)
+
+ ".g-PaymentHeaderInfos__ExceedingPayers" ? do
backgroundColor Color.mossGreen
borderRadius (px 5) (px 5) (px 5) (px 5)
color Color.white
@@ -33,27 +35,7 @@ design = do
".userName" ? marginRight (px 8)
- -- ".addPayment" ? do
- -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
- -- Media.mobile $ width (pct 100)
-
- ".g-HeaderForm" ? do
- marginBottom (em 1)
- Media.mobile $ textAlign (alignSide sideCenter)
-
- ".textInput" ? do
- display inlineBlock
- marginBottom (px 0)
-
- Media.tabletDesktop $ marginRight (px 30)
- Media.mobile $ do
- marginBottom (em 1)
- width (pct 100)
-
- ".selectInput" ? do
- Media.tabletDesktop $ display inlineBlock
-
- ".g-HeaderInfos__Repartition" ? do
+ ".g-PaymentHeaderInfos__Repartition" ? do
Media.tabletDesktop $ lineHeight (px Constants.inputHeight)
Media.mobile $ lineHeight (px 25)
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 1a478dc..34bbd3a 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -15,11 +15,26 @@ import qualified View.Mail.WeeklyReport as WeeklyReport
weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime
weeklyReport conf mbLastExecution = do
now <- getCurrentTime
+
case mbLastExecution of
- Nothing -> return ()
+ Nothing ->
+ return ()
+
Just lastExecution -> do
- (payments, incomes, users) <- Query.run $
- (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list
- _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
+ (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do
+ users <- UserPersistence.list
+ paymentRange <- PaymentPersistence.getRange
+ weekPayments <- PaymentPersistence.listModifiedSince lastExecution
+ weekIncomes <- IncomePersistence.listModifiedSince lastExecution
+ (preIncomeRepartition, postIncomeRepartition) <-
+ PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
+ return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users)
+
+ _ <-
+ SendMail.sendMail
+ conf
+ (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now)
+
return ()
+
return now
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 5068d10..f4d75a0 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -42,9 +42,15 @@ main = do
User.list
S.get "/api/payments" $ do
+ frequency <- S.param "frequency"
page <- S.param "page"
perPage <- S.param "perPage"
- Payment.list page perPage
+ search <- S.param "search"
+ Payment.list (read frequency) page perPage search
+
+ S.get "/api/payment/category" $ do
+ name <- S.param "name"
+ Payment.searchCategory name
S.post "/api/payment" $
S.jsonData >>= Payment.create
@@ -61,9 +67,6 @@ main = do
perPage <- S.param "perPage"
Income.list page perPage
- S.get "/api/deprecated/incomes" $ do
- Income.deprecatedList
-
S.post "/api/income" $
S.jsonData >>= Income.create
@@ -74,9 +77,6 @@ main = do
incomeId <- S.param "id"
Income.delete incomeId
- S.get "/api/paymentCategories" $
- Payment.listPaymentCategories
-
S.get "/api/categories" $
Category.list
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
index 0cc4a03..bcdce61 100644
--- a/server/src/Model/SignIn.hs
+++ b/server/src/Model/SignIn.hs
@@ -7,7 +7,7 @@ module Model.SignIn
) where
import Data.Int (Int64)
-import Data.Maybe (listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock (UTCTime)
@@ -47,7 +47,7 @@ createSignInToken signInEmail =
getSignIn :: Text -> Query (Maybe SignIn)
getSignIn signInToken =
Query (\conn -> do
- listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn])
+ Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn])
)
signInTokenToUsed :: SignInId -> Query ()
diff --git a/common/src/Common/Model/Payer.hs b/server/src/Payer.hs
index 39a5788..d913afe 100644
--- a/common/src/Common/Model/Payer.hs
+++ b/server/src/Payer.hs
@@ -1,19 +1,19 @@
-module Common.Model.Payer
+module Payer
( getExceedingPayers
, useIncomesFrom
, cumulativeIncomesSince
) where
-import qualified Data.List as List
-import qualified Data.Maybe as Maybe
-import Data.Time (NominalDiffTime, UTCTime (..))
-import qualified Data.Time as Time
-import Data.Time.Calendar (Day)
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Time (NominalDiffTime, UTCTime (..))
+import qualified Data.Time as Time
+import Data.Time.Calendar (Day)
-import Common.Model.ExceedingPayer (ExceedingPayer (..))
-import Common.Model.Income (Income (..))
-import Common.Model.Payment (Payment (..))
-import Common.Model.User (User (..), UserId)
+import Common.Model (ExceedingPayer (..), Income (..),
+ User (..), UserId)
data Payer = Payer
{ _payer_userId :: UserId
@@ -29,13 +29,12 @@ data PostPaymentPayer = PostPaymentPayer
, _postPaymentPayer_ratio :: Float
}
-getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer]
-getExceedingPayers currentTime users incomes payments =
+getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer]
+getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment =
let userIds = map _user_id users
- payers = getPayers userIds incomes payments
+ payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition
exceedingPayersOnPreIncome =
exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
- firstPayment = safeHead . List.sort . map _payment_date $ payments
mbSince = useIncomesFrom userIds incomes firstPayment
in case mbSince of
Just since ->
@@ -60,35 +59,15 @@ useIncomesFrom userIds incomes firstPayment =
dayUTCTime :: Day -> UTCTime
dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0)
-getPayers :: [UserId] -> [Income] -> [Payment] -> [Payer]
-getPayers userIds incomes payments =
- let incomesDefined = incomeDefinedForAll userIds incomes
- in flip map userIds (\userId -> Payer
- { _payer_userId = userId
- , _payer_preIncomePayments =
- totalPayments
- (\p ->
- case incomesDefined of
- Just d ->
- _payment_date p < d
-
- Nothing ->
- True
- )
- userId
- payments
- , _payer_postIncomePayments =
- totalPayments
- (\p ->
- case incomesDefined of
- Nothing -> False
- Just t -> _payment_date p >= t
- )
- userId
- payments
- , _payer_incomes = filter ((==) userId . _income_userId) incomes
- }
- )
+getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer]
+getPayers userIds incomes preIncomeRepartition postIncomeRepartition =
+ flip map userIds (\userId -> Payer
+ { _payer_userId = userId
+ , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition
+ , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition
+ , _payer_incomes = filter ((==) userId . _income_userId) incomes
+ }
+ )
exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer]
exceedingPayersFromAmounts userAmounts =
@@ -125,9 +104,9 @@ getFinalDiff maxRatio payer =
incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day
incomeDefinedForAll userIds incomes =
let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
- firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes
+ firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes
in if all Maybe.isJust firstIncomes
- then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
+ then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
else Nothing
cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int
@@ -182,10 +161,6 @@ durationIncome (duration, income) =
nominalDay :: NominalDiffTime
nominalDay = 86400
-safeHead :: [a] -> Maybe a
-safeHead [] = Nothing
-safeHead (x : _) = Just x
-
safeMinimum :: (Ord a) => [a] -> Maybe a
safeMinimum [] = Nothing
safeMinimum xs = Just . minimum $ xs
@@ -193,10 +168,3 @@ safeMinimum xs = Just . minimum $ xs
safeMaximum :: (Ord a) => [a] -> Maybe a
safeMaximum [] = Nothing
safeMaximum xs = Just . maximum $ xs
-
-totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int
-totalPayments paymentFilter userId payments =
- sum
- . map _payment_cost
- . filter (\payment -> paymentFilter payment && _payment_user payment == userId)
- $ payments
diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs
index 2afe5db..00cf0a5 100644
--- a/server/src/Persistence/Category.hs
+++ b/server/src/Persistence/Category.hs
@@ -5,7 +5,7 @@ module Persistence.Category
, delete
) where
-import Data.Maybe (isJust, listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
@@ -48,9 +48,9 @@ create categoryName categoryColor =
edit :: CategoryId -> Text -> Text -> Query Bool
edit categoryId categoryName categoryColor =
Query (\conn -> do
- mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
+ mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
(SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
- if isJust mbCategory
+ if Maybe.isJust mbCategory
then do
now <- getCurrentTime
SQLite.execute
@@ -65,9 +65,9 @@ edit categoryId categoryName categoryColor =
delete :: CategoryId -> Query Bool
delete categoryId =
Query (\conn -> do
- mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
+ mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
(SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
- if isJust mbCategory
+ if Maybe.isJust mbCategory
then do
now <- getCurrentTime
SQLite.execute
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index cb2ef10..ba7ad19 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -2,17 +2,22 @@ module Persistence.Income
( count
, list
, listAll
+ , listModifiedSince
, create
, edit
, delete
+ , definedForAll
) where
-import Data.Maybe (listToMaybe)
+import qualified Data.List as L
+import qualified Data.Maybe as Maybe
+import qualified Data.Text as T
import Data.Time.Calendar (Day)
+import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
+import Prelude hiding (id, until)
import Common.Model (Income (..), IncomeId, PaymentId,
UserId)
@@ -31,15 +36,15 @@ instance FromRow Row where
SQLite.field <*>
SQLite.field)
-data Count = Count Int
+data CountRow = CountRow Int
-instance FromRow Count where
- fromRow = Count <$> SQLite.field
+instance FromRow CountRow where
+ fromRow = CountRow <$> SQLite.field
count :: Query Int
count =
Query (\conn ->
- (\[Count n] -> n) <$>
+ (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$>
SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL"
)
@@ -60,6 +65,23 @@ listAll =
SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
)
+listModifiedSince :: UTCTime -> Query [Income]
+listModifiedSince since =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query
+ conn
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT *"
+ , "FROM income"
+ , "WHERE"
+ , "created_at >= ?"
+ , "OR edited_at >= ?"
+ , "OR deleted_at >= ?"
+ ])
+ (Only since)
+ )
+
create :: UserId -> Day -> Int -> Query Income
create userId date amount =
Query (\conn -> do
@@ -83,7 +105,7 @@ create userId date amount =
edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income)
edit userId incomeId incomeDate incomeAmount =
Query (\conn -> do
- mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$>
+ mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$>
SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
case mbIncome of
Just income ->
@@ -114,3 +136,26 @@ delete userId paymentId =
"UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
(paymentId, userId)
)
+
+data UserDayRow = UserDayRow (UserId, Day)
+
+instance FromRow UserDayRow where
+ fromRow = do
+ user <- SQLite.field
+ day <- SQLite.field
+ return $ UserDayRow (user, day)
+
+definedForAll :: [UserId] -> Query (Maybe Day)
+definedForAll users =
+ Query (\conn ->
+ (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$>
+ SQLite.query_
+ conn
+ "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;"
+ )
+ where
+ fromRows rows =
+ if L.sort users == L.sort (map fst rows) then
+ Maybe.listToMaybe . L.sort . map snd $ rows
+ else
+ Nothing
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index 7835c98..f75925d 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -1,33 +1,57 @@
module Persistence.Payment
( count
, find
- , firstPunctualDay
- , listActive
+ , getRange
, listActivePage
- , listPunctual
+ , listModifiedSince
, listActiveMonthlyOrderedByName
, create
, createMany
, edit
, delete
+ , searchCategory
+ , repartition
+ , getPreAndPostPaymentRepartition
) where
-import Data.Maybe (listToMaybe)
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
+import qualified Data.Time.Calendar as Calendar
+import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only),
ToRow)
import qualified Database.SQLite.Simple as SQLite
import Database.SQLite.Simple.ToField (ToField (toField))
-import Prelude hiding (id)
+import Prelude hiding (id, until)
-import Common.Model (Frequency (..), Payment (..),
- PaymentId, UserId)
+import Common.Model (CategoryId, Frequency (..),
+ Payment (..), PaymentId,
+ User (..), UserId)
import Model.Query (Query (Query))
import Persistence.Frequency (FrequencyField (..))
+import qualified Persistence.Income as IncomePersistence
+
+
+
+fields :: Text
+fields = T.intercalate "," $
+ [ "id"
+ , "user_id"
+ , "name"
+ , "cost"
+ , "date"
+ , "category"
+ , "frequency"
+ , "created_at"
+ , "edited_at"
+ , "deleted_at"
+ ]
newtype Row = Row Payment
@@ -38,6 +62,7 @@ instance FromRow Row where
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
+ SQLite.field <*>
(fmap (\(FrequencyField f) -> f) $ SQLite.field) <*>
SQLite.field <*>
SQLite.field <*>
@@ -51,6 +76,7 @@ instance ToRow InsertRow where
, toField (_payment_name p)
, toField (_payment_cost p)
, toField (_payment_date p)
+ , toField (_payment_category p)
, toField (FrequencyField (_payment_frequency p))
, toField (_payment_createdAt p)
]
@@ -60,73 +86,94 @@ data Count = Count Int
instance FromRow Count where
fromRow = Count <$> SQLite.field
-count :: Query Int
-count =
+count :: Frequency -> Text -> Query Int
+count frequency search =
Query (\conn ->
(\[Count n] -> n) <$>
- SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL"
+ SQLite.query
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT COUNT(*)"
+ , "FROM payment"
+ , "WHERE"
+ , "deleted_at IS NULL"
+ , "AND frequency = ?"
+ , "AND name LIKE ?"
+ ])
+ (FrequencyField frequency, "%" <> search <> "%")
)
find :: PaymentId -> Query (Maybe Payment)
find paymentId =
Query (\conn -> do
- fmap (\(Row p) -> p) . listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+ fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
+ SQLite.query
+ conn
+ (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?")
+ (Only paymentId)
)
-data DayRow = DayRow Day
+data RangeRow = RangeRow (Day, Day)
-instance FromRow DayRow where
- fromRow = DayRow <$> SQLite.field
+instance FromRow RangeRow where
+ fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field
-firstPunctualDay :: Query (Maybe Day)
-firstPunctualDay =
+getRange :: Query (Maybe (Day, Day))
+getRange =
Query (\conn -> do
- fmap (\(DayRow d) -> d) . listToMaybe <$>
+ fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$>
SQLite.query
conn
- "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1"
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT MIN(date), MAX(date)"
+ , "FROM payment"
+ , "WHERE"
+ , "frequency = ?"
+ , "AND deleted_at IS NULL"
+ ])
(Only (FrequencyField Punctual))
)
-listActive :: Frequency -> Query [Payment]
-listActive frequency =
- Query (\conn -> do
- map (\(Row p) -> p) <$>
- SQLite.query
- conn
- "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?"
- (Only (FrequencyField frequency))
- )
-
-listActivePage :: Int -> Int -> Query [Payment]
-listActivePage page perPage =
+listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment]
+listActivePage frequency page perPage search =
Query (\conn ->
map (\(Row p) -> p) <$>
SQLite.query
conn
(SQLite.Query $ T.intercalate " "
- [ "SELECT *"
+ [ "SELECT"
+ , fields
, "FROM payment"
- , "WHERE deleted_at IS NULL AND frequency = ?"
+ , "WHERE"
+ , "deleted_at IS NULL"
+ , "AND frequency = ?"
+ , "AND name LIKE ?"
, "ORDER BY date DESC"
, "LIMIT ?"
, "OFFSET ?"
]
)
- (FrequencyField Punctual, perPage, (page - 1) * perPage)
+ (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage)
)
-listPunctual :: Query [Payment]
-listPunctual =
- Query (\conn -> do
- map (\(Row p) -> p) <$>
+listModifiedSince :: UTCTime -> Query [Payment]
+listModifiedSince since =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
SQLite.query
conn
- (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
- (Only (FrequencyField Punctual))
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT *"
+ , "FROM payment"
+ , "WHERE"
+ , "created_at >= ?"
+ , "OR edited_at >= ?"
+ , "OR deleted_at >= ?"
+ ])
+ (Only since)
)
+
listActiveMonthlyOrderedByName :: Query [Payment]
listActiveMonthlyOrderedByName =
Query (\conn -> do
@@ -134,7 +181,8 @@ listActiveMonthlyOrderedByName =
SQLite.query
conn
(SQLite.Query $ T.intercalate " "
- [ "SELECT *"
+ [ "SELECT"
+ , fields
, "FROM payment"
, "WHERE deleted_at IS NULL AND frequency = ?"
, "ORDER BY name DESC"
@@ -142,17 +190,17 @@ listActiveMonthlyOrderedByName =
(Only (FrequencyField Monthly))
)
-create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment
-create userId name cost date frequency =
+create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment
+create userId name cost date category frequency =
Query (\conn -> do
time <- getCurrentTime
SQLite.execute
conn
(SQLite.Query $ T.intercalate " "
- [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
- , "VALUES (?, ?, ?, ?, ?, ?)"
+ [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)"
+ , "VALUES (?, ?, ?, ?, ?, ?, ?)"
])
- (userId, name, cost, date, FrequencyField frequency, time)
+ (userId, name, cost, date, category, FrequencyField frequency, time)
paymentId <- SQLite.lastInsertRowId conn
return $ Payment
{ _payment_id = paymentId
@@ -160,6 +208,7 @@ create userId name cost date frequency =
, _payment_name = name
, _payment_cost = cost
, _payment_date = date
+ , _payment_category = category
, _payment_frequency = frequency
, _payment_createdAt = time
, _payment_editedAt = Nothing
@@ -173,19 +222,19 @@ createMany payments =
SQLite.executeMany
conn
(SQLite.Query $ T.intercalate ""
- [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
- , "VALUES (?, ?, ?, ?, ?, ?)"
+ [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)"
+ , "VALUES (?, ?, ?, ?, ?, ?, ?)"
])
(map InsertRow payments)
)
-edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment))
-edit userId paymentId name cost date frequency =
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment)
+edit userId paymentId name cost date category frequency =
Query (\conn -> do
- mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
+ mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
SQLite.query
conn
- "SELECT * FROM payment WHERE id = ? and user_id = ?"
+ (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?")
(paymentId, userId)
case mbPayment of
Just payment -> do
@@ -200,6 +249,7 @@ edit userId paymentId name cost date frequency =
, " name = ?,"
, " cost = ?,"
, " date = ?,"
+ , " category = ?,"
, " frequency = ?"
, "WHERE"
, " id = ?"
@@ -209,16 +259,18 @@ edit userId paymentId name cost date frequency =
, name
, cost
, date
+ , category
, FrequencyField frequency
, paymentId
, userId
)
- return . Just . (,) payment $ Payment
+ return . Just $ Payment
{ _payment_id = paymentId
, _payment_user = userId
, _payment_name = name
, _payment_cost = cost
, _payment_date = date
+ , _payment_category = category
, _payment_frequency = frequency
, _payment_createdAt = _payment_createdAt payment
, _payment_editedAt = Just now
@@ -236,3 +288,59 @@ delete userId paymentId =
"UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
(paymentId, userId)
)
+
+data CategoryIdRow = CategoryIdRow CategoryId
+
+instance FromRow CategoryIdRow where
+ fromRow = CategoryIdRow <$> SQLite.field
+
+searchCategory :: Text -> Query (Maybe CategoryId)
+searchCategory paymentName =
+ Query (\conn ->
+ fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$>
+ SQLite.query
+ conn
+ "SELECT category FROM payment WHERE name LIKE ? LIMIT 1"
+ (Only $ "%" <> paymentName <> "%")
+ )
+
+data UserCostRow = UserCostRow (UserId, Int)
+
+instance FromRow UserCostRow where
+ fromRow = do
+ user <- SQLite.field
+ cost <- SQLite.field
+ return $ UserCostRow (user, cost)
+
+repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int)
+repartition frequency search from to =
+ Query (\conn ->
+ M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query
+ conn
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT user_id, SUM(cost)"
+ , "FROM payment"
+ , "WHERE"
+ , "deleted_at IS NULL"
+ , "AND frequency = ?"
+ , "AND name LIKE ?"
+ , "AND date >= ?"
+ , "AND date < ?"
+ , "GROUP BY user_id"
+ ])
+ (FrequencyField frequency, "%" <> search <> "%", from, to)
+ )
+
+getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int)
+getPreAndPostPaymentRepartition paymentRange users = do
+ case paymentRange of
+ Just (from, to) -> do
+ incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users)
+ (,)
+ <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll))
+ <*> (case incomeDefinedForAll of
+ Just d -> repartition Punctual "" d (Calendar.addDays 1 to)
+ Nothing -> return M.empty)
+
+ Nothing ->
+ return (M.empty, M.empty)
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
deleted file mode 100644
index 46be7f5..0000000
--- a/server/src/Persistence/PaymentCategory.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-module Persistence.PaymentCategory
- ( list
- , listByCategory
- , save
- , deleteIfUnused
- ) where
-
-import qualified Data.Maybe as Maybe
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
-import qualified Database.SQLite.Simple as SQLite
-
-import Common.Model (CategoryId, PaymentCategory (..))
-
-import Model.Query (Query (Query))
-
-newtype Row = Row PaymentCategory
-
-instance FromRow Row where
- fromRow = Row <$> (PaymentCategory <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field)
-
-list :: Query [PaymentCategory]
-list =
- Query (\conn -> do
- map (\(Row pc) -> pc) <$>
- SQLite.query_ conn "SELECT * from payment_category"
- )
-
-listByCategory :: CategoryId -> Query [PaymentCategory]
-listByCategory cat =
- Query (\conn -> do
- map (\(Row pc) -> pc) <$>
- SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
- )
-
-save :: Text -> CategoryId -> Query PaymentCategory
-save newName categoryId =
- Query (\conn -> do
- now <- getCurrentTime
- paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$>
- (SQLite.query
- conn
- "SELECT * FROM payment_category WHERE name = ?"
- (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
- formattedNewName = T.toLower newName
-
-deleteIfUnused :: Text -> Query ()
-deleteIfUnused name =
- Query (\conn ->
- SQLite.execute
- conn
- "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 ()
diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs
index 4ec2dcf..3c3a2b1 100644
--- a/server/src/Persistence/User.hs
+++ b/server/src/Persistence/User.hs
@@ -3,7 +3,7 @@ module Persistence.User
, get
) where
-import Data.Maybe (listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
@@ -32,6 +32,6 @@ list =
get :: Text -> Query (Maybe User)
get userEmail =
Query (\conn -> do
- fmap (\(Row u) -> u) . listToMaybe <$>
+ fmap (\(Row u) -> u) . Maybe.listToMaybe <$>
SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
)
diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs
deleted file mode 100644
index 4e22ba8..0000000
--- a/server/src/Util/List.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Util.List
- ( groupBy
- ) where
-
-import Control.Arrow ((&&&))
-import Data.Function (on)
-import qualified Data.List as L
-
-groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
-groupBy f =
- map (f . head &&& id)
- . L.groupBy ((==) `on` f)
- . L.sortBy (compare `on` f)
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 7e88d98..1f637bc 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -9,6 +9,7 @@ import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Common.Model (ExceedingPayer (..), Income (..),
@@ -23,10 +24,11 @@ import Model.IncomeResource (IncomeResource (..))
import Model.Mail (Mail (Mail))
import qualified Model.Mail as M
import Model.PaymentResource (PaymentResource (..))
+import qualified Payer as Payer
import Resource (Status (..), groupByStatus, statuses)
-mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
-mail conf users payments incomes start end =
+mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail
+mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end =
Mail
{ M.from = Conf.noReplyMail conf
, M.to = map _user_email users
@@ -35,24 +37,24 @@ mail conf users payments incomes start end =
, " − "
, Msg.get Msg.WeeklyReport_Title
]
- , M.body = body conf users payments incomes start end
+ , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end
}
-body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text
-body conf users payments incomes start end =
+body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text
+body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end =
T.intercalate "\n" $
- [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments)
+ [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment
, operations conf users paymentsGroupedByStatus incomesGroupedByStatus
]
where
- paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments
+ paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments
incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes
-exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text
-exceedingPayers conf time users incomes payments =
+exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text
+exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment =
T.intercalate "\n" . map formatPayer $ payers
where
- payers = CM.getExceedingPayers time users incomes payments
+ payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment
formatPayer p = T.concat
[ " * "
, fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 07:18:32 +0000