From a48e79e2f7c1ab1ffb52b86ef9e900c75c5d023b Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Sep 2015 23:57:16 +0200 Subject: Adding UI income read-only --- src/client/Main.elm | 6 +- src/client/Model/View/LoggedIn/Account.elm | 19 ++++++ src/client/Model/View/LoggedInView.elm | 9 +-- src/client/Update.elm | 6 +- src/client/Update/LoggedIn.elm | 9 ++- src/client/Update/LoggedIn/Account.elm | 20 ++++++ src/client/View/Expand.elm | 25 ++++++++ src/client/View/LoggedIn.elm | 4 +- src/client/View/LoggedIn/Account.elm | 74 ++++++++++++++++++++++ src/client/View/LoggedIn/Add.elm | 24 +++++-- src/client/View/LoggedIn/ExceedingPayer.elm | 35 ----------- src/client/View/LoggedIn/Monthly.elm | 54 +++++++++------- src/client/View/LoggedIn/Paging.elm | 5 +- src/client/View/LoggedIn/Table.elm | 14 ++++- src/client/View/Price.elm | 38 +++++++++++ src/server/Controller/Index.hs | 12 ++-- src/server/Controller/Payment.hs | 55 ++++++++-------- src/server/Controller/SignIn.hs | 12 ++-- src/server/Controller/User.hs | 31 ++++++--- src/server/Design/Global.hs | 97 +++++++++++++++++------------ src/server/Main.hs | 39 ++++++------ src/server/Model/Mail.hs | 1 - src/server/Model/Message/Key.hs | 9 ++- src/server/Model/Message/Translations.hs | 72 ++++++++++++++------- src/server/SendMail.hs | 8 +-- src/server/View/Mail/SignIn.hs | 24 +------ 26 files changed, 458 insertions(+), 244 deletions(-) create mode 100644 src/client/Model/View/LoggedIn/Account.elm create mode 100644 src/client/Update/LoggedIn/Account.elm create mode 100644 src/client/View/Expand.elm create mode 100644 src/client/View/LoggedIn/Account.elm delete mode 100644 src/client/View/LoggedIn/ExceedingPayer.elm create mode 100644 src/client/View/Price.elm diff --git a/src/client/Main.elm b/src/client/Main.elm index 0b579d7..621fb97 100644 --- a/src/client/Main.elm +++ b/src/client/Main.elm @@ -66,7 +66,8 @@ goLoggedInView = Task.andThen getPayments <| \payments -> Task.andThen getPaymentsCount <| \paymentsCount -> Task.andThen getPayers <| \payers -> - Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers) + Task.andThen getIncome <| \income -> + Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers income) getUsers : Task Http.Error Users getUsers = Http.get usersDecoder "/users" @@ -86,6 +87,9 @@ getPaymentsCount = Http.get ("number" := Json.int) "/payments/count" getPayers : Task Http.Error Payers getPayers = Http.get payersDecoder "/payments/total" +getIncome : Task Http.Error (Maybe Int) +getIncome = Http.get (Json.maybe ("income" := Json.int)) "/income" + --------------------------------------- port serverCommunicationsPort : Signal (Task Http.RawError ()) diff --git a/src/client/Model/View/LoggedIn/Account.elm b/src/client/Model/View/LoggedIn/Account.elm new file mode 100644 index 0000000..410345c --- /dev/null +++ b/src/client/Model/View/LoggedIn/Account.elm @@ -0,0 +1,19 @@ +module Model.View.LoggedIn.Account + ( Account + , initAccount + ) where + +import Model.Payers exposing (..) + +type alias Account = + { payers : Payers + , income : Maybe Int + , visibleDetail : Bool + } + +initAccount : Payers -> Maybe Int -> Account +initAccount payers income = + { payers = payers + , income = income + , visibleDetail = False + } diff --git a/src/client/Model/View/LoggedInView.elm b/src/client/Model/View/LoggedInView.elm index cf7f552..12a7294 100644 --- a/src/client/Model/View/LoggedInView.elm +++ b/src/client/Model/View/LoggedInView.elm @@ -9,28 +9,29 @@ import Model.Payers 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 , me : UserId , add : AddPayment , monthly : Monthly + , account : Account , payments : Payments , paymentsCount : Int - , payers : Payers , paymentEdition : Maybe Edition , currentPage : Int } -initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> LoggedInView -initLoggedInView users me monthlyPayments payments paymentsCount payers = +initLoggedInView : Users -> UserId -> Payments -> Payments -> Int -> Payers -> Maybe Int -> LoggedInView +initLoggedInView users me monthlyPayments payments paymentsCount payers income = { users = users , me = me , add = initAddPayment Punctual , monthly = initMonthly monthlyPayments + , account = initAccount payers income , payments = payments , paymentsCount = paymentsCount - , payers = payers , paymentEdition = Nothing , currentPage = 1 } diff --git a/src/client/Update.elm b/src/client/Update.elm index 23e5c84..4389140 100644 --- a/src/client/Update.elm +++ b/src/client/Update.elm @@ -23,7 +23,7 @@ type Action = | GoSignInView | SignInError String | UpdateSignIn SignInAction - | GoLoggedInView Users UserId Payments Payments Int Payers + | GoLoggedInView Users UserId Payments Payments Int Payers (Maybe Int) | UpdateLoggedIn LoggedAction actions : Signal.Mailbox Action @@ -38,8 +38,8 @@ updateModel action model = { model | currentTime <- time } GoSignInView -> { model | view <- V.SignInView initSignInView } - GoLoggedInView users me monthlyPayments payments paymentsCount payers -> - { model | view <- V.LoggedInView (initLoggedInView users me monthlyPayments payments paymentsCount payers) } + GoLoggedInView users me monthlyPayments payments paymentsCount payers mbIncome -> + { model | view <- V.LoggedInView (initLoggedInView users me monthlyPayments payments paymentsCount payers mbIncome) } SignInError msg -> let signInView = { initSignInView | result <- Just (Err msg) } in { model | view <- V.SignInView signInView } diff --git a/src/client/Update/LoggedIn.elm b/src/client/Update/LoggedIn.elm index 03eb137..07f3426 100644 --- a/src/client/Update/LoggedIn.elm +++ b/src/client/Update/LoggedIn.elm @@ -9,12 +9,12 @@ import Dict import Model exposing (Model) import Model.User exposing (UserId) import Model.Payment exposing (..) -import Model.Payers 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 @@ -25,6 +25,7 @@ type LoggedAction = | DeletePayment UserId Int Payments | UpdatePage Int Payments | UpdateMonthly UM.MonthlyAction + | UpdateAccount UA.AccountAction updateLoggedIn : Model -> LoggedAction -> LoggedInView -> LoggedInView updateLoggedIn model action loggedInView = @@ -38,7 +39,7 @@ updateLoggedIn model action loggedInView = | payments <- payments , currentPage <- 1 , add <- initAddPayment Punctual - , payers <- updatePayers loggedInView.payers userId cost + , account <- UA.updateAccount (UA.UpdatePayer userId cost) loggedInView.account , paymentsCount <- loggedInView.paymentsCount + 1 } AddMonthlyPayment id name cost -> @@ -53,7 +54,7 @@ updateLoggedIn model action loggedInView = DeletePayment userId cost payments -> { loggedInView | payments <- payments - , payers <- updatePayers loggedInView.payers userId -cost + , account <- UA.updateAccount (UA.UpdatePayer userId -cost) loggedInView.account , paymentsCount <- loggedInView.paymentsCount - 1 } UpdatePage page payments -> @@ -63,3 +64,5 @@ updateLoggedIn model action loggedInView = } 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 new file mode 100644 index 0000000..ab07c2e --- /dev/null +++ b/src/client/Update/LoggedIn/Account.elm @@ -0,0 +1,20 @@ +module Update.LoggedIn.Account + ( AccountAction(..) + , updateAccount + ) where + +import Model.User exposing (UserId) +import Model.Payers exposing (..) +import Model.View.LoggedIn.Account exposing (..) + +type AccountAction = + ToggleDetail + | UpdatePayer UserId Int + +updateAccount : AccountAction -> Account -> Account +updateAccount action account = + case action of + ToggleDetail -> + { account | visibleDetail <- not account.visibleDetail } + UpdatePayer userId cost -> + { account | payers <- updatePayers account.payers userId cost } diff --git a/src/client/View/Expand.elm b/src/client/View/Expand.elm new file mode 100644 index 0000000..53b4fe5 --- /dev/null +++ b/src/client/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/View/LoggedIn.elm b/src/client/View/LoggedIn.elm index e4577a2..20c99d3 100644 --- a/src/client/View/LoggedIn.elm +++ b/src/client/View/LoggedIn.elm @@ -9,9 +9,9 @@ import Model exposing (Model) import Model.Payment exposing (Payments) import Model.View.LoggedInView exposing (LoggedInView) -import View.LoggedIn.ExceedingPayer exposing (exceedingPayers) 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) @@ -23,7 +23,7 @@ renderLoggedIn model loggedInView = , div [ class "expandables" ] [ monthlyPayments model loggedInView - , exceedingPayers model loggedInView + , account model loggedInView ] , paymentsTable model loggedInView , paymentsPaging loggedInView diff --git a/src/client/View/LoggedIn/Account.elm b/src/client/View/LoggedIn/Account.elm new file mode 100644 index 0000000..e2b8e7e --- /dev/null +++ b/src/client/View/LoggedIn/Account.elm @@ -0,0 +1,74 @@ +module View.LoggedIn.Account + ( account + ) where + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import List + +import Update exposing (..) +import Update.LoggedIn exposing (..) +import Update.LoggedIn.Account exposing (..) + +import Model exposing (Model) +import Model.User exposing (getUserName) +import Model.Payers exposing (..) +import Model.View.LoggedInView exposing (LoggedInView) +import Model.Translations exposing (getParamMessage, getMessage) +import Model.View.LoggedIn.Account exposing (Account) + +import View.Expand exposing (..) +import View.Price exposing (price) + +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 "exceedingPayers" + , onClick actions.address (UpdateLoggedIn << UpdateAccount <| ToggleDetail) + ] + ( (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers 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 = + div + [ class "income" ] + ( case account.income of + Nothing -> + [ text (getMessage "NoIncome" model.translations) ] + Just income -> + [ text (getParamMessage [price model income] "Income" model.translations) ] + ) diff --git a/src/client/View/LoggedIn/Add.elm b/src/client/View/LoggedIn/Add.elm index acdda2d..bae3853 100644 --- a/src/client/View/LoggedIn/Add.elm +++ b/src/client/View/LoggedIn/Add.elm @@ -50,7 +50,11 @@ addPayment model loggedInView = addPaymentName : AddPayment -> Html addPaymentName addPayment = div - [ class ("name " ++ (if isJust addPayment.nameError then "error" else "")) ] + [ classList + [ ("name", True) + , ("error", isJust addPayment.nameError) + ] + ] [ input [ id "nameInput" , value addPayment.name @@ -71,7 +75,11 @@ addPaymentName addPayment = addPaymentCost : Model -> AddPayment -> Html addPaymentCost model addPayment = div - [ class ("cost " ++ (if isJust addPayment.costError then "error" else "")) ] + [ classList + [ ("cost", True) + , ("error", isJust addPayment.costError) + ] + ] [ input [ id "costInput" , value addPayment.cost @@ -97,9 +105,17 @@ paymentFrequency model addPayment = , onClick actions.address (UpdateLoggedIn << UpdateAdd <| ToggleFrequency) ] [ div - [ class ("punctual" ++ if addPayment.frequency == Punctual then " selected" else "") ] + [ classList + [ ("punctual", True) + , ("selected", addPayment.frequency == Punctual) + ] + ] [ text (getMessage "Punctual" model.translations) ] , div - [ class ("monthly" ++ if addPayment.frequency == Monthly then " selected" else "") ] + [ classList + [ ("monthly", True) + , ("selected", addPayment.frequency == Monthly) + ] + ] [ text (getMessage "Monthly" model.translations) ] ] diff --git a/src/client/View/LoggedIn/ExceedingPayer.elm b/src/client/View/LoggedIn/ExceedingPayer.elm deleted file mode 100644 index ea848b6..0000000 --- a/src/client/View/LoggedIn/ExceedingPayer.elm +++ /dev/null @@ -1,35 +0,0 @@ -module View.LoggedIn.ExceedingPayer - ( exceedingPayers - ) where - -import Html exposing (..) -import Html.Attributes exposing (..) -import List - -import Model exposing (Model) -import Model.User exposing (getUserName) -import Model.Payers exposing (..) -import Model.View.LoggedInView exposing (LoggedInView) -import Model.Translations exposing (getMessage) - -exceedingPayers : Model -> LoggedInView -> Html -exceedingPayers model loggedInView = - div - [ class "exceedingPayers" ] - (List.map (exceedingPayer model loggedInView) (getOrderedExceedingPayers loggedInView.payers)) - -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 ("+ " ++ (toString payer.amount) ++ " " ++ (getMessage "MoneySymbol" model.translations)) ] - ] diff --git a/src/client/View/LoggedIn/Monthly.elm b/src/client/View/LoggedIn/Monthly.elm index 17c354a..518724b 100644 --- a/src/client/View/LoggedIn/Monthly.elm +++ b/src/client/View/LoggedIn/Monthly.elm @@ -21,37 +21,40 @@ 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.isEmpty monthly.payments - then - text "" - else - div - [ class ("monthlyPayments" ++ if monthly.visibleDetail then " detail" else "") ] - [ monthlyCount model monthly - , if monthly.visibleDetail then paymentsTable model loggedInView monthly else text "" + in 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 "count" - , onClick actions.address (UpdateLoggedIn << UpdateMonthly <| ToggleDetail) - ] - [ text (getParamMessage [toString count, toString total] key model.translations) - , div - [ class "expand" ] - [ if monthly.visibleDetail - then renderIcon "chevron-up" - else renderIcon "chevron-down" + in if count == 0 + then + div + [ class "count" ] + [ text (getMessage "NoMonthlyPayment" model.translations) ] + else + button + [ class "count" + , 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 = @@ -65,13 +68,20 @@ paymentsTable model loggedInView monthly = paymentLine : Model -> LoggedInView -> Payment -> Html paymentLine model loggedInView payment = a - [ class ("row" ++ (if loggedInView.paymentEdition == Just payment.id then " edition" else "")) + [ classList + [ ("row", True) + , ("edition", loggedInView.paymentEdition == Just payment.id) + ] , onClick actions.address (UpdateLoggedIn (ToggleEdit payment.id)) ] [ div [ class "cell category" ] [ text (payment.name) ] , div - [ class ("cell cost" ++ if payment.cost < 0 then " refund" else "") ] - [ text (toString payment.cost ++ " " ++ getMessage "MoneySymbol" model.translations) ] + [ classList + [ ("cell cost", True) + , ("refund", payment.cost < 0) + ] + ] + [ text (price model payment.cost) ] , div [ class "cell delete" , onClick serverCommunications.address (SC.DeleteMonthlyPayment payment.id) diff --git a/src/client/View/LoggedIn/Paging.elm b/src/client/View/LoggedIn/Paging.elm index 5d5f2db..93d7f1d 100644 --- a/src/client/View/LoggedIn/Paging.elm +++ b/src/client/View/LoggedIn/Paging.elm @@ -90,7 +90,10 @@ paymentsPage : LoggedInView -> Int -> Html paymentsPage loggedInView page = let onCurrentPage = page == loggedInView.currentPage in button - [ class ("page" ++ (if onCurrentPage then " current" else "")) + [ classList + [ ("page", True) + , ("current", onCurrentPage) + ] , onClick serverCommunications.address <| if onCurrentPage then SC.NoCommunication else SC.UpdatePage page ] diff --git a/src/client/View/LoggedIn/Table.elm b/src/client/View/LoggedIn/Table.elm index 0c65e50..d98cee6 100644 --- a/src/client/View/LoggedIn/Table.elm +++ b/src/client/View/LoggedIn/Table.elm @@ -25,6 +25,7 @@ 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 = @@ -53,13 +54,20 @@ paymentLines model loggedInView = paymentLine : Model -> LoggedInView -> Payment -> Html paymentLine model loggedInView payment = a - [ class ("row" ++ (if loggedInView.paymentEdition == Just payment.id then " edition" else "")) + [ classList + [ ("row", True) + , ("edition", loggedInView.paymentEdition == Just payment.id) + ] , onClick actions.address (UpdateLoggedIn (ToggleEdit payment.id)) ] [ div [ class "cell category" ] [ text payment.name ] , div - [ class ("cell cost" ++ if payment.cost < 0 then " refund" else "") ] - [ text ((toString payment.cost) ++ " " ++ (getMessage "MoneySymbol" model.translations)) ] + [ classList + [ ("cell cost", True) + , ("refund", payment.cost < 0) + ] + ] + [ text (price model payment.cost) ] , div [ class "cell user" ] [ payment.userId diff --git a/src/client/View/Price.elm b/src/client/View/Price.elm new file mode 100644 index 0000000..cb8abd2 --- /dev/null +++ b/src/client/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 + ++ " " + ++ getMessage "MoneySymbol" model.translations + ) + +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/server/Controller/Index.hs b/src/server/Controller/Index.hs index 17f5ae9..da67051 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -1,6 +1,6 @@ module Controller.Index - ( getIndexAction - , signOutAction + ( getIndex + , signOut ) where import Web.Scotty @@ -11,10 +11,10 @@ import qualified LoginSession import View.Page (page) -getIndexAction :: ActionM () -getIndexAction = html page +getIndex :: ActionM () +getIndex = html page -signOutAction :: ActionM () -signOutAction = do +signOut :: ActionM () +signOut = do LoginSession.delete status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index 85e2a87..02c8a8e 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Controller.Payment - ( getPaymentsAction - , getMonthlyPaymentsAction - , createPaymentAction - , deletePaymentAction - , getTotalPaymentsAction - , getPaymentsCountAction + ( getPayments + , getMonthlyPayments + , createPayment + , deletePayment + , getTotalPayments + , getPaymentsCount ) where import Web.Scotty @@ -22,40 +22,39 @@ import qualified Data.Aeson.Types as Json import qualified Secure +import Json (jsonObject) + import Model.Database -import Model.Payment +import qualified Model.Payment as P import Model.Frequency import Model.Json.Number import qualified Model.Json.PaymentId as JP import Model.Message import Model.Message.Key (Key(PaymentNotDeleted)) - -import Json (jsonObject) - -getPaymentsAction :: Int -> Int -> ActionM () -getPaymentsAction page perPage = +getPayments :: Int -> Int -> ActionM () +getPayments page perPage = Secure.loggedAction (\_ -> do - (liftIO $ runDb (getPunctualPayments page perPage)) >>= json + (liftIO $ runDb (P.getPunctualPayments page perPage)) >>= json ) -getMonthlyPaymentsAction :: ActionM () -getMonthlyPaymentsAction = +getMonthlyPayments :: ActionM () +getMonthlyPayments = Secure.loggedAction (\user -> do - (liftIO $ runDb (getUserMonthlyPayments (entityKey user))) >>= json + (liftIO $ runDb (P.getUserMonthlyPayments (entityKey user))) >>= json ) -createPaymentAction :: Text -> Int -> Frequency -> ActionM () -createPaymentAction name cost frequency = +createPayment :: Text -> Int -> Frequency -> ActionM () +createPayment name cost frequency = Secure.loggedAction (\user -> do - paymentId <- liftIO . runDb $ createPayment (entityKey user) name cost frequency + paymentId <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency json (JP.PaymentId paymentId) ) -deletePaymentAction :: Text -> ActionM () -deletePaymentAction paymentId = +deletePayment :: Text -> ActionM () +deletePayment paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . runDb $ deleteOwnPayment user (textToKey paymentId) + deleted <- liftIO . runDb $ P.deleteOwnPayment user (textToKey paymentId) if deleted then status ok200 @@ -64,14 +63,14 @@ deletePaymentAction paymentId = jsonObject [("error", Json.String $ getMessage PaymentNotDeleted)] ) -getTotalPaymentsAction :: ActionM () -getTotalPaymentsAction = +getTotalPayments :: ActionM () +getTotalPayments = Secure.loggedAction (\_ -> do - (liftIO . runDb $ getTotalPayments) >>= json + (liftIO . runDb $ P.getTotalPayments) >>= json ) -getPaymentsCountAction :: ActionM () -getPaymentsCountAction = +getPaymentsCount :: ActionM () +getPaymentsCount = Secure.loggedAction (\_ -> do - Number <$> (liftIO . runDb $ getPaymentsCount) >>= json + Number <$> (liftIO . runDb $ P.getPaymentsCount) >>= json ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 4f41c6e..955ad35 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Controller.SignIn - ( signInAction - , validateSignInAction + ( signIn + , validateSignIn ) where import Web.Scotty @@ -38,8 +38,8 @@ import Json (jsonObject) import qualified View.Mail.SignIn as SignIn -signInAction :: Config -> Text -> ActionM () -signInAction config login = +signIn :: Config -> Text -> ActionM () +signIn config login = if isValid (TE.encodeUtf8 login) then do maybeUser <- liftIO . runDb $ getUser login @@ -63,8 +63,8 @@ errorResponse msg = do status badRequest400 jsonObject [("error", Json.String msg)] -validateSignInAction :: Config -> Text -> ActionM () -validateSignInAction config token = do +validateSignIn :: Config -> Text -> ActionM () +validateSignIn config token = do maybeSignIn <- liftIO . runDb $ getSignInToken token now <- liftIO getCurrentTime case maybeSignIn of diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs index 95e5fa8..bc99ea5 100644 --- a/src/server/Controller/User.hs +++ b/src/server/Controller/User.hs @@ -1,25 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + module Controller.User - ( getUsersAction - , whoAmIAction + ( getUsers + , whoAmI + , getIncome ) where import Web.Scotty import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson.Types as Json + import qualified Secure +import Json (jsonObject) + import Model.Database -import Model.User +import qualified Model.User as U -getUsersAction :: ActionM () -getUsersAction = +getUsers :: ActionM () +getUsers = Secure.loggedAction (\_ -> do - (liftIO $ map getJsonUser <$> runDb getUsers) >>= json + (liftIO $ map U.getJsonUser <$> runDb U.getUsers) >>= json ) -whoAmIAction :: ActionM () -whoAmIAction = +whoAmI :: ActionM () +whoAmI = Secure.loggedAction (\user -> do - json (getJsonUser user) + json (U.getJsonUser user) + ) + +getIncome :: ActionM () +getIncome = + Secure.loggedAction (\_ -> do + jsonObject [] ) diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index 7d2b7b6..10e997d 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -26,9 +26,15 @@ radius = px 3 blockPadding :: Size Abs blockPadding = px 15 +blockPercentWidth :: Double +blockPercentWidth = 90 + blockMarginBottom :: Size Abs blockMarginBottom = px 50 +rowHeight :: Size Abs +rowHeight = px 60 + global :: Css global = do @@ -38,24 +44,27 @@ global = do fontFamily ["Cantarell"] [sansSerif] header ? do - let headerHeight = 150 + let headerHeight = 80 + let sidePercent = (pct ((100 - blockPercentWidth) / 2)) h1 ? do fontSize (px 45) - textAlign (alignSide sideCenter) - color C.red + textAlign (alignSide sideLeft) + backgroundColor C.red + color C.white lineHeight (px headerHeight) - + marginBottom blockMarginBottom + paddingLeft sidePercent button # ".signOut" ? do let iconHeight = 50 - let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) + 5 + let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) position absolute top (px sideMargin) - right (pct 2) + right sidePercent height (px iconHeight) lineHeight (px iconHeight) - backgroundColor C.white - color C.red + backgroundColor C.red + color C.white fontSize iconFontSize hover & transform (scale 1.2 1.2) @@ -137,6 +146,11 @@ global = do centeredWithMargin clearFix + ".expand" ? do + position absolute + right blockPadding + bottom (px 2) + ".monthlyPayments" ? do marginBottom blockMarginBottom @@ -144,40 +158,35 @@ global = do float floatLeft width (pct 55) - button # ".count" ? do - width (pct 100) - fontSize (px 18) + ".count" ? do defaultButton C.blue C.white inputHeight - borderRadius radius radius radius radius - textAlign (alignSide sideLeft) - position relative - paddingLeft blockPadding - paddingRight blockPadding - - ".expand" ? do - float floatRight - marginTop (px (-2)) - - ".detail" & - button # ".count" ? - borderRadius radius radius 0 0 - - ".exceedingPayers" ? do - backgroundColor C.green - color C.white - fontSize (px 18) - borderRadius radius radius radius radius + buttonBlock + cursor cursorText + + button # ".count" ? cursor pointer + + ".account" ? do marginBottom blockMarginBottom - paddingLeft blockPadding - paddingRight blockPadding largeScreen $ do float floatRight width (pct 40) - ".exceedingPayer" ? do - lineHeight (px inputHeight) - ".userName" ? marginRight (px 10) + ".exceedingPayers" ? do + defaultButton C.green C.white inputHeight + buttonBlock + + ".exceedingPayer" ? do + lineHeight (px inputHeight) + ".userName" ? marginRight (px 10) + + ".income" ? do + backgroundColor C.lightGrey + lineHeight rowHeight + padding (px 0) (px 20) (px 0) (px 20) + + ".detail" |> (".count" <> ".exceedingPayers") ? + borderRadius radius radius 0 0 ".table" ? do display D.table @@ -187,11 +196,10 @@ global = do ".header" <> ".row" ? display tableRow let headerHeight = (px 70) - let rowHeight = (px 60) ".header" ? do fontWeight bold - backgroundColor C.red + backgroundColor C.blue color C.white fontSize iconFontSize lineHeight headerHeight @@ -261,7 +269,7 @@ global = do form ? do let inputHeight = 50 width (px 500) - marginTop (px 50) + marginTop (px 100) marginLeft auto marginRight auto @@ -296,7 +304,6 @@ defaultButton backgroundCol textCol pxHeight = do borderRadius radius radius radius radius verticalAlign middle cursor pointer - height (px pxHeight) lineHeight (px pxHeight) textAlign (alignSide sideCenter) @@ -311,6 +318,16 @@ defaultInput inputHeight = do centeredWithMargin :: Css centeredWithMargin = do - width (pct 90) + width (pct blockPercentWidth) marginLeft auto marginRight auto + +buttonBlock :: Css +buttonBlock = do + width (pct 100) + fontSize (px 18) + borderRadius radius radius radius radius + textAlign (alignSide sideLeft) + position relative + paddingLeft blockPadding + paddingRight blockPadding diff --git a/src/server/Main.hs b/src/server/Main.hs index 1a151fc..8956fa4 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -33,46 +33,43 @@ main = do middleware $ staticPolicy (noDots >-> addBase "public") - get "/" $ - getIndexAction + get "/" getIndex + post "/signOut" signOut + + -- SignIn post "/signIn" $ do login <- param "login" :: ActionM Text - signInAction config login + signIn config login get "/validateSignIn" $ do token <- param "token" :: ActionM Text - validateSignInAction config token + validateSignIn config token - post "/signOut" $ - signOutAction + -- Users - get "/whoAmI" $ - whoAmIAction + get "/users" getUsers + get "/whoAmI" whoAmI + get "/income" getIncome - get "/users" $ do - getUsersAction + -- Payments get "/payments" $ do - page <- param "page" :: ActionM Int + page <- param "page" :: ActionM Int perPage <- param "perPage" :: ActionM Int - getPaymentsAction page perPage + getPayments page perPage - get "/monthlyPayments" $ do - getMonthlyPaymentsAction + get "/monthlyPayments" getMonthlyPayments post "/payment/add" $ do name <- param "name" :: ActionM Text cost <- param "cost" :: ActionM Int frequency <- param "frequency" :: ActionM Frequency - createPaymentAction name cost frequency + createPayment name cost frequency post "/payment/delete" $ do paymentId <- param "id" :: ActionM Text - deletePaymentAction paymentId - - get "/payments/total" $ do - getTotalPaymentsAction + deletePayment paymentId - get "/payments/count" $ do - getPaymentsCountAction + get "/payments/total" getTotalPayments + get "/payments/count" getPaymentsCount diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs index 20addee..7c1a6ed 100644 --- a/src/server/Model/Mail.hs +++ b/src/server/Model/Mail.hs @@ -10,5 +10,4 @@ data Mail = Mail , to :: [Text] , subject :: Text , plainBody :: LT.Text - , htmlBody :: LT.Text } deriving (Eq, Show) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index 3d915b9..4076768 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -19,8 +19,7 @@ data Key = | SignInExpired | SignInInvalid | SignInMailTitle - | HiMail - | SignInLinkMail + | SignInMail | SignInEmailSent -- Dates @@ -54,7 +53,13 @@ data Key = | MoneySymbol | Punctual | Monthly + | NoMonthlyPayment | SingularMonthlyCount | PluralMonthlyCount + -- Income + + | Income + | NoIncome + deriving (Enum, Bounded, Show) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index 79d177f..fce979a 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -69,25 +69,35 @@ m l SignInMailTitle = English -> T.concat ["Sign in to ", m l SharedCost] French -> T.concat ["Connexion à ", m l SharedCost] -m l HiMail = - case l of - English -> "Hi {1}," - French -> "Salut {1}," - -m l SignInLinkMail = - case l of - English -> - T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l SharedCost - , ":" - ] - French -> - T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l SharedCost - , ":" - ] +m l SignInMail = + T.intercalate + "\n" + ( case l of + English -> + [ "Hi {1}," + , "" + , T.concat + [ "Click to the following link in order to sign in to Shared Cost:" + , m l SharedCost + , ":" + ] + , "{2}" + , "" + , "See you soon!" + ] + French -> + [ "Salut {1}," + , "" + , T.concat + [ "Clique sur le lien suivant pour te connecter à " + , m l SharedCost + , ":" + ] + , "{2}" + , "" + , "À très vite !" + ] + ) m l SignInEmailSent = case l of @@ -210,20 +220,34 @@ m l Monthly = English -> "Monthly" French -> "Mensuel" +m l NoMonthlyPayment = + case l of + English -> "No monthly payment" + French -> "Aucun paiement mensuel" + m l SingularMonthlyCount = T.concat [ case l of English -> "{1} monthly payment of {2} " French -> "{1} paiement mensuel de {2} " , m l MoneySymbol - , "." ] m l PluralMonthlyCount = T.concat [ case l of - English -> "{1} monthly payments totalling {2} " - French -> "{1} paiements mensuels comptabilisant {2} " - , m l MoneySymbol - , "." + English -> "{1} monthly payments totalling {2}" + French -> "{1} paiements mensuels comptabilisant {2}" ] + +m l Income = + T.concat + [ case l of + English -> "You have a monthly net income of {1}" + French -> "Votre revenu mensuel net est de {1}" + ] + +m l NoIncome = + case l of + English -> "Income not given" + French -> "Revenu non renseigné" diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs index e57f345..8f62bb1 100644 --- a/src/server/SendMail.hs +++ b/src/server/SendMail.hs @@ -24,15 +24,11 @@ sendMail mail = do return result getMimeMail :: Mail -> M.Mail -getMimeMail (Mail from to subject plainBody htmlBody) = +getMimeMail (Mail from to subject plainBody) = let fromMail = M.emptyMail (address from) in fromMail { M.mailTo = map address to - , M.mailParts = - [ [ M.plainPart plainBody - , M.htmlPart htmlBody - ] - ] + , M.mailParts = [ [ M.plainPart plainBody ] ] , M.mailHeaders = [("Subject", subject)] } diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index fc73dae..dca261d 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -8,10 +8,6 @@ import Data.Text (Text) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (toLazyText, fromText) -import Text.Blaze.Html -import Text.Blaze.Html5 -import Text.Blaze.Html.Renderer.Text (renderHtml) - import Model.Database (User(..)) import qualified Model.Mail as M import Model.Message.Key @@ -24,28 +20,10 @@ getMail user url to = , M.to = to , M.subject = (getMessage SignInMailTitle) , M.plainBody = plainBody user url - , M.htmlBody = htmlBody user url } plainBody :: User -> Text -> LT.Text -plainBody user url = - LT.intercalate - "\n" - [ strictToLazy (getParamMessage [userName user] HiMail) - , "" - , strictToLazy (getMessage SignInLinkMail) - , strictToLazy url - ] - -htmlBody :: User -> Text -> LT.Text -htmlBody user url = - renderHtml . docTypeHtml . body $ do - toHtml $ strictToLazy (getParamMessage [userName user] HiMail) - br - br - toHtml $ strictToLazy (getMessage SignInLinkMail) - br - toHtml url +plainBody user url = strictToLazy (getParamMessage [userName user, url] SignInMail) strictToLazy :: Text -> LT.Text strictToLazy = toLazyText . fromText -- cgit v1.2.3