From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 18:08:28 +0100 Subject: Optimize and refactor payments --- server/src/Payer.hs | 170 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 server/src/Payer.hs (limited to 'server/src/Payer.hs') 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 -- cgit v1.2.3 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/Payer.hs | 135 ++++++++++------------------------------------------ 1 file changed, 26 insertions(+), 109 deletions(-) (limited to 'server/src/Payer.hs') 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 -- cgit v1.2.3