diff options
Diffstat (limited to 'server/src')
| -rw-r--r-- | server/src/Controller/Category.hs | 27 | ||||
| -rw-r--r-- | server/src/Controller/Income.hs | 17 | ||||
| -rw-r--r-- | server/src/Controller/Payment.hs | 137 | ||||
| -rw-r--r-- | server/src/Design/Form.hs | 1 | ||||
| -rw-r--r-- | server/src/Design/View/Payment.hs | 6 | ||||
| -rw-r--r-- | server/src/Design/View/Payment/HeaderForm.hs | 40 | ||||
| -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.hs | 23 | ||||
| -rw-r--r-- | server/src/Main.hs | 14 | ||||
| -rw-r--r-- | server/src/Model/SignIn.hs | 4 | ||||
| -rw-r--r-- | server/src/Payer.hs | 170 | ||||
| -rw-r--r-- | server/src/Persistence/Category.hs | 10 | ||||
| -rw-r--r-- | server/src/Persistence/Income.hs | 59 | ||||
| -rw-r--r-- | server/src/Persistence/Payment.hs | 214 | ||||
| -rw-r--r-- | server/src/Persistence/PaymentCategory.hs | 89 | ||||
| -rw-r--r-- | server/src/Persistence/User.hs | 4 | ||||
| -rw-r--r-- | server/src/Util/List.hs | 13 | ||||
| -rw-r--r-- | server/src/View/Mail/WeeklyReport.hs | 22 |
18 files changed, 561 insertions, 325 deletions
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 |