aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorJoris2019-11-17 18:08:28 +0100
committerJoris2019-11-17 18:08:28 +0100
commitc0ea63f8c1a8c7123b78798cec99726b113fb1f3 (patch)
tree0b92f7e0c125c067a5f1ccafe6a1f04f1edfae86 /server
parent4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 (diff)
Optimize and refactor payments
Diffstat (limited to 'server')
-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.hs170
-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
20 files changed, 585 insertions, 328 deletions
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/server/src/Payer.hs b/server/src/Payer.hs
new file mode 100644
index 0000000..d913afe
--- /dev/null
+++ b/server/src/Payer.hs
@@ -0,0 +1,170 @@
+module Payer
+ ( getExceedingPayers
+ , useIncomesFrom
+ , cumulativeIncomesSince
+ ) where
+
+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 (..), Income (..),
+ User (..), UserId)
+
+data Payer = Payer
+ { _payer_userId :: UserId
+ , _payer_preIncomePayments :: Int
+ , _payer_postIncomePayments :: Int
+ , _payer_incomes :: [Income]
+ }
+
+data PostPaymentPayer = PostPaymentPayer
+ { _postPaymentPayer_userId :: UserId
+ , _postPaymentPayer_preIncomePayments :: Int
+ , _postPaymentPayer_cumulativeIncome :: Int
+ , _postPaymentPayer_ratio :: Float
+ }
+
+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 preIncomeRepartition postIncomeRepartition
+ exceedingPayersOnPreIncome =
+ exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
+ mbSince = useIncomesFrom userIds incomes firstPayment
+ in case mbSince of
+ Just since ->
+ let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers
+ mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers
+ in case mbMaxRatio of
+ Just maxRatio ->
+ exceedingPayersFromAmounts
+ . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p))
+ $ postPaymentPayers
+ Nothing ->
+ exceedingPayersOnPreIncome
+ _ ->
+ exceedingPayersOnPreIncome
+
+useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day
+useIncomesFrom userIds incomes firstPayment =
+ case (firstPayment, incomeDefinedForAll userIds incomes) of
+ (Just d1, Just d2) -> Just (max d1 d2)
+ _ -> Nothing
+
+dayUTCTime :: Day -> UTCTime
+dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0)
+
+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 =
+ case mbMinAmount of
+ Nothing ->
+ []
+ Just minAmount ->
+ filter (\payer -> _exceedingPayer_amount payer > 0)
+ . map (\userAmount ->
+ ExceedingPayer
+ { _exceedingPayer_userId = fst userAmount
+ , _exceedingPayer_amount = snd userAmount - minAmount
+ }
+ )
+ $ userAmounts
+ where mbMinAmount = safeMinimum . map snd $ userAmounts
+
+getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer
+getPostPaymentPayer currentTime since payer =
+ PostPaymentPayer
+ { _postPaymentPayer_userId = _payer_userId payer
+ , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer
+ , _postPaymentPayer_cumulativeIncome = cumulativeIncome
+ , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome)
+ }
+ where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer)
+
+getFinalDiff :: Float -> PostPaymentPayer -> Int
+getFinalDiff maxRatio payer =
+ let postIncomeDiff =
+ truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer)
+ in postIncomeDiff + _postPaymentPayer_preIncomePayments payer
+
+incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day
+incomeDefinedForAll userIds incomes =
+ let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
+ firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes
+ in if all Maybe.isJust firstIncomes
+ then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
+ else Nothing
+
+cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int
+cumulativeIncomesSince currentTime since incomes =
+ getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
+
+getOrderedIncomesSince :: Day -> [Income] -> [Income]
+getOrderedIncomesSince since incomes =
+ let mbStarterIncome = getIncomeAt since incomes
+ orderedIncomesSince = filter (\income -> _income_date income >= since) incomes
+ in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
+
+getIncomeAt :: Day -> [Income] -> Maybe Income
+getIncomeAt day incomes =
+ case incomes of
+ [x] ->
+ if _income_date x < day
+ then Just $ x { _income_date = day }
+ else Nothing
+ x1 : x2 : xs ->
+ if _income_date x1 < day && _income_date x2 >= day
+ then Just $ x1 { _income_date = day }
+ else getIncomeAt day (x2 : xs)
+ [] ->
+ Nothing
+
+getCumulativeIncome :: UTCTime -> [Income] -> Int
+getCumulativeIncome currentTime incomes =
+ sum
+ . map durationIncome
+ . getIncomesWithDuration currentTime
+ . List.sortOn incomeTime
+ $ incomes
+
+getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)]
+getIncomesWithDuration currentTime incomes =
+ case incomes of
+ [] ->
+ []
+ [income] ->
+ [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)]
+ (income1 : income2 : xs) ->
+ (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs))
+
+incomeTime :: Income -> UTCTime
+incomeTime = dayUTCTime . _income_date
+
+durationIncome :: (NominalDiffTime, Int) -> Int
+durationIncome (duration, income) =
+ truncate $ duration * fromIntegral income / (nominalDay * 365 / 12)
+
+nominalDay :: NominalDiffTime
+nominalDay = 86400
+
+safeMinimum :: (Ord a) => [a] -> Maybe a
+safeMinimum [] = Nothing
+safeMinimum xs = Just . minimum $ xs
+
+safeMaximum :: (Ord a) => [a] -> Maybe a
+safeMaximum [] = Nothing
+safeMaximum xs = Just . maximum $ xs
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