aboutsummaryrefslogtreecommitdiff
path: root/server/src/Model
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Model')
-rw-r--r--server/src/Model/Payer.hs217
1 files changed, 0 insertions, 217 deletions
diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs
deleted file mode 100644
index db3f37c..0000000
--- a/server/src/Model/Payer.hs
+++ /dev/null
@@ -1,217 +0,0 @@
-module Model.Payer
- ( getOrderedExceedingPayers
- ) where
-
-import qualified Data.List as List
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Maybe as Maybe
-import Data.Time (NominalDiffTime, UTCTime (..))
-import qualified Data.Time as Time
-
-import Common.Model (Income (..), IncomeId, Payment (..), User (..),
- UserId)
-
-type Users = Map UserId User
-
-type Payers = Map UserId Payer
-
-type Incomes = Map IncomeId Income
-
-type Payments = [Payment]
-
-data Payer = Payer
- { preIncomePaymentSum :: Int
- , postIncomePaymentSum :: Int
- , _incomes :: [Income]
- }
-
-data PostPaymentPayer = PostPaymentPayer
- { _preIncomePaymentSum :: Int
- , _cumulativeIncome :: Int
- , ratio :: Float
- }
-
-data ExceedingPayer = ExceedingPayer
- { _userId :: UserId
- , amount :: Int
- } deriving (Show)
-
-getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer]
-getOrderedExceedingPayers currentTime users incomes payments =
- let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users
- incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes
- payers = getPayers currentTime usersMap incomesMap payments
- exceedingPayersOnPreIncome =
- exceedingPayersFromAmounts
- . Map.toList
- . Map.map preIncomePaymentSum
- $ payers
- mbSince = useIncomesFrom usersMap incomesMap payments
- in case mbSince of
- Just since ->
- let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers
- mbMaxRatio =
- safeMaximum
- . map (ratio . snd)
- . Map.toList
- $ postPaymentPayers
- in case mbMaxRatio of
- Just maxRatio ->
- exceedingPayersFromAmounts
- . Map.toList
- . Map.map (getFinalDiff maxRatio)
- $ postPaymentPayers
- Nothing ->
- exceedingPayersOnPreIncome
- _ ->
- exceedingPayersOnPreIncome
-
-useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime
-useIncomesFrom users incomes payments =
- let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments
- mbIncomeTime = incomeDefinedForAll (Map.keys users) 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 -> Users -> Incomes -> Payments -> Payers
-getPayers currentTime users incomes payments =
- let userIds = Map.keys users
- incomesDefined = incomeDefinedForAll userIds incomes
- in Map.fromList
- . map (\userId ->
- ( userId
- , Payer
- { preIncomePaymentSum =
- totalPayments
- (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined))
- userId
- payments
- , postIncomePaymentSum =
- totalPayments
- (\p ->
- case incomesDefined of
- Nothing -> False
- Just t -> paymentTime p >= t
- )
- userId
- payments
- , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes)
- }
- )
- )
- $ userIds
-
-exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer]
-exceedingPayersFromAmounts userAmounts =
- case mbMinAmount of
- Nothing ->
- []
- Just minAmount ->
- filter (\payer -> amount payer > 0)
- . map (\userAmount ->
- ExceedingPayer
- { _userId = fst userAmount
- , amount = snd userAmount - minAmount
- }
- )
- $ userAmounts
- where mbMinAmount = safeMinimum . map snd $ userAmounts
-
-getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer
-getPostPaymentPayer currentTime since payer =
- PostPaymentPayer
- { _preIncomePaymentSum = preIncomePaymentSum payer
- , _cumulativeIncome = cumulativeIncome
- , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome)
- }
- where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer)
-
-getFinalDiff :: Float -> PostPaymentPayer -> Int
-getFinalDiff maxRatio payer =
- let postIncomeDiff =
- truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer)
- in postIncomeDiff + _preIncomePaymentSum payer
-
-incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime
-incomeDefinedForAll userIds incomes =
- let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ 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 -> Payments -> Int
-totalPayments paymentFilter userId payments =
- sum
- . map _payment_cost
- . filter (\payment -> paymentFilter payment && _payment_user payment == userId)
- $ payments