Fetch the first payment date instead of every payment to get cumulative income

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) =