Add exceeding payer block

2 files changed, 199 insertions, 0 deletions

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