aboutsummaryrefslogtreecommitdiff
path: root/common
diff options
context:
space:
mode:
Diffstat (limited to 'common')
-rw-r--r--common/common.cabal1
-rw-r--r--common/src/Common/Model.hs1
-rw-r--r--common/src/Common/Model/Payer.hs198
3 files changed, 200 insertions, 0 deletions
diff --git a/common/common.cabal b/common/common.cabal
index e4a9c59..7eadb49 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -47,6 +47,7 @@ Library
Common.Model.Income
Common.Model.Init
Common.Model.InitResult
+ Common.Model.Payer
Common.Model.Payment
Common.Model.PaymentCategory
Common.Model.SignIn
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index 20e86c1..cb38b2f 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -12,6 +12,7 @@ import Common.Model.Frequency as X
import Common.Model.Income as X
import Common.Model.Init as X
import Common.Model.InitResult as X
+import Common.Model.Payer as X
import Common.Model.Payment as X
import Common.Model.PaymentCategory as X
import Common.Model.SignIn as X
diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs
new file mode 100644
index 0000000..d09dbf6
--- /dev/null
+++ b/common/src/Common/Model/Payer.hs
@@ -0,0 +1,198 @@
+module Common.Model.Payer
+ ( getExceedingPayers
+ , ExceedingPayer(..)
+ ) where
+
+import qualified Data.List as List
+import qualified Data.Maybe as Maybe
+import Data.Time (NominalDiffTime, UTCTime (..))
+import qualified Data.Time as Time
+
+import Common.Model.Income (Income (..))
+import Common.Model.Payment (Payment (..))
+import Common.Model.User (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
+ }
+
+data ExceedingPayer = ExceedingPayer
+ { _exceedingPayer_userId :: UserId
+ , _exceedingPayer_amount :: Int
+ } deriving (Show)
+
+getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer]
+getExceedingPayers currentTime users incomes payments =
+ let userIds = map _user_id users
+ payers = getPayers currentTime userIds incomes payments
+ exceedingPayersOnPreIncome =
+ exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
+ mbSince = useIncomesFrom userIds incomes payments
+ 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] -> [Payment] -> Maybe UTCTime
+useIncomesFrom userIds incomes payments =
+ let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments
+ mbIncomeTime = incomeDefinedForAll userIds incomes
+ in case (firstPaymentTime, mbIncomeTime) of
+ (Just t1, Just t2) -> Just (max t1 t2)
+ _ -> Nothing
+
+paymentTime :: Payment -> UTCTime
+paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date
+
+getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer]
+getPayers currentTime userIds incomes payments =
+ let incomesDefined = incomeDefinedForAll userIds incomes
+ in flip map userIds (\userId -> Payer
+ { _payer_userId = userId
+ , _payer_preIncomePayments =
+ totalPayments
+ (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined))
+ userId
+ payments
+ , _payer_postIncomePayments =
+ totalPayments
+ (\p ->
+ case incomesDefined of
+ Nothing -> False
+ Just t -> paymentTime p >= t
+ )
+ userId
+ payments
+ , _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 -> UTCTime -> 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 UTCTime
+incomeDefinedForAll userIds incomes =
+ let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
+ firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes
+ in if all Maybe.isJust firstIncomes
+ then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes
+ else Nothing
+
+cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int
+cumulativeIncomesSince currentTime since incomes =
+ getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
+
+getOrderedIncomesSince :: UTCTime -> [Income] -> [Income]
+getOrderedIncomesSince time incomes =
+ let mbStarterIncome = getIncomeAt time incomes
+ orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes
+ in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
+
+getIncomeAt :: UTCTime -> [Income] -> Maybe Income
+getIncomeAt time incomes =
+ case incomes of
+ [x] ->
+ if incomeTime x < time
+ then Just $ x { _income_date = utctDay time }
+ else Nothing
+ x1 : x2 : xs ->
+ if incomeTime x1 < time && incomeTime x2 >= time
+ then Just $ x1 { _income_date = utctDay time }
+ else getIncomeAt time (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 = flip UTCTime (Time.secondsToDiffTime 0) . _income_date
+
+durationIncome :: (NominalDiffTime, Int) -> Int
+durationIncome (duration, income) =
+ truncate $ duration * fromIntegral income / (nominalDay * 365 / 12)
+
+nominalDay :: NominalDiffTime
+nominalDay = 86400
+
+safeHead :: [a] -> Maybe a
+safeHead [] = Nothing
+safeHead (x : _) = Just x
+
+safeMinimum :: (Ord a) => [a] -> Maybe a
+safeMinimum [] = Nothing
+safeMinimum xs = Just . minimum $ xs
+
+safeMaximum :: (Ord a) => [a] -> Maybe a
+safeMaximum [] = Nothing
+safeMaximum xs = Just . maximum $ xs
+
+totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int
+totalPayments paymentFilter userId payments =
+ sum
+ . map _payment_cost
+ . filter (\payment -> paymentFilter payment && _payment_user payment == userId)
+ $ payments
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 15:55:44 +0000