From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Nov 2019 16:19:53 +0100 Subject: Compute cumulative income with a DB query --- server/src/Controller/Income.hs | 28 +++----- server/src/Controller/Payment.hs | 16 +++-- server/src/Design/Global.hs | 6 +- server/src/Design/Loadable.hs | 29 ++++++++ server/src/Design/View/Table.hs | 3 + server/src/Design/Views.hs | 16 +++-- server/src/Job/WeeklyReport.hs | 17 ++++- server/src/Payer.hs | 135 +++++++---------------------------- server/src/Persistence/Income.hs | 58 ++++++++++++--- server/src/Persistence/Payment.hs | 12 +++- server/src/View/Mail/WeeklyReport.hs | 21 +++--- 11 files changed, 173 insertions(+), 168 deletions(-) create mode 100644 server/src/Design/Loadable.hs (limited to 'server/src') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 75d0133..784a2db 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -13,7 +13,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), Income (..), + EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) @@ -21,7 +21,6 @@ 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 @@ -36,26 +35,19 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - paymentRange <- PaymentPersistence.getRange - allIncomes <- IncomePersistence.listAll -- TODO optimize - - let since = - Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) + let userIds = _user_id <$> users - let byUser = - case since of - Just s -> - M.fromList . flip map users $ \user -> - ( _user_id user - , Payer.cumulativeIncomesSince currentTime s $ - filter ((==) (_user_id user) . _income_userId) allIncomes - ) + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll - Nothing -> - M.empty + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty incomes <- IncomePersistence.list page perPage - return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c860810..42a4436 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -11,7 +11,6 @@ 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 @@ -36,16 +35,23 @@ import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () list frequency page perPage search = - Secure.loggedAction (\_ -> do - currentTime <- liftIO Clock.getCurrentTime + Secure.loggedAction (\_ -> (liftIO . Query.run $ do count <- PaymentPersistence.count frequency search payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll -- TODO optimize paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty searchRepartition <- case paymentRange of @@ -57,7 +63,7 @@ list frequency page perPage search = (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index df41cfd..ebd7084 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -12,6 +12,7 @@ import qualified Design.Constants as Constants import qualified Design.Errors as Errors import qualified Design.Form as Form import qualified Design.Helper as Helper +import qualified Design.Loadable as Loadable import qualified Design.Media as Media import qualified Design.Modal as Modal import qualified Design.Tooltip as Tooltip @@ -28,6 +29,7 @@ global = do ".tooltip" ? Tooltip.design Views.design Form.design + Loadable.design spinKeyframes appearKeyframe @@ -92,14 +94,14 @@ global = do h1 ? do color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) + lineHeight (em 1.3) Media.desktop $ fontSize (px 24) Media.tablet $ fontSize (px 22) Media.mobile $ fontSize (px 20) ul ? do + "margin-top" -: "1vh" "margin-bottom" -: "3vh" "margin-left" -: "1vh" li do - (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do users <- UserPersistence.list paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty weekPayments <- PaymentPersistence.listModifiedSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) _ <- SendMail.sendMail conf - (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) return () diff --git a/server/src/Payer.hs b/server/src/Payer.hs index d913afe..ab8312e 100644 --- a/server/src/Payer.hs +++ b/server/src/Payer.hs @@ -1,25 +1,17 @@ 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 Data.Map (Map) +import qualified Data.Map as M -import Common.Model (ExceedingPayer (..), Income (..), - User (..), UserId) +import Common.Model (ExceedingPayer (..), User (..), UserId) data Payer = Payer { _payer_userId :: UserId , _payer_preIncomePayments :: Int , _payer_postIncomePayments :: Int - , _payer_incomes :: [Income] + , _payer_income :: Int } data PostPaymentPayer = PostPaymentPayer @@ -29,43 +21,29 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] -getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = +getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer] +getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition = 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 = + payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition + postPaymentPayers = map getPostPaymentPayer payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersFromAmounts + . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) + $ payers + +getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds cumulativeIncome 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 + , _payer_income = M.findWithDefault 0 userId cumulativeIncome } ) @@ -85,15 +63,14 @@ exceedingPayersFromAmounts userAmounts = $ userAmounts where mbMinAmount = safeMinimum . map snd $ userAmounts -getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = +getPostPaymentPayer :: Payer -> PostPaymentPayer +getPostPaymentPayer payer = PostPaymentPayer { _postPaymentPayer_userId = _payer_userId payer , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer - , _postPaymentPayer_cumulativeIncome = cumulativeIncome - , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + , _postPaymentPayer_cumulativeIncome = _payer_income payer + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer) } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) getFinalDiff :: Float -> PostPaymentPayer -> Int getFinalDiff maxRatio payer = @@ -101,66 +78,6 @@ getFinalDiff maxRatio payer = 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 diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index ba7ad19..e689505 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,21 +1,24 @@ module Persistence.Income ( count , list - , listAll , listModifiedSince , create , edit , delete , definedForAll + , getCumulativeIncome ) where import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M 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 Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)), + Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id, until) @@ -58,13 +61,6 @@ list page perPage = (perPage, (page - 1) * perPage) ) -listAll :: Query [Income] -listAll = - Query (\conn -> - map (\(Row i) -> i) <$> - SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" - ) - listModifiedSince :: UTCTime -> Query [Income] listModifiedSince since = Query (\conn -> @@ -79,7 +75,7 @@ listModifiedSince since = , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) create :: UserId -> Day -> Int -> Query Income @@ -156,6 +152,46 @@ definedForAll users = where fromRows rows = if L.sort users == L.sort (map fst rows) then - Maybe.listToMaybe . L.sort . map snd $ rows + Maybe.listToMaybe . reverse . L.sort . map snd $ rows else Nothing + +getCumulativeIncome :: Day -> Day -> Query (Map UserId Int) +getCumulativeIncome start end = + Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters) + where + query = + T.intercalate "\n" $ + [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM (" + , " SELECT" + , " I1.user_id," + , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count" + , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1" + , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2" + , " ON I2.date > I1.date AND I2.user_id == I1.user_id" + , " GROUP BY I1.date, I1.user_id" + , ") GROUP BY user_id" + ] + + selectBoundedIncomes op param = + T.intercalate "\n" $ + [ " SELECT user_id, date, amount FROM (" + , " SELECT" + , " i.user_id, " <> param <> " AS date, i.amount" + , " FROM" + , " (SELECT id, MAX(date) AS max_date" + , " FROM income" + , " WHERE date <= " <> param <> " AND deleted_at IS NULL" + , " GROUP BY user_id) AS m" + , " INNER JOIN income AS i" + , " ON i.id = m.id AND i.date = m.max_date" + , " ) UNION" + , " SELECT user_id, date, amount" + , " FROM income" + , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL" + ] + + parameters = + [ ":start" := start + , ":end" := end + ] diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index f75925d..953f0ae 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -163,14 +163,14 @@ listModifiedSince since = SQLite.query conn (SQLite.Query . T.intercalate " " $ - [ "SELECT *" + [ "SELECT " <> fields , "FROM payment" , "WHERE" , "created_at >= ?" , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) @@ -300,7 +300,13 @@ searchCategory paymentName = fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (SQLite.Query . T.intercalate " " $ + [ "SELECT category" + , "FROM payment" + , "WHERE deleted_at is NULL AND name LIKE ?" + , "ORDER BY edited_at, created_at" + , "LIMIT 1" + ]) (Only $ "%" <> paymentName <> "%") ) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 1f637bc..3fe224f 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,7 +9,6 @@ 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 (..), @@ -27,8 +26,8 @@ import Model.PaymentResource (PaymentResource (..)) import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -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 :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -37,24 +36,24 @@ mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPay , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition 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 = +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments - incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text -exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = T.intercalate "\n" . map formatPayer $ payers where - payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users -- cgit v1.2.3