diff options
Diffstat (limited to 'src')
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 + } |