Add exceeding payer block

10 files changed, 127 insertions, 119 deletions

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 09c93cd..754b903 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -48,9 +48,3 @@ button buttonIn = do
   return $ ButtonOut
     { _buttonOut_clic = R.domEvent R.Click e
     }
-
--- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text
--- mergeAttr = M.unionWithKey $ \k a b ->
---   if k == "class"
---     then T.intercalate " " [ a, b ]
---     else b
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index fbf5388..e04e2a8 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -58,8 +58,8 @@ loading =
 
 signOut :: forall t m. MonadWidget t m => m ()
 signOut =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
+  svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank
 
 svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
 svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 934f720..15892c4 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -4,6 +4,7 @@ module View.Payment
   , PaymentOut(..)
   ) where
 
+import           Prelude             hiding (init)
 import           Reflex.Dom          (MonadWidget)
 import qualified Reflex.Dom          as R
 
@@ -29,13 +30,14 @@ widget paymentIn = do
   R.divClass "payment" $ do
     rec
       _ <- Header.widget $ HeaderIn
-        { _headerIn_init = _paymentIn_init $ paymentIn
+        { _headerIn_init = init
         }
       _ <- Table.widget $ TableIn
-        { _tableIn_init = _paymentIn_init paymentIn
+        { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pagesOut
         }
       pagesOut <- Pages.widget $ PagesIn
-        { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn
+        { _pagesIn_payments = _init_payments init
         }
     return $ PaymentOut {}
+  where init = _paymentIn_init paymentIn
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 67b4eb4..3f2adc3 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -4,22 +4,29 @@ module View.Payment.Header
   , HeaderOut(..)
   ) where
 
-import qualified Data.List          as L hiding (groupBy)
-import           Data.Maybe         (fromMaybe)
-import qualified Data.Text          as T
-import           Prelude            hiding (init)
-import           Reflex.Dom         (MonadWidget)
-import qualified Reflex.Dom         as R
+import           Control.Monad          (forM_)
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.List              as L hiding (groupBy)
+import           Data.Maybe             (fromMaybe)
+import qualified Data.Text              as T
+import qualified Data.Time              as Time
+import           Prelude                hiding (init)
+import           Reflex.Dom             (MonadWidget)
+import qualified Reflex.Dom             as R
 
-import           Common.Model       (Currency, Frequency (..), Init (..),
-                                     Payment (..), User (..), UserId)
-import qualified Common.Msg         as Msg
-import qualified Common.View.Format as Format
+import           Common.Model           (Currency, ExceedingPayer (..),
+                                         Frequency (..), Income (..), Init (..),
+                                         Payment (..), User (..), UserId)
+import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
+import qualified Common.View.Format     as Format
 
-import qualified Util.List          as L
+import           Component              (ButtonIn (..))
+import qualified Component              as Component
+import qualified Util.List              as L
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init    :: Init
+  { _headerIn_init :: Init
   }
 
 data HeaderOut = HeaderOut
@@ -29,13 +36,37 @@ data HeaderOut = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut
 widget headerIn =
   R.divClass "header" $ do
+    payerAndAdd incomes payments users currency
     infos payments users currency
     return $ HeaderOut {}
   where init = _headerIn_init headerIn
-        payments = _init_payments init
+        incomes = _init_incomes init
+        payments = filter ((==) Punctual . _payment_frequency) (_init_payments init)
         users = _init_users init
         currency = _init_currency init
 
+payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
+payerAndAdd incomes payments users currency = do
+  time <- liftIO Time.getCurrentTime
+  R.divClass "payerAndAdd" $ do
+    R.divClass "exceedingPayers" $
+      forM_
+        (CM.getExceedingPayers time users incomes payments)
+        (\p ->
+          R.elClass "span" "exceedingPayer" $ do
+            R.elClass "span" "userName" $
+              R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users
+            R.elClass "span" "amount" $ do
+              R.text "+ "
+              R.text . Format.price currency $ _exceedingPayer_amount p
+        )
+    _ <- Component.button $ ButtonIn
+      { _buttonIn_class = R.constDyn "addPayment"
+      , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
+      , _buttonIn_waiting = R.never
+      }
+    return ()
+
 infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m ()
 infos payments users currency =
   R.divClass "infos" $ do
@@ -52,14 +83,13 @@ infos payments users currency =
       T.intercalate ", "
         . map (\(userId, userTotal) ->
             Msg.get $ Msg.Payment_By
-              (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users)
+              (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
               (Format.price currency userTotal)
           )
         $ totalByUser
 
-  where punctualPayments = filter ((==) Punctual . _payment_frequency) payments
-        paymentCount = length punctualPayments
-        total = sum . map _payment_cost $ punctualPayments
+  where paymentCount = length payments
+        total = sum . map _payment_cost $ payments
 
         totalByUser :: [(UserId, Int)]
         totalByUser =
@@ -67,4 +97,4 @@ infos payments users currency =
             . map (\(u, xs) -> (u, sum . map snd $ xs))
             . L.groupBy fst
             . map (\p -> (_payment_user p, _payment_cost p))
-            $ punctualPayments
+            $ payments
diff --git a/common/common.cabal b/common/common.cabal
index e4a9c59..7eadb49 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -47,6 +47,7 @@ Library
     Common.Model.Income
     Common.Model.Init
     Common.Model.InitResult
+    Common.Model.Payer
     Common.Model.Payment
     Common.Model.PaymentCategory
     Common.Model.SignIn
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/server/src/Model/Payer.hs b/common/src/Common/Model/Payer.hs
index db3f37c..d09dbf6 100644
--- a/server/src/Model/Payer.hs
+++ b/common/src/Common/Model/Payer.hs
@@ -1,76 +1,61 @@
-module Model.Payer
-  ( getOrderedExceedingPayers
+module Common.Model.Payer
+  ( getExceedingPayers
+  , ExceedingPayer(..)
   ) 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 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 (..), IncomeId, Payment (..), User (..),
-                               UserId)
-
-type Users = Map UserId User
-
-type Payers = Map UserId Payer
-
-type Incomes = Map IncomeId Income
-
-type Payments = [Payment]
+import           Common.Model.Income  (Income (..))
+import           Common.Model.Payment (Payment (..))
+import           Common.Model.User    (User (..), UserId)
 
 data Payer = Payer
-  { preIncomePaymentSum  :: Int
-  , postIncomePaymentSum :: Int
-  , _incomes             :: [Income]
+  { _payer_userId             :: UserId
+  , _payer_preIncomePayments  :: Int
+  , _payer_postIncomePayments :: Int
+  , _payer_incomes            :: [Income]
   }
 
 data PostPaymentPayer = PostPaymentPayer
-  { _preIncomePaymentSum :: Int
-  , _cumulativeIncome    :: Int
-  , ratio                :: Float
+  { _postPaymentPayer_userId            :: UserId
+  , _postPaymentPayer_preIncomePayments :: Int
+  , _postPaymentPayer_cumulativeIncome  :: Int
+  , _postPaymentPayer_ratio             :: Float
   }
 
 data ExceedingPayer = ExceedingPayer
-  { _userId :: UserId
-  , amount  :: Int
+  { _exceedingPayer_userId :: UserId
+  , _exceedingPayer_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
+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.toList
-          . Map.map preIncomePaymentSum
-          $ payers
-      mbSince = useIncomesFrom usersMap incomesMap payments
+        exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
+      mbSince = useIncomesFrom userIds incomes payments
   in  case mbSince of
         Just since ->
-          let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers
-              mbMaxRatio =
-                safeMaximum
-                  . map (ratio . snd)
-                  . Map.toList
-                  $ postPaymentPayers
+          let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers
+              mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers
           in  case mbMaxRatio of
                 Just maxRatio ->
                   exceedingPayersFromAmounts
-                    . Map.toList
-                    . Map.map (getFinalDiff maxRatio)
+                    . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p))
                     $ postPaymentPayers
                 Nothing ->
                   exceedingPayersOnPreIncome
         _ ->
           exceedingPayersOnPreIncome
 
-useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime
-useIncomesFrom users incomes payments =
+useIncomesFrom :: [UserId] -> [Income] -> [Payment] -> Maybe UTCTime
+useIncomesFrom userIds incomes payments =
   let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments
-      mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes
+      mbIncomeTime = incomeDefinedForAll userIds incomes
   in  case (firstPaymentTime, mbIncomeTime) of
         (Just t1, Just t2) -> Just (max t1 t2)
         _                  -> Nothing
@@ -78,33 +63,28 @@ useIncomesFrom users incomes payments =
 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
+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 =
@@ -112,11 +92,11 @@ exceedingPayersFromAmounts userAmounts =
     Nothing ->
       []
     Just minAmount ->
-      filter (\payer -> amount payer > 0)
+      filter (\payer -> _exceedingPayer_amount payer > 0)
         . map (\userAmount ->
            ExceedingPayer
-             { _userId = fst userAmount
-             , amount = snd userAmount - minAmount
+             { _exceedingPayer_userId = fst userAmount
+             , _exceedingPayer_amount = snd userAmount - minAmount
              }
         )
         $ userAmounts
@@ -125,21 +105,22 @@ exceedingPayersFromAmounts userAmounts =
 getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer
 getPostPaymentPayer currentTime since payer =
   PostPaymentPayer
-    { _preIncomePaymentSum = preIncomePaymentSum payer
-    , _cumulativeIncome = cumulativeIncome
-    , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome)
+    { _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 (_incomes payer)
+  where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer)
 
 getFinalDiff :: Float -> PostPaymentPayer -> Int
 getFinalDiff maxRatio payer =
   let postIncomeDiff =
-        truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer)
-  in  postIncomeDiff + _preIncomePaymentSum payer
+        truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer)
+  in  postIncomeDiff + _postPaymentPayer_preIncomePayments payer
 
-incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime
+incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime
 incomeDefinedForAll userIds incomes =
-  let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds
+  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
@@ -209,7 +190,7 @@ safeMaximum :: (Ord a) => [a] -> Maybe a
 safeMaximum [] = Nothing
 safeMaximum xs = Just . maximum $ xs
 
-totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int
+totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int
 totalPayments paymentFilter userId payments =
   sum
     . map _payment_cost
diff --git a/server/server.cabal b/server/server.cabal
index e4a1730..771a961 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -94,7 +94,6 @@ Executable server
     Model.Income
     Model.Init
     Model.Mail
-    Model.Payer
     Model.Payment
     Model.PaymentCategory
     Model.Query
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