From a7db22556b91bc7c499e010b4c051f4442ad8ce2 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 29 Dec 2015 22:38:42 +0100 Subject: Using persona to validate emails --- src/client/Main.elm | 101 ----------------- src/client/Model.elm | 32 ------ src/client/Model/Config.elm | 18 ---- src/client/Model/Date.elm | 15 --- src/client/Model/Income.elm | 76 ------------- src/client/Model/Payer.elm | 132 ----------------------- src/client/Model/Payment.elm | 44 -------- src/client/Model/Translations.elm | 69 ------------ src/client/Model/User.elm | 44 -------- src/client/Model/View.elm | 12 --- src/client/Model/View/LoggedIn/Account.elm | 67 ------------ src/client/Model/View/LoggedIn/Add.elm | 43 -------- src/client/Model/View/LoggedIn/Edition.elm | 7 -- src/client/Model/View/LoggedIn/Monthly.elm | 17 --- src/client/Model/View/LoggedInView.elm | 35 ------ src/client/Model/View/SignInView.elm | 15 --- src/client/Native/Reads.js | 22 ---- src/client/Reads.elm | 10 -- src/client/ServerCommunication.elm | 143 ------------------------- src/client/Update.elm | 57 ---------- src/client/Update/LoggedIn.elm | 68 ------------ src/client/Update/LoggedIn/Account.elm | 64 ----------- src/client/Update/LoggedIn/Add.elm | 29 ----- src/client/Update/LoggedIn/Monthly.elm | 27 ----- src/client/Update/SignIn.elm | 24 ----- src/client/Utils/Dict.elm | 11 -- src/client/Utils/Either.elm | 9 -- src/client/Utils/Maybe.elm | 27 ----- src/client/Utils/Validation.elm | 23 ---- src/client/View/Date.elm | 59 ---------- src/client/View/Events.elm | 19 ---- src/client/View/Expand.elm | 25 ----- src/client/View/Header.elm | 36 ------- src/client/View/Icon.elm | 12 --- src/client/View/Loading.elm | 8 -- src/client/View/LoggedIn.elm | 30 ------ src/client/View/LoggedIn/Account.elm | 130 ---------------------- src/client/View/LoggedIn/Add.elm | 122 --------------------- src/client/View/LoggedIn/Monthly.elm | 89 --------------- src/client/View/LoggedIn/Paging.elm | 100 ----------------- src/client/View/LoggedIn/Table.elm | 97 ----------------- src/client/View/Page.elm | 31 ------ src/client/View/Price.elm | 38 ------- src/client/View/SignIn.elm | 57 ---------- src/client/elm/InitViewAction.elm | 25 +++++ src/client/elm/Main.elm | 89 +++++++++++++++ src/client/elm/Model.elm | 32 ++++++ src/client/elm/Model/Config.elm | 18 ++++ src/client/elm/Model/Date.elm | 15 +++ src/client/elm/Model/Income.elm | 76 +++++++++++++ src/client/elm/Model/Payer.elm | 132 +++++++++++++++++++++++ src/client/elm/Model/Payment.elm | 44 ++++++++ src/client/elm/Model/Translations.elm | 69 ++++++++++++ src/client/elm/Model/User.elm | 44 ++++++++ src/client/elm/Model/View.elm | 12 +++ src/client/elm/Model/View/LoggedIn/Account.elm | 67 ++++++++++++ src/client/elm/Model/View/LoggedIn/Add.elm | 43 ++++++++ src/client/elm/Model/View/LoggedIn/Edition.elm | 7 ++ src/client/elm/Model/View/LoggedIn/Monthly.elm | 17 +++ src/client/elm/Model/View/LoggedInView.elm | 35 ++++++ src/client/elm/Model/View/SignInView.elm | 15 +++ src/client/elm/Native/Reads.js | 22 ++++ src/client/elm/Persona.elm | 28 +++++ src/client/elm/Reads.elm | 10 ++ src/client/elm/ServerCommunication.elm | 95 ++++++++++++++++ src/client/elm/Sign.elm | 43 ++++++++ src/client/elm/SimpleHTTP.elm | 41 +++++++ src/client/elm/Update.elm | 57 ++++++++++ src/client/elm/Update/LoggedIn.elm | 68 ++++++++++++ src/client/elm/Update/LoggedIn/Account.elm | 64 +++++++++++ src/client/elm/Update/LoggedIn/Add.elm | 29 +++++ src/client/elm/Update/LoggedIn/Monthly.elm | 27 +++++ src/client/elm/Update/SignIn.elm | 15 +++ src/client/elm/Utils/Dict.elm | 11 ++ src/client/elm/Utils/Either.elm | 9 ++ src/client/elm/Utils/Maybe.elm | 27 +++++ src/client/elm/Utils/Validation.elm | 23 ++++ src/client/elm/View/Date.elm | 59 ++++++++++ src/client/elm/View/Events.elm | 19 ++++ src/client/elm/View/Expand.elm | 25 +++++ src/client/elm/View/Header.elm | 39 +++++++ src/client/elm/View/Icon.elm | 12 +++ src/client/elm/View/Loading.elm | 8 ++ src/client/elm/View/LoggedIn.elm | 30 ++++++ src/client/elm/View/LoggedIn/Account.elm | 130 ++++++++++++++++++++++ src/client/elm/View/LoggedIn/Add.elm | 122 +++++++++++++++++++++ src/client/elm/View/LoggedIn/Monthly.elm | 89 +++++++++++++++ src/client/elm/View/LoggedIn/Paging.elm | 100 +++++++++++++++++ src/client/elm/View/LoggedIn/Table.elm | 97 +++++++++++++++++ src/client/elm/View/Page.elm | 31 ++++++ src/client/elm/View/Price.elm | 38 +++++++ src/client/elm/View/SignIn.elm | 46 ++++++++ src/client/js/main.js | 28 +++++ src/server/Config.hs | 2 - src/server/Controller/SignIn.hs | 84 +++------------ src/server/Design/Header.hs | 2 +- src/server/Design/SignIn.hs | 20 ---- src/server/Main.hs | 12 +-- src/server/Model/Database.hs | 1 - src/server/Model/Message/Key.hs | 6 +- src/server/Model/Message/Translations.hs | 26 +---- src/server/Model/SignIn.hs | 17 +-- src/server/Persona.hs | 42 ++++++++ src/server/Secure.hs | 7 +- src/server/View/Page.hs | 4 +- 105 files changed, 2253 insertions(+), 2246 deletions(-) delete mode 100644 src/client/Main.elm delete mode 100644 src/client/Model.elm delete mode 100644 src/client/Model/Config.elm delete mode 100644 src/client/Model/Date.elm delete mode 100644 src/client/Model/Income.elm delete mode 100644 src/client/Model/Payer.elm delete mode 100644 src/client/Model/Payment.elm delete mode 100644 src/client/Model/Translations.elm delete mode 100644 src/client/Model/User.elm delete mode 100644 src/client/Model/View.elm delete mode 100644 src/client/Model/View/LoggedIn/Account.elm delete mode 100644 src/client/Model/View/LoggedIn/Add.elm delete mode 100644 src/client/Model/View/LoggedIn/Edition.elm delete mode 100644 src/client/Model/View/LoggedIn/Monthly.elm delete mode 100644 src/client/Model/View/LoggedInView.elm delete mode 100644 src/client/Model/View/SignInView.elm delete mode 100644 src/client/Native/Reads.js delete mode 100644 src/client/Reads.elm delete mode 100644 src/client/ServerCommunication.elm delete mode 100644 src/client/Update.elm delete mode 100644 src/client/Update/LoggedIn.elm delete mode 100644 src/client/Update/LoggedIn/Account.elm delete mode 100644 src/client/Update/LoggedIn/Add.elm delete mode 100644 src/client/Update/LoggedIn/Monthly.elm delete mode 100644 src/client/Update/SignIn.elm delete mode 100644 src/client/Utils/Dict.elm delete mode 100644 src/client/Utils/Either.elm delete mode 100644 src/client/Utils/Maybe.elm delete mode 100644 src/client/Utils/Validation.elm delete mode 100644 src/client/View/Date.elm delete mode 100644 src/client/View/Events.elm delete mode 100644 src/client/View/Expand.elm delete mode 100644 src/client/View/Header.elm delete mode 100644 src/client/View/Icon.elm delete mode 100644 src/client/View/Loading.elm delete mode 100644 src/client/View/LoggedIn.elm delete mode 100644 src/client/View/LoggedIn/Account.elm delete mode 100644 src/client/View/LoggedIn/Add.elm delete mode 100644 src/client/View/LoggedIn/Monthly.elm delete mode 100644 src/client/View/LoggedIn/Paging.elm delete mode 100644 src/client/View/LoggedIn/Table.elm delete mode 100644 src/client/View/Page.elm delete mode 100644 src/client/View/Price.elm delete mode 100644 src/client/View/SignIn.elm create mode 100644 src/client/elm/InitViewAction.elm create mode 100644 src/client/elm/Main.elm create mode 100644 src/client/elm/Model.elm create mode 100644 src/client/elm/Model/Config.elm create mode 100644 src/client/elm/Model/Date.elm create mode 100644 src/client/elm/Model/Income.elm create mode 100644 src/client/elm/Model/Payer.elm create mode 100644 src/client/elm/Model/Payment.elm create mode 100644 src/client/elm/Model/Translations.elm create mode 100644 src/client/elm/Model/User.elm create mode 100644 src/client/elm/Model/View.elm create mode 100644 src/client/elm/Model/View/LoggedIn/Account.elm create mode 100644 src/client/elm/Model/View/LoggedIn/Add.elm create mode 100644 src/client/elm/Model/View/LoggedIn/Edition.elm create mode 100644 src/client/elm/Model/View/LoggedIn/Monthly.elm create mode 100644 src/client/elm/Model/View/LoggedInView.elm create mode 100644 src/client/elm/Model/View/SignInView.elm create mode 100644 src/client/elm/Native/Reads.js create mode 100644 src/client/elm/Persona.elm create mode 100644 src/client/elm/Reads.elm create mode 100644 src/client/elm/ServerCommunication.elm create mode 100644 src/client/elm/Sign.elm create mode 100644 src/client/elm/SimpleHTTP.elm create mode 100644 src/client/elm/Update.elm create mode 100644 src/client/elm/Update/LoggedIn.elm create mode 100644 src/client/elm/Update/LoggedIn/Account.elm create mode 100644 src/client/elm/Update/LoggedIn/Add.elm create mode 100644 src/client/elm/Update/LoggedIn/Monthly.elm create mode 100644 src/client/elm/Update/SignIn.elm create mode 100644 src/client/elm/Utils/Dict.elm create mode 100644 src/client/elm/Utils/Either.elm create mode 100644 src/client/elm/Utils/Maybe.elm create mode 100644 src/client/elm/Utils/Validation.elm create mode 100644 src/client/elm/View/Date.elm create mode 100644 src/client/elm/View/Events.elm create mode 100644 src/client/elm/View/Expand.elm create mode 100644 src/client/elm/View/Header.elm create mode 100644 src/client/elm/View/Icon.elm create mode 100644 src/client/elm/View/Loading.elm create mode 100644 src/client/elm/View/LoggedIn.elm create mode 100644 src/client/elm/View/LoggedIn/Account.elm create mode 100644 src/client/elm/View/LoggedIn/Add.elm create mode 100644 src/client/elm/View/LoggedIn/Monthly.elm create mode 100644 src/client/elm/View/LoggedIn/Paging.elm create mode 100644 src/client/elm/View/LoggedIn/Table.elm create mode 100644 src/client/elm/View/Page.elm create mode 100644 src/client/elm/View/Price.elm create mode 100644 src/client/elm/View/SignIn.elm create mode 100644 src/client/js/main.js create mode 100644 src/server/Persona.hs (limited to 'src') diff --git a/src/client/Main.elm b/src/client/Main.elm deleted file mode 100644 index 4f96675..0000000 --- a/src/client/Main.elm +++ /dev/null @@ -1,101 +0,0 @@ -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 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.Payer exposing (Payers, payersDecoder) -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 exposing (serverCommunications, sendRequest) - -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 signInError : Maybe String - ---------------------------------------- - -port initialTime : Time - ---------------------------------------- - -port translations : String - ---------------------------------------- - -port config : String - ---------------------------------------- - -port initView : Task Http.Error () -port initView = - case signInError of - Just msg -> - Signal.send actions.address (SignInError msg) - Nothing -> - Task.onError goLoggedInView (\_ -> Signal.send actions.address GoSignInView) - -goLoggedInView : Task Http.Error () -goLoggedInView = - Task.andThen getUsers <| \users -> - Task.andThen whoAmI <| \me -> - Task.andThen getMonthlyPayments <| \monthlyPayments -> - Task.andThen getPayments <| \payments -> - Task.andThen getPaymentsCount <| \paymentsCount -> - Task.andThen getPayers <| \payers -> - Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers) - -getUsers : Task Http.Error Users -getUsers = Http.get usersDecoder "/users" - -whoAmI : Task Http.Error UserId -whoAmI = Http.get ("id" := userIdDecoder) "/whoAmI" - -getMonthlyPayments : Task Http.Error Payments -getMonthlyPayments = Http.get paymentsDecoder "/monthlyPayments" - -getPayments : Task Http.Error Payments -getPayments = Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage) - -getPaymentsCount : Task Http.Error Int -getPaymentsCount = Http.get ("number" := Json.int) "/payments/count" - -getPayers : Task Http.Error Payers -getPayers = Http.get payersDecoder "/payers" - ---------------------------------------- - -port serverCommunicationsPort : Signal (Task Http.RawError ()) -port serverCommunicationsPort = - Signal.map - (\comm -> sendRequest comm `Task.andThen` (Signal.send actions.address)) - serverCommunications.signal diff --git a/src/client/Model.elm b/src/client/Model.elm deleted file mode 100644 index 43a19c5..0000000 --- a/src/client/Model.elm +++ /dev/null @@ -1,32 +0,0 @@ -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/Model/Config.elm b/src/client/Model/Config.elm deleted file mode 100644 index e47b032..0000000 --- a/src/client/Model/Config.elm +++ /dev/null @@ -1,18 +0,0 @@ -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/Model/Date.elm b/src/client/Model/Date.elm deleted file mode 100644 index 1c56de4..0000000 --- a/src/client/Model/Date.elm +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 index 97a5652..0000000 --- a/src/client/Model/Income.elm +++ /dev/null @@ -1,76 +0,0 @@ -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/Model/Payer.elm b/src/client/Model/Payer.elm deleted file mode 100644 index 9fd1bb5..0000000 --- a/src/client/Model/Payer.elm +++ /dev/null @@ -1,132 +0,0 @@ -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/Model/Payment.elm b/src/client/Model/Payment.elm deleted file mode 100644 index c4a8963..0000000 --- a/src/client/Model/Payment.elm +++ /dev/null @@ -1,44 +0,0 @@ -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/Model/Translations.elm b/src/client/Model/Translations.elm deleted file mode 100644 index bec8c9b..0000000 --- a/src/client/Model/Translations.elm +++ /dev/null @@ -1,69 +0,0 @@ -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/Model/User.elm b/src/client/Model/User.elm deleted file mode 100644 index 1412913..0000000 --- a/src/client/Model/User.elm +++ /dev/null @@ -1,44 +0,0 @@ -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/Model/View.elm b/src/client/Model/View.elm deleted file mode 100644 index 90c0e53..0000000 --- a/src/client/Model/View.elm +++ /dev/null @@ -1,12 +0,0 @@ -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/Model/View/LoggedIn/Account.elm b/src/client/Model/View/LoggedIn/Account.elm deleted file mode 100644 index 2bb3ae7..0000000 --- a/src/client/Model/View/LoggedIn/Account.elm +++ /dev/null @@ -1,67 +0,0 @@ -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/Model/View/LoggedIn/Add.elm b/src/client/Model/View/LoggedIn/Add.elm deleted file mode 100644 index 5598084..0000000 --- a/src/client/Model/View/LoggedIn/Add.elm +++ /dev/null @@ -1,43 +0,0 @@ -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/Model/View/LoggedIn/Edition.elm b/src/client/Model/View/LoggedIn/Edition.elm deleted file mode 100644 index da6d7b0..0000000 --- a/src/client/Model/View/LoggedIn/Edition.elm +++ /dev/null @@ -1,7 +0,0 @@ -module Model.View.LoggedIn.Edition - ( Edition - ) where - -import Model.Payment exposing (PaymentId) - -type alias Edition = PaymentId diff --git a/src/client/Model/View/LoggedIn/Monthly.elm b/src/client/Model/View/LoggedIn/Monthly.elm deleted file mode 100644 index 3c6f66a..0000000 --- a/src/client/Model/View/LoggedIn/Monthly.elm +++ /dev/null @@ -1,17 +0,0 @@ -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/Model/View/LoggedInView.elm b/src/client/Model/View/LoggedInView.elm deleted file mode 100644 index 122c4be..0000000 --- a/src/client/Model/View/LoggedInView.elm +++ /dev/null @@ -1,35 +0,0 @@ -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/Model/View/SignInView.elm b/src/client/Model/View/SignInView.elm deleted file mode 100644 index 0fbce39..0000000 --- a/src/client/Model/View/SignInView.elm +++ /dev/null @@ -1,15 +0,0 @@ -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/Native/Reads.js b/src/client/Native/Reads.js deleted file mode 100644 index 5785aed..0000000 --- a/src/client/Native/Reads.js +++ /dev/null @@ -1,22 +0,0 @@ -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/Reads.elm b/src/client/Reads.elm deleted file mode 100644 index f855802..0000000 --- a/src/client/Reads.elm +++ /dev/null @@ -1,10 +0,0 @@ -module Reads - ( readInt - ) where - - -import Native.Reads -import Result exposing (Result) - -readInt : String -> Maybe Int -readInt = Native.Reads.readInt diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm deleted file mode 100644 index 55bf947..0000000 --- a/src/client/ServerCommunication.elm +++ /dev/null @@ -1,143 +0,0 @@ -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 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 - -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.RawError U.Action -sendRequest communication = - case getRequest communication of - Nothing -> - Task.succeed U.NoOp - Just request -> - Http.send Http.defaultSettings request - |> flip Task.andThen (serverResult communication) - -getRequest : Communication -> Maybe Http.Request -getRequest communication = - case communication of - NoCommunication -> Nothing - 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 payment _ -> Just (deletePaymentRequest payment.id) - DeleteMonthlyPayment paymentId -> Just (deletePaymentRequest paymentId) - UpdatePage page -> Just (updatePageRequest page) - SignOut -> Just (simple "post" "/signOut") - -addPaymentRequest : String -> Int -> Frequency -> Http.Request -addPaymentRequest name cost frequency = - simple "post" ("/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost) ++ "&frequency=" ++ (toString frequency)) - -deletePaymentRequest : PaymentId -> Http.Request -deletePaymentRequest id = - simple "post" ("payment/delete?id=" ++ (toString id)) - -updatePageRequest : Int -> Http.Request -updatePageRequest page = - simple "get" ("payments?page=" ++ toString page ++ "&perPage=" ++ toString perPage) - -simple : String -> String -> Http.Request -simple method url = - { verb = method - , headers = [] - , url = url - , body = Http.empty - } - -serverResult : Communication -> Http.Response -> Task Http.RawError U.Action -serverResult communication response = - case response.status of - 200 -> - case communication of - NoCommunication -> - Task.succeed U.NoOp - SignIn login -> - Task.succeed << U.UpdateSignIn <| ValidLogin login - AddPayment userId name cost -> - Http.send Http.defaultSettings (updatePageRequest 1) - |> flip Task.andThen (decodeOkResponse paymentsDecoder (\payments -> - Task.succeed <| U.UpdateLoggedIn (UL.AddPayment userId name cost payments) - )) - AddMonthlyPayment name cost -> - decodeResponse - ("id" := paymentIdDecoder) - (\id -> Task.succeed <| U.UpdateLoggedIn (UL.AddMonthlyPayment id name cost)) - response - 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 payment payments) - )) - DeleteMonthlyPayment id -> - Task.succeed <| U.UpdateLoggedIn (UL.UpdateMonthly (UM.DeletePayment id)) - UpdatePage page -> - decodeResponse - paymentsDecoder - (\payments -> Task.succeed <| U.UpdateLoggedIn (UL.UpdatePage page payments)) - response - SignOut -> - Task.succeed (U.GoSignInView) - errorStatus -> - case communication of - SignIn _ -> - decodeResponse - ("error" := string) - (\error -> - Task.succeed <| U.UpdateSignIn (ErrorLogin error) - ) - response - _ -> - Task.succeed <| U.NoOp - -decodeOkResponse : Decoder a -> (a -> Task b U.Action) -> Http.Response -> Task b U.Action -decodeOkResponse decoder responseToAction response = - if response.status == 200 - then decodeResponse decoder responseToAction response - else Task.succeed U.NoOp - -decodeResponse : Decoder a -> (a -> Task b U.Action) -> Http.Response -> Task b U.Action -decodeResponse decoder responseToAction response = - case response.value of - Http.Text text -> - case decodeString decoder text of - Ok x -> - responseToAction x - Err _ -> - Task.succeed U.NoOp - Http.Blob _ -> - Task.succeed U.NoOp diff --git a/src/client/Update.elm b/src/client/Update.elm deleted file mode 100644 index 3c4614a..0000000 --- a/src/client/Update.elm +++ /dev/null @@ -1,57 +0,0 @@ -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/Update/LoggedIn.elm b/src/client/Update/LoggedIn.elm deleted file mode 100644 index e477094..0000000 --- a/src/client/Update/LoggedIn.elm +++ /dev/null @@ -1,68 +0,0 @@ -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/Update/LoggedIn/Account.elm b/src/client/Update/LoggedIn/Account.elm deleted file mode 100644 index cf4c834..0000000 --- a/src/client/Update/LoggedIn/Account.elm +++ /dev/null @@ -1,64 +0,0 @@ -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/Update/LoggedIn/Add.elm b/src/client/Update/LoggedIn/Add.elm deleted file mode 100644 index 1f28997..0000000 --- a/src/client/Update/LoggedIn/Add.elm +++ /dev/null @@ -1,29 +0,0 @@ -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/Update/LoggedIn/Monthly.elm b/src/client/Update/LoggedIn/Monthly.elm deleted file mode 100644 index 1379323..0000000 --- a/src/client/Update/LoggedIn/Monthly.elm +++ /dev/null @@ -1,27 +0,0 @@ -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/Update/SignIn.elm b/src/client/Update/SignIn.elm deleted file mode 100644 index 0aa7c84..0000000 --- a/src/client/Update/SignIn.elm +++ /dev/null @@ -1,24 +0,0 @@ -module Update.SignIn - ( SignInAction(..) - , updateSignIn - ) where - -import Model.View.SignInView exposing (..) - -type SignInAction = - UpdateLogin String - | ValidLogin String - | ErrorLogin String - -updateSignIn : SignInAction -> SignInView -> SignInView -updateSignIn action signInView = - case action of - UpdateLogin login -> - { signInView | login <- login } - ValidLogin message -> - { signInView - | login <- "" - , result <- Just (Ok message) - } - ErrorLogin message -> - { signInView | result <- Just (Err message) } diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm deleted file mode 100644 index dc01b17..0000000 --- a/src/client/Utils/Dict.elm +++ /dev/null @@ -1,11 +0,0 @@ -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/Either.elm b/src/client/Utils/Either.elm deleted file mode 100644 index 10c40e3..0000000 --- a/src/client/Utils/Either.elm +++ /dev/null @@ -1,9 +0,0 @@ -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/Utils/Maybe.elm b/src/client/Utils/Maybe.elm deleted file mode 100644 index d954ae0..0000000 --- a/src/client/Utils/Maybe.elm +++ /dev/null @@ -1,27 +0,0 @@ -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/Utils/Validation.elm b/src/client/Utils/Validation.elm deleted file mode 100644 index b9bccb3..0000000 --- a/src/client/Utils/Validation.elm +++ /dev/null @@ -1,23 +0,0 @@ -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/View/Date.elm b/src/client/View/Date.elm deleted file mode 100644 index 81c5112..0000000 --- a/src/client/View/Date.elm +++ /dev/null @@ -1,59 +0,0 @@ -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/View/Events.elm b/src/client/View/Events.elm deleted file mode 100644 index 1eb9027..0000000 --- a/src/client/View/Events.elm +++ /dev/null @@ -1,19 +0,0 @@ -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/View/Expand.elm b/src/client/View/Expand.elm deleted file mode 100644 index 53b4fe5..0000000 --- a/src/client/View/Expand.elm +++ /dev/null @@ -1,25 +0,0 @@ -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/View/Header.elm b/src/client/View/Header.elm deleted file mode 100644 index 9d31183..0000000 --- a/src/client/View/Header.elm +++ /dev/null @@ -1,36 +0,0 @@ -module View.Header - ( renderHeader - ) where - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import ServerCommunication as SC -import ServerCommunication exposing (serverCommunications) - -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 _ -> - text "" - LoggedInView _ -> - button - [ class "signOut" - , onClick serverCommunications.address SC.SignOut - ] - [ renderIcon "power-off" ] - ] diff --git a/src/client/View/Icon.elm b/src/client/View/Icon.elm deleted file mode 100644 index f22c1a2..0000000 --- a/src/client/View/Icon.elm +++ /dev/null @@ -1,12 +0,0 @@ -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/View/Loading.elm b/src/client/View/Loading.elm deleted file mode 100644 index f8c6cd6..0000000 --- a/src/client/View/Loading.elm +++ /dev/null @@ -1,8 +0,0 @@ -module View.Loading - ( renderLoading - ) where - -import Html exposing (..) - -renderLoading : Html -renderLoading = text "" diff --git a/src/client/View/LoggedIn.elm b/src/client/View/LoggedIn.elm deleted file mode 100644 index 96916e0..0000000 --- a/src/client/View/LoggedIn.elm +++ /dev/null @@ -1,30 +0,0 @@ -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/View/LoggedIn/Account.elm b/src/client/View/LoggedIn/Account.elm deleted file mode 100644 index 706f7cc..0000000 --- a/src/client/View/LoggedIn/Account.elm +++ /dev/null @@ -1,130 +0,0 @@ -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/View/LoggedIn/Add.elm b/src/client/View/LoggedIn/Add.elm deleted file mode 100644 index 572bdf6..0000000 --- a/src/client/View/LoggedIn/Add.elm +++ /dev/null @@ -1,122 +0,0 @@ -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/View/LoggedIn/Monthly.elm b/src/client/View/LoggedIn/Monthly.elm deleted file mode 100644 index a274015..0000000 --- a/src/client/View/LoggedIn/Monthly.elm +++ /dev/null @@ -1,89 +0,0 @@ -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/View/LoggedIn/Paging.elm b/src/client/View/LoggedIn/Paging.elm deleted file mode 100644 index 93d7f1d..0000000 --- a/src/client/View/LoggedIn/Paging.elm +++ /dev/null @@ -1,100 +0,0 @@ -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/View/LoggedIn/Table.elm b/src/client/View/LoggedIn/Table.elm deleted file mode 100644 index f5a08b5..0000000 --- a/src/client/View/LoggedIn/Table.elm +++ /dev/null @@ -1,97 +0,0 @@ -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/View/Page.elm b/src/client/View/Page.elm deleted file mode 100644 index 763734d..0000000 --- a/src/client/View/Page.elm +++ /dev/null @@ -1,31 +0,0 @@ -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/View/Price.elm b/src/client/View/Price.elm deleted file mode 100644 index 286bcaa..0000000 --- a/src/client/View/Price.elm +++ /dev/null @@ -1,38 +0,0 @@ -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/View/SignIn.elm b/src/client/View/SignIn.elm deleted file mode 100644 index 2a6cbca..0000000 --- a/src/client/View/SignIn.elm +++ /dev/null @@ -1,57 +0,0 @@ -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" ] - [ H.form - [ onSubmitPrevDefault serverCommunications.address (SC.SignIn signInView.login) ] - [ input - [ value signInView.login - , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin) - ] - [] - , button - [] - [ text (getMessage "SignIn" model.translations)] - ] - , 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 "" 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 "" diff --git a/src/client/js/main.js b/src/client/js/main.js new file mode 100644 index 0000000..12593e6 --- /dev/null +++ b/src/client/js/main.js @@ -0,0 +1,28 @@ +var app = Elm.fullscreen(Elm.Main, { + initialTime: new Date().getTime(), + translations: document.getElementById('messages').innerHTML, + config: document.getElementById('config').innerHTML, + sign: null +}); + +navigator.id.watch({ + loggedInUser: null, + onlogin: function(assertion) { + app.ports.sign.send({ + operation: 'SignIn', + assertion: assertion + }); + }, + onlogout: function() {} +}); + +app.ports.persona.subscribe(function(communication) { + if(communication === 'SignIn') { + navigator.id.request(); + } else if(communication === 'SignOut') { + navigator.id.logout(); + app.ports.sign.send({ + operation: 'SignOut' + }); + } +}); diff --git a/src/server/Config.hs b/src/server/Config.hs index bd7f325..37f57ec 100644 --- a/src/server/Config.hs +++ b/src/server/Config.hs @@ -18,7 +18,6 @@ import Control.Arrow (left) data Config = Config { hostname :: Text , port :: Int - , signInExpirationMn :: Int , currency :: Text } deriving (Read, Eq, Show) @@ -29,6 +28,5 @@ getConfig filePath = Config <$> (T.pack <$> get cp "DEFAULT" "hostname") <*> (get cp "DEFAULT" "port") <*> - (get cp "DEFAULT" "sign-in-expiration-mn") <*> (T.pack <$> get cp "DEFAULT" "currency") ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 31cd510..8eceb56 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -2,32 +2,21 @@ module Controller.SignIn ( signIn - , validateSignIn ) where import Web.Scotty import Network.HTTP.Types.Status (ok200) -import Database.Persist - import Control.Monad.IO.Class (liftIO) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Encoding as TE -import Data.Time.Clock (getCurrentTime, diffUTCTime) import Data.Maybe (isJust) import qualified LoginSession import Config -import SendMail - -import Text.Email.Validate as Email - import Model.Database import Model.User import Model.SignIn @@ -36,65 +25,20 @@ import Model.Message (getMessage) import Json (jsonError) -import Secure (getUserFromToken) - -import qualified View.Mail.SignIn as SignIn +import Persona (verifyEmail) signIn :: Config -> Text -> ActionM () -signIn config login = - if Email.isValid (TE.encodeUtf8 login) - then do - maybeUser <- liftIO . runDb $ getUser login - case maybeUser of - Just user -> do - token <- liftIO . runDb $ createSignInToken login - let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token] - maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login] - case maybeSentMail of - Right _ -> - status ok200 - Left _ -> - jsonError (getMessage SendEmailFail) - Nothing -> - jsonError (getMessage Unauthorized) - else - jsonError (getMessage EnterValidEmail) - -validateSignIn :: Config -> Text -> ActionM () -validateSignIn config textToken = do - alreadySigned <- isAlreadySigned - if alreadySigned - then - redirect "/" - else do - mbSignIn <- liftIO . runDb $ getSignInToken textToken - now <- liftIO getCurrentTime - case mbSignIn of - Just signIn -> - if signInIsUsed . entityVal $ signIn - then - redirectError (getMessage SignInUsed) - else - let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn) - in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60) - then - redirectError (getMessage SignInExpired) - else do - LoginSession.put (signInToken . entityVal $ signIn) - liftIO . runDb . signInTokenToUsed . entityKey $ signIn - redirect "/" - Nothing -> - redirectError (getMessage SignInInvalid) - -isAlreadySigned :: ActionM Bool -isAlreadySigned = do - mbToken <- LoginSession.get - case mbToken of +signIn config assertion = do + mbEmail <- liftIO $ verifyEmail config assertion + case mbEmail of Nothing -> - return False - Just token -> do - liftIO . runDb . fmap isJust $ getUserFromToken token - -redirectError :: Text -> ActionM () -redirectError msg = - redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg] + jsonError (getMessage InvalidEmail) + Just email -> do + isAuthorized <- liftIO . fmap isJust . runDb $ getUser email + if isAuthorized + then do + token <- liftIO . runDb $ createSignInToken email + LoginSession.put token + status ok200 + else + jsonError (getMessage Unauthorized) diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs index 7b82577..9f83778 100644 --- a/src/server/Design/Header.hs +++ b/src/server/Design/Header.hs @@ -25,7 +25,7 @@ headerDesign = marginBottom blockMarginBottom paddingLeft sidePercent - button # ".signOut" ? do + button # ".icon" ? do let iconHeight = 50 let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) position absolute diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs index 6bacc3a..7aff720 100644 --- a/src/server/Design/SignIn.hs +++ b/src/server/Design/SignIn.hs @@ -15,26 +15,6 @@ signInDesign = ".signIn" ? do - opacityAnimation - - form ? do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - defaultInput inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - defaultButton C.red C.white (px inputHeight) - display block - width (pct 100) - ".result" ? do marginTop (px 40) textAlign (alignSide sideCenter) diff --git a/src/server/Main.hs b/src/server/Main.hs index 3d61481..3539120 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -8,7 +8,7 @@ import Control.Concurrent (forkIO) import MonthlyPaymentJob (monthlyPaymentJobListener) import Data.Text (Text) -import qualified Data.Text.IO as TIO +import qualified Data.Text.IO as T import Controller.Index import Controller.SignIn @@ -28,7 +28,7 @@ main = do eitherConfig <- Config.getConfig "config.txt" case eitherConfig of Left errorMessage -> - TIO.putStrLn errorMessage + T.putStrLn errorMessage Right config -> do scotty (Config.port config) $ do middleware $ @@ -40,12 +40,8 @@ main = do -- SignIn post "/signIn" $ do - login <- param "login" :: ActionM Text - signIn config login - - get "/validateSignIn" $ do - token <- param "token" :: ActionM Text - validateSignIn config token + assertion <- param "assertion" :: ActionM Text + signIn config assertion -- Users diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 8d1da25..67cc8b3 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -44,7 +44,6 @@ SignIn token Text creation UTCTime email Text - isUsed Bool UniqSignInToken token deriving Show Job diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index e9f8ef6..7f49ae7 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -12,12 +12,8 @@ data Key = | SharedCost | SignIn - | SendEmailFail + | InvalidEmail | Unauthorized - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid | SignInMailTitle | SignInMail | SignInEmailSent diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index a2e9a30..29b21ea 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -34,36 +34,16 @@ m l SignIn = English -> "Sign in" French -> "Connexion" -m l SendEmailFail = +m l InvalidEmail = case l of - English -> "Sorry, we failed to send you the sign up email." - French -> "Désolé, nous n'avons pas pu t'envoyer le courriel de connexion." + English -> "Your email is not valid." + French -> "Votre courriel n'est pas valide." m l Unauthorized = case l of English -> "You are not authorized to sign in." French -> "Tu n'es pas autorisé à te connecter." -m l EnterValidEmail = - case l of - English -> "Please enter a valid email address." - French -> "Ton courriel n'est pas valide." - -m l SignInUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignInExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignInInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - m l SignInMailTitle = case l of English -> T.concat ["Sign in to ", m l SharedCost] diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs index 117b8b5..b475fdb 100644 --- a/src/server/Model/SignIn.hs +++ b/src/server/Model/SignIn.hs @@ -1,8 +1,6 @@ module Model.SignIn ( createSignInToken , getSignInToken - , signInTokenToUsed - , isLastValidToken ) where import Data.Text (Text) @@ -19,22 +17,9 @@ createSignInToken :: Text -> Persist Text createSignInToken email = do now <- liftIO getCurrentTime token <- liftIO generateUUID - _ <- insert $ SignIn token now email False + _ <- insert $ SignIn token now email return token getSignInToken :: Text -> Persist (Maybe (Entity SignIn)) getSignInToken token = selectFirst [SignInToken ==. token] [] - -signInTokenToUsed :: SignInId -> Persist () -signInTokenToUsed tokenId = - update tokenId [SignInIsUsed =. True] - -isLastValidToken :: SignIn -> Persist Bool -isLastValidToken signIn = do - maybe False ((== (signInToken signIn)) . signInToken . entityVal) <$> - selectFirst - [ SignInEmail ==. (signInEmail signIn) - , SignInIsUsed ==. True - ] - [ Desc SignInCreation ] diff --git a/src/server/Persona.hs b/src/server/Persona.hs new file mode 100644 index 0000000..8055e8b --- /dev/null +++ b/src/server/Persona.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Persona + ( verifyEmail + ) where + +import Control.Monad (guard) + +import Network.HTTP.Conduit + +import Data.Text (Text) +import qualified Data.Text as T +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Aeson +import Data.Aeson.Types (parseMaybe) + +import Config + +verifyEmail :: Config -> Text -> IO (Maybe Text) +verifyEmail config assertion = do + + initReq <- parseUrl "https://verifier.login.persona.org/verify" + + let request = + (flip urlEncodedBody) initReq $ + [ ("assertion", encodeUtf8 $ assertion) + , ("audience", encodeUtf8 $ hostname config) + ] + + manager <- newManager tlsManagerSettings + response <- httpLbs request manager + + return . parseEmail . decodeUtf8 . toStrict . responseBody $ response + +parseEmail :: Text -> Maybe Text +parseEmail payload = do + result <- decode . fromStrict . encodeUtf8 $ payload + flip parseMaybe result $ \obj -> do + status <- T.pack <$> obj .: "status" + guard (status == "okay") + obj .: "email" diff --git a/src/server/Secure.hs b/src/server/Secure.hs index 192fa10..7b6e6de 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -12,7 +12,7 @@ import Network.HTTP.Types.Status (forbidden403) import Database.Persist (Entity, entityVal) import Model.User (getUser) -import Model.SignIn (getSignInToken, isLastValidToken) +import Model.SignIn (getSignInToken) import Model.Database import Control.Monad.IO.Class (liftIO) @@ -44,9 +44,6 @@ getUserFromToken token = do mbSignIn <- fmap entityVal <$> getSignInToken token case mbSignIn of Just signIn -> do - isValid <- isLastValidToken signIn - if isValid - then getUser (signInEmail signIn) - else return Nothing + getUser (signInEmail signIn) Nothing -> return Nothing diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 2865337..7310fbb 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -26,7 +26,9 @@ page config = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" + meta ! httpEquiv "X-UA-Compatible" ! content "IE=Edge" -- IE8+ only is valid to use with persona H.title (toHtml $ getMessage SharedCost) + script ! src "https://login.persona.org/include.js" $ "" script ! src "javascripts/client.js" $ "" script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations script ! A.id "config" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ config @@ -35,4 +37,4 @@ page config = link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign body $ do - script ! src "javascripts/elmLauncher.js" $ "" + script ! src "javascripts/main.js" $ "" -- cgit v1.2.3