diff options
Diffstat (limited to 'src/client/elm')
48 files changed, 2154 insertions, 0 deletions
diff --git a/src/client/elm/InitViewAction.elm b/src/client/elm/InitViewAction.elm new file mode 100644 index 0000000..7c353a7 --- /dev/null +++ b/src/client/elm/InitViewAction.elm @@ -0,0 +1,25 @@ +module InitViewAction + ( initViewAction + ) where + +import Task exposing (..) +import Http +import Json.Decode as Json exposing ((:=)) + +import Update exposing (Action(GoLoggedInView, GoSignInView)) + +import Model.Payment exposing (Payments, paymentsDecoder, perPage) +import Model.Payer exposing (Payers, payersDecoder) +import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder) + +initViewAction : Task Http.Error Action +initViewAction = Task.onError loggedInView (always <| Task.succeed GoSignInView) + +loggedInView : Task Http.Error Action +loggedInView = + Task.map GoLoggedInView (Http.get usersDecoder "/users") + `Task.andMap` (Http.get ("id" := userIdDecoder) "/whoAmI") + `Task.andMap` (Http.get paymentsDecoder "/monthlyPayments") + `Task.andMap` (Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage)) + `Task.andMap` (Http.get ("number" := Json.int) "/payments/count") + `Task.andMap` (Http.get payersDecoder "/payers") diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm new file mode 100644 index 0000000..f79d6a0 --- /dev/null +++ b/src/client/elm/Main.elm @@ -0,0 +1,89 @@ +module Main + ( main + ) where + +import Graphics.Element exposing (..) + +import Html exposing (Html) + +import Http +import Task exposing (..) +import Time exposing (..) +import Json.Decode as Json +import Dict +import String + +import Model exposing (Model, initialModel) +import Model.Translations exposing (..) +import Model.Config exposing (..) + +import Update exposing (Action(..), actions, updateModel) +import Update.SignIn exposing (..) + +import View.Page exposing (renderPage) + +import ServerCommunication as SC exposing (serverCommunications, sendRequest) + +import Persona as Persona exposing (operations) + +import InitViewAction exposing (initViewAction) + +import Sign + +main : Signal Html +main = Signal.map renderPage model + +model : Signal Model +model = Signal.foldp updateModel (initialModel initialTime translations config) update + +update : Signal Action +update = Signal.mergeMany + [ Signal.map UpdateTime (Time.every 1000) + , actions.signal + ] + +--------------------------------------- + +port initialTime : Time + +--------------------------------------- + +port translations : String + +--------------------------------------- + +port config : String + +--------------------------------------- + +port ready : Signal String +port ready = Signal.constant "ready" + +--------------------------------------- + +port initView : Task Http.Error () +port initView = initViewAction `Task.andThen` (Signal.send actions.address) + +--------------------------------------- + +port serverCommunicationsPort : Signal (Task Http.Error ()) +port serverCommunicationsPort = + Signal.map + (\comm -> + sendRequest comm + |> flip Task.andThen (\action -> Signal.send actions.address action) + ) + (Signal.merge signCommunication serverCommunications.signal) + +--------------------------------------- + +port persona : Signal String +port persona = Signal.map Persona.toString operations.signal + +--------------------------------------- + +port sign : Signal Json.Value + +signCommunication : Signal SC.Communication +signCommunication = + Signal.map (Sign.toServerCommunication << Sign.decodeOperation) sign diff --git a/src/client/elm/Model.elm b/src/client/elm/Model.elm new file mode 100644 index 0000000..43a19c5 --- /dev/null +++ b/src/client/elm/Model.elm @@ -0,0 +1,32 @@ +module Model + ( Model + , initialModel + ) where + +import Time exposing (Time) +import Json.Decode as Json + +import Model.View exposing (..) +import Model.Translations exposing (..) +import Model.Config exposing (..) + +type alias Model = + { view : View + , currentTime : Time + , translations : Translations + , config : Config + } + +initialModel : Time -> String -> String -> Model +initialModel initialTime translationsValue configValue = + { view = LoadingView + , currentTime = initialTime + , translations = + case Json.decodeString translationsDecoder translationsValue of + Ok translations -> translations + Err err -> [] + , config = + case Json.decodeString configDecoder configValue of + Ok config -> config + Err err -> { currency = "" } + } diff --git a/src/client/elm/Model/Config.elm b/src/client/elm/Model/Config.elm new file mode 100644 index 0000000..e47b032 --- /dev/null +++ b/src/client/elm/Model/Config.elm @@ -0,0 +1,18 @@ +module Model.Config + ( Config + , configDecoder + ) where + +import Json.Decode exposing (..) + +type alias Config = + { currency : String + } + +configDecoder : Decoder Config +configDecoder = object1 Config ("currency" := string) + +defaultConfig : Config +defaultConfig = + { currency = "€" + } diff --git a/src/client/elm/Model/Date.elm b/src/client/elm/Model/Date.elm new file mode 100644 index 0000000..1c56de4 --- /dev/null +++ b/src/client/elm/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/elm/Model/Income.elm b/src/client/elm/Model/Income.elm new file mode 100644 index 0000000..97a5652 --- /dev/null +++ b/src/client/elm/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 (List Income) -> Maybe Time +incomeDefinedForAll usersIncomes = + let firstIncomes = map (head << sortBy .creation) 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/elm/Model/Payer.elm b/src/client/elm/Model/Payer.elm new file mode 100644 index 0000000..9fd1bb5 --- /dev/null +++ b/src/client/elm/Model/Payer.elm @@ -0,0 +1,132 @@ +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 = + payersIncomeDefinedForAll 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 exceedingPayersOnPreIncome = + payers + |> mapValues .preIncomePaymentSum + |> Dict.toList + |> exceedingPayersFromAmounts + in case payersIncomeDefinedForAll payers 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 + +payersIncomeDefinedForAll : Payers -> Maybe Time +payersIncomeDefinedForAll payers = + incomeDefinedForAll (List.map (.incomes << snd) << Dict.toList <| payers) + +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/elm/Model/Payment.elm b/src/client/elm/Model/Payment.elm new file mode 100644 index 0000000..c4a8963 --- /dev/null +++ b/src/client/elm/Model/Payment.elm @@ -0,0 +1,44 @@ +module Model.Payment + ( perPage + , Payments + , Payment + , PaymentId + , paymentsDecoder + , paymentIdDecoder + ) where + +import Date exposing (..) +import Json.Decode as Json exposing ((:=)) + +import Model.User exposing (UserId, userIdDecoder) +import Model.Date exposing (dateDecoder) + +perPage : Int +perPage = 8 + +type alias Payments = List Payment + +type alias Payment = + { id : PaymentId + , creation : Date + , name : String + , cost : Int + , userId : UserId + } + +type alias PaymentId = Int + +paymentsDecoder : Json.Decoder Payments +paymentsDecoder = Json.list paymentDecoder + +paymentDecoder : Json.Decoder Payment +paymentDecoder = + Json.object5 Payment + ("id" := paymentIdDecoder) + ("creation" := dateDecoder) + ("name" := Json.string) + ("cost" := Json.int) + ("userId" := userIdDecoder) + +paymentIdDecoder : Json.Decoder PaymentId +paymentIdDecoder = Json.int diff --git a/src/client/elm/Model/Translations.elm b/src/client/elm/Model/Translations.elm new file mode 100644 index 0000000..bec8c9b --- /dev/null +++ b/src/client/elm/Model/Translations.elm @@ -0,0 +1,69 @@ +module Model.Translations + ( translationsDecoder + , Translations + , Translation + , getMessage + , getParamMessage + ) where + +import Maybe exposing (withDefault) +import Json.Decode as Json exposing ((:=)) +import String + +type alias Translations = List Translation + +translationsDecoder : Json.Decoder Translations +translationsDecoder = Json.list translationDecoder + +type alias Translation = + { key : String + , message : List MessagePart + } + +getTranslation : String -> Translations -> Maybe (List MessagePart) +getTranslation key translations = + translations + |> List.filter (\translation -> translation.key == key) + |> List.head + |> Maybe.map .message + +translationDecoder : Json.Decoder Translation +translationDecoder = + Json.object2 Translation + ("key" := Json.string) + ("message" := Json.list partDecoder) + +type MessagePart = + Order Int + | Str String + +partDecoder : Json.Decoder MessagePart +partDecoder = + ("tag" := Json.string) `Json.andThen` partDecoderWithTag + +partDecoderWithTag : String -> Json.Decoder MessagePart +partDecoderWithTag tag = + case tag of + "Order" -> Json.object1 Order ("contents" := Json.int) + "Str" -> Json.object1 Str ("contents" := Json.string) + +----- + +getMessage : String -> Translations -> String +getMessage = getParamMessage [] + +getParamMessage : List String -> String -> Translations -> String +getParamMessage values key translations = + getTranslation key translations + |> Maybe.map (\parts -> String.concat (List.map (replacePart values) parts)) + |> withDefault key + +replacePart : List String -> MessagePart -> String +replacePart values part = + case part of + Str str -> str + Order n -> + values + |> List.drop (n - 1) + |> List.head + |> withDefault ("{" ++ (toString n) ++ "}") diff --git a/src/client/elm/Model/User.elm b/src/client/elm/Model/User.elm new file mode 100644 index 0000000..1412913 --- /dev/null +++ b/src/client/elm/Model/User.elm @@ -0,0 +1,44 @@ +module Model.User + ( Users + , usersDecoder + , User + , userDecoder + , UserId + , userIdDecoder + , getUserName + ) where + +import Json.Decode as Json exposing ((:=)) +import Dict exposing (Dict) + +type alias Users = Dict UserId User + +type alias UserId = Int + +type alias User = + { name : String + , email : String + } + +usersDecoder : Json.Decoder Users +usersDecoder = Json.map Dict.fromList (Json.list userWithIdDecoder) + +userWithIdDecoder : Json.Decoder (UserId, User) +userWithIdDecoder = + Json.object2 (,) + ("id" := userIdDecoder) + userDecoder + +userDecoder : Json.Decoder User +userDecoder = + Json.object2 User + ("name" := Json.string) + ("email" := Json.string) + +userIdDecoder : Json.Decoder UserId +userIdDecoder = Json.int + +getUserName : Users -> UserId -> Maybe String +getUserName users userId = + Dict.get userId users + |> Maybe.map .name diff --git a/src/client/elm/Model/View.elm b/src/client/elm/Model/View.elm new file mode 100644 index 0000000..90c0e53 --- /dev/null +++ b/src/client/elm/Model/View.elm @@ -0,0 +1,12 @@ +module Model.View + ( View(..) + ) where + +import Model.Payment exposing (Payments) +import Model.View.SignInView exposing (..) +import Model.View.LoggedInView exposing (..) + +type View = + LoadingView + | SignInView SignInView + | LoggedInView LoggedInView diff --git a/src/client/elm/Model/View/LoggedIn/Account.elm b/src/client/elm/Model/View/LoggedIn/Account.elm new file mode 100644 index 0000000..2bb3ae7 --- /dev/null +++ b/src/client/elm/Model/View/LoggedIn/Account.elm @@ -0,0 +1,67 @@ +module Model.View.LoggedIn.Account + ( 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.Payer exposing (..) +import Model.User exposing (UserId) + +type alias Account = + { 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 + } + +initIncomeEdition : Int -> IncomeEdition +initIncomeEdition income = + { income = toString income + , error = Nothing + } + +validateIncome : String -> Translations -> Result String Int +validateIncome amount translations = + amount + |> validateNonEmpty (getMessage "IncomeRequired" translations) + |> flip Result.andThen (validateNumber (getMessage "IncomeMustBePositiveNumber" translations) (\number -> number > 0)) diff --git a/src/client/elm/Model/View/LoggedIn/Add.elm b/src/client/elm/Model/View/LoggedIn/Add.elm new file mode 100644 index 0000000..5598084 --- /dev/null +++ b/src/client/elm/Model/View/LoggedIn/Add.elm @@ -0,0 +1,43 @@ +module Model.View.LoggedIn.Add + ( AddPayment + , Frequency(..) + , initAddPayment + , validateName + , validateCost + ) where + +import Result as Result exposing (Result(..)) + +import Utils.Validation exposing (..) + +import Model.Translations exposing (..) + +type alias AddPayment = + { name : String + , nameError : Maybe String + , cost : String + , costError : Maybe String + , frequency : Frequency + } + +initAddPayment : Frequency -> AddPayment +initAddPayment frequency = + { name = "" + , nameError = Nothing + , cost = "" + , costError = Nothing + , frequency = frequency + } + +validateName : String -> Translations -> Result String String +validateName name translations = + name + |> validateNonEmpty (getMessage "CategoryRequired" translations) + +validateCost : String -> Translations -> Result String Int +validateCost cost translations = + cost + |> validateNonEmpty (getMessage "CostRequired" translations) + |> flip Result.andThen (validateNumber (getMessage "CostMustBeNonNullNumber" translations) ((/=) 0)) + +type Frequency = Punctual | Monthly diff --git a/src/client/elm/Model/View/LoggedIn/Edition.elm b/src/client/elm/Model/View/LoggedIn/Edition.elm new file mode 100644 index 0000000..da6d7b0 --- /dev/null +++ b/src/client/elm/Model/View/LoggedIn/Edition.elm @@ -0,0 +1,7 @@ +module Model.View.LoggedIn.Edition + ( Edition + ) where + +import Model.Payment exposing (PaymentId) + +type alias Edition = PaymentId diff --git a/src/client/elm/Model/View/LoggedIn/Monthly.elm b/src/client/elm/Model/View/LoggedIn/Monthly.elm new file mode 100644 index 0000000..3c6f66a --- /dev/null +++ b/src/client/elm/Model/View/LoggedIn/Monthly.elm @@ -0,0 +1,17 @@ +module Model.View.LoggedIn.Monthly + ( Monthly + , initMonthly + ) where + +import Model.Payment exposing (Payments) + +type alias Monthly = + { payments : Payments + , visibleDetail : Bool + } + +initMonthly : Payments -> Monthly +initMonthly payments = + { payments = payments + , visibleDetail = False + } diff --git a/src/client/elm/Model/View/LoggedInView.elm b/src/client/elm/Model/View/LoggedInView.elm new file mode 100644 index 0000000..122c4be --- /dev/null +++ b/src/client/elm/Model/View/LoggedInView.elm @@ -0,0 +1,35 @@ +module Model.View.LoggedInView + ( LoggedInView + , initLoggedInView + ) where + +import Model.User exposing (Users, UserId) +import Model.Payment exposing (Payments) +import Model.Payer exposing (Payers) +import Model.View.LoggedIn.Add exposing (..) +import Model.View.LoggedIn.Edition exposing (..) +import Model.View.LoggedIn.Monthly exposing (..) +import Model.View.LoggedIn.Account exposing (..) + +type alias LoggedInView = + { users : Users + , add : AddPayment + , monthly : Monthly + , account : Account + , payments : Payments + , paymentsCount : Int + , paymentEdition : Maybe Edition + , currentPage : Int + } + +initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> LoggedInView +initLoggedInView users me monthlyPayments payments paymentsCount payers = + { users = users + , add = initAddPayment Punctual + , monthly = initMonthly monthlyPayments + , account = initAccount me payers + , payments = payments + , paymentsCount = paymentsCount + , paymentEdition = Nothing + , currentPage = 1 + } diff --git a/src/client/elm/Model/View/SignInView.elm b/src/client/elm/Model/View/SignInView.elm new file mode 100644 index 0000000..0fbce39 --- /dev/null +++ b/src/client/elm/Model/View/SignInView.elm @@ -0,0 +1,15 @@ +module Model.View.SignInView + ( SignInView + , initSignInView + ) where + +type alias SignInView = + { login : String + , result : Maybe (Result String String) + } + +initSignInView : SignInView +initSignInView = + { login = "" + , result = Nothing + } diff --git a/src/client/elm/Native/Reads.js b/src/client/elm/Native/Reads.js new file mode 100644 index 0000000..5785aed --- /dev/null +++ b/src/client/elm/Native/Reads.js @@ -0,0 +1,22 @@ +Elm.Native.Reads = {}; +Elm.Native.Reads.make = function(localRuntime) { + + localRuntime.Native = localRuntime.Native || {}; + localRuntime.Native.Reads = localRuntime.Native.Reads || {}; + if(localRuntime.Native.Reads.values) { + return localRuntime.Native.Reads.values; + } + + var Maybe = Elm.Maybe.make(localRuntime); + + function readInt(str) { + var number = Number(str); + return isNaN(number) || str === '' + ? Maybe.Nothing + : Maybe.Just(number); + } + + return localRuntime.Native.Reads.values = { + readInt: readInt + }; +}; diff --git a/src/client/elm/Persona.elm b/src/client/elm/Persona.elm new file mode 100644 index 0000000..51b5fc6 --- /dev/null +++ b/src/client/elm/Persona.elm @@ -0,0 +1,28 @@ +module Persona + ( Operation(..) + , operations + , fromString + , toString + ) where + +type Operation = + NoOp + | SignIn + | SignOut + +operations : Signal.Mailbox Operation +operations = Signal.mailbox NoOp + +fromString : String -> Operation +fromString str = + case str of + "SignIn" -> SignIn + "SignOut" -> SignOut + _ -> NoOp + +toString : Operation -> String +toString operation = + case operation of + SignIn -> "SignIn" + SignOut -> "SignOut" + _ -> "NoOp" diff --git a/src/client/elm/Reads.elm b/src/client/elm/Reads.elm new file mode 100644 index 0000000..f855802 --- /dev/null +++ b/src/client/elm/Reads.elm @@ -0,0 +1,10 @@ +module Reads + ( readInt + ) where + + +import Native.Reads +import Result exposing (Result) + +readInt : String -> Maybe Int +readInt = Native.Reads.readInt diff --git a/src/client/elm/ServerCommunication.elm b/src/client/elm/ServerCommunication.elm new file mode 100644 index 0000000..70612cb --- /dev/null +++ b/src/client/elm/ServerCommunication.elm @@ -0,0 +1,95 @@ +module ServerCommunication + ( Communication(..) + , sendRequest + , serverCommunications + ) where + +import Signal +import Task as Task exposing (Task) +import Http +import Json.Decode exposing (..) +import Date +import Time exposing (Time) +import Debug + +import SimpleHTTP exposing (..) + +import Model.User exposing (UserId) +import Model.Payment exposing (..) +import Model.View.LoggedIn.Add exposing (Frequency(..)) + +import Update as U +import Update.SignIn exposing (..) +import Update.LoggedIn as UL +import Update.LoggedIn.Monthly as UM +import Update.LoggedIn.Account as UA + +import InitViewAction exposing (initViewAction) + +type Communication = + NoCommunication + | SignIn String + | AddPayment UserId String Int + | AddMonthlyPayment String Int + | SetIncome Time Int + | DeletePayment Payment Int + | DeleteMonthlyPayment PaymentId + | UpdatePage Int + | SignOut + +serverCommunications : Signal.Mailbox Communication +serverCommunications = Signal.mailbox NoCommunication + +sendRequest : Communication -> Task Http.Error U.Action +sendRequest communication = + case communication of + + NoCommunication -> + Task.succeed U.NoOp + + SignIn assertion -> + post ("/signIn?assertion=" ++ assertion) + |> flip Task.andThen (always initViewAction) + + AddPayment userId name cost -> + post (addPaymentURL name cost Punctual) + |> flip Task.andThen (always (getPaymentsAtPage 1)) + |> Task.map (\payments -> U.UpdateLoggedIn (UL.AddPayment userId name cost payments)) + + AddMonthlyPayment name cost -> + post (addPaymentURL name cost Monthly) + |> flip Task.andThen (decodeHttpValue <| "id" := paymentIdDecoder) + |> Task.map (\id -> U.UpdateLoggedIn (UL.AddMonthlyPayment id name cost)) + + DeletePayment payment currentPage -> + post (deletePaymentURL payment.id) + |> flip Task.andThen (always (getPaymentsAtPage currentPage)) + |> Task.map (\payments -> U.UpdateLoggedIn (UL.DeletePayment payment payments)) + + DeleteMonthlyPayment id -> + post (deletePaymentURL id) + |> Task.map (always (U.UpdateLoggedIn (UL.UpdateMonthly (UM.DeletePayment id)))) + + UpdatePage page -> + getPaymentsAtPage page + |> flip Task.andThen (Task.succeed << U.UpdateLoggedIn << UL.UpdatePage page) + + SetIncome currentTime amount -> + post ("/income?amount=" ++ (toString amount)) + |> Task.map (always (U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome currentTime amount)))) + + SignOut -> + post "/signOut" + |> Task.map (always U.GoSignInView) + +getPaymentsAtPage : Int -> Task Http.Error Payments +getPaymentsAtPage page = + Http.get paymentsDecoder ("payments?page=" ++ toString page ++ "&perPage=" ++ toString perPage) + +addPaymentURL : String -> Int -> Frequency -> String +addPaymentURL name cost frequency = + "/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost) ++ "&frequency=" ++ (toString frequency) + +deletePaymentURL : PaymentId -> String +deletePaymentURL id = + "payment/delete?id=" ++ (toString id) diff --git a/src/client/elm/Sign.elm b/src/client/elm/Sign.elm new file mode 100644 index 0000000..44f23b8 --- /dev/null +++ b/src/client/elm/Sign.elm @@ -0,0 +1,43 @@ +module Sign + ( Operation(..) + , decodeOperation + , toServerCommunication + ) where + +import Json.Decode as Json +import Json.Decode exposing (Value, Decoder, (:=)) +import Maybe + +import ServerCommunication as SC + +type Operation = + NoOp + | SignIn String + | SignOut + +decodeOperation : Value -> Operation +decodeOperation value = + Json.decodeValue operationDecoder value + |> Result.toMaybe + |> Maybe.withDefault NoOp + +toServerCommunication : Operation -> SC.Communication +toServerCommunication operation = + case operation of + NoOp -> SC.NoCommunication + SignIn assertion -> SC.SignIn assertion + SignOut -> SC.SignOut + +operationDecoder : Decoder Operation +operationDecoder = + ("operation" := Json.string) `Json.andThen` operationDecoderWithTag + +operationDecoderWithTag : String -> Decoder Operation +operationDecoderWithTag operation = + case operation of + "SignIn" -> + Json.map SignIn ("assertion" := Json.string) + "SignOut" -> + Json.succeed SignOut + _ -> + Json.succeed NoOp diff --git a/src/client/elm/SimpleHTTP.elm b/src/client/elm/SimpleHTTP.elm new file mode 100644 index 0000000..99a7056 --- /dev/null +++ b/src/client/elm/SimpleHTTP.elm @@ -0,0 +1,41 @@ +module SimpleHTTP + ( post + , decodeHttpValue + ) where + +import Http exposing (..) +import Task exposing (..) +import Json.Decode as Json exposing (Decoder) + +post : String -> Task Error Value +post url = + { verb = "POST" + , headers = [] + , url = url + , body = empty + } + |> Http.send defaultSettings + |> mapError promoteError + |> flip Task.andThen handleResponse + +handleResponse : Response -> Task Error Value +handleResponse response = + if 200 <= response.status && response.status < 300 + then Task.succeed response.value + else fail (BadResponse response.status response.statusText) + +promoteError : RawError -> Error +promoteError rawError = + case rawError of + RawTimeout -> Timeout + RawNetworkError -> NetworkError + +decodeHttpValue : Decoder a -> Value -> Task Error a +decodeHttpValue decoder value = + case value of + Text str -> + case Json.decodeString decoder str of + Ok v -> succeed v + Err msg -> fail (UnexpectedPayload msg) + _ -> + fail (UnexpectedPayload "Response body is a blob, expecting a string.") diff --git a/src/client/elm/Update.elm b/src/client/elm/Update.elm new file mode 100644 index 0000000..3c4614a --- /dev/null +++ b/src/client/elm/Update.elm @@ -0,0 +1,57 @@ +module Update + ( Action(..) + , actions + , updateModel + ) where + +import Time exposing (Time) + +import Model exposing (Model) +import Model.User exposing (Users, UserId) +import Model.Payment exposing (Payments) +import Model.Payer exposing (Payers) +import Model.View as V +import Model.View.SignInView exposing (..) +import Model.View.LoggedInView exposing (..) + +import Update.SignIn exposing (..) +import Update.LoggedIn exposing (..) + +type Action = + NoOp + | UpdateTime Time + | GoSignInView + | SignInError String + | UpdateSignIn SignInAction + | GoLoggedInView Users UserId Payments Payments Int Payers + | UpdateLoggedIn LoggedAction + +actions : Signal.Mailbox Action +actions = Signal.mailbox NoOp + +updateModel : Action -> Model -> Model +updateModel action model = + case action of + NoOp -> + model + UpdateTime time -> + { model | currentTime <- time } + GoSignInView -> + { model | view <- V.SignInView initSignInView } + 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 } + UpdateSignIn signInAction -> + case model.view of + V.SignInView signInView -> + { model | view <- V.SignInView (updateSignIn signInAction signInView) } + _ -> + model + UpdateLoggedIn loggedAction -> + case model.view of + V.LoggedInView loggedInView -> + { model | view <- V.LoggedInView (updateLoggedIn model loggedAction loggedInView) } + _ -> + model diff --git a/src/client/elm/Update/LoggedIn.elm b/src/client/elm/Update/LoggedIn.elm new file mode 100644 index 0000000..e477094 --- /dev/null +++ b/src/client/elm/Update/LoggedIn.elm @@ -0,0 +1,68 @@ +module Update.LoggedIn + ( LoggedAction(..) + , updateLoggedIn + ) where + +import Date +import Dict + +import Model exposing (Model) +import Model.User exposing (UserId) +import Model.Payment exposing (..) +import Model.View.LoggedInView exposing (..) +import Model.View.LoggedIn.Add exposing (..) + +import Update.LoggedIn.Add exposing (..) +import Update.LoggedIn.Monthly as UM +import Update.LoggedIn.Account as UA + +type LoggedAction = + UpdateAdd AddPaymentAction + | UpdatePayments Payments + | AddPayment UserId String Int Payments + | AddMonthlyPayment PaymentId String Int + | ToggleEdit PaymentId + | DeletePayment Payment Payments + | UpdatePage Int Payments + | UpdateMonthly UM.MonthlyAction + | UpdateAccount UA.AccountAction + +updateLoggedIn : Model -> LoggedAction -> LoggedInView -> LoggedInView +updateLoggedIn model action loggedInView = + case action of + UpdateAdd addPaymentAction -> + { loggedInView | add <- updateAddPayment addPaymentAction loggedInView.add } + UpdatePayments payments -> + { loggedInView | payments <- payments } + AddPayment userId name cost payments -> + { loggedInView + | payments <- payments + , currentPage <- 1 + , add <- initAddPayment Punctual + , 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.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 payment payments -> + { loggedInView + | payments <- payments + , account <- UA.updateAccount (UA.UpdatePayer payment.userId (Date.toTime payment.creation) -payment.cost) loggedInView.account + , paymentsCount <- loggedInView.paymentsCount - 1 + } + UpdatePage page payments -> + { loggedInView + | currentPage <- page + , payments <- payments + } + UpdateMonthly monthlyAction -> + { loggedInView | monthly <- UM.updateMonthly monthlyAction loggedInView.monthly } + UpdateAccount accountAction -> + { loggedInView | account <- UA.updateAccount accountAction loggedInView.account } diff --git a/src/client/elm/Update/LoggedIn/Account.elm b/src/client/elm/Update/LoggedIn/Account.elm new file mode 100644 index 0000000..cf4c834 --- /dev/null +++ b/src/client/elm/Update/LoggedIn/Account.elm @@ -0,0 +1,64 @@ +module Update.LoggedIn.Account + ( AccountAction(..) + , updateAccount + ) where + +import Maybe +import Time exposing (Time) +import Dict + +import Model.User exposing (UserId) +import Model.Payer exposing (..) +import Model.View.LoggedIn.Account exposing (..) + +import Utils.Maybe exposing (isJust) + +type AccountAction = + ToggleDetail + | UpdatePayer UserId Time Int + | ToggleIncomeEdition + | UpdateIncomeEdition String + | UpdateEditionError String + | UpdateIncome Time Int + +updateAccount : AccountAction -> Account -> Account +updateAccount action account = + case action of + ToggleDetail -> + { account | visibleDetail <- not account.visibleDetail } + 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 (getCurrentIncome account))) + } + UpdateIncomeEdition income -> + case account.incomeEdition of + Just incomeEdition -> + { account | incomeEdition <- Just { incomeEdition | income <- income } } + Nothing -> + account + UpdateEditionError error -> + case account.incomeEdition of + Just incomeEdition -> + { account | incomeEdition <- Just { incomeEdition | error <- Just error } } + Nothing -> + account + UpdateIncome currentTime amount -> + { account + | 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/elm/Update/LoggedIn/Add.elm b/src/client/elm/Update/LoggedIn/Add.elm new file mode 100644 index 0000000..1f28997 --- /dev/null +++ b/src/client/elm/Update/LoggedIn/Add.elm @@ -0,0 +1,29 @@ +module Update.LoggedIn.Add + ( AddPaymentAction(..) + , updateAddPayment + ) where + +import Model.View.LoggedIn.Add exposing (..) + +type AddPaymentAction = + UpdateName String + | UpdateCost String + | AddError (Maybe String) (Maybe String) + | ToggleFrequency + +updateAddPayment : AddPaymentAction -> AddPayment -> AddPayment +updateAddPayment action addPayment = + case action of + UpdateName name -> + { addPayment | name <- name } + UpdateCost cost -> + { addPayment | cost <- cost } + AddError nameError costError -> + { addPayment + | nameError <- nameError + , costError <- costError + } + ToggleFrequency -> + { addPayment + | frequency <- if addPayment.frequency == Punctual then Monthly else Punctual + } diff --git a/src/client/elm/Update/LoggedIn/Monthly.elm b/src/client/elm/Update/LoggedIn/Monthly.elm new file mode 100644 index 0000000..1379323 --- /dev/null +++ b/src/client/elm/Update/LoggedIn/Monthly.elm @@ -0,0 +1,27 @@ +module Update.LoggedIn.Monthly + ( MonthlyAction(..) + , updateMonthly + ) where + +import Model.Payment exposing (Payment, PaymentId) +import Model.View.LoggedIn.Monthly exposing (..) + +type MonthlyAction = + ToggleDetail + | AddPayment Payment + | DeletePayment PaymentId + +updateMonthly : MonthlyAction -> Monthly -> Monthly +updateMonthly action monthly = + case action of + ToggleDetail -> + { monthly | visibleDetail <- not monthly.visibleDetail } + AddPayment payment -> + { monthly + | payments <- payment :: monthly.payments + , visibleDetail <- True + } + DeletePayment id -> + { monthly + | payments <- List.filter (\payment -> payment.id /= id) monthly.payments + } diff --git a/src/client/elm/Update/SignIn.elm b/src/client/elm/Update/SignIn.elm new file mode 100644 index 0000000..cabe4cb --- /dev/null +++ b/src/client/elm/Update/SignIn.elm @@ -0,0 +1,15 @@ +module Update.SignIn + ( SignInAction(..) + , updateSignIn + ) where + +import Model.View.SignInView exposing (..) + +type SignInAction = + ErrorLogin String + +updateSignIn : SignInAction -> SignInView -> SignInView +updateSignIn action signInView = + case action of + ErrorLogin message -> + { signInView | result <- Just (Err message) } diff --git a/src/client/elm/Utils/Dict.elm b/src/client/elm/Utils/Dict.elm new file mode 100644 index 0000000..dc01b17 --- /dev/null +++ b/src/client/elm/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/elm/Utils/Either.elm b/src/client/elm/Utils/Either.elm new file mode 100644 index 0000000..10c40e3 --- /dev/null +++ b/src/client/elm/Utils/Either.elm @@ -0,0 +1,9 @@ +module Utils.Either + ( toMaybeError + ) where + +toMaybeError : Result a b -> Maybe a +toMaybeError result = + case result of + Ok _ -> Nothing + Err x -> Just x diff --git a/src/client/elm/Utils/Maybe.elm b/src/client/elm/Utils/Maybe.elm new file mode 100644 index 0000000..d954ae0 --- /dev/null +++ b/src/client/elm/Utils/Maybe.elm @@ -0,0 +1,27 @@ +module Utils.Maybe + ( isJust + , catMaybes + , maybeToList + ) where + +isJust : Maybe a -> Bool +isJust maybe = + case maybe of + 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/elm/Utils/Validation.elm b/src/client/elm/Utils/Validation.elm new file mode 100644 index 0000000..b9bccb3 --- /dev/null +++ b/src/client/elm/Utils/Validation.elm @@ -0,0 +1,23 @@ +module Utils.Validation + ( validateNonEmpty + , validateNumber + ) where + +import String +import Reads exposing (readInt) + +validateNonEmpty : String -> String -> Result String String +validateNonEmpty message str = + if String.isEmpty str + then Err message + else Ok str + +validateNumber : String -> (Int -> Bool) -> String -> Result String Int +validateNumber message numberForm str = + case readInt str of + Just number -> + if numberForm number + then Ok number + else Err message + Nothing -> + Err message diff --git a/src/client/elm/View/Date.elm b/src/client/elm/View/Date.elm new file mode 100644 index 0000000..81c5112 --- /dev/null +++ b/src/client/elm/View/Date.elm @@ -0,0 +1,59 @@ +module View.Date + ( renderShortDate + , renderLongDate + ) where + +import Date exposing (..) +import String + +import Model.Translations exposing (..) + +renderShortDate : Date -> Translations -> String +renderShortDate date translations = + let params = + [ String.pad 2 '0' (toString (Date.day date)) + , String.pad 2 '0' (toString (getMonthNumber (Date.month date))) + , toString (Date.year date) + ] + in getParamMessage params "ShortDate" translations + +renderLongDate : Date -> Translations -> String +renderLongDate date translations = + let params = + [ toString (Date.day date) + , (getMessage (getMonthKey (Date.month date)) translations) + , toString (Date.year date) + ] + in getParamMessage params "LongDate" translations + +getMonthNumber : Month -> Int +getMonthNumber month = + case month of + Jan -> 1 + Feb -> 2 + Mar -> 3 + Apr -> 4 + May -> 5 + Jun -> 6 + Jul -> 7 + Aug -> 8 + Sep -> 9 + Oct -> 10 + Nov -> 11 + Dec -> 12 + +getMonthKey : Month -> String +getMonthKey month = + case month of + Jan -> "January" + Feb -> "February" + Mar -> "March" + Apr -> "April" + May -> "May" + Jun -> "June" + Jul -> "July" + Aug -> "August" + Sep -> "September" + Oct -> "October" + Nov -> "November" + Dec -> "December" diff --git a/src/client/elm/View/Events.elm b/src/client/elm/View/Events.elm new file mode 100644 index 0000000..1eb9027 --- /dev/null +++ b/src/client/elm/View/Events.elm @@ -0,0 +1,19 @@ +module View.Events + ( onSubmitPrevDefault + ) where + +import Signal +import Json.Decode as Json +import Html exposing (..) +import Html.Events exposing (..) +import Html.Attributes exposing (..) + +onSubmitPrevDefault : Signal.Address a -> a -> Attribute +onSubmitPrevDefault address value = + onWithOptions + "submit" + { defaultOptions | preventDefault <- True } + Json.value + (\_ -> + Signal.message address value + ) diff --git a/src/client/elm/View/Expand.elm b/src/client/elm/View/Expand.elm new file mode 100644 index 0000000..53b4fe5 --- /dev/null +++ b/src/client/elm/View/Expand.elm @@ -0,0 +1,25 @@ +module View.Expand + ( expand + , ExpandType(..) + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) + +import View.Icon exposing (renderIcon) + +type ExpandType = ExpandUp | ExpandDown + +expand : ExpandType -> Bool -> Html +expand expandType isExpanded = + div + [ class "expand" ] + [ renderIcon (chevronIcon expandType isExpanded) ] + +chevronIcon : ExpandType -> Bool -> String +chevronIcon expandType isExpanded = + case (expandType, isExpanded) of + (ExpandUp, True) -> "chevron-down" + (ExpandUp, False) -> "chevron-up" + (ExpandDown, True) -> "chevron-up" + (ExpandDown, False) -> "chevron-down" diff --git a/src/client/elm/View/Header.elm b/src/client/elm/View/Header.elm new file mode 100644 index 0000000..3a6241b --- /dev/null +++ b/src/client/elm/View/Header.elm @@ -0,0 +1,39 @@ +module View.Header + ( renderHeader + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import Persona exposing (operations) + +import Model exposing (Model) +import Model.View exposing (..) +import Model.Translations exposing (getMessage) + +import View.Icon exposing (renderIcon) + +renderHeader : Model -> Html +renderHeader model = + header + [] + [ h1 + [] + [ text (getMessage "SharedCost" model.translations) ] + , case model.view of + LoadingView -> + text "" + SignInView _ -> + button + [ class "icon" + , onClick operations.address Persona.SignIn + ] + [ renderIcon "sign-in" ] + LoggedInView _ -> + button + [ class "icon" + , onClick operations.address Persona.SignOut + ] + [ renderIcon "sign-out" ] + ] diff --git a/src/client/elm/View/Icon.elm b/src/client/elm/View/Icon.elm new file mode 100644 index 0000000..f22c1a2 --- /dev/null +++ b/src/client/elm/View/Icon.elm @@ -0,0 +1,12 @@ +module View.Icon + ( renderIcon + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) + +renderIcon : String -> Html +renderIcon iconClass = + i + [ class <| "fa fa-fw fa-" ++ iconClass ] + [] diff --git a/src/client/elm/View/Loading.elm b/src/client/elm/View/Loading.elm new file mode 100644 index 0000000..f8c6cd6 --- /dev/null +++ b/src/client/elm/View/Loading.elm @@ -0,0 +1,8 @@ +module View.Loading + ( renderLoading + ) where + +import Html exposing (..) + +renderLoading : Html +renderLoading = text "" diff --git a/src/client/elm/View/LoggedIn.elm b/src/client/elm/View/LoggedIn.elm new file mode 100644 index 0000000..96916e0 --- /dev/null +++ b/src/client/elm/View/LoggedIn.elm @@ -0,0 +1,30 @@ +module View.LoggedIn + ( renderLoggedIn + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) + +import Model exposing (Model) +import Model.Payment exposing (Payments) +import Model.View.LoggedInView exposing (LoggedInView) + +import View.LoggedIn.Add exposing (addPayment) +import View.LoggedIn.Monthly exposing (monthlyPayments) +import View.LoggedIn.Account exposing (account) +import View.LoggedIn.Table exposing (paymentsTable) +import View.LoggedIn.Paging exposing (paymentsPaging) + +renderLoggedIn : Model -> LoggedInView -> Html +renderLoggedIn model loggedInView = + div + [ class "loggedIn" ] + [ addPayment model loggedInView + , div + [ class "expandables" ] + [ account model loggedInView + , monthlyPayments model loggedInView + ] + , paymentsTable model loggedInView + , paymentsPaging loggedInView + ] diff --git a/src/client/elm/View/LoggedIn/Account.elm b/src/client/elm/View/LoggedIn/Account.elm new file mode 100644 index 0000000..706f7cc --- /dev/null +++ b/src/client/elm/View/LoggedIn/Account.elm @@ -0,0 +1,130 @@ +module View.LoggedIn.Account + ( account + ) where + +import Html exposing (..) +import Html as H exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import List + +import ServerCommunication as SC exposing (serverCommunications) + +import Update exposing (..) +import Update.LoggedIn exposing (..) +import Update.LoggedIn.Account exposing (..) + +import Model exposing (Model) +import Model.User exposing (getUserName) +import Model.Payer exposing (..) +import Model.View.LoggedInView exposing (LoggedInView) +import Model.Translations exposing (getParamMessage, getMessage) +import Model.View.LoggedIn.Account exposing (..) + +import View.Expand exposing (..) +import View.Price exposing (price) +import View.Events exposing (onSubmitPrevDefault) + +import Utils.Either exposing (toMaybeError) + +account : Model -> LoggedInView -> Html +account model loggedInView = + let account = loggedInView.account + in div + [ classList + [ ("account", True) + , ("detail", account.visibleDetail) + ] + ] + [ exceedingPayers model loggedInView + , if account.visibleDetail + then income model account + else text "" + ] + +exceedingPayers : Model -> LoggedInView -> Html +exceedingPayers model loggedInView = + button + [ class "header" + , onClick actions.address (UpdateLoggedIn << UpdateAccount <| ToggleDetail) + ] + ( (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers model.currentTime loggedInView.account.payers)) + ++ [ expand ExpandDown loggedInView.account.visibleDetail ] + ) + +exceedingPayer : Model -> LoggedInView -> ExceedingPayer -> Html +exceedingPayer model loggedInView payer = + div + [ class "exceedingPayer" ] + [ span + [ class "userName" ] + [ payer.userId + |> getUserName loggedInView.users + |> Maybe.withDefault "−" + |> text + ] + , span + [ class "amount" ] + [ text ("+ " ++ (price model payer.amount)) ] + ] + +income : Model -> Account -> Html +income model account = + case account.incomeEdition of + Just edition -> + incomeEdition model account edition + Nothing -> + incomeRead model account + +incomeRead : Model -> Account -> Html +incomeRead model account = + div + [ class "income" ] + [ ( case getCurrentIncome account of + Nothing -> + text (getMessage "NoIncome" model.translations) + Just income -> + text (getParamMessage [price model income] "Income" model.translations) + ) + , toggleIncomeEdition "editIncomeEdition" (getMessage "Edit" model.translations) + ] + +incomeEdition : Model -> Account -> IncomeEdition -> Html +incomeEdition model account edition = + H.form + [ case validateIncome edition.income model.translations of + Ok validatedAmount -> + onSubmitPrevDefault serverCommunications.address (SC.SetIncome model.currentTime validatedAmount) + Err error -> + onSubmitPrevDefault actions.address (UpdateLoggedIn << UpdateAccount << UpdateEditionError <| error) + , class "income" + ] + [ label + [ for "incomeInput" ] + [ text (getMessage "NewIncome" model.translations) ] + , input + [ id "incomeInput" + , value edition.income + , on "input" targetValue (Signal.message actions.address << UpdateLoggedIn << UpdateAccount << UpdateIncomeEdition) + , maxlength 10 + ] + [] + , button + [ type' "submit" + , class "validateIncomeEdition" + ] + [ text (getMessage "Validate" model.translations) ] + , toggleIncomeEdition "undoIncomeEdition" (getMessage "Undo" model.translations) + , case edition.error of + Just error -> div [ class "error" ] [ text error ] + Nothing -> text "" + ] + +toggleIncomeEdition : String -> String -> Html +toggleIncomeEdition className name = + button + [ type' "button" + , class className + , onClick actions.address (UpdateLoggedIn << UpdateAccount <| ToggleIncomeEdition) + ] + [ text name ] diff --git a/src/client/elm/View/LoggedIn/Add.elm b/src/client/elm/View/LoggedIn/Add.elm new file mode 100644 index 0000000..572bdf6 --- /dev/null +++ b/src/client/elm/View/LoggedIn/Add.elm @@ -0,0 +1,122 @@ +module View.LoggedIn.Add + ( addPayment + ) where + +import Html as H exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Reads exposing (readInt) +import Result exposing (..) + +import ServerCommunication as SC exposing (serverCommunications) + +import Update exposing (..) +import Update.LoggedIn exposing (..) +import Update.LoggedIn.Add exposing (..) + +import Model exposing (Model) +import Model.View.LoggedIn.Add exposing (..) +import Model.Translations exposing (getMessage) +import Model.View.LoggedInView exposing (LoggedInView) + +import View.Events exposing (onSubmitPrevDefault) +import View.Icon exposing (renderIcon) + +import Utils.Maybe exposing (isJust) +import Utils.Either exposing (toMaybeError) + +addPayment : Model -> LoggedInView -> Html +addPayment model loggedInView = + H.form + [ case (validateName loggedInView.add.name model.translations, validateCost loggedInView.add.cost model.translations) of + (Ok name, Ok cost) -> + let action = + case loggedInView.add.frequency of + Punctual -> SC.AddPayment loggedInView.account.me name cost + Monthly -> SC.AddMonthlyPayment name cost + in onSubmitPrevDefault serverCommunications.address action + (resName, resCost) -> + onSubmitPrevDefault actions.address (UpdateLoggedIn <| UpdateAdd <| AddError (toMaybeError resName) (toMaybeError resCost)) + , class "addPayment" + ] + [ addPaymentName loggedInView.add + , addPaymentCost model loggedInView.add + , paymentFrequency model loggedInView.add + , button + [ type' "submit" + , class "add" ] + [ text (getMessage "Add" model.translations)] + ] + +addPaymentName : AddPayment -> Html +addPaymentName addPayment = + div + [ classList + [ ("name", True) + , ("error", isJust addPayment.nameError) + ] + ] + [ input + [ id "nameInput" + , value addPayment.name + , on "input" targetValue (Signal.message actions.address << UpdateLoggedIn << UpdateAdd << UpdateName) + , maxlength 20 + ] + [] + , label + [ for "nameInput" ] + [ renderIcon "shopping-cart" ] + , case addPayment.nameError of + Just error -> + div [ class "errorMessage" ] [ text error ] + Nothing -> + text "" + ] + +addPaymentCost : Model -> AddPayment -> Html +addPaymentCost model addPayment = + div + [ classList + [ ("cost", True) + , ("error", isJust addPayment.costError) + ] + ] + [ input + [ id "costInput" + , value addPayment.cost + , on "input" targetValue (Signal.message actions.address << UpdateLoggedIn << UpdateAdd << UpdateCost) + , maxlength 7 + ] + [] + , label + [ for "costInput" ] + [ text model.config.currency ] + , case addPayment.costError of + Just error -> + div [ class "errorMessage" ] [ text error ] + Nothing -> + text "" + ] + +paymentFrequency : Model -> AddPayment -> Html +paymentFrequency model addPayment = + button + [ type' "button" + , class "frequency" + , onClick actions.address (UpdateLoggedIn << UpdateAdd <| ToggleFrequency) + ] + [ div + [ classList + [ ("punctual", True) + , ("selected", addPayment.frequency == Punctual) + ] + ] + [ text (getMessage "Punctual" model.translations) ] + , div + [ classList + [ ("monthly", True) + , ("selected", addPayment.frequency == Monthly) + ] + ] + [ text (getMessage "Monthly" model.translations) ] + ] diff --git a/src/client/elm/View/LoggedIn/Monthly.elm b/src/client/elm/View/LoggedIn/Monthly.elm new file mode 100644 index 0000000..a274015 --- /dev/null +++ b/src/client/elm/View/LoggedIn/Monthly.elm @@ -0,0 +1,89 @@ +module View.LoggedIn.Monthly + ( monthlyPayments + ) where + +import String + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import Update exposing (..) +import Update.LoggedIn exposing (..) +import Update.LoggedIn.Monthly exposing (..) + +import Model exposing (Model) +import Model.View.LoggedIn.Monthly exposing (Monthly) +import Model.Payment exposing (Payments, Payment) +import Model.View.LoggedInView exposing (LoggedInView) +import Model.Translations exposing (getMessage, getParamMessage) + +import ServerCommunication as SC exposing (serverCommunications) + +import View.Icon exposing (renderIcon) +import View.Expand exposing (..) +import View.Price exposing (price) + +monthlyPayments : Model -> LoggedInView -> Html +monthlyPayments model loggedInView = + let monthly = loggedInView.monthly + 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 -> Html +monthlyCount model monthly = + let count = List.length monthly.payments + total = List.sum << List.map .cost <| monthly.payments + key = if count > 1 then "PluralMonthlyCount" else "SingularMonthlyCount" + in button + [ class "header" + , onClick actions.address (UpdateLoggedIn << UpdateMonthly <| ToggleDetail) + ] + [ text (getParamMessage [toString count, price model total] key model.translations) + , expand ExpandDown monthly.visibleDetail + ] + +paymentsTable : Model -> LoggedInView -> Monthly -> Html +paymentsTable model loggedInView monthly = + div + [ class "table" ] + ( monthly.payments + |> List.sortBy (String.toLower << .name) + |> List.map (paymentLine model loggedInView) + ) + +paymentLine : Model -> LoggedInView -> Payment -> Html +paymentLine model loggedInView payment = + a + [ classList + [ ("row", True) + , ("edition", loggedInView.paymentEdition == Just payment.id) + ] + , onClick actions.address (UpdateLoggedIn (ToggleEdit payment.id)) + ] + [ div [ class "cell category" ] [ text (payment.name) ] + , div + [ classList + [ ("cell cost", True) + , ("refund", payment.cost < 0) + ] + ] + [ text (price model payment.cost) ] + , div + [ class "cell delete" + , onClick serverCommunications.address (SC.DeleteMonthlyPayment payment.id) + ] + [ button [] [ renderIcon "times" ] + ] + ] diff --git a/src/client/elm/View/LoggedIn/Paging.elm b/src/client/elm/View/LoggedIn/Paging.elm new file mode 100644 index 0000000..93d7f1d --- /dev/null +++ b/src/client/elm/View/LoggedIn/Paging.elm @@ -0,0 +1,100 @@ +module View.LoggedIn.Paging + ( paymentsPaging + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import Model.View.LoggedInView exposing (..) +import Model.Payment exposing (perPage) + +import ServerCommunication as SC exposing (serverCommunications) + +import Update exposing (..) +import Update.LoggedIn exposing (..) + +import View.Icon exposing (renderIcon) + +showedPages : Int +showedPages = 5 + +paymentsPaging : LoggedInView -> Html +paymentsPaging loggedInView = + let maxPage = ceiling (toFloat loggedInView.paymentsCount / toFloat perPage) + pages = truncatePages loggedInView.currentPage [1..maxPage] + in if maxPage == 1 + then + text "" + else + div + [ class "pages" ] + ( ( if loggedInView.currentPage > 1 + then [ firstPage, previousPage loggedInView ] + else [] + ) + ++ ( List.map (paymentsPage loggedInView) pages) + ++ ( if loggedInView.currentPage < maxPage + then [ nextPage loggedInView, lastPage maxPage ] + else [] + ) + ) + +truncatePages : Int -> List Int -> List Int +truncatePages currentPage pages = + let totalPages = List.length pages + showedLeftPages = ceiling ((toFloat showedPages - 1) / 2) + showedRightPages = floor ((toFloat showedPages - 1) / 2) + truncatedPages = + if | currentPage < showedLeftPages -> + [1..showedPages] + | currentPage > totalPages - showedRightPages -> + [(totalPages - showedPages)..totalPages] + | otherwise -> + [(currentPage - showedLeftPages)..(currentPage + showedRightPages)] + in List.filter (flip List.member pages) truncatedPages + +firstPage : Html +firstPage = + button + [ class "page" + , onClick serverCommunications.address (SC.UpdatePage 1) + ] + [ renderIcon "fast-backward" ] + +previousPage : LoggedInView -> Html +previousPage loggedInView = + button + [ class "page" + , onClick serverCommunications.address (SC.UpdatePage (loggedInView.currentPage - 1)) + ] + [ renderIcon "backward" ] + +nextPage : LoggedInView -> Html +nextPage loggedInView = + button + [ class "page" + , onClick serverCommunications.address (SC.UpdatePage (loggedInView.currentPage + 1)) + ] + [ renderIcon "forward" ] + +lastPage : Int -> Html +lastPage maxPage = + button + [ class "page" + , onClick serverCommunications.address (SC.UpdatePage maxPage) + ] + [ renderIcon "fast-forward" ] + +paymentsPage : LoggedInView -> Int -> Html +paymentsPage loggedInView page = + let onCurrentPage = page == loggedInView.currentPage + in button + [ classList + [ ("page", True) + , ("current", onCurrentPage) + ] + , onClick serverCommunications.address <| + if onCurrentPage then SC.NoCommunication else SC.UpdatePage page + ] + [ text (toString page) ] diff --git a/src/client/elm/View/LoggedIn/Table.elm b/src/client/elm/View/LoggedIn/Table.elm new file mode 100644 index 0000000..f5a08b5 --- /dev/null +++ b/src/client/elm/View/LoggedIn/Table.elm @@ -0,0 +1,97 @@ +module View.LoggedIn.Table + ( paymentsTable + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Dict exposing (..) + +import Date +import Date exposing (Date) + +import String exposing (append) + +import Model exposing (Model) +import Model.User exposing (getUserName) +import Model.Payment exposing (..) +import Model.View.LoggedInView exposing (LoggedInView) +import Model.Translations exposing (getMessage) + +import ServerCommunication as SC exposing (serverCommunications) + +import Update exposing (..) +import Update.LoggedIn exposing (..) + +import View.Icon exposing (renderIcon) +import View.Date exposing (..) +import View.Price exposing (price) + +paymentsTable : Model -> LoggedInView -> Html +paymentsTable model loggedInView = + div + [ class "table" ] + ( headerLine model :: paymentLines model loggedInView) + +headerLine : Model -> Html +headerLine model = + div + [ class "header" ] + [ div [ class "cell category" ] [ renderIcon "shopping-cart" ] + , div [ class "cell cost" ] [ text model.config.currency ] + , div [ class "cell user" ] [ renderIcon "user" ] + , div [ class "cell date" ] [ renderIcon "calendar" ] + , div [ class "cell" ] [] + ] + +paymentLines : Model -> LoggedInView -> List Html +paymentLines model loggedInView = + loggedInView.payments + |> List.sortBy (Date.toTime << .creation) + |> List.reverse + |> List.map (paymentLine model loggedInView) + +paymentLine : Model -> LoggedInView -> Payment -> Html +paymentLine model loggedInView payment = + a + [ classList + [ ("row", True) + , ("edition", loggedInView.paymentEdition == Just payment.id) + ] + , onClick actions.address (UpdateLoggedIn (ToggleEdit payment.id)) + ] + [ div [ class "cell category" ] [ text payment.name ] + , div + [ classList + [ ("cell cost", True) + , ("refund", payment.cost < 0) + ] + ] + [ text (price model payment.cost) ] + , div + [ class "cell user" ] + [ payment.userId + |> getUserName loggedInView.users + |> Maybe.withDefault "−" + |> text + ] + , div + [ class "cell date" ] + [ span + [ class "shortDate" ] + [ text (renderShortDate payment.creation model.translations) ] + , span + [ class "longDate" ] + [ text (renderLongDate payment.creation model.translations) ] + ] + , if loggedInView.account.me == payment.userId + then + div + [ class "cell delete" ] + [ button + [ onClick serverCommunications.address (SC.DeletePayment payment loggedInView.currentPage) ] + [ renderIcon "times" ] + ] + else + div [ class "cell" ] [] + ] diff --git a/src/client/elm/View/Page.elm b/src/client/elm/View/Page.elm new file mode 100644 index 0000000..763734d --- /dev/null +++ b/src/client/elm/View/Page.elm @@ -0,0 +1,31 @@ +module View.Page + ( renderPage + ) where + +import Html exposing (..) + +import Model exposing (Model) +import Model.View exposing (..) + +import View.Header exposing (renderHeader) +import View.Loading exposing (renderLoading) +import View.SignIn exposing (renderSignIn) +import View.LoggedIn exposing (renderLoggedIn) + +renderPage : Model -> Html +renderPage model = + div + [] + [ renderHeader model + , renderMain model + ] + +renderMain : Model -> Html +renderMain model = + case model.view of + LoadingView -> + renderLoading + SignInView signInView -> + renderSignIn model signInView + LoggedInView loggedInView -> + renderLoggedIn model loggedInView diff --git a/src/client/elm/View/Price.elm b/src/client/elm/View/Price.elm new file mode 100644 index 0000000..286bcaa --- /dev/null +++ b/src/client/elm/View/Price.elm @@ -0,0 +1,38 @@ +module View.Price + ( price + ) where + +import String exposing (..) + +import Model exposing (Model) +import Model.Translations exposing (getMessage) + +price : Model -> Int -> String +price model amount = + ( formatInt amount + ++ " " + ++ model.config.currency + ) + +formatInt : Int -> String +formatInt n = + abs n + |> toString + |> toList + |> List.reverse + |> group 3 + |> List.intersperse [' '] + |> List.concat + |> List.reverse + |> fromList + |> append (if n < 0 then "-" else "") + +group : Int -> List a -> List (List a) +group n xs = + if List.length xs <= n + then + [xs] + else + let take = List.take n xs + drop = List.drop n xs + in take :: (group n drop) diff --git a/src/client/elm/View/SignIn.elm b/src/client/elm/View/SignIn.elm new file mode 100644 index 0000000..8fcac16 --- /dev/null +++ b/src/client/elm/View/SignIn.elm @@ -0,0 +1,46 @@ +module View.SignIn + ( renderSignIn + ) where + +import Html as H exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) + +import Json.Decode as Json + +import Update exposing (..) +import Update.SignIn exposing (..) + +import ServerCommunication as SC +import ServerCommunication exposing (serverCommunications) + +import Model exposing (Model) +import Model.View.SignInView exposing (..) +import Model.Translations exposing (getMessage) + +import View.Events exposing (onSubmitPrevDefault) + +renderSignIn : Model -> SignInView -> Html +renderSignIn model signInView = + div + [ class "signIn" ] + [ div + [ class "result" ] + [ signInResult model signInView ] + ] + +signInResult : Model -> SignInView -> Html +signInResult model signInView = + case signInView.result of + Just result -> + case result of + Ok login -> + div + [ class "success" ] + [ text (getMessage "SignInEmailSent" model.translations) ] + Err error -> + div + [ class "error" ] + [ text error ] + Nothing -> + text "" |