1 files changed, 170 insertions, 0 deletions
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