aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/Main.elm13
-rw-r--r--src/client/Model/Date.elm15
-rw-r--r--src/client/Model/Income.elm76
-rw-r--r--src/client/Model/Payer.elm129
-rw-r--r--src/client/Model/Payers.elm59
-rw-r--r--src/client/Model/Payment.elm4
-rw-r--r--src/client/Model/User.elm4
-rw-r--r--src/client/Model/View/LoggedIn/Account.elm43
-rw-r--r--src/client/Model/View/LoggedInView.elm10
-rw-r--r--src/client/ServerCommunication.elm17
-rw-r--r--src/client/Update.elm8
-rw-r--r--src/client/Update/LoggedIn.elm12
-rw-r--r--src/client/Update/LoggedIn/Account.elm29
-rw-r--r--src/client/Utils/Dict.elm11
-rw-r--r--src/client/Utils/List.elm6
-rw-r--r--src/client/Utils/Maybe.elm20
-rw-r--r--src/client/View/LoggedIn/Account.elm8
-rw-r--r--src/client/View/LoggedIn/Add.elm2
-rw-r--r--src/client/View/LoggedIn/Monthly.elm20
-rw-r--r--src/client/View/LoggedIn/Table.elm4
-rw-r--r--src/server/Controller/Payer.hs20
-rw-r--r--src/server/Controller/Payment.hs8
-rw-r--r--src/server/Main.hs6
-rw-r--r--src/server/Model/Database.hs1
-rw-r--r--src/server/Model/Income.hs9
-rw-r--r--src/server/Model/Json/Income.hs18
-rw-r--r--src/server/Model/Json/Payer.hs22
-rw-r--r--src/server/Model/Json/TotalPayment.hs19
-rw-r--r--src/server/Model/Message/Translations.hs7
-rw-r--r--src/server/Model/Payer.hs46
-rw-r--r--src/server/Model/Payer/Income.hs22
-rw-r--r--src/server/Model/Payer/Payment.hs40
-rw-r--r--src/server/Model/Payment.hs20
-rw-r--r--src/server/MonthlyPaymentJob.hs16
-rw-r--r--src/server/Utils/Time.hs27
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
+ }