Add exceeding payer block

3 files changed, 3 insertions, 220 deletions

diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index 792d482..904a2f5 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -57,7 +57,7 @@ design = do
 
     ".signOut" ? do
       Helper.waitable
-      heightMedia
+      display flex
       svg ? do
         Media.tabletDesktop $ width (px 30)
         Media.mobile $ width (px 20)
diff --git a/server/src/Main.hs b/server/src/Main.hs
index d7b9b93..c8080dc 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -8,6 +8,7 @@ import           Network.Wai.Middleware.Static
 import           Web.Scotty
 
 import           Common.Model                  (Frequency (..), Payment (..))
+import qualified Common.Model                  as CM
 
 import qualified Conf
 import qualified Controller.Category           as Category
@@ -18,7 +19,6 @@ import qualified Controller.SignIn             as SignIn
 import qualified Data.Time                     as Time
 import           Job.Daemon                    (runDaemons)
 import qualified Model.Income                  as IncomeM
-import           Model.Payer                   (getOrderedExceedingPayers)
 import qualified Model.Payment                 as PaymentM
 import qualified Model.Query                   as Query
 import qualified Model.User                    as UserM
@@ -36,7 +36,7 @@ main = do
       (users, incomes, payments) <- liftIO . Query.run $
         liftA3 (,,) UserM.list IncomeM.list PaymentM.list
       let punctualPayments = filter ((==) Punctual . _payment_frequency) payments
-          exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments
+          exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments
       text . LT.pack . show $ exceedingPayers
 
     get "/" $ do
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