aboutsummaryrefslogtreecommitdiff
path: root/common/src
diff options
context:
space:
mode:
Diffstat (limited to 'common/src')
-rw-r--r--common/src/Common/Model/IncomeHeader.hs12
-rw-r--r--common/src/Common/Model/Payer.hs71
2 files changed, 45 insertions, 38 deletions
diff --git a/common/src/Common/Model/IncomeHeader.hs b/common/src/Common/Model/IncomeHeader.hs
index a1defdf..87c7aae 100644
--- a/common/src/Common/Model/IncomeHeader.hs
+++ b/common/src/Common/Model/IncomeHeader.hs
@@ -2,15 +2,15 @@ module Common.Model.IncomeHeader
( IncomeHeader(..)
) where
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Map (Map)
-import Data.Time.Clock (UTCTime)
-import GHC.Generics (Generic)
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Map (Map)
+import Data.Time.Calendar (Day)
+import GHC.Generics (Generic)
-import Common.Model.User (UserId)
+import Common.Model.User (UserId)
data IncomeHeader = IncomeHeader
- { _incomeHeader_since :: Maybe UTCTime
+ { _incomeHeader_since :: Maybe Day
, _incomeHeader_byUser :: Map UserId Int
} deriving (Show, Generic)
diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs
index 40228d5..3c816c8 100644
--- a/common/src/Common/Model/Payer.hs
+++ b/common/src/Common/Model/Payer.hs
@@ -9,6 +9,7 @@ import qualified Data.List as List
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.Income (Income (..))
import Common.Model.Payment (Payment (..))
@@ -36,10 +37,11 @@ data ExceedingPayer = ExceedingPayer
getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer]
getExceedingPayers currentTime users incomes payments =
let userIds = map _user_id users
- payers = getPayers currentTime userIds incomes payments
+ payers = getPayers userIds incomes payments
exceedingPayersOnPreIncome =
exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
- mbSince = useIncomesFrom userIds incomes payments
+ firstPayment = safeHead . List.sort . map _payment_date $ payments
+ mbSince = useIncomesFrom userIds incomes firstPayment
in case mbSince of
Just since ->
let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers
@@ -54,25 +56,30 @@ getExceedingPayers currentTime users incomes payments =
_ ->
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
+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
-paymentTime :: Payment -> UTCTime
-paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date
+dayUTCTime :: Day -> UTCTime
+dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0)
-getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer]
-getPayers currentTime userIds incomes payments =
+getPayers :: [UserId] -> [Income] -> [Payment] -> [Payer]
+getPayers 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))
+ (\p ->
+ case incomesDefined of
+ Just d ->
+ _payment_date p < d
+
+ Nothing ->
+ True
+ )
userId
payments
, _payer_postIncomePayments =
@@ -80,7 +87,7 @@ getPayers currentTime userIds incomes payments =
(\p ->
case incomesDefined of
Nothing -> False
- Just t -> paymentTime p >= t
+ Just t -> _payment_date p >= t
)
userId
payments
@@ -104,7 +111,7 @@ exceedingPayersFromAmounts userAmounts =
$ userAmounts
where mbMinAmount = safeMinimum . map snd $ userAmounts
-getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer
+getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer
getPostPaymentPayer currentTime since payer =
PostPaymentPayer
{ _postPaymentPayer_userId = _payer_userId payer
@@ -120,35 +127,35 @@ getFinalDiff maxRatio payer =
truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer)
in postIncomeDiff + _postPaymentPayer_preIncomePayments payer
-incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime
+incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day
incomeDefinedForAll userIds incomes =
let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
- firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes
+ firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes
in if all Maybe.isJust firstIncomes
- then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes
+ then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
else Nothing
-cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int
+cumulativeIncomesSince :: UTCTime -> Day -> [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
+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 :: UTCTime -> [Income] -> Maybe Income
-getIncomeAt time incomes =
+getIncomeAt :: Day -> [Income] -> Maybe Income
+getIncomeAt day incomes =
case incomes of
[x] ->
- if incomeTime x < time
- then Just $ x { _income_date = utctDay time }
+ if _income_date x < day
+ then Just $ x { _income_date = day }
else Nothing
x1 : x2 : xs ->
- if incomeTime x1 < time && incomeTime x2 >= time
- then Just $ x1 { _income_date = utctDay time }
- else getIncomeAt time (x2 : xs)
+ if _income_date x1 < day && _income_date x2 >= day
+ then Just $ x1 { _income_date = day }
+ else getIncomeAt day (x2 : xs)
[] ->
Nothing
@@ -171,7 +178,7 @@ getIncomesWithDuration currentTime incomes =
(Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs))
incomeTime :: Income -> UTCTime
-incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date
+incomeTime = dayUTCTime . _income_date
durationIncome :: (NominalDiffTime, Int) -> Int
durationIncome (duration, income) =