Using incomes to compute a fair computation to designate the payer

35 files changed, 577 insertions, 194 deletions

diff --git a/src/client/Main.elm b/src/client/Main.elm
index 621fb97..de98809 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -10,11 +10,12 @@ import Http
 import Task exposing (..)
 import Time exposing (..)
 import Json.Decode as Json exposing ((:=))
+import Dict
 
 import Model exposing (Model, initialModel)
 import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
 import Model.Payment exposing (Payments, paymentsDecoder, perPage)
-import Model.Payers exposing (Payers, payersDecoder)
+import Model.Payer exposing (Payers, payersDecoder)
 import Model.Translations exposing (..)
 
 import Update exposing (Action(..), actions, updateModel)
@@ -32,7 +33,7 @@ model = Signal.foldp updateModel (initialModel initialTime translations) update
 
 update : Signal Action
 update = Signal.mergeMany
-  [ Signal.map UpdateTime (Time.every 30)
+  [ Signal.map UpdateTime (Time.every 1000)
   , actions.signal
   ]
 
@@ -66,8 +67,7 @@ goLoggedInView =
   Task.andThen getPayments <| \payments ->
   Task.andThen getPaymentsCount <| \paymentsCount ->
   Task.andThen getPayers <| \payers ->
-  Task.andThen getIncome <| \income ->
-    Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers income)
+    Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers)
 
 getUsers : Task Http.Error Users
 getUsers = Http.get usersDecoder "/users"
@@ -85,10 +85,7 @@ getPaymentsCount : Task Http.Error Int
 getPaymentsCount = Http.get ("number" := Json.int) "/payments/count"
 
 getPayers : Task Http.Error Payers
-getPayers = Http.get payersDecoder "/payments/total"
-
-getIncome : Task Http.Error (Maybe Int)
-getIncome = Http.get (Json.maybe ("income" := Json.int)) "/income"
+getPayers = Http.get payersDecoder "/payers"
 
 ---------------------------------------
 
diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm
new file mode 100644
index 0000000..1c56de4
--- /dev/null
+++ b/src/client/Model/Date.elm
@@ -0,0 +1,15 @@
+module Model.Date
+  ( timeDecoder
+  , dateDecoder
+  ) where
+
+import Date as Date exposing (Date)
+import Time exposing (Time)
+
+import Json.Decode as Json exposing (..)
+
+timeDecoder : Decoder Time
+timeDecoder = Json.map Date.toTime dateDecoder
+
+dateDecoder : Decoder Date
+dateDecoder = customDecoder string Date.fromString
diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm
new file mode 100644
index 0000000..ce30772
--- /dev/null
+++ b/src/client/Model/Income.elm
@@ -0,0 +1,76 @@
+module Model.Income
+  ( Income
+  , incomeDecoder
+  , incomeDefinedForAll
+  , cumulativeIncomesSince
+  ) where
+
+import Json.Decode as Json exposing ((:=))
+import Time exposing (Time, hour)
+import List exposing (..)
+
+import Model.Date exposing (timeDecoder)
+import Model.User exposing (UserId)
+
+import Utils.Maybe exposing (isJust, catMaybes, maybeToList)
+
+type alias Income =
+  { creation : Time
+  , amount : Int
+  }
+
+incomeDecoder : Json.Decoder Income
+incomeDecoder =
+  Json.object2 Income
+    ("creation" := timeDecoder)
+    ("amount" := Json.int)
+
+incomeDefinedForAll : List (UserId, List Income) -> Maybe Time
+incomeDefinedForAll usersIncomes =
+  let firstIncomes = map (head << sortBy .creation << snd) usersIncomes
+  in  if all isJust firstIncomes
+        then head << reverse << List.sort << map .creation << catMaybes <| firstIncomes
+        else Nothing
+
+cumulativeIncomesSince : Time -> Time -> (List Income) -> Int
+cumulativeIncomesSince currentTime since incomes =
+  cumulativeIncome currentTime (getOrderedIncomesSince since incomes)
+
+getOrderedIncomesSince : Time -> List Income -> List Income
+getOrderedIncomesSince time incomes =
+  let mbStarterIncome = getIncomesAt time incomes
+      orderedIncomesSince = filter (\income -> income.creation >= time) incomes
+  in  (maybeToList mbStarterIncome) ++ orderedIncomesSince
+
+getIncomesAt : Time -> List Income -> Maybe Income
+getIncomesAt time incomes =
+  case incomes of
+    [x] ->
+      if x.creation < time
+        then Just { creation = time, amount = x.amount }
+        else Nothing
+    x1 :: x2 :: xs ->
+      if x1.creation < time && x2.creation > time
+        then Just { creation = time, amount = x2.amount }
+        else getIncomesAt time (x2 :: xs)
+    [] ->
+      Nothing
+
+cumulativeIncome : Time -> List Income -> Int
+cumulativeIncome currentTime incomes =
+  getIncomesWithDuration (incomes ++ [{ creation = currentTime, amount = 0 }])
+    |> map durationIncome
+    |> sum
+
+getIncomesWithDuration : List Income -> List (Float, Int)
+getIncomesWithDuration incomes =
+  case incomes of
+    (income1 :: income2 :: xs) ->
+      (income2.creation - income1.creation, income1.amount) :: (getIncomesWithDuration (income2 :: xs))
+    _ ->
+      []
+
+durationIncome : (Float, Int) -> Int
+durationIncome (duration, income) =
+  duration * toFloat income / (hour * 24 * 365 / 12)
+    |> truncate
diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm
new file mode 100644
index 0000000..af475bb
--- /dev/null
+++ b/src/client/Model/Payer.elm
@@ -0,0 +1,129 @@
+module Model.Payer
+  ( Payers
+  , Payer
+  , ExceedingPayer
+  , payersDecoder
+  , updatePayers
+  , getOrderedExceedingPayers
+  ) where
+
+import Json.Decode as Json exposing (..)
+import Dict exposing (..)
+import List
+import Maybe
+import Time exposing (Time)
+
+import Model.User exposing (UserId, userIdDecoder)
+import Model.Income exposing (..)
+
+import Utils.Dict exposing (mapValues)
+import Utils.Maybe exposing (isJust)
+
+type alias Payers = Dict UserId Payer
+
+type alias Payer =
+  { preIncomePaymentSum : Int
+  , postIncomePaymentSum : Int
+  , incomes : List Income
+  }
+
+payersDecoder : Decoder Payers
+payersDecoder = Json.map Dict.fromList (list payerDecoder)
+
+payerDecoder : Decoder (UserId, Payer)
+payerDecoder =
+  object2 (,)
+    ("userId" := userIdDecoder)
+    (object3 Payer
+      ("preIncomePaymentSum" := int)
+      ("postIncomePaymentSum" := int)
+      ("incomes" := list incomeDecoder))
+
+updatePayers : Payers -> UserId -> Time -> Int -> Payers
+updatePayers payers userId creation amountDiff =
+  payers
+    |> Dict.update userId (\mbPayer ->
+       case mbPayer of
+         Just payer ->
+           let postIncome =
+                incomeDefinedForAll (Dict.toList << mapValues .incomes <| payers)
+                  |> Maybe.map (\date -> creation > date)
+                  |> Maybe.withDefault False
+           in  if postIncome
+                 then
+                   Just { payer | postIncomePaymentSum <- payer.postIncomePaymentSum + amountDiff }
+                 else
+                   Just { payer | preIncomePaymentSum <- payer.preIncomePaymentSum + amountDiff }
+         Nothing ->
+           Nothing
+    )
+
+type alias ExceedingPayer =
+  { userId : UserId
+  , amount : Int
+  }
+
+getOrderedExceedingPayers : Time -> Payers -> List ExceedingPayer
+getOrderedExceedingPayers currentTime payers =
+  let mbIncomeDefinedForAll = incomeDefinedForAll (Dict.toList << mapValues .incomes <| payers)
+      exceedingPayersOnPreIncome =
+        payers
+          |> mapValues .preIncomePaymentSum
+          |> Dict.toList
+          |> exceedingPayersFromAmounts
+  in  case mbIncomeDefinedForAll of
+        Just since ->
+          let postPaymentPayers =
+                payers
+                  |> mapValues (getPostPaymentPayer currentTime since)
+              mbMaxRatio =
+                postPaymentPayers
+                  |> Dict.toList
+                  |> List.map (.ratio << snd)
+                  |> List.maximum
+          in  case mbMaxRatio of
+                Just maxRatio ->
+                  postPaymentPayers
+                    |> mapValues (getFinalDiff maxRatio)
+                    |> Dict.toList
+                    |> exceedingPayersFromAmounts
+                Nothing ->
+                  exceedingPayersOnPreIncome
+        Nothing ->
+          exceedingPayersOnPreIncome
+
+exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer
+exceedingPayersFromAmounts userAmounts =
+  let mbMinAmount = List.minimum << List.map snd <| userAmounts
+  in  case mbMinAmount of
+        Nothing ->
+          []
+        Just minAmount ->
+          userAmounts
+            |> List.map (\userAmount ->
+                 { userId = fst userAmount
+                 , amount = snd userAmount - minAmount
+                 }
+               )
+            |> List.filter (\payer -> payer.amount > 0)
+
+type alias PostPaymentPayer =
+  { preIncomePaymentSum : Int
+  , cumulativeIncome : Int
+  , ratio : Float
+  }
+
+getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer
+getPostPaymentPayer currentTime since payer =
+  let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes
+  in  { preIncomePaymentSum = payer.preIncomePaymentSum
+      , cumulativeIncome = cumulativeIncome
+      , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome
+      }
+
+getFinalDiff : Float -> PostPaymentPayer -> Int
+getFinalDiff maxRatio payer =
+  let postIncomeDiff =
+        -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome
+          |> truncate
+  in  postIncomeDiff + payer.preIncomePaymentSum
diff --git a/src/client/Model/Payers.elm b/src/client/Model/Payers.elm
deleted file mode 100644
index 983e7b3..0000000
--- a/src/client/Model/Payers.elm
+++ /dev/null
@@ -1,59 +0,0 @@
-module Model.Payers
-  ( Payers
-  , ExceedingPayer
-  , payersDecoder
-  , updatePayers
-  , getOrderedExceedingPayers
-  ) where
-
-import Json.Decode as Json exposing (..)
-import Dict exposing (..)
-import List
-import Maybe
-
-import Model.User exposing (UserId, userIdDecoder)
-
-type alias Payers = Dict UserId Int
-
-payersDecoder : Decoder Payers
-payersDecoder = Json.map Dict.fromList (list payerDecoder)
-
-payerDecoder : Decoder (UserId, Int)
-payerDecoder =
-  object2 (,)
-    ("userId" := userIdDecoder)
-    ("totalPayment" := int)
-
-updatePayers : Payers -> UserId -> Int -> Payers
-updatePayers payers userId amountDiff =
-  Dict.update
-    userId
-    (\mbAmount ->
-      case mbAmount of
-        Just amount -> Just (amount + amountDiff)
-        Nothing -> Nothing
-    )
-    payers
-
-type alias ExceedingPayer =
-  { userId : UserId
-  , amount : Int
-  }
-
-getOrderedExceedingPayers : Payers -> List ExceedingPayer
-getOrderedExceedingPayers payers =
-  let orderedPayers =
-        Dict.toList payers
-          |> List.map (\(userId, amount) -> ExceedingPayer userId amount)
-          |> List.sortBy .amount
-      maybeMinAmount =
-        List.head orderedPayers
-          |> Maybe.map .amount
-  in  case maybeMinAmount of
-        Just minAmount ->
-          orderedPayers
-            |> List.map (\payer -> { payer | amount <- payer.amount - minAmount })
-            |> List.filter (\payer -> payer.amount /= 0)
-            |> List.reverse
-        Nothing ->
-          []
diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm
index 1f1c4ed..c4a8963 100644
--- a/src/client/Model/Payment.elm
+++ b/src/client/Model/Payment.elm
@@ -11,6 +11,7 @@ import Date exposing (..)
 import Json.Decode as Json exposing ((:=))
 
 import Model.User exposing (UserId, userIdDecoder)
+import Model.Date exposing (dateDecoder)
 
 perPage : Int
 perPage = 8
@@ -41,6 +42,3 @@ paymentDecoder =
 
 paymentIdDecoder : Json.Decoder PaymentId
 paymentIdDecoder = Json.int
-
-dateDecoder : Json.Decoder Date
-dateDecoder = Json.customDecoder Json.string Date.fromString
diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm
index b0d62a6..1412913 100644
--- a/src/client/Model/User.elm
+++ b/src/client/Model/User.elm
@@ -25,7 +25,9 @@ usersDecoder = Json.map Dict.fromList (Json.list userWithIdDecoder)
 
 userWithIdDecoder : Json.Decoder (UserId, User)
 userWithIdDecoder =
-  userDecoder `Json.andThen` (\user -> Json.map (\id -> (id, user)) ("id" := userIdDecoder))
+  Json.object2 (,)
+    ("id" := userIdDecoder)
+    userDecoder
 
 userDecoder : Json.Decoder User
 userDecoder =
diff --git a/src/client/Model/View/LoggedIn/Account.elm b/src/client/Model/View/LoggedIn/Account.elm
index 7f0fbe3..ab37b81 100644
--- a/src/client/Model/View/LoggedIn/Account.elm
+++ b/src/client/Model/View/LoggedIn/Account.elm
@@ -3,36 +3,57 @@ module Model.View.LoggedIn.Account
   , IncomeEdition
   , initAccount
   , initIncomeEdition
+  , getCurrentIncome
   , validateIncome
   ) where
 
 import Result as Result exposing (Result(..))
+import Dict
 
 import Utils.Validation exposing (..)
+import Utils.Dict exposing (mapValues)
 
 import Model.Translations exposing (..)
-import Model.Payers exposing (..)
+import Model.Payer exposing (..)
+import Model.User exposing (UserId)
 
 type alias Account =
-  { payers : Payers
-  , income : Maybe Int
+  { me : UserId
+  , payers : Payers
   , visibleDetail : Bool
   , incomeEdition : Maybe IncomeEdition
   }
 
+initAccount : UserId -> Payers -> Account
+initAccount me payers =
+  { me = me
+  , payers =
+      payers
+        |> mapValues
+             (\payer ->
+               { payer | incomes <- List.sortBy .creation payer.incomes }
+             )
+  , visibleDetail = False
+  , incomeEdition = Nothing
+  }
+
+getCurrentIncome : Account -> Maybe Int
+getCurrentIncome account =
+  case Dict.get account.me account.payers of
+    Just payer ->
+      payer.incomes
+        |> List.sortBy .creation
+        |> List.reverse
+        |> List.head
+        |> Maybe.map .amount
+    Nothing ->
+      Nothing
+
 type alias IncomeEdition =
   { income : String
   , error : Maybe String
   }
 
-initAccount : Payers -> Maybe Int -> Account
-initAccount payers income =
-  { payers = payers
-  , income = income
-  , visibleDetail = False
-  , incomeEdition = Nothing
-  }
-
 initIncomeEdition : Int -> IncomeEdition
 initIncomeEdition income =
   { income = toString income
diff --git a/src/client/Model/View/LoggedInView.elm b/src/client/Model/View/LoggedInView.elm
index 12a7294..122c4be 100644
--- a/src/client/Model/View/LoggedInView.elm
+++ b/src/client/Model/View/LoggedInView.elm
@@ -5,7 +5,7 @@ module Model.View.LoggedInView
 
 import Model.User exposing (Users, UserId)
 import Model.Payment exposing (Payments)
-import Model.Payers exposing (Payers)
+import Model.Payer exposing (Payers)
 import Model.View.LoggedIn.Add exposing (..)
 import Model.View.LoggedIn.Edition exposing (..)
 import Model.View.LoggedIn.Monthly exposing (..)
@@ -13,7 +13,6 @@ import Model.View.LoggedIn.Account exposing (..)
 
 type alias LoggedInView =
   { users : Users
-  , me : UserId
   , add : AddPayment
   , monthly : Monthly
   , account : Account
@@ -23,13 +22,12 @@ type alias LoggedInView =
   , currentPage : Int
   }
 
-initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> Maybe Int -> LoggedInView
-initLoggedInView users me monthlyPayments payments paymentsCount payers income =
+initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> LoggedInView
+initLoggedInView users me monthlyPayments payments paymentsCount payers =
   { users = users
-  , me = me
   , add = initAddPayment Punctual
   , monthly = initMonthly monthlyPayments
-  , account = initAccount payers income
+  , account = initAccount me payers
   , payments = payments
   , paymentsCount = paymentsCount
   , paymentEdition = Nothing
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
index 47d8c27..55bf947 100644
--- a/src/client/ServerCommunication.elm
+++ b/src/client/ServerCommunication.elm
@@ -9,6 +9,7 @@ import Task as Task exposing (Task)
 import Http
 import Json.Decode exposing (..)
 import Date
+import Time exposing (Time)
 
 import Model.User exposing (UserId)
 import Model.Payment exposing (..)
@@ -25,8 +26,8 @@ type Communication =
   | SignIn String
   | AddPayment UserId String Int
   | AddMonthlyPayment String Int
-  | SetIncome Int
-  | DeletePayment PaymentId UserId Int Int
+  | SetIncome Time Int
+  | DeletePayment Payment Int
   | DeleteMonthlyPayment PaymentId
   | UpdatePage Int
   | SignOut
@@ -50,8 +51,8 @@ getRequest communication =
     SignIn login                   -> Just (simple "post" ("/signIn?login=" ++ login))
     AddPayment userId name cost    -> Just (addPaymentRequest name cost Punctual)
     AddMonthlyPayment name cost    -> Just (addPaymentRequest name cost Monthly)
-    SetIncome amount               -> Just (simple "post" ("/income?amount=" ++ (toString amount)))
-    DeletePayment paymentId _ _ _  -> Just (deletePaymentRequest paymentId)
+    SetIncome _ amount               -> Just (simple "post" ("/income?amount=" ++ (toString amount)))
+    DeletePayment payment _  -> Just (deletePaymentRequest payment.id)
     DeleteMonthlyPayment paymentId -> Just (deletePaymentRequest paymentId)
     UpdatePage page                -> Just (updatePageRequest page)
     SignOut                        -> Just (simple "post"  "/signOut")
@@ -95,12 +96,12 @@ serverResult communication response =
             ("id" := paymentIdDecoder)
             (\id -> Task.succeed <| U.UpdateLoggedIn (UL.AddMonthlyPayment id name cost))
             response
-        SetIncome amount ->
-          Task.succeed <| U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome amount))
-        DeletePayment id userId cost currentPage ->
+        SetIncome currentTime amount ->
+          Task.succeed <| U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome currentTime amount))
+        DeletePayment payment currentPage ->
           Http.send Http.defaultSettings (updatePageRequest currentPage)
             |> flip Task.andThen (decodeOkResponse paymentsDecoder (\payments ->
-                 Task.succeed <| U.UpdateLoggedIn (UL.DeletePayment userId cost payments)
+                 Task.succeed <| U.UpdateLoggedIn (UL.DeletePayment payment payments)
                ))
         DeleteMonthlyPayment id ->
           Task.succeed <| U.UpdateLoggedIn (UL.UpdateMonthly (UM.DeletePayment id))
diff --git a/src/client/Update.elm b/src/client/Update.elm
index 4389140..3c4614a 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -9,7 +9,7 @@ import Time exposing (Time)
 import Model exposing (Model)
 import Model.User exposing (Users, UserId)
 import Model.Payment exposing (Payments)
-import Model.Payers exposing (Payers)
+import Model.Payer exposing (Payers)
 import Model.View as V
 import Model.View.SignInView exposing (..)
 import Model.View.LoggedInView exposing (..)
@@ -23,7 +23,7 @@ type Action =
   | GoSignInView
   | SignInError String
   | UpdateSignIn SignInAction
-  | GoLoggedInView Users UserId Payments Payments Int Payers (Maybe Int)
+  | GoLoggedInView Users UserId Payments Payments Int Payers
   | UpdateLoggedIn LoggedAction
 
 actions : Signal.Mailbox Action
@@ -38,8 +38,8 @@ updateModel action model =
       { model | currentTime <- time }
     GoSignInView ->
       { model | view <- V.SignInView initSignInView }
-    GoLoggedInView users me monthlyPayments payments paymentsCount payers mbIncome ->
-      { model | view <- V.LoggedInView (initLoggedInView users me monthlyPayments payments paymentsCount payers mbIncome) }
+    GoLoggedInView users me monthlyPayments payments paymentsCount payers ->
+      { model | view <- V.LoggedInView (initLoggedInView users me monthlyPayments payments paymentsCount payers) }
     SignInError msg ->
       let signInView = { initSignInView | result <- Just (Err msg) }
       in  { model | view <- V.SignInView signInView }
diff --git a/src/client/Update/LoggedIn.elm b/src/client/Update/LoggedIn.elm
index 07f3426..e200b04 100644
--- a/src/client/Update/LoggedIn.elm
+++ b/src/client/Update/LoggedIn.elm
@@ -16,13 +16,15 @@ import Update.LoggedIn.Add exposing (..)
 import Update.LoggedIn.Monthly as UM
 import Update.LoggedIn.Account as UA
 
+import Utils.List exposing (find)
+
 type LoggedAction =
   UpdateAdd AddPaymentAction
   | UpdatePayments Payments
   | AddPayment UserId String Int Payments
   | AddMonthlyPayment PaymentId String Int
   | ToggleEdit PaymentId
-  | DeletePayment UserId Int Payments
+  | DeletePayment Payment Payments
   | UpdatePage Int Payments
   | UpdateMonthly UM.MonthlyAction
   | UpdateAccount UA.AccountAction
@@ -39,22 +41,22 @@ updateLoggedIn model action loggedInView =
       | payments <- payments
       , currentPage <- 1
       , add <- initAddPayment Punctual
-      , account <- UA.updateAccount (UA.UpdatePayer userId cost) loggedInView.account
+      , account <- UA.updateAccount (UA.UpdatePayer userId model.currentTime cost) loggedInView.account
       , paymentsCount <- loggedInView.paymentsCount + 1
       }
     AddMonthlyPayment id name cost ->
       { loggedInView
       | add <- initAddPayment Monthly
       , monthly <-
-          let payment = Payment id (Date.fromTime model.currentTime) name cost loggedInView.me
+          let payment = Payment id (Date.fromTime model.currentTime) name cost loggedInView.account.me
           in  UM.updateMonthly (UM.AddPayment payment) loggedInView.monthly
       }
     ToggleEdit id ->
       { loggedInView | paymentEdition <- if loggedInView.paymentEdition == Just id then Nothing else Just id }
-    DeletePayment userId cost payments ->
+    DeletePayment payment payments ->
       { loggedInView
       | payments <- payments
-      , account <- UA.updateAccount (UA.UpdatePayer userId -cost) loggedInView.account
+      , account <- UA.updateAccount (UA.UpdatePayer payment.userId (Date.toTime payment.creation) -payment.cost) loggedInView.account
       , paymentsCount <- loggedInView.paymentsCount - 1
       }
     UpdatePage page payments ->
diff --git a/src/client/Update/LoggedIn/Account.elm b/src/client/Update/LoggedIn/Account.elm
index 2d9cd87..cf4c834 100644
--- a/src/client/Update/LoggedIn/Account.elm
+++ b/src/client/Update/LoggedIn/Account.elm
@@ -4,33 +4,35 @@ module Update.LoggedIn.Account
   ) where
 
 import Maybe
+import Time exposing (Time)
+import Dict
 
 import Model.User exposing (UserId)
-import Model.Payers exposing (..)
+import Model.Payer exposing (..)
 import Model.View.LoggedIn.Account exposing (..)
 
 import Utils.Maybe exposing (isJust)
 
 type AccountAction =
   ToggleDetail
-  | UpdatePayer UserId Int
+  | UpdatePayer UserId Time Int
   | ToggleIncomeEdition
   | UpdateIncomeEdition String
   | UpdateEditionError String
-  | UpdateIncome Int
+  | UpdateIncome Time Int
 
 updateAccount : AccountAction -> Account -> Account
 updateAccount action account =
   case action of
     ToggleDetail ->
       { account | visibleDetail <- not account.visibleDetail }
-    UpdatePayer userId cost ->
-      { account | payers <- updatePayers account.payers userId cost }
+    UpdatePayer userId creation amountDiff ->
+      { account | payers <- updatePayers account.payers userId creation amountDiff }
     ToggleIncomeEdition ->
       { account | incomeEdition <-
           if isJust account.incomeEdition
             then Nothing
-            else Just (initIncomeEdition (Maybe.withDefault 0 account.income))
+            else Just (initIncomeEdition (Maybe.withDefault 0 (getCurrentIncome account)))
       }
     UpdateIncomeEdition income ->
       case account.incomeEdition of
@@ -44,8 +46,19 @@ updateAccount action account =
           { account | incomeEdition <- Just { incomeEdition | error <- Just error } }
         Nothing ->
           account
-    UpdateIncome amount ->
+    UpdateIncome currentTime amount ->
       { account
-      | income <- Just amount
+      | payers <-
+          account.payers
+            |> Dict.update account.me (\mbPayer ->
+              case mbPayer of
+                Just payer ->
+                  Just
+                    { payer
+                    | incomes <- payer.incomes ++ [{ creation = currentTime, amount = amount }]
+                    }
+                Nothing ->
+                  Nothing
+            )
       , incomeEdition <- Nothing
       }
diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm
new file mode 100644
index 0000000..dc01b17
--- /dev/null
+++ b/src/client/Utils/Dict.elm
@@ -0,0 +1,11 @@
+module Utils.Dict
+  ( mapValues
+  ) where
+
+import Dict as Dict exposing (..)
+
+mapValues : (a -> b) -> Dict comparable a -> Dict comparable b
+mapValues f = Dict.fromList << List.map (onSecond f) << Dict.toList
+
+onSecond : (a -> b) -> (comparable, a) -> (comparable, b)
+onSecond f tuple = case tuple of (x, y) -> (x, f y)
diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm
new file mode 100644
index 0000000..f33e124
--- /dev/null
+++ b/src/client/Utils/List.elm
@@ -0,0 +1,6 @@
+module Utils.List
+  ( find
+  ) where
+
+find : (a -> Bool) -> List a -> Maybe a
+find predicate = List.head << List.filter predicate
diff --git a/src/client/Utils/Maybe.elm b/src/client/Utils/Maybe.elm
index 507d9a4..d954ae0 100644
--- a/src/client/Utils/Maybe.elm
+++ b/src/client/Utils/Maybe.elm
@@ -1,9 +1,27 @@
 module Utils.Maybe
   ( isJust
+  , catMaybes
+  , maybeToList
   ) where
 
 isJust : Maybe a -> Bool
 isJust maybe =
   case maybe of
-    Just _ -> True
+    Just _  -> True
     Nothing -> False
+
+catMaybes : List (Maybe a) -> List a
+catMaybes =
+  List.foldr
+    (\mb xs ->
+      case mb of
+        Just x  -> x :: xs
+        Nothing -> xs
+    )
+    []
+
+maybeToList : Maybe a -> List a
+maybeToList mb =
+  case mb of
+    Just a  -> [a]
+    Nothing -> []
diff --git a/src/client/View/LoggedIn/Account.elm b/src/client/View/LoggedIn/Account.elm
index 7e383f3..706f7cc 100644
--- a/src/client/View/LoggedIn/Account.elm
+++ b/src/client/View/LoggedIn/Account.elm
@@ -16,7 +16,7 @@ import Update.LoggedIn.Account exposing (..)
 
 import Model exposing (Model)
 import Model.User exposing (getUserName)
-import Model.Payers exposing (..)
+import Model.Payer exposing (..)
 import Model.View.LoggedInView exposing (LoggedInView)
 import Model.Translations exposing (getParamMessage, getMessage)
 import Model.View.LoggedIn.Account exposing (..)
@@ -48,7 +48,7 @@ exceedingPayers model loggedInView =
     [ class "header"
     , onClick actions.address (UpdateLoggedIn << UpdateAccount <| ToggleDetail)
     ]
-    (  (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers loggedInView.account.payers))
+    (  (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers model.currentTime loggedInView.account.payers))
     ++ [ expand ExpandDown loggedInView.account.visibleDetail ]
     )
 
@@ -80,7 +80,7 @@ incomeRead : Model -> Account -> Html
 incomeRead model account =
   div
     [ class "income" ]
-    [ ( case account.income of
+    [ ( case getCurrentIncome account of
           Nothing ->
             text (getMessage "NoIncome" model.translations)
           Just income ->
@@ -94,7 +94,7 @@ incomeEdition model account edition =
   H.form
     [ case validateIncome edition.income model.translations of
         Ok validatedAmount ->
-          onSubmitPrevDefault serverCommunications.address (SC.SetIncome validatedAmount)
+          onSubmitPrevDefault serverCommunications.address (SC.SetIncome model.currentTime validatedAmount)
         Err error ->
           onSubmitPrevDefault actions.address (UpdateLoggedIn << UpdateAccount << UpdateEditionError <| error)
     , class "income"
diff --git a/src/client/View/LoggedIn/Add.elm b/src/client/View/LoggedIn/Add.elm
index 2167a7f..52d931a 100644
--- a/src/client/View/LoggedIn/Add.elm
+++ b/src/client/View/LoggedIn/Add.elm
@@ -32,7 +32,7 @@ addPayment model loggedInView =
         (Ok name, Ok cost) ->
           let action =
                 case loggedInView.add.frequency of
-                  Punctual -> SC.AddPayment loggedInView.me name cost
+                  Punctual -> SC.AddPayment loggedInView.account.me name cost
                   Monthly -> SC.AddMonthlyPayment name cost
           in onSubmitPrevDefault serverCommunications.address action
         (resName, resCost) ->
diff --git a/src/client/View/LoggedIn/Monthly.elm b/src/client/View/LoggedIn/Monthly.elm
index 9195479..a274015 100644
--- a/src/client/View/LoggedIn/Monthly.elm
+++ b/src/client/View/LoggedIn/Monthly.elm
@@ -27,15 +27,19 @@ import View.Price exposing (price)
 monthlyPayments : Model -> LoggedInView -> Html
 monthlyPayments model loggedInView =
   let monthly = loggedInView.monthly
-  in  div
-        [ classList
-            [ ("monthlyPayments", True)
-            , ("detail", monthly.visibleDetail)
+  in  if List.length monthly.payments == 0
+        then
+          text ""
+        else
+          div
+            [ classList
+                [ ("monthlyPayments", True)
+                , ("detail", monthly.visibleDetail)
+                ]
+            ]
+            [ monthlyCount model monthly
+            , if monthly.visibleDetail then paymentsTable model loggedInView monthly else text ""
             ]
-        ]
-        [ monthlyCount model monthly
-        , if monthly.visibleDetail then paymentsTable model loggedInView monthly else text ""
-        ]
 
 monthlyCount : Model -> Monthly -> Html
 monthlyCount model monthly =
diff --git a/src/client/View/LoggedIn/Table.elm b/src/client/View/LoggedIn/Table.elm
index d98cee6..9d28e81 100644
--- a/src/client/View/LoggedIn/Table.elm
+++ b/src/client/View/LoggedIn/Table.elm
@@ -84,12 +84,12 @@ paymentLine model loggedInView payment =
             [ class "longDate" ]
             [ text (renderLongDate payment.creation model.translations) ]
         ]
-    , if loggedInView.me == payment.userId
+    , if loggedInView.account.me == payment.userId
         then
           div
             [ class "cell delete" ]
             [ button
-                [ onClick serverCommunications.address (SC.DeletePayment payment.id payment.userId payment.cost loggedInView.currentPage) ]
+                [ onClick serverCommunications.address (SC.DeletePayment payment loggedInView.currentPage) ]
                 [ renderIcon "times" ]
             ]
         else
diff --git a/src/server/Controller/Payer.hs b/src/server/Controller/Payer.hs
new file mode 100644
index 0000000..70760ae
--- /dev/null
+++ b/src/server/Controller/Payer.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Controller.Payer
+  ( getPayers
+  ) where
+
+import Web.Scotty
+
+import Control.Monad.IO.Class (liftIO)
+
+import Model.Database
+import qualified Model.Payer as P
+
+import Secure (loggedAction)
+
+getPayers :: ActionM ()
+getPayers =
+  Secure.loggedAction (\_ ->
+    (liftIO $ runDb P.getPayers) >>= json
+  )
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 02c8a8e..ffb575c 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -5,7 +5,6 @@ module Controller.Payment
   , getMonthlyPayments
   , createPayment
   , deletePayment
-  , getTotalPayments
   , getPaymentsCount
   ) where
 
@@ -26,6 +25,7 @@ import Json (jsonObject)
 
 import Model.Database
 import qualified Model.Payment as P
+import qualified Model.Payer as Payer
 import Model.Frequency
 import Model.Json.Number
 import qualified Model.Json.PaymentId as JP
@@ -63,12 +63,6 @@ deletePayment paymentId =
         jsonObject [("error", Json.String $ getMessage PaymentNotDeleted)]
   )
 
-getTotalPayments :: ActionM ()
-getTotalPayments =
-  Secure.loggedAction (\_ -> do
-    (liftIO . runDb $ P.getTotalPayments) >>= json
-  )
-
 getPaymentsCount :: ActionM ()
 getPaymentsCount =
   Secure.loggedAction (\_ -> do
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 71c4674..6a120d6 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -14,6 +14,7 @@ import Controller.Index
 import Controller.SignIn
 import Controller.Payment
 import Controller.User
+import Controller.Payer
 
 import Model.Database (runMigrations)
 import Model.Frequency
@@ -74,5 +75,8 @@ main = do
           paymentId <- param "id" :: ActionM Text
           deletePayment paymentId
 
-        get "/payments/total" getTotalPayments
         get "/payments/count" getPaymentsCount
+
+        -- Payers
+
+        get "/payers" getPayers
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index f38379a..8d1da25 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -57,6 +57,7 @@ Income
   userId UserId
   creation UTCTime
   amount Int
+  deriving Show
 |]
 
 type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
index edf1c92..70b9149 100644
--- a/src/server/Model/Income.hs
+++ b/src/server/Model/Income.hs
@@ -1,5 +1,7 @@
 module Model.Income
   ( getIncome
+  , getFirstIncome
+  , getIncomes
   , setIncome
   ) where
 
@@ -15,6 +17,13 @@ getIncome :: UserId -> Persist (Maybe Income)
 getIncome userId =
   fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Desc IncomeCreation]
 
+getIncomes :: Persist [Income]
+getIncomes = map entityVal <$> selectList [] []
+
+getFirstIncome :: UserId -> Persist (Maybe Income)
+getFirstIncome userId =
+  fmap entityVal <$> selectFirst [IncomeUserId ==. userId] [Asc IncomeCreation]
+
 setIncome :: UserId -> Int -> Persist IncomeId
 setIncome userId amount = do
   now <- liftIO getCurrentTime
diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs
new file mode 100644
index 0000000..4549ca5
--- /dev/null
+++ b/src/server/Model/Json/Income.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Income
+  ( Income(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Time.Clock (UTCTime)
+
+data Income = Income
+  { creation :: UTCTime
+  , amount :: Int
+  } deriving (Show, Generic)
+
+instance FromJSON Income
+instance ToJSON Income
diff --git a/src/server/Model/Json/Payer.hs b/src/server/Model/Json/Payer.hs
new file mode 100644
index 0000000..2101e40
--- /dev/null
+++ b/src/server/Model/Json/Payer.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Payer
+  ( Payer(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+
+import Model.Database (UserId)
+import Model.Json.Income
+
+data Payer = Payer
+  { userId :: UserId
+  , preIncomePaymentSum :: Int
+  , postIncomePaymentSum :: Int
+  , incomes :: [Income]
+  } deriving (Show, Generic)
+
+instance FromJSON Payer
+instance ToJSON Payer
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
deleted file mode 100644
index 2b1cd06..0000000
--- a/src/server/Model/Json/TotalPayment.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.TotalPayment
-  ( TotalPayment(..)
-  ) where
-
-import GHC.Generics
-
-import Data.Aeson
-
-import Model.Database (UserId)
-
-data TotalPayment = TotalPayment
-  { userId :: UserId
-  , totalPayment :: Int
-  } deriving (Show, Generic)
-
-instance FromJSON TotalPayment
-instance ToJSON TotalPayment
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index a5de110..f594833 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -154,7 +154,7 @@ m l September =
 m l October =
   case l of
     English -> "October"
-    French  -> "Octoble"
+    French  -> "Octobre"
 
 m l November =
   case l of
@@ -233,9 +233,8 @@ m l Monthly =
 m l SingularMonthlyCount =
   T.concat
     [ case l of
-        English -> "{1} monthly payment of {2} "
-        French  -> "{1} paiement mensuel de {2} "
-    , m l MoneySymbol
+        English -> "{1} monthly payment of {2}"
+        French  -> "{1} paiement mensuel de {2}"
     ]
 
 m l PluralMonthlyCount =
diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs
new file mode 100644
index 0000000..3893765
--- /dev/null
+++ b/src/server/Model/Payer.hs
@@ -0,0 +1,46 @@
+module Model.Payer
+  ( getPayers
+  )
+  where
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Time.Clock (getCurrentTime)
+import Data.List (find)
+import Data.Maybe (fromMaybe, fromMaybe)
+
+import Database.Persist
+
+import Model.Database
+import Model.Payer.Payment (getTotalPaymentsBefore, getTotalPaymentsAfter)
+import Model.Payer.Income (incomeDefinedForAll)
+import Model.User (getUsers)
+import Model.Income (getIncomes)
+
+import qualified Model.Json.Payer as Json
+import qualified Model.Json.Income as Json
+
+getPayers :: Persist [Json.Payer]
+getPayers = do
+  userIds <- map entityKey <$> getUsers
+  incomes <- getIncomes
+  now <- liftIO getCurrentTime
+  incomeIsDefined <- fromMaybe now <$> incomeDefinedForAll
+  preIncomePaymentSums <- getTotalPaymentsBefore incomeIsDefined
+  postIncomePaymentSums <- getTotalPaymentsAfter incomeIsDefined
+  return $ map (getPayer incomes preIncomePaymentSums postIncomePaymentSums) userIds
+
+getPayer :: [Income] -> [(UserId, Int)] -> [(UserId, Int)] -> UserId -> Json.Payer
+getPayer incomes preIncomePaymentSums postIncomePaymentSums userId =
+  Json.Payer
+    { Json.userId = userId
+    , Json.preIncomePaymentSum = findOrDefault userId 0 preIncomePaymentSums
+    , Json.postIncomePaymentSum = findOrDefault userId 0 postIncomePaymentSums
+    , Json.incomes =
+        map (\income -> Json.Income (incomeCreation income) (incomeAmount income))
+        . filter ((==) userId . incomeUserId)
+        $ incomes
+    }
+
+findOrDefault :: (Eq a) => a -> b -> [(a, b)] -> b
+findOrDefault a b = fromMaybe b . fmap snd . find ((==) a . fst)
diff --git a/src/server/Model/Payer/Income.hs b/src/server/Model/Payer/Income.hs
new file mode 100644
index 0000000..f4bc9fd
--- /dev/null
+++ b/src/server/Model/Payer/Income.hs
@@ -0,0 +1,22 @@
+module Model.Payer.Income
+  ( incomeDefinedForAll
+  ) where
+
+import Data.Time.Clock (UTCTime)
+import Data.List (sort)
+import Data.Maybe
+
+import Database.Persist
+
+import Model.Database
+import Model.User (getUsers)
+import Model.Income (getFirstIncome)
+
+incomeDefinedForAll :: Persist (Maybe UTCTime)
+incomeDefinedForAll = do
+  userIds <- map entityKey <$> getUsers
+  firstIncomes <- mapM getFirstIncome userIds
+  return $
+    if all isJust firstIncomes
+      then listToMaybe . reverse . sort . map incomeCreation . catMaybes $ firstIncomes
+      else Nothing
diff --git a/src/server/Model/Payer/Payment.hs b/src/server/Model/Payer/Payment.hs
new file mode 100644
index 0000000..6efc38d
--- /dev/null
+++ b/src/server/Model/Payer/Payment.hs
@@ -0,0 +1,40 @@
+module Model.Payer.Payment
+  ( getTotalPaymentsBefore
+  , getTotalPaymentsAfter
+  ) where
+
+import Data.Time.Clock (UTCTime)
+import Data.Maybe (catMaybes)
+
+import Database.Persist
+import Database.Esqueleto
+import qualified Database.Esqueleto as E
+
+import Model.Database
+import Model.Frequency
+
+getTotalPaymentsBefore :: UTCTime -> Persist [(UserId, Int)]
+getTotalPaymentsBefore time =
+  getTotalPayments (\p -> p ^. PaymentCreation E.<. val time)
+
+getTotalPaymentsAfter :: UTCTime -> Persist [(UserId, Int)]
+getTotalPaymentsAfter time =
+  getTotalPayments (\p -> p ^. PaymentCreation E.>=. val time)
+
+getTotalPayments :: (SqlExpr (Entity Payment) -> SqlExpr (Value Bool)) -> Persist [(UserId, Int)]
+getTotalPayments paymentWhere = do
+  values <- select $
+            from $ \payment -> do
+              where_ (isNothing (payment ^. PaymentDeletedAt))
+              where_ (payment ^. PaymentFrequency E.==. val Punctual)
+              where_ (paymentWhere payment)
+              groupBy (payment ^. PaymentUserId)
+              return (payment ^. PaymentUserId, sum_ (payment ^. PaymentCost))
+  return $ catMaybes . map (unMaybe . unValueTuple) $ values
+
+unValueTuple :: (Value a, Value b) -> (a, b)
+unValueTuple (Value a, Value b) = (a, b)
+
+unMaybe :: (a, Maybe b) -> Maybe (a, b)
+unMaybe (a, Just b) = Just (a, b)
+unMaybe _ = Nothing
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 25b1bb7..233cafa 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -4,13 +4,11 @@ module Model.Payment
   , getMonthlyPayments
   , createPayment
   , deleteOwnPayment
-  , getTotalPayments
   , getPaymentsCount
   ) where
 
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
-import Data.Maybe (catMaybes)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -22,7 +20,6 @@ import qualified Database.Esqueleto as E
 import Model.Database
 import Model.Frequency
 import qualified Model.Json.Payment as P
-import qualified Model.Json.TotalPayment as TP
 
 getPunctualPayments :: Int -> Int -> Persist [P.Payment]
 getPunctualPayments page perPage = do
@@ -80,23 +77,6 @@ deleteOwnPayment user paymentId = do
     Nothing ->
       return False
 
-getTotalPayments :: Persist [TP.TotalPayment]
-getTotalPayments = do
-  values <- select $
-            from $ \payment -> do
-              where_ (isNothing (payment ^. PaymentDeletedAt))
-              where_ (payment ^. PaymentFrequency E.==. val Punctual)
-              groupBy (payment ^. PaymentUserId)
-              return (payment ^. PaymentUserId, sum_ (payment ^. PaymentCost))
-  return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
-
-getTotalPayment :: (UserId, Maybe Int) -> Maybe TP.TotalPayment
-getTotalPayment (userId, Just cost) = Just (TP.TotalPayment userId cost)
-getTotalPayment (_, Nothing) = Nothing
-
-unValueTuple :: (Value a, Value b) -> (a, b)
-unValueTuple (Value a, Value b) = (a, b)
-
 getPaymentsCount :: Persist Int
 getPaymentsCount =
   unValue . head <$>
diff --git a/src/server/MonthlyPaymentJob.hs b/src/server/MonthlyPaymentJob.hs
index 1b331af..f5f6878 100644
--- a/src/server/MonthlyPaymentJob.hs
+++ b/src/server/MonthlyPaymentJob.hs
@@ -5,8 +5,6 @@ module MonthlyPaymentJob
 import Control.Monad.IO.Class (liftIO)
 
 import Data.Time.Clock
-import Data.Time.LocalTime
-import Data.Time.Calendar
 
 import Database.Persist (entityVal, insert)
 
@@ -17,6 +15,8 @@ import Model.Payment (getMonthlyPayments)
 import Model.JobKind
 import Model.Frequency
 
+import Utils.Time (belongToCurrentMonth)
+
 monthlyPaymentJobListener :: IO ()
 monthlyPaymentJobListener =
   let lastExecutionTooOld = fmap not . belongToCurrentMonth
@@ -24,18 +24,6 @@ monthlyPaymentJobListener =
       msDelay = 1000000 * 60 * 60
   in  jobListener MonthlyPaymentJob lastExecutionTooOld runJob msDelay
 
-belongToCurrentMonth :: UTCTime -> IO Bool
-belongToCurrentMonth time = do
-  month <- getLocalMonth time
-  actualMonth <- getCurrentTime >>= getLocalMonth
-  return (month == actualMonth)
-
-getLocalMonth :: UTCTime -> IO Int
-getLocalMonth time = do
-  timeZone <- getCurrentTimeZone
-  let (_, month, _) = toGregorian . localDay $ utcToLocalTime timeZone time
-  return month
-
 monthlyPaymentJob :: Persist ()
 monthlyPaymentJob = do
   monthlyPayments <- map entityVal <$> getMonthlyPayments
diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs
new file mode 100644
index 0000000..0d6ed73
--- /dev/null
+++ b/src/server/Utils/Time.hs
@@ -0,0 +1,27 @@
+module Utils.Time
+  ( belongToCurrentMonth
+  , getLocalDate
+  , Date(..)
+  ) where
+
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+
+belongToCurrentMonth :: UTCTime -> IO Bool
+belongToCurrentMonth time = do
+  timeMonth <- month <$> getLocalDate time
+  actualMonth <- month <$> (getCurrentTime >>= getLocalDate)
+  return (timeMonth == actualMonth)
+
+getLocalDate :: UTCTime -> IO Date
+getLocalDate time = do
+  timeZone <- getCurrentTimeZone
+  let (y, m, d) = toGregorian . localDay $ utcToLocalTime timeZone time
+  return (Date y m d)
+
+data Date = Date
+  { year :: Integer
+  , month :: Int
+  , day :: Int
+  }