From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Sep 2017 22:14:48 +0200 Subject: Bootstrap with GHCJS and reflex: - setup login and logout, - first draft of payment view. --- src/client/Chart/Api.elm | 41 -- src/client/Chart/Model.elm | 73 --- src/client/Chart/View.elm | 182 ------ src/client/Common | 1 + src/client/Component/Button.hs | 53 ++ src/client/Component/Input.hs | 34 + src/client/Debug.hs | 17 + src/client/Dialog.elm | 165 ----- src/client/Dialog/AddCategory/Model.elm | 54 -- src/client/Dialog/AddCategory/View.elm | 72 --- src/client/Dialog/AddIncome/Model.elm | 53 -- src/client/Dialog/AddIncome/View.elm | 72 --- src/client/Dialog/AddPayment/Model.elm | 70 --- src/client/Dialog/AddPayment/View.elm | 95 --- src/client/Dialog/Model.elm | 23 - src/client/Dialog/Msg.elm | 15 - src/client/Dialog/Update.elm | 74 --- src/client/Icon.hs | 44 ++ src/client/Init.elm | 30 - src/client/LoggedData.elm | 44 -- src/client/LoggedIn/Category/Table.elm | 123 ---- src/client/LoggedIn/Category/View.elm | 34 - src/client/LoggedIn/Home/Header/View.elm | 105 ---- src/client/LoggedIn/Home/Model.elm | 44 -- src/client/LoggedIn/Home/Msg.elm | 13 - src/client/LoggedIn/Home/Update.elm | 44 -- src/client/LoggedIn/Home/View.elm | 43 -- src/client/LoggedIn/Home/View/ExceedingPayers.elm | 45 -- src/client/LoggedIn/Home/View/Paging.elm | 109 ---- src/client/LoggedIn/Home/View/Table.elm | 167 ----- src/client/LoggedIn/Income/Table.elm | 128 ---- src/client/LoggedIn/Income/View.elm | 104 --- src/client/LoggedIn/Model.elm | 38 -- src/client/LoggedIn/Msg.elm | 26 - src/client/LoggedIn/Stat/Model.elm | 34 - src/client/LoggedIn/Stat/Msg.elm | 7 - src/client/LoggedIn/Stat/Update.elm | 24 - src/client/LoggedIn/Stat/View.elm | 77 --- src/client/LoggedIn/Update.elm | 137 ---- src/client/LoggedIn/View.elm | 33 - src/client/LoggedIn/View/Format.elm | 37 -- src/client/Main.elm | 26 - src/client/Main.hs | 41 ++ src/client/Model.elm | 72 --- src/client/Model/Category.elm | 35 -- src/client/Model/Conf.elm | 13 - src/client/Model/Date.elm | 15 - src/client/Model/Frequency.elm | 36 -- src/client/Model/Income.elm | 101 --- src/client/Model/Init.elm | 31 - src/client/Model/InitResult.elm | 28 - src/client/Model/Payer.elm | 137 ---- src/client/Model/Payment.elm | 117 ---- src/client/Model/PaymentCategory.elm | 61 -- src/client/Model/Size.elm | 17 - src/client/Model/Translations.elm | 68 -- src/client/Model/User.elm | 44 -- src/client/Model/View.elm | 12 - src/client/Msg.elm | 49 -- src/client/Page.elm | 43 -- src/client/Server.elm | 115 ---- src/client/SignIn/Model.elm | 17 - src/client/SignIn/Msg.elm | 9 - src/client/SignIn/Update.elm | 31 - src/client/SignIn/View.elm | 63 -- src/client/Tooltip.elm | 113 ---- src/client/Update.elm | 182 ------ src/client/Utils/Cmd.elm | 16 - src/client/Utils/Dict.elm | 11 - src/client/Utils/Either.elm | 9 - src/client/Utils/Form.elm | 11 - src/client/Utils/Http.elm | 39 -- src/client/Utils/Json.elm | 12 - src/client/Utils/List.elm | 36 -- src/client/Utils/Search.elm | 10 - src/client/Utils/String.elm | 38 -- src/client/Validation.elm | 65 -- src/client/View.elm | 34 - src/client/View/App.hs | 44 ++ src/client/View/Color.elm | 12 - src/client/View/Date.elm | 57 -- src/client/View/Errors.elm | 21 - src/client/View/Events.elm | 15 - src/client/View/Form.elm | 152 ----- src/client/View/Header.elm | 60 -- src/client/View/Header.hs | 86 +++ src/client/View/Payment.hs | 33 + src/client/View/Payment/Table.hs | 90 +++ src/client/View/Plural.elm | 11 - src/client/View/SignIn.hs | 86 +++ src/common/Message.hs | 12 + src/common/Message/Key.hs | 152 +++++ src/common/Message/Lang.hs | 7 + src/common/Message/Translation.hs | 697 +++++++++++++++++++++ src/common/Model.hs | 40 ++ src/common/Model/Category.hs | 26 + src/common/Model/CreateCategory.hs | 16 + src/common/Model/CreateIncome.hs | 16 + src/common/Model/CreatePayment.hs | 23 + src/common/Model/Currency.hs | 14 + src/common/Model/EditCategory.hs | 19 + src/common/Model/EditIncome.hs | 19 + src/common/Model/EditPayment.hs | 25 + src/common/Model/Frequency.hs | 16 + src/common/Model/Income.hs | 29 + src/common/Model/Init.hs | 28 + src/common/Model/InitResult.hs | 19 + src/common/Model/Payment.hs | 33 + src/common/Model/PaymentCategory.hs | 27 + src/common/Model/SignIn.hs | 16 + src/common/Model/User.hs | 29 + src/common/Util/Text.hs | 41 ++ src/common/View/Format.hs | 69 ++ src/migrations/2.sql | 23 + src/server/Common | 1 + src/server/Conf.hs | 6 +- src/server/Controller/Category.hs | 12 +- src/server/Controller/Income.hs | 23 +- src/server/Controller/Index.hs | 30 +- src/server/Controller/Payment.hs | 25 +- src/server/Controller/SignIn.hs | 34 +- src/server/Controller/User.hs | 20 - src/server/Design/Color.hs | 3 + src/server/Design/Global.hs | 11 +- src/server/Design/Header.hs | 74 --- src/server/Design/Helper.hs | 46 +- src/server/Design/LoggedIn.hs | 45 -- src/server/Design/LoggedIn/Home.hs | 17 - src/server/Design/LoggedIn/Home/Header.hs | 84 --- src/server/Design/LoggedIn/Home/Pages.hs | 54 -- src/server/Design/LoggedIn/Home/Table.hs | 37 -- src/server/Design/LoggedIn/Stat.hs | 15 - src/server/Design/LoggedIn/Table.hs | 84 --- src/server/Design/SignIn.hs | 40 -- src/server/Design/View/Header.hs | 78 +++ src/server/Design/View/Payment.hs | 17 + src/server/Design/View/Payment/Header.hs | 84 +++ src/server/Design/View/Payment/Pages.hs | 54 ++ src/server/Design/View/Payment/Table.hs | 42 ++ src/server/Design/View/SignIn.hs | 42 ++ src/server/Design/View/Stat.hs | 15 + src/server/Design/View/Table.hs | 84 +++ src/server/Design/Views.hs | 49 ++ src/server/Job/MonthlyPayment.hs | 11 +- src/server/Main.hs | 21 +- src/server/Model/Category.hs | 23 +- src/server/Model/Frequency.hs | 23 +- src/server/Model/Income.hs | 32 +- src/server/Model/Init.hs | 31 +- src/server/Model/Json/Category.hs | 24 - src/server/Model/Json/Conf.hs | 17 - src/server/Model/Json/CreateCategory.hs | 17 - src/server/Model/Json/CreateIncome.hs | 17 - src/server/Model/Json/CreatePayment.hs | 23 - src/server/Model/Json/EditCategory.hs | 19 - src/server/Model/Json/EditIncome.hs | 20 - src/server/Model/Json/EditPayment.hs | 25 - src/server/Model/Json/Income.hs | 26 - src/server/Model/Json/Init.hs | 36 -- src/server/Model/Json/MessagePart.hs | 18 - src/server/Model/Json/Number.hs | 15 - src/server/Model/Json/Payment.hs | 40 -- src/server/Model/Json/PaymentCategory.hs | 23 - src/server/Model/Json/Translation.hs | 20 - src/server/Model/Json/User.hs | 25 - src/server/Model/Message.hs | 35 -- src/server/Model/Message/Key.hs | 193 ------ src/server/Model/Message/Lang.hs | 11 - src/server/Model/Message/Parts.hs | 37 -- src/server/Model/Message/Translations.hs | 729 ---------------------- src/server/Model/Payer.hs | 216 +++++++ src/server/Model/Payment.hs | 59 +- src/server/Model/PaymentCategory.hs | 24 +- src/server/Model/User.hs | 31 +- src/server/Secure.hs | 13 +- src/server/Utils/Text.hs | 41 -- src/server/Utils/Time.hs | 19 - src/server/View/Format.hs | 33 - src/server/View/Mail/SignIn.hs | 11 +- src/server/View/Mail/WeeklyReport.hs | 110 ++-- src/server/View/Page.hs | 23 +- 181 files changed, 2875 insertions(+), 6746 deletions(-) delete mode 100644 src/client/Chart/Api.elm delete mode 100644 src/client/Chart/Model.elm delete mode 100644 src/client/Chart/View.elm create mode 120000 src/client/Common create mode 100644 src/client/Component/Button.hs create mode 100644 src/client/Component/Input.hs create mode 100644 src/client/Debug.hs delete mode 100644 src/client/Dialog.elm delete mode 100644 src/client/Dialog/AddCategory/Model.elm delete mode 100644 src/client/Dialog/AddCategory/View.elm delete mode 100644 src/client/Dialog/AddIncome/Model.elm delete mode 100644 src/client/Dialog/AddIncome/View.elm delete mode 100644 src/client/Dialog/AddPayment/Model.elm delete mode 100644 src/client/Dialog/AddPayment/View.elm delete mode 100644 src/client/Dialog/Model.elm delete mode 100644 src/client/Dialog/Msg.elm delete mode 100644 src/client/Dialog/Update.elm create mode 100644 src/client/Icon.hs delete mode 100644 src/client/Init.elm delete mode 100644 src/client/LoggedData.elm delete mode 100644 src/client/LoggedIn/Category/Table.elm delete mode 100644 src/client/LoggedIn/Category/View.elm delete mode 100644 src/client/LoggedIn/Home/Header/View.elm delete mode 100644 src/client/LoggedIn/Home/Model.elm delete mode 100644 src/client/LoggedIn/Home/Msg.elm delete mode 100644 src/client/LoggedIn/Home/Update.elm delete mode 100644 src/client/LoggedIn/Home/View.elm delete mode 100644 src/client/LoggedIn/Home/View/ExceedingPayers.elm delete mode 100644 src/client/LoggedIn/Home/View/Paging.elm delete mode 100644 src/client/LoggedIn/Home/View/Table.elm delete mode 100644 src/client/LoggedIn/Income/Table.elm delete mode 100644 src/client/LoggedIn/Income/View.elm delete mode 100644 src/client/LoggedIn/Model.elm delete mode 100644 src/client/LoggedIn/Msg.elm delete mode 100644 src/client/LoggedIn/Stat/Model.elm delete mode 100644 src/client/LoggedIn/Stat/Msg.elm delete mode 100644 src/client/LoggedIn/Stat/Update.elm delete mode 100644 src/client/LoggedIn/Stat/View.elm delete mode 100644 src/client/LoggedIn/Update.elm delete mode 100644 src/client/LoggedIn/View.elm delete mode 100644 src/client/LoggedIn/View/Format.elm delete mode 100644 src/client/Main.elm create mode 100644 src/client/Main.hs delete mode 100644 src/client/Model.elm delete mode 100644 src/client/Model/Category.elm delete mode 100644 src/client/Model/Conf.elm delete mode 100644 src/client/Model/Date.elm delete mode 100644 src/client/Model/Frequency.elm delete mode 100644 src/client/Model/Income.elm delete mode 100644 src/client/Model/Init.elm delete mode 100644 src/client/Model/InitResult.elm delete mode 100644 src/client/Model/Payer.elm delete mode 100644 src/client/Model/Payment.elm delete mode 100644 src/client/Model/PaymentCategory.elm delete mode 100644 src/client/Model/Size.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/Msg.elm delete mode 100644 src/client/Page.elm delete mode 100644 src/client/Server.elm delete mode 100644 src/client/SignIn/Model.elm delete mode 100644 src/client/SignIn/Msg.elm delete mode 100644 src/client/SignIn/Update.elm delete mode 100644 src/client/SignIn/View.elm delete mode 100644 src/client/Tooltip.elm delete mode 100644 src/client/Update.elm delete mode 100644 src/client/Utils/Cmd.elm delete mode 100644 src/client/Utils/Dict.elm delete mode 100644 src/client/Utils/Either.elm delete mode 100644 src/client/Utils/Form.elm delete mode 100644 src/client/Utils/Http.elm delete mode 100644 src/client/Utils/Json.elm delete mode 100644 src/client/Utils/List.elm delete mode 100644 src/client/Utils/Search.elm delete mode 100644 src/client/Utils/String.elm delete mode 100644 src/client/Validation.elm delete mode 100644 src/client/View.elm create mode 100644 src/client/View/App.hs delete mode 100644 src/client/View/Color.elm delete mode 100644 src/client/View/Date.elm delete mode 100644 src/client/View/Errors.elm delete mode 100644 src/client/View/Events.elm delete mode 100644 src/client/View/Form.elm delete mode 100644 src/client/View/Header.elm create mode 100644 src/client/View/Header.hs create mode 100644 src/client/View/Payment.hs create mode 100644 src/client/View/Payment/Table.hs delete mode 100644 src/client/View/Plural.elm create mode 100644 src/client/View/SignIn.hs create mode 100644 src/common/Message.hs create mode 100644 src/common/Message/Key.hs create mode 100644 src/common/Message/Lang.hs create mode 100644 src/common/Message/Translation.hs create mode 100644 src/common/Model.hs create mode 100644 src/common/Model/Category.hs create mode 100644 src/common/Model/CreateCategory.hs create mode 100644 src/common/Model/CreateIncome.hs create mode 100644 src/common/Model/CreatePayment.hs create mode 100644 src/common/Model/Currency.hs create mode 100644 src/common/Model/EditCategory.hs create mode 100644 src/common/Model/EditIncome.hs create mode 100644 src/common/Model/EditPayment.hs create mode 100644 src/common/Model/Frequency.hs create mode 100644 src/common/Model/Income.hs create mode 100644 src/common/Model/Init.hs create mode 100644 src/common/Model/InitResult.hs create mode 100644 src/common/Model/Payment.hs create mode 100644 src/common/Model/PaymentCategory.hs create mode 100644 src/common/Model/SignIn.hs create mode 100644 src/common/Model/User.hs create mode 100644 src/common/Util/Text.hs create mode 100644 src/common/View/Format.hs create mode 100644 src/migrations/2.sql create mode 120000 src/server/Common delete mode 100644 src/server/Controller/User.hs delete mode 100644 src/server/Design/Header.hs delete mode 100644 src/server/Design/LoggedIn.hs delete mode 100644 src/server/Design/LoggedIn/Home.hs delete mode 100644 src/server/Design/LoggedIn/Home/Header.hs delete mode 100644 src/server/Design/LoggedIn/Home/Pages.hs delete mode 100644 src/server/Design/LoggedIn/Home/Table.hs delete mode 100644 src/server/Design/LoggedIn/Stat.hs delete mode 100644 src/server/Design/LoggedIn/Table.hs delete mode 100644 src/server/Design/SignIn.hs create mode 100644 src/server/Design/View/Header.hs create mode 100644 src/server/Design/View/Payment.hs create mode 100644 src/server/Design/View/Payment/Header.hs create mode 100644 src/server/Design/View/Payment/Pages.hs create mode 100644 src/server/Design/View/Payment/Table.hs create mode 100644 src/server/Design/View/SignIn.hs create mode 100644 src/server/Design/View/Stat.hs create mode 100644 src/server/Design/View/Table.hs create mode 100644 src/server/Design/Views.hs delete mode 100644 src/server/Model/Json/Category.hs delete mode 100644 src/server/Model/Json/Conf.hs delete mode 100644 src/server/Model/Json/CreateCategory.hs delete mode 100644 src/server/Model/Json/CreateIncome.hs delete mode 100644 src/server/Model/Json/CreatePayment.hs delete mode 100644 src/server/Model/Json/EditCategory.hs delete mode 100644 src/server/Model/Json/EditIncome.hs delete mode 100644 src/server/Model/Json/EditPayment.hs delete mode 100644 src/server/Model/Json/Income.hs delete mode 100644 src/server/Model/Json/Init.hs delete mode 100644 src/server/Model/Json/MessagePart.hs delete mode 100644 src/server/Model/Json/Number.hs delete mode 100644 src/server/Model/Json/Payment.hs delete mode 100644 src/server/Model/Json/PaymentCategory.hs delete mode 100644 src/server/Model/Json/Translation.hs delete mode 100644 src/server/Model/Json/User.hs delete mode 100644 src/server/Model/Message.hs delete mode 100644 src/server/Model/Message/Key.hs delete mode 100644 src/server/Model/Message/Lang.hs delete mode 100644 src/server/Model/Message/Parts.hs delete mode 100644 src/server/Model/Message/Translations.hs create mode 100644 src/server/Model/Payer.hs delete mode 100644 src/server/Utils/Text.hs delete mode 100644 src/server/View/Format.hs (limited to 'src') diff --git a/src/client/Chart/Api.elm b/src/client/Chart/Api.elm deleted file mode 100644 index 693f362..0000000 --- a/src/client/Chart/Api.elm +++ /dev/null @@ -1,41 +0,0 @@ -module Chart.Api exposing - ( from - , withSize - , withTitle - , withOrdinate - , toHtml - ) - -import Html exposing (Html) -import Svg exposing (..) -import Svg.Attributes exposing (..) - -import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) -import Chart.View as Chart - -from : List String -> List Serie -> Chart -from keys series = - { keys = keys - , series = series - , size = { x = 600, y = 400 } - , title = "" - , scaleColor = "#DDDDDD" - , formatOrdinate = toString - , ordinateLines = 5 - } - -withSize : Vec2 -> Chart -> Chart -withSize size chart = { chart | size = size } - -withTitle : String -> Chart -> Chart -withTitle title chart = { chart | title = title } - -withOrdinate : Int -> (Float -> String) -> Chart -> Chart -withOrdinate lines format chart = - { chart - | formatOrdinate = format - , ordinateLines = lines - } - -toHtml : Chart -> Html msg -toHtml chart = Chart.view chart diff --git a/src/client/Chart/Model.elm b/src/client/Chart/Model.elm deleted file mode 100644 index b5c176f..0000000 --- a/src/client/Chart/Model.elm +++ /dev/null @@ -1,73 +0,0 @@ -module Chart.Model exposing - ( Chart - , Serie - , maxScale - , Vec2 - , View - , mkView - , bounds - ) - -import List.Extra as List - -type alias Chart = - { keys : List String - , series : List Serie - , size : Vec2 - , title : String - , scaleColor : String - , formatOrdinate : Float -> String - , ordinateLines : Int - } - -type alias Serie = - { values : List Float - , color : String - , label : String - } - -maxScale : Chart -> Float -maxScale { keys, series } = - List.range 0 (List.length keys - 1) - |> List.map (\i -> - series - |> List.map (truncate << Maybe.withDefault 0 << List.getAt i << .values) - |> List.maximum - |> Maybe.withDefault 0 - ) - |> List.maximum - |> Maybe.withDefault 0 - |> upperBound - -upperBound : Int -> Float -upperBound n = toFloat (upperBoundInt 0 n) - -upperBoundInt : Int -> Int -> Int -upperBoundInt count n = - if n < 10 - then - (n + 1) * (10 ^ count) - else - upperBoundInt (count + 1) (n // 10) - -type alias Vec2 = - { x : Float - , y : Float - } - -type alias View = - { fx : Float -> Float - , fy : Float -> Float - } - -mkView : Vec2 -> Vec2 -> View -mkView p1 p2 = - { fx = \x -> p1.x + x * (p2.x - p1.x) - , fy = \y -> p1.y + y * (p2.y - p1.y) - } - -bounds : View -> (Vec2, Vec2) -bounds { fx, fy } = - ( { x = fx 0, y = fy 0 } - , { x = fx 1, y = fy 1 } - ) diff --git a/src/client/Chart/View.elm b/src/client/Chart/View.elm deleted file mode 100644 index af8b4b7..0000000 --- a/src/client/Chart/View.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Chart.View exposing - ( view - ) - -import Html exposing (Html) -import List.Extra as List -import Svg exposing (..) -import Svg.Attributes exposing (..) - -import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) -import Utils.List as List - -view : Chart -> Html msg -view chart = - let { size, title, series } = chart - titleHeight = 100 - captionHeight = 50 - in svg - [ width << toString <| size.x - , height << toString <| size.y - , viewBox ("0 0 " ++ (toString size.x) ++ " " ++ (toString size.y)) - ] - ( [ renderTitle (Chart.mkView { x = 0, y = 0 } { x = size.x, y = titleHeight }) title ] - ++ renderSeriesAndScales (Chart.mkView { x = 50, y = titleHeight } { x = size.x, y = size.y - captionHeight }) chart - ++ renderCaptions (Chart.mkView { x = 0, y = size.y - captionHeight } { x = size.x, y = size.y }) series - ) - -renderTitle : View -> String -> Svg msg -renderTitle view title = - text_ - [ x << toString <| view.fx 0.5 - , y << toString <| view.fy 0.5 - , textAnchor "middle" - , dominantBaseline "middle" - , fontSize "20" - ] - [ text title ] - -renderSeriesAndScales : View -> Chart -> List (Svg msg) -renderSeriesAndScales view chart = - let { keys, series, scaleColor, formatOrdinate } = chart - (p1, p2) = Chart.bounds view - ordinateWidth = 100 - abscissaHeight = 60 - maxScale = Chart.maxScale chart - in ( renderOrdinates (Chart.mkView { x = p1.x, y = p1.y } { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight }) formatOrdinate maxScale - ++ renderAbscissas (Chart.mkView { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight } { x = p2.x, y = p2.y }) keys scaleColor - ++ renderSeries (Chart.mkView { x = p1.x + ordinateWidth, y = p1.y } { x = p2.x, y = p2.y - abscissaHeight }) series maxScale scaleColor - ) - -renderOrdinates : View -> (Float -> String) -> Float -> List (Svg msg) -renderOrdinates view formatOrdinate maxScale = - ordinates - |> List.map (\l -> - text_ - [ x << toString <| view.fx 0.5 - , y << toString <| view.fy l - , textAnchor "middle" - , dominantBaseline "middle" - ] - [ text << formatOrdinate <| (1 - l) * maxScale ] - ) - - -renderAbscissas : View -> List String -> String -> List (Svg msg) -renderAbscissas view keys scaleColor = - let count = List.length keys - in ( abscissasXPositions keys - |> List.map (\(xPos, key) -> - [ text_ - [ x << toString <| view.fx xPos - , y << toString <| view.fy 0.5 - , textAnchor "middle" - , dominantBaseline "middle" - ] - [ text key ] - , line - [ x1 << toString <| view.fx xPos - , y1 << toString <| view.fy 0 - , x2 << toString <| view.fx xPos - , y2 << toString <| view.fy 0.2 - , stroke scaleColor - ] - [] - ] - ) - |> List.concat - ) - -renderSeries : View -> List Serie -> Float -> String -> List (Svg msg) -renderSeries view series maxScale scaleColor = - ( renderHorizontalLines view series scaleColor - ++ renderPoints view series maxScale - ) - -renderHorizontalLines : View -> List Serie -> String -> List (Svg msg) -renderHorizontalLines view series scaleColor = - ordinates - |> List.map (\l -> - line - [ x1 << toString <| view.fx 0 - , y1 << toString <| view.fy l - , x2 << toString <| view.fx 1 - , y2 << toString <| view.fy l - , stroke scaleColor - ] - [] - ) - -renderPoints : View -> List Serie -> Float -> List (Svg msg) -renderPoints view series maxScale = - series - |> List.map (\serie -> - let points = - abscissasXPositions serie.values - |> List.map (\(xPos, value) -> { x = xPos, y = 1 - value / maxScale }) - in [ renderLines view serie.color points - , List.map (renderPoint view serie.color) points - ] - |> List.concat - ) - |> List.concat - -renderLines : View -> String -> List Vec2 -> List (Svg msg) -renderLines view color points = - List.links points - |> List.map (\(p1, p2) -> - line - [ x1 << toString <| view.fx p1.x - , y1 << toString <| view.fy p1.y - , x2 << toString <| view.fx p2.x - , y2 << toString <| view.fy p2.y - , stroke color - ] - [] - ) - -renderPoint : View -> String -> Vec2 -> Svg msg -renderPoint view color pos = - circle - [ cx << toString <| view.fx pos.x - , cy << toString <| view.fy pos.y - , r "4" - , fill color - ] - [] - -abscissasXPositions : List a -> List (Float, a) -abscissasXPositions xs = - let count = List.length xs - in xs - |> List.zip (List.range 1 (count + 1)) - |> List.map (\(i, x) -> (toFloat i / (toFloat count + 1), x)) - -ordinates : List Float -ordinates = - let count = 10 - in List.range 0 (count - 1) - |> List.map (\l -> toFloat l / (toFloat count - 1)) - -renderCaptions : View -> List Serie -> List (Svg msg) -renderCaptions view series = - let count = List.length series - in series - |> List.zip (List.range 1 (List.length series)) - |> List.map (\(i, serie) -> - renderCaption { x = view.fx (toFloat i / (toFloat count + 1)), y = view.fy 0.5 } serie - ) - |> List.concat - -renderCaption : Vec2 -> Serie -> List (Svg msg) -renderCaption point { label, color } = - [ text_ - [ x << toString <| point.x - , y << toString <| point.y - , textAnchor "middle" - , dominantBaseline "middle" - , fill color - , fontSize "18" - ] - [ text label ] - ] diff --git a/src/client/Common b/src/client/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/client/Common @@ -0,0 +1 @@ +../common \ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs new file mode 100644 index 0000000..f21798c --- /dev/null +++ b/src/client/Component/Button.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Button + ( ButtonIn(..) + , buttonInDefault + , ButtonOut(..) + , button + ) where + +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Icon + +data ButtonIn t m = ButtonIn + { _buttonIn_class :: Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + } + +buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault = ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.blank + , _buttonIn_waiting = R.never + } + +data ButtonOut t = ButtonOut + { _buttonOut_clic :: Event t () + } + +button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) +button buttonIn = do + attr <- R.holdDyn + (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) + (fmap + (\w -> M.fromList $ + [ ("type", "button") ] + <> if w + then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] + else [("class", _buttonIn_class buttonIn)]) + (_buttonIn_waiting buttonIn)) + (e, _) <- R.elDynAttr' "button" attr $ do + Icon.loading + R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut + { _buttonOut_clic = R.domEvent R.Click e + } diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs new file mode 100644 index 0000000..7111630 --- /dev/null +++ b/src/client/Component/Input.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Input + ( InputIn(..) + , InputOut(..) + , input + ) where + +import Data.Text (Text) +import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import qualified Reflex.Dom as R + +data InputIn t a b = InputIn + { _inputIn_reset :: Event t a + , _inputIn_placeHolder :: Text + } + +data InputOut t = InputOut + { _inputOut_value :: Dynamic t Text + , _inputOut_enter :: Event t () + } + +input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) +input inputIn = do + let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) + let value = fmap (const "") (_inputIn_reset inputIn) + textInput <- R.textInput $ R.def & R.attributes .~ placeHolder + & R.setValue .~ value + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + return $ InputOut + { _inputOut_value = R._textInput_value textInput + , _inputOut_enter = enter + } diff --git a/src/client/Debug.hs b/src/client/Debug.hs new file mode 100644 index 0000000..0c5c979 --- /dev/null +++ b/src/client/Debug.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Debug + ( event + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event, Dynamic) +import qualified Reflex.Dom as R + +event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () +event name e = do + count <- R.count e :: m (Dynamic t Int) + let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count + R.el "div" $ R.dynText text diff --git a/src/client/Dialog.elm b/src/client/Dialog.elm deleted file mode 100644 index a7e059a..0000000 --- a/src/client/Dialog.elm +++ /dev/null @@ -1,165 +0,0 @@ -module Dialog exposing - ( Msg(..) - , Model - , Config - , init - , update - , view - ) - -import Platform.Cmd exposing (Cmd) -import Task exposing (Task) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - --- Model - -type alias Model model modelMsg msg = - { config : Maybe (Config model msg) - , mapMsg : Msg model modelMsg msg -> msg - , model : model - } - -type alias Config model msg = - { className : String - , title : String - , body : model -> Html msg - , confirm : String - , confirmMsg : model -> msg - , undo : String - } - -init : model -> (Msg model modelMsg msg -> msg) -> Model model modelMsg msg -init model mapMsg = - { config = Nothing - , mapMsg = mapMsg - , model = model - } - --- Update - -type Msg model modelMsg msg = - NoOp - | Update modelMsg - | UpdateAndClose msg - | OpenWithUpdate (Config model msg) modelMsg - | Open (Config model msg) - | Close - -update : (modelMsg -> model -> (model, Cmd modelMsg)) -> Msg model modelMsg msg -> model -> Model model modelMsg msg -> (Model model modelMsg msg, Cmd msg) -update updateModel msg baseModel model = - case msg of - NoOp -> - ( model - , Cmd.none - ) - - Update modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model | model = newModel } - , Cmd.map (model.mapMsg << Update) effects - ) - - UpdateAndClose msg -> - ( { model | config = Nothing } - , Task.perform (always msg) (Task.succeed msg) - ) - - OpenWithUpdate config modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model - | model = newModel - , config = Just config - } - , Cmd.map (model.mapMsg << Update) effects - ) - - Open config -> - ( { model | config = Just config } - , Cmd.none - ) - - Close -> - ( { model | config = Nothing } - , Cmd.none - ) - --- View - -view : Model model modelMsg msg -> Html msg -view { mapMsg, config, model } = - let isVisible = - case config of - Just _ -> True - Nothing -> False - in div - [ class "dialog" ] - [ curtain mapMsg isVisible - , case config of - Nothing -> - text "" - Just c -> - dialog model mapMsg c - ] - -curtain : (Msg model modelMsg msg -> msg) -> Bool -> Html msg -curtain mapMsg isVisible = - div - [ class "curtain" - , style - [ ("position", "fixed") - , ("top", "0") - , ("left", "0") - , ("width", "100%") - , ("height", "100%") - , ("background-color", "rgba(0, 0, 0, 0.5)") - , ("z-index", if isVisible then "1000" else "-1") - , ("opacity", if isVisible then "1" else "0") - , ("transition", "all 0.2s ease") - ] - , onClick (mapMsg Close) - ] - [] - -dialog : model -> (Msg model modelMsg msg -> msg) -> Config model msg -> Html msg -dialog model mapMsg { className, title, body, confirm, confirmMsg, undo } = - div - [ class ("content " ++ className) - , style - [ ("position", "fixed") - , ("top", "25%") - , ("left", "50%") - , ("transform", "translate(-50%, -25%)") - , ("z-index", "1000") - , ("background-color", "white") - , ("padding", "20px") - , ("border-radius", "5px") - , ("box-shadow", "0px 0px 15px rgba(0, 0, 0, 0.5)") - ] - ] - [ h1 [] [ text title ] - , body model - , div - [ style - [ ("float", "right") - ] - ] - [ button - [ class "confirm" - , onClick (confirmMsg model) - , style - [ ("margin-right", "15px") - ] - ] - [ text confirm ] - , button - [ class "undo" - , onClick (mapMsg Close) - ] - [ text undo ] - ] - ] diff --git a/src/client/Dialog/AddCategory/Model.elm b/src/client/Dialog/AddCategory/Model.elm deleted file mode 100644 index 3b70482..0000000 --- a/src/client/Dialog/AddCategory/Model.elm +++ /dev/null @@ -1,54 +0,0 @@ -module Dialog.AddCategory.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import Dict - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Category exposing (Categories, Category, CategoryId) -import Model.Translations exposing (Translations) -import Validation -import View.Date as Date - -type alias Model = - { id : Maybe CategoryId - , name : String - , color : String - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> List (String, Field) -initialAdd translations = - [ ("color", Field.string "#000000") - ] - -initialClone : Translations -> Category -> List (String, Field) -initialClone translations category = - [ ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -initialEdit : Translations -> CategoryId -> Category -> List (String, Field) -initialEdit translations categoryId category = - [ ("id", Field.string (toString categoryId)) - , ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "color" Validation.color) diff --git a/src/client/Dialog/AddCategory/View.elm b/src/client/Dialog/AddCategory/View.elm deleted file mode 100644 index dc55b60..0000000 --- a/src/client/Dialog/AddCategory/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddCategory.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "categoryDialog" - , title = getMessage loggedData.translations title - , body = \model -> addCategoryForm loggedData model.addCategory - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addCategory - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "categoryname" (DialogMsg.AddCategoryMsg (Form.Reset initialForm)))) ] - ) - [ buttonContent ] - -addCategoryForm : LoggedData -> Form String AddCategory.Model -> Html Msg -addCategoryForm loggedData addCategory = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddCategoryMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addCategory "category" "name" - , htmlMap <| Form.colorInput loggedData.translations addCategory "category" "color" - , Form.hiddenSubmit (submitForm addCategory) - ] - -submitForm : Form String AddCategory.Model -> Msg -submitForm addCategory = - case Form.getOutput addCategory of - Just data -> - case data.id of - Just categoryId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditCategory categoryId (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateCategory (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddCategoryMsg <| Form.Submit diff --git a/src/client/Dialog/AddIncome/Model.elm b/src/client/Dialog/AddIncome/Model.elm deleted file mode 100644 index 5e2ccf1..0000000 --- a/src/client/Dialog/AddIncome/Model.elm +++ /dev/null @@ -1,53 +0,0 @@ -module Dialog.AddIncome.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Translations exposing (Translations) -import Model.Income exposing (Income, IncomeId) - -type alias Model = - { id : Maybe IncomeId - , amount : Int - , date : Date - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> Date -> List (String, Field) -initialAdd translations date = - [ ("date", Field.string (Date.shortView date translations)) - ] - -initialClone : Translations -> Date -> Income -> List (String, Field) -initialClone translations date income = - [ ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView date translations)) - ] - -initialEdit : Translations -> IncomeId -> Income -> List (String, Field) -initialEdit translations incomeId income = - [ ("id", Field.string (toString incomeId)) - , ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView (Date.fromTime income.time) translations)) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 0))) - (Validate.field "date" Validation.date) diff --git a/src/client/Dialog/AddIncome/View.elm b/src/client/Dialog/AddIncome/View.elm deleted file mode 100644 index b413308..0000000 --- a/src/client/Dialog/AddIncome/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddIncome.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "incomeDialog" - , title = getMessage loggedData.translations title - , body = \model -> addIncomeForm loggedData model.addIncome - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addIncome - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "incomeamount" (DialogMsg.AddIncomeMsg <| Form.Reset initialForm))) ] - ) - [ buttonContent ] - -addIncomeForm : LoggedData -> Form String AddIncome.Model -> Html Msg -addIncomeForm loggedData addIncome = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddIncomeMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addIncome "income" "amount" - , htmlMap <| Form.textInput loggedData.translations addIncome "income" "date" - , Form.hiddenSubmit (submitForm addIncome) - ] - -submitForm : Form String AddIncome.Model -> Msg -submitForm addIncome = - case Form.getOutput addIncome of - Just data -> - case data.id of - Just incomeId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditIncome incomeId data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateIncome data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddIncomeMsg <| Form.Submit diff --git a/src/client/Dialog/AddPayment/Model.elm b/src/client/Dialog/AddPayment/Model.elm deleted file mode 100644 index 07e7cbb..0000000 --- a/src/client/Dialog/AddPayment/Model.elm +++ /dev/null @@ -1,70 +0,0 @@ -module Dialog.AddPayment.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Category as Category exposing (Categories, CategoryId) -import Model.Frequency as Frequency -import Model.Payment as Payment exposing (Payment, PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Translations exposing (Translations) - -type alias Model = - { id : Maybe PaymentId - , name : String - , cost : Int - , date : Date - , category : CategoryId - , frequency : Frequency - } - -init : Form String Model -init = Form.initial [] (validation Category.empty) - -initialAdd : Translations -> Date -> Frequency -> List (String, Field) -initialAdd translations date frequency = - [ ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString frequency)) - , ("category", Field.string "") - ] - -initialClone : Translations -> Date -> Maybe CategoryId -> Payment -> List (String, Field) -initialClone translations date category payment = - [ ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -initialEdit : Translations -> Maybe CategoryId -> Payment -> List (String, Field) -initialEdit translations category payment = - [ ("id", Field.string (toString payment.id)) - , ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView payment.date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -validation : Categories -> Validation String Model -validation categories = - Validate.map6 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "cost" Validation.cost) - (Validate.field "date" Validation.date) - (Validate.field "category" (Validation.category categories)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/Dialog/AddPayment/View.elm b/src/client/Dialog/AddPayment/View.elm deleted file mode 100644 index 584adcd..0000000 --- a/src/client/Dialog/AddPayment/View.elm +++ /dev/null @@ -1,95 +0,0 @@ -module Dialog.AddPayment.View exposing - ( button - ) - -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Events exposing (onSubmitPrevDefault) -import View.Form as Form - -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Msg as LoggedInMsg -import Msg exposing (Msg) - -import Model.Category exposing (Categories) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "paymentDialog" - , title = getMessage loggedData.translations title - , body = \model -> addPaymentForm loggedData model.addPayment - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm loggedData.categories loggedData.paymentCategories << .addPayment - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ class "addPayment" - , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "paymentname" (DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories <| Form.Reset initialForm))) - ] - ) - [ buttonContent ] - -addPaymentForm : LoggedData -> Form String AddPayment.Model -> Html Msg -addPaymentForm loggedData addPayment = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories) - categoryOptions = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - |> List.map (\(id, category) -> (toString id, category.name)) - in Html.form - [ class "addPayment" - , onSubmitPrevDefault Msg.NoOp - ] - [ htmlMap <| Form.textInput loggedData.translations addPayment "payment" "name" - , htmlMap <| Form.textInput loggedData.translations addPayment "payment" "cost" - , if (Form.getFieldAsString "frequency" addPayment).value == Just (toString Punctual) - then htmlMap <| Form.textInput loggedData.translations addPayment "payment" "date" - else text "" - , htmlMap <| Form.selectInput loggedData.translations addPayment "payment" "category" categoryOptions - - , htmlMap <| Form.radioInputs loggedData.translations addPayment "payment" "frequency" [ toString Punctual, toString Monthly ] - , Form.hiddenSubmit (submitForm loggedData.categories loggedData.paymentCategories addPayment) - ] - -submitForm : Categories -> PaymentCategories -> Form String AddPayment.Model -> Msg -submitForm categories paymentCategories addPayment = - case Form.getOutput addPayment of - Just data -> - case data.id of - Just paymentId -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.EditPayment paymentId (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.CreatePayment (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg categories paymentCategories <| Form.Submit diff --git a/src/client/Dialog/Model.elm b/src/client/Dialog/Model.elm deleted file mode 100644 index ff8bc57..0000000 --- a/src/client/Dialog/Model.elm +++ /dev/null @@ -1,23 +0,0 @@ -module Dialog.Model exposing - ( Model - , init - ) - -import Form exposing (Form) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddCategory.Model as AddCategory - -type alias Model = - { addPayment : Form String AddPayment.Model - , addIncome : Form String AddIncome.Model - , addCategory : Form String AddCategory.Model - } - -init : Model -init = - { addPayment = AddPayment.init - , addIncome = AddIncome.init - , addCategory = AddCategory.init - } diff --git a/src/client/Dialog/Msg.elm b/src/client/Dialog/Msg.elm deleted file mode 100644 index 68ed146..0000000 --- a/src/client/Dialog/Msg.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Dialog.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -type Msg = - NoOp - | Init String Msg - | AddPaymentMsg Categories PaymentCategories Form.Msg - | AddIncomeMsg Form.Msg - | AddCategoryMsg Form.Msg diff --git a/src/client/Dialog/Update.elm b/src/client/Dialog/Update.elm deleted file mode 100644 index 3915548..0000000 --- a/src/client/Dialog/Update.elm +++ /dev/null @@ -1,74 +0,0 @@ -module Dialog.Update exposing - ( update - ) - -import Dom exposing (Id) -import Form exposing (Form) -import Form.Field as Field -import Task - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddPayment.Model as AddPayment -import Dialog.Model as Dialog -import Dialog.Msg as Dialog - -import Model.Category exposing (Categories) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -update : Dialog.Msg -> Dialog.Model -> (Dialog.Model, Cmd Dialog.Msg) -update msg model = - case msg of - - Dialog.NoOp -> - ( model - , Cmd.none - ) - - Dialog.Init inputId dialogMsg -> - update dialogMsg model - |> Tuple.mapSecond (\cmd -> Cmd.batch [cmd, inputFocus inputId]) - - Dialog.AddPaymentMsg categories paymentCategories formMsg -> - ( { model - | addPayment = - Form.update (AddPayment.validation categories) formMsg model.addPayment - |> updateCategory categories paymentCategories formMsg - } - , Cmd.none - ) - - Dialog.AddIncomeMsg formMsg -> - ( { model - | addIncome = Form.update AddIncome.validation formMsg model.addIncome - } - , Cmd.none - ) - - Dialog.AddCategoryMsg formMsg -> - ( { model - | addCategory = Form.update AddCategory.validation formMsg model.addCategory - } - , Cmd.none - ) - -inputFocus : Id -> Cmd Dialog.Msg -inputFocus id = - Dom.focus id - |> Task.map (always Dialog.NoOp) - |> Task.onError (\_ -> Task.succeed Dialog.NoOp) - |> Task.perform (always Dialog.NoOp) - -updateCategory : Categories -> PaymentCategories -> Form.Msg -> (Form String AddPayment.Model -> Form String AddPayment.Model) -updateCategory categories paymentCategories formMsg = - case formMsg of - Form.Input "name" Form.Text (Field.String paymentName) -> - case PaymentCategory.search paymentName paymentCategories of - Just category -> - Form.update - (AddPayment.validation categories) - (Form.Input "category" Form.Text (Field.String <| toString category)) - Nothing -> - identity - _ -> - identity diff --git a/src/client/Icon.hs b/src/client/Icon.hs new file mode 100644 index 0000000..7223def --- /dev/null +++ b/src/client/Icon.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Icon + ( loading + , signOut + , clone + , edit + , delete + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/src/client/Init.elm b/src/client/Init.elm deleted file mode 100644 index d87e870..0000000 --- a/src/client/Init.elm +++ /dev/null @@ -1,30 +0,0 @@ -module Init exposing - ( Init - , decoder - ) - -import Time exposing (..) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import Model.Size exposing (..) - -type alias Init = - { time : Time - , translations : Translations - , conf : Conf - , result : InitResult - , windowSize : Size - } - -decoder : Decoder Init -decoder = - Decode.map5 Init - (Decode.field "time" Decode.float) - (Decode.field "translations" translationsDecoder) - (Decode.field "conf" confDecoder) - (Decode.field "result" initResultDecoder) - (Decode.field "windowSize" sizeDecoder) diff --git a/src/client/LoggedData.elm b/src/client/LoggedData.elm deleted file mode 100644 index e048247..0000000 --- a/src/client/LoggedData.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedData exposing - ( LoggedData - , build - ) - -import Time exposing (Time) - -import Msg exposing (Msg) - -import Model exposing (Model) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.Payment exposing (Payments) -import Model.User exposing (Users, UserId) -import Model.Income exposing (Incomes) -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -import LoggedIn.Model as LoggedInModel - -type alias LoggedData = - { currentTime : Time - , translations : Translations - , conf : Conf - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -build : Time -> Translations -> Conf -> LoggedInModel.Model -> LoggedData -build currentTime translations conf loggedIn = - { currentTime = currentTime - , translations = translations - , conf = conf - , users = loggedIn.users - , me = loggedIn.me - , payments = loggedIn.payments - , incomes = loggedIn.incomes - , categories = loggedIn.categories - , paymentCategories = loggedIn.paymentCategories - } diff --git a/src/client/LoggedIn/Category/Table.elm b/src/client/LoggedIn/Category/Table.elm deleted file mode 100644 index 9405e57..0000000 --- a/src/client/LoggedIn/Category/Table.elm +++ /dev/null @@ -1,123 +0,0 @@ -module LoggedIn.Category.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Category as Category exposing (CategoryId, Category) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let categories = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) categories) - , if List.isEmpty (Dict.toList loggedData.categories) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoCategories" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell category" ] [ text <| getMessage loggedData.translations "Color" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (CategoryId, Category) -> Html Msg -paymentLine loggedData (categoryId, category) = - div - [ class "row" ] - [ div - [ class "cell category" ] - [ text category.name ] - , div - [ class "cell category" ] - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.color ] - ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddCategory.button - loggedData - (AddCategory.initialClone loggedData.translations category) - "CloneCategory" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ AddCategory.button - loggedData - (AddCategory.initialEdit loggedData.translations categoryId category) - "EditCategory" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if PaymentCategory.isCategoryUnused categoryId loggedData.paymentCategories - then - let dialogConfig = - { className = "deleteCategoryDialog" - , title = getMessage loggedData.translations "ConfirmCategoryDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteCategory categoryId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - else - span - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "UsedCategory") ) - [ FontAwesome.trash Color.silver 18 ] - ] - ] diff --git a/src/client/LoggedIn/Category/View.elm b/src/client/LoggedIn/Category/View.elm deleted file mode 100644 index bba51b7..0000000 --- a/src/client/LoggedIn/Category/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Category.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import LoggedData exposing (LoggedData) - -import Msg exposing (Msg) - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import LoggedIn.Category.Table as Table - -import Model.Translations exposing (getMessage, getParamMessage) - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "categories" ] - [ div - [ class "titleButton withMargin" ] - [ h1 [] [ text <| getMessage loggedData.translations "Categories" ] - , AddCategory.button - loggedData - (AddCategory.initialAdd loggedData.translations) - "AddCategory" - (text (getMessage loggedData.translations "AddCategory")) - Nothing - ] - , Table.view loggedData - ] diff --git a/src/client/LoggedIn/Home/Header/View.elm b/src/client/LoggedIn/Home/Header/View.elm deleted file mode 100644 index 14d90d7..0000000 --- a/src/client/LoggedIn/Home/Header/View.elm +++ /dev/null @@ -1,105 +0,0 @@ -module LoggedIn.Home.Header.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import String -import Dict -import Date - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import Model.Translations exposing (getParamMessage) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.Translations exposing (getMessage) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import LoggedIn.Home.View.ExceedingPayers as ExceedingPayers -import LoggedIn.View.Format as Format -import View.Plural exposing (plural) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg -view loggedData { search } payments frequency = - let currentDate = Date.fromTime loggedData.currentTime - in Html.div - [ class "header" ] - [ div - [ class "payerAndAdd" ] - [ ExceedingPayers.view loggedData - , AddPayment.button - loggedData - (AddPayment.initialAdd loggedData.translations currentDate frequency) - "AddPayment" - (text (getMessage loggedData.translations "AddPayment")) - Nothing - ] - , Html.div - [ class "searchLine" ] - [ searchForm loggedData search ] - , infos loggedData payments - ] - -searchForm : LoggedData -> Form String Home.Search -> Html Msg -searchForm loggedData search = - Html.map (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.SearchMsg) <| - Html.form - [ onSubmitPrevDefault Form.NoOp ] - [ Form.textInput loggedData.translations search "search" "name" - , if List.isEmpty (Payment.monthly loggedData.payments) - then text "" - else Form.radioInputs loggedData.translations search "search" "frequency" [ toString Punctual, toString Monthly ] - ] - -infos : LoggedData -> Payments -> Html Msg -infos loggedData payments = - let paymentsCount = List.length payments - in if paymentsCount == 0 - then text "" - else - let count = plural loggedData.translations (List.length payments) "Payment" "Payments" - sum = paymentsSum loggedData.conf payments - in div - [ class "infos" ] - [ span - [ class "total" ] - [ text <| getParamMessage [ count, sum ] loggedData.translations "Worth" ] - , span - [ class "partition" ] - [ text <| paymentsPartition loggedData payments ] - ] - -paymentsPartition : LoggedData -> Payments -> String -paymentsPartition loggedData payments = - String.join - ", " - ( loggedData.users - |> Dict.toList - |> List.map (Tuple.mapFirst (\userId -> Payment.totalPayments (always True) userId payments)) - |> List.filter (\(sum, _) -> sum > 0) - |> List.sortBy Tuple.first - |> List.reverse - |> List.map (\(sum, user) -> - getParamMessage [ user.name, Format.price loggedData.conf sum ] loggedData.translations "By" - ) - ) - -paymentsSum : Conf -> Payments -> String -paymentsSum conf payments = - payments - |> List.map .cost - |> List.sum - |> Format.price conf diff --git a/src/client/LoggedIn/Home/Model.elm b/src/client/LoggedIn/Home/Model.elm deleted file mode 100644 index e5381f6..0000000 --- a/src/client/LoggedIn/Home/Model.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Model exposing - ( Model - , Search - , init - , searchInitial - , validation - ) - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Frequency as Frequency -import Model.Payer exposing (Payers) -import Model.Payment as Payment exposing (PaymentId, Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.User exposing (Users, UserId) - -type alias Model = - { punctualPage : Int - , monthlyPage : Int - , search : Form String Search - } - -type alias Search = - { name : Maybe String - , frequency : Frequency - } - -init : Model -init = - { punctualPage = 1 - , monthlyPage = 1 - , search = Form.initial (searchInitial Punctual) validation - } - -searchInitial : Frequency -> List (String, Field) -searchInitial frequency = [ ("frequency", Field.string (toString frequency)) ] - -validation : Validation String Search -validation = - Validate.map2 Search - (Validate.field "name" (Validate.maybe Validate.string)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/LoggedIn/Home/Msg.elm b/src/client/LoggedIn/Home/Msg.elm deleted file mode 100644 index 69f15ad..0000000 --- a/src/client/LoggedIn/Home/Msg.elm +++ /dev/null @@ -1,13 +0,0 @@ -module LoggedIn.Home.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) - -type Msg = - NoOp - | UpdatePage Int - | SearchMsg Form.Msg diff --git a/src/client/LoggedIn/Home/Update.elm b/src/client/LoggedIn/Home/Update.elm deleted file mode 100644 index 06c2c7e..0000000 --- a/src/client/LoggedIn/Home/Update.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Update exposing - ( update - ) - -import Form exposing (Form) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import Model.Frequency as Frequency exposing (Frequency(..)) - -update : LoggedData -> Home.Msg -> Home.Model -> (Home.Model, Cmd Home.Msg) -update loggedData msg model = - case msg of - - Home.NoOp -> - ( model - , Cmd.none - ) - - Home.UpdatePage page -> - ( updatePage page model - , Cmd.none - ) - - Home.SearchMsg formMsg -> - let newModel = - case formMsg of - Form.Input "name" _ _ -> updatePage 1 model - _ -> model - in ( { model | search = Form.update Home.validation formMsg model.search } - , Cmd.none - ) - -updatePage : Int -> Home.Model -> Home.Model -updatePage page model = - let frequency = - Form.getFieldAsString "frequency" model.search - |> .value - |> Maybe.andThen Frequency.fromString - in case frequency of - Just Punctual -> { model | punctualPage = page } - Just Monthly -> { model | monthlyPage = page } - Nothing -> model diff --git a/src/client/LoggedIn/Home/View.elm b/src/client/LoggedIn/Home/View.elm deleted file mode 100644 index fba3f7c..0000000 --- a/src/client/LoggedIn/Home/View.elm +++ /dev/null @@ -1,43 +0,0 @@ -module LoggedIn.Home.View exposing - ( view - ) - -import Date -import Html exposing (..) -import Html.Attributes exposing (..) - -import Form -import Utils.Form as Form - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Header.View as Header -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Home.View.Paging as Paging -import LoggedIn.Home.View.Table as Table -import LoggedIn.Msg as LoggedInMsg -import Model.Payment as Payment -import Model.Frequency exposing (Frequency(..)) -import Msg exposing (Msg) - -view : LoggedData -> Home.Model -> Html Msg -view loggedData home = - let (name, frequency) = - case Form.getOutput home.search of - Just data -> (Maybe.withDefault "" data.name, data.frequency) - Nothing -> ("", Punctual) - payments = Payment.search name frequency loggedData.payments - page = - case frequency of - Punctual -> home.punctualPage - Monthly -> home.monthlyPage - in div - [ class "home" ] - [ Header.view loggedData home payments frequency - , Table.view loggedData home payments frequency page - , Paging.view - page - (List.length payments) - Msg.NoOp - (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage) - ] diff --git a/src/client/LoggedIn/Home/View/ExceedingPayers.elm b/src/client/LoggedIn/Home/View/ExceedingPayers.elm deleted file mode 100644 index 6f2439c..0000000 --- a/src/client/LoggedIn/Home/View/ExceedingPayers.elm +++ /dev/null @@ -1,45 +0,0 @@ -module LoggedIn.Home.View.ExceedingPayers exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.View.Format as Format - -import Model exposing (Model) -import Model.User exposing (getUserName) -import Model.Payment as Payment -import Model.Payer exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let payments = Payment.punctual loggedData.payments - exceedingPayers = getOrderedExceedingPayers loggedData.currentTime loggedData.users loggedData.incomes payments - in div - [ class "exceedingPayers" ] - ( if List.isEmpty exceedingPayers - then [ text <| getMessage loggedData.translations "PaymentsAreBalanced" ] - else (List.map (exceedingPayer loggedData) exceedingPayers) - ) - -exceedingPayer : LoggedData -> ExceedingPayer -> Html Msg -exceedingPayer loggedData payer = - span - [ class "exceedingPayer" ] - [ span - [ class "userName" ] - [ payer.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , span - [ class "amount" ] - [ text ("+ " ++ (Format.price loggedData.conf payer.amount)) ] - ] diff --git a/src/client/LoggedIn/Home/View/Paging.elm b/src/client/LoggedIn/Home/View/Paging.elm deleted file mode 100644 index dffe061..0000000 --- a/src/client/LoggedIn/Home/View/Paging.elm +++ /dev/null @@ -1,109 +0,0 @@ -module LoggedIn.Home.View.Paging exposing - ( view - ) - -import Color exposing (Color) - -import FontAwesome - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import LoggedData exposing (LoggedData) -import Model.Payment as Payment exposing (Payments, perPage) - -showedPages : Int -showedPages = 5 - -view : Int -> Int -> msg -> (Int -> msg) -> Html msg -view currentPage payments noOp pageMsg = - let maxPage = ceiling (toFloat payments / toFloat perPage) - pages = truncatePages currentPage (List.range 1 maxPage) - in if maxPage <= 1 - then - text "" - else - div - [ class "pages" ] - ( [ firstPage currentPage pageMsg - , previousPage currentPage noOp pageMsg - ] - ++ ( List.map (paymentsPage currentPage noOp pageMsg) pages) - ++ [ nextPage currentPage maxPage noOp pageMsg - , lastPage currentPage maxPage pageMsg - ] - ) - -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 then - (List.range 1 showedPages) - else if currentPage > totalPages - showedRightPages then - (List.range (totalPages - showedPages + 1) totalPages) - else - (List.range (currentPage - showedLeftPages) (currentPage + showedRightPages)) - in List.filter (flip List.member pages) truncatedPages - -firstPage : Int -> (Int -> msg) -> Html msg -firstPage currentPage pageMsg = - button - [ classList - [ ("page", True) - , ("disable", currentPage <= 1) - ] - , onClick (pageMsg 1) - ] - [ FontAwesome.fast_backward grey 13 ] - -previousPage : Int -> msg -> (Int -> msg) -> Html msg -previousPage currentPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage > 1 - then (pageMsg <| currentPage - 1) - else noOp - ] - [ FontAwesome.backward grey 13 ] - -nextPage : Int -> Int -> msg -> (Int -> msg) -> Html msg -nextPage currentPage maxPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage < maxPage - then (pageMsg <| currentPage + 1) - else noOp - ] - [ FontAwesome.forward grey 13 ] - -lastPage : Int -> Int -> (Int -> msg) -> Html msg -lastPage currentPage maxPage pageMsg = - button - [ class "page" - , onClick (pageMsg maxPage) - ] - [ FontAwesome.fast_forward grey 13 ] - -paymentsPage : Int -> msg -> (Int -> msg) -> Int -> Html msg -paymentsPage currentPage noOp pageMsg page = - let onCurrentPage = page == currentPage - in button - [ classList - [ ("page", True) - , ("current", onCurrentPage) - ] - , onClick <| - if onCurrentPage - then noOp - else pageMsg page - ] - [ text (toString page) ] - -grey : Color -grey = Color.greyscale 0.35 diff --git a/src/client/LoggedIn/Home/View/Table.elm b/src/client/LoggedIn/Home/View/Table.elm deleted file mode 100644 index f94bb19..0000000 --- a/src/client/LoggedIn/Home/View/Table.elm +++ /dev/null @@ -1,167 +0,0 @@ -module LoggedIn.Home.View.Table exposing - ( view - ) - -import Date exposing (Date) -import Dict exposing (..) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import LoggedIn.Home.Model as Home -import LoggedIn.View.Format as Format -import View.Date as Date - -import Model.Payment as Payment exposing (..) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) -import Model.User exposing (getUserName) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Int -> Html Msg -view loggedData homeModel payments frequency page = - let visiblePayments = - payments - |> List.drop ((page - 1) * perPage) - |> List.take perPage - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData frequency :: List.map (paymentLine loggedData homeModel frequency) visiblePayments ) - , if List.isEmpty visiblePayments - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoPayment" ] - else - text "" - ] - -headerLine : LoggedData -> Frequency -> Html Msg -headerLine loggedData frequency = - div - [ class "header" ] - [ div [ class "cell category" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell cost" ] [ text <| getMessage loggedData.translations "Cost" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "Payer" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "PaymentCategory" ] - , case frequency of - Punctual -> div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - Monthly -> text "" - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> Home.Model -> Frequency -> Payment -> Html Msg -paymentLine loggedData homeModel frequency payment = - div - [ class "row" ] - [ div [ class "cell name" ] [ text payment.name ] - , div - [ classList - [ ("cell cost", True) - , ("refund", payment.cost < 0) - ] - ] - [ text (Format.price loggedData.conf payment.cost) ] - , div - [ class "cell user" ] - [ payment.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell category" ] - ( let mbCategory = - PaymentCategory.search payment.name loggedData.paymentCategories - |> Maybe.andThen (\category -> Dict.get category loggedData.categories) - in case mbCategory of - Just category -> - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.name ] - ] - Nothing -> - [] - ) - , case frequency of - Punctual -> - div - [ class "cell date" ] - [ span - [ class "shortDate" ] - [ text (Date.shortView payment.date loggedData.translations) ] - , span - [ class "longDate" ] - [ text (Date.longView payment.date loggedData.translations) ] - ] - Monthly -> - text "" - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialClone loggedData.translations currentDate category payment) - "ClonePayment" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialEdit loggedData.translations category payment) - "EditPayment" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let dialogConfig = - { className = "deletePaymentDialog" - , title = getMessage loggedData.translations "ConfirmPaymentDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeletePayment payment.id - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/Table.elm b/src/client/LoggedIn/Income/Table.elm deleted file mode 100644 index f10a552..0000000 --- a/src/client/LoggedIn/Income/Table.elm +++ /dev/null @@ -1,128 +0,0 @@ -module LoggedIn.Income.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Income as Income exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let incomes = - loggedData.incomes - |> Dict.toList - |> List.sortBy (.time << Tuple.second) - |> List.reverse - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) incomes) - , if List.isEmpty (Dict.toList loggedData.incomes) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoIncome" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell income" ] [ text <| getMessage loggedData.translations "Income" ] - , div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (IncomeId, Income) -> Html Msg -paymentLine loggedData (incomeId, income) = - div - [ class "row" ] - [ div - [ class "cell name" ] - [ income.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell income" ] - [ text (Format.price loggedData.conf income.amount) ] - , div - [ class "cell date" ] - [ text (Date.longView (Date.fromTime income.time) loggedData.translations) ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddIncome.button - loggedData - (AddIncome.initialClone loggedData.translations currentDate income) - "CloneIncome" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - AddIncome.button - loggedData - (AddIncome.initialEdit loggedData.translations incomeId income) - "EditIncome" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/View.elm b/src/client/LoggedIn/Income/View.elm deleted file mode 100644 index 85b0dc3..0000000 --- a/src/client/LoggedIn/Income/View.elm +++ /dev/null @@ -1,104 +0,0 @@ -module LoggedIn.Income.View exposing - ( view - ) - -import Dict -import Date -import Time exposing (Time) -import Task - -import FontAwesome - -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Income exposing (IncomeId, Income, userCumulativeIncomeSince) -import Model.Translations exposing (getMessage, getParamMessage) -import Model.Payer exposing (useIncomesFrom) -import Model.User exposing (UserId, User) -import Model.View as View - -import View.Date as Date -import LoggedIn.View.Format as Format -import View.Color as Color -import LoggedIn.Income.Table as Table - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "income" ] - [ div - [ class "withMargin" ] - [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of - Just since -> cumulativeIncomesView loggedData since - Nothing -> text "" - , div - [ class "titleButton" ] - [ h1 [] [ text <| getMessage loggedData.translations "MonthlyNetIncomes" ] - , AddIncome.button - loggedData - (AddIncome.initialAdd loggedData.translations (Date.fromTime loggedData.currentTime)) - "AddIncome" - (text (getMessage loggedData.translations "AddIncome")) - Nothing - ] - ] - , Table.view loggedData - ] - -cumulativeIncomesView : LoggedData -> Time -> Html Msg -cumulativeIncomesView loggedData since = - let longDate = Date.longView (Date.fromTime since) loggedData.translations - in div - [] - [ h1 [] [ text <| getParamMessage [longDate] loggedData.translations "CumulativeIncomesSince" ] - , ul - [] - ( Dict.toList loggedData.users - |> List.map (\(userId, user) -> - (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId) - ) - |> List.sortBy Tuple.second - |> List.map (\(userName, cumulativeIncome) -> - li - [] - [ text userName - , text " − " - , text <| Format.price loggedData.conf cumulativeIncome - ] - ) - ) - ] - -incomeView : LoggedData -> (IncomeId, Income) -> Html Msg -incomeView loggedData (incomeId, income) = - li - [] - [ text <| Date.shortView (Date.fromTime income.time) loggedData.translations - , text " − " - , text <| Format.price loggedData.conf income.amount - , let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - [ FontAwesome.trash Color.chestnutRose 14 ] - ] diff --git a/src/client/LoggedIn/Model.elm b/src/client/LoggedIn/Model.elm deleted file mode 100644 index f4fad94..0000000 --- a/src/client/LoggedIn/Model.elm +++ /dev/null @@ -1,38 +0,0 @@ -module LoggedIn.Model exposing - ( Model - , init - ) - -import Time exposing (Time) - -import LoggedIn.Home.Model as Home -import LoggedIn.Stat.Model as Stat -import Model.Category exposing (Categories) -import Model.Income exposing (Incomes) -import Model.Init exposing (..) -import Model.Payment exposing (Payments) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.User exposing (Users, UserId) - -type alias Model = - { home : Home.Model - , stat : Stat.Model - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -init : Time -> Init -> Model -init time { users, me, payments, incomes, categories, paymentCategories } = - { home = Home.init - , stat = Stat.init time paymentCategories payments - , users = users - , me = me - , payments = payments - , incomes = incomes - , categories = categories - , paymentCategories = paymentCategories - } diff --git a/src/client/LoggedIn/Msg.elm b/src/client/LoggedIn/Msg.elm deleted file mode 100644 index d9b3bce..0000000 --- a/src/client/LoggedIn/Msg.elm +++ /dev/null @@ -1,26 +0,0 @@ -module LoggedIn.Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) - -import LoggedIn.Home.Msg as Home -import LoggedIn.Stat.Msg as Stat -import Model.Category exposing (CategoryId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Payment exposing (PaymentId) - -type Msg = - NoOp - | HomeMsg Home.Msg - | StatMsg Stat.Msg - | ValidateCreatePayment PaymentId String Int Date CategoryId Frequency - | ValidateEditPayment PaymentId String Int Date CategoryId Frequency - | ValidateDeletePayment PaymentId - | ValidateCreateIncome IncomeId Int Date - | ValidateEditIncome IncomeId Int Date - | ValidateDeleteIncome IncomeId - | ValidateCreateCategory CategoryId String String - | ValidateEditCategory CategoryId String String - | ValidateDeleteCategory CategoryId diff --git a/src/client/LoggedIn/Stat/Model.elm b/src/client/LoggedIn/Stat/Model.elm deleted file mode 100644 index bfc66f2..0000000 --- a/src/client/LoggedIn/Stat/Model.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Stat.Model exposing - ( Model - , init - , getPaymentsByMonthByCategory - ) - -import Date exposing (Month) -import List.Extra as List -import Time exposing (Time) - -import Model.Category exposing (CategoryId) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -type alias Model = - { paymentsByMonthByCategory : List ((Month, Int), List (CategoryId, Int)) - } - -init : Time -> PaymentCategories -> Payments -> Model -init currentTime paymentCategories payments = - { paymentsByMonthByCategory = getPaymentsByMonthByCategory currentTime paymentCategories payments - } - -getPaymentsByMonthByCategory : Time -> PaymentCategories -> Payments -> List ((Month, Int), List (CategoryId, Int)) -getPaymentsByMonthByCategory currentTime paymentCategories payments = - Payment.punctual payments - |> Payment.groupAndSortByMonth - |> List.map (\(m, payments) -> - ( m - , PaymentCategory.groupPaymentsByCategory paymentCategories payments - |> List.map (Tuple.mapSecond (List.sum << List.map .cost)) - ) - ) diff --git a/src/client/LoggedIn/Stat/Msg.elm b/src/client/LoggedIn/Stat/Msg.elm deleted file mode 100644 index d517544..0000000 --- a/src/client/LoggedIn/Stat/Msg.elm +++ /dev/null @@ -1,7 +0,0 @@ -module LoggedIn.Stat.Msg exposing - ( Msg(..) - ) - -type Msg = - NoOp - | UpdateChart diff --git a/src/client/LoggedIn/Stat/Update.elm b/src/client/LoggedIn/Stat/Update.elm deleted file mode 100644 index 2415733..0000000 --- a/src/client/LoggedIn/Stat/Update.elm +++ /dev/null @@ -1,24 +0,0 @@ -module LoggedIn.Stat.Update exposing - ( update - ) - -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat - -update : LoggedData -> Stat.Msg -> Stat.Model -> (Stat.Model, Cmd Stat.Msg) -update loggedData msg model = - case msg of - - Stat.NoOp -> - ( model - , Cmd.none - ) - - Stat.UpdateChart -> - let { currentTime, paymentCategories, payments } = loggedData - in ( { model - | paymentsByMonthByCategory = Stat.getPaymentsByMonthByCategory currentTime paymentCategories payments - } - , Cmd.none - ) diff --git a/src/client/LoggedIn/Stat/View.elm b/src/client/LoggedIn/Stat/View.elm deleted file mode 100644 index e389c67..0000000 --- a/src/client/LoggedIn/Stat/View.elm +++ /dev/null @@ -1,77 +0,0 @@ -module LoggedIn.Stat.View exposing - ( view - ) - -import Date exposing (Month) -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import List.Extra as List -import Time exposing (Time) - -import Chart.Api as Chart -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.View.Format as Format -import Model.Category exposing (CategoryId, Categories) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (Translations, getMessage, getParamMessage) -import Msg exposing (Msg) -import Utils.List as List -import View.Date as Date -import View.Plural exposing (plural) - -view : LoggedData -> Stat.Model -> Html Msg -view loggedData { paymentsByMonthByCategory } = - div - [ class "stat withMargin" ] - [ renderChart loggedData paymentsByMonthByCategory ] - -renderChart : LoggedData -> List ((Month, Int), List (CategoryId, Int)) -> Html msg -renderChart { currentTime, paymentCategories, categories, conf, translations } paymentsByMonthByCategory = - let monthPaymentMean = getMonthPaymentMean currentTime paymentsByMonthByCategory - title = getParamMessage [ Format.price conf monthPaymentMean ] translations "ByMonthsAndMean" - keys = - paymentsByMonthByCategory - |> List.map (\((month, year), _) -> Date.shortMonthAndYear month year translations) - series = - categories - |> Dict.toList - |> List.map (\(categoryId, category) -> - { values = - List.map - (\(_, paymentsByCategory) -> - paymentsByCategory - |> List.find (\(c, _) -> c == categoryId) - |> Maybe.map (toFloat << Tuple.second) - |> Maybe.withDefault 0 - ) - paymentsByMonthByCategory - , color = category.color - , label = category.name - } - ) - totalSerie = - { values = - List.transpose (List.map .values series) - |> List.map List.sum - , color = "black" - , label = getMessage translations "Total" - } - in Chart.from keys (series ++ [totalSerie]) - |> Chart.withSize { x = 2000, y = 900 } - |> Chart.withTitle title - |> Chart.withOrdinate 10 (Format.price conf << truncate) - |> Chart.toHtml - -getMonthPaymentMean : Time -> List ((Month, Int), List (CategoryId, Int)) -> Int -getMonthPaymentMean currentTime paymentsByMonthByCategory = - paymentsByMonthByCategory - |> List.filter (\((month, year), _) -> - let currentDate = Date.fromTime currentTime - in not (Date.month currentDate == month && Date.year currentDate == year) - ) - |> List.map (List.sum << List.map Tuple.second << Tuple.second) - |> List.mean diff --git a/src/client/LoggedIn/Update.elm b/src/client/LoggedIn/Update.elm deleted file mode 100644 index a1d5f7d..0000000 --- a/src/client/LoggedIn/Update.elm +++ /dev/null @@ -1,137 +0,0 @@ -module LoggedIn.Update exposing - ( update - ) - -import Date exposing (Date) -import Dict -import Form -import Http exposing (Error(..)) -import Platform.Cmd exposing (Cmd) -import String -import Task - -import LoggedData -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import LoggedIn.Home.Update as Home -import LoggedIn.Model as LoggedInModel -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Stat.Update as Stat -import Model exposing (Model) -import Model.Category exposing (Category) -import Model.Frequency exposing (Frequency(..)) -import Model.Income as Income exposing (Income) -import Model.Payment as Payment exposing (Payment) -import Model.PaymentCategory as PaymentCategory -import Server - -import Utils.Cmd exposing ((:>)) - -update : Model -> LoggedIn.Msg -> LoggedInModel.Model -> (LoggedInModel.Model, Cmd LoggedIn.Msg) -update model msg loggedIn = - let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case msg of - - LoggedIn.NoOp -> - ( loggedIn - , Cmd.none - ) - - LoggedIn.HomeMsg homeMsg -> - case Home.update loggedData homeMsg loggedIn.home of - (home, effects) -> - ( { loggedIn | home = home } - , Cmd.map LoggedIn.HomeMsg effects - ) - - LoggedIn.StatMsg statMsg -> - case Stat.update loggedData statMsg loggedIn.stat of - (stat, effects) -> - ( { loggedIn | stat = stat } - , Cmd.map LoggedIn.StatMsg effects - ) - - LoggedIn.ValidateCreatePayment paymentId name cost date category frequency -> - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial frequency))) loggedIn - :> update model (LoggedIn.HomeMsg <| Home.UpdatePage 1) - :> (\loggedIn -> - let newPayment = Payment paymentId name cost date loggedIn.me frequency - in ( { loggedIn - | payments = newPayment :: loggedIn.payments - , paymentCategories = PaymentCategory.save name category loggedIn.paymentCategories - } - , Cmd.none - ) - ) - - LoggedIn.ValidateEditPayment paymentId name cost date category frequency -> - let updatedPayment = Payment paymentId name cost date loggedIn.me frequency - mbOldPayment = Payment.find paymentId loggedIn.payments - in ( { loggedIn - | payments = Payment.edit updatedPayment loggedIn.payments - , paymentCategories = - case mbOldPayment of - Just oldPayment -> - PaymentCategory.save name category loggedIn.paymentCategories - Nothing -> - loggedData.paymentCategories - } - , Cmd.none - ) - - LoggedIn.ValidateDeletePayment paymentId -> - let payments = Payment.delete paymentId loggedIn.payments - frequency = - case Form.getOutput loggedIn.home.search of - Just data -> data.frequency - Nothing -> Punctual - switchToPunctual = - ( frequency == Monthly - && List.isEmpty (Payment.monthly payments) - ) - in if switchToPunctual - then - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial Punctual))) loggedIn - :> (\loggedIn -> - ( { loggedIn | payments = payments } - , Cmd.none - ) - ) - else - ( { loggedIn | payments = payments } - , Cmd.none - ) - - LoggedIn.ValidateCreateIncome incomeId amount date -> - let newIncome = { userId = loggedIn.me, amount = amount, time = Date.toTime date } - in ( { loggedIn | incomes = Dict.insert incomeId newIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateEditIncome incomeId amount date -> - let updateIncome _ = Just <| Income loggedIn.me (Date.toTime date) amount - in ( { loggedIn | incomes = Dict.update incomeId updateIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateDeleteIncome incomeId -> - ( { loggedIn | incomes = Dict.remove incomeId loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateCreateCategory categoryId name color -> - let newCategory = { name = name, color = color } - in ( { loggedIn | categories = Dict.insert categoryId newCategory loggedIn.categories } - , Cmd.none - ) - - LoggedIn.ValidateEditCategory categoryId name color -> - let updateCategory _ = Just <| Category name color - in ( { loggedIn | categories = Dict.update categoryId updateCategory loggedIn.categories } , Cmd.none) - - LoggedIn.ValidateDeleteCategory categoryId -> - ( { loggedIn | categories = Dict.remove categoryId loggedIn.categories } - , Cmd.none - ) diff --git a/src/client/LoggedIn/View.elm b/src/client/LoggedIn/View.elm deleted file mode 100644 index 4936c6e..0000000 --- a/src/client/LoggedIn/View.elm +++ /dev/null @@ -1,33 +0,0 @@ -module LoggedIn.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Page - -import Msg exposing (Msg) -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import LoggedData - -import LoggedIn.Model as LoggedInModel - -import LoggedIn.Home.View as Home -import LoggedIn.Income.View as Income -import LoggedIn.Category.View as Categories -import LoggedIn.Stat.View as Stat - -view : Model -> LoggedInModel.Model -> Html Msg -view model loggedIn = - div - [ class "loggedIn" ] - [ let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case model.page of - Page.Home -> Home.view loggedData loggedIn.home - Page.Income -> Income.view loggedData - Page.Categories -> Categories.view loggedData - Page.Statistics -> Stat.view loggedData loggedIn.stat - Page.NotFound -> div [] [ text (getMessage model.translations "PageNotFound") ] - ] diff --git a/src/client/LoggedIn/View/Format.elm b/src/client/LoggedIn/View/Format.elm deleted file mode 100644 index f41e2cd..0000000 --- a/src/client/LoggedIn/View/Format.elm +++ /dev/null @@ -1,37 +0,0 @@ -module LoggedIn.View.Format exposing - ( price - ) - -import String exposing (..) - -import Model.Conf exposing (Conf) - -price : Conf -> Int -> String -price conf amount = - ( number amount - ++ " " - ++ conf.currency - ) - -number : Int -> String -number 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/Main.elm b/src/client/Main.elm deleted file mode 100644 index 7981a1c..0000000 --- a/src/client/Main.elm +++ /dev/null @@ -1,26 +0,0 @@ -module Main exposing - ( main - ) - -import Navigation -import Time -import Msg exposing (Msg(UpdatePage)) - -import Model exposing (init) -import Update exposing (update) -import View exposing (view) -import Page -import Tooltip - -main = - Navigation.programWithFlags (UpdatePage << Page.fromLocation) - { init = init - , view = view - , update = update - , subscriptions = (\model -> - Sub.batch - [ Time.every 60000 Msg.UpdateTime - , Sub.map Msg.Tooltip Tooltip.subscription - ] - ) - } diff --git a/src/client/Main.hs b/src/client/Main.hs new file mode 100644 index 0000000..c5f2c50 --- /dev/null +++ b/src/client/Main.hs @@ -0,0 +1,41 @@ +module Main + ( main + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import Data.JSString.Text (textFromJSString) +import qualified Data.Text.Encoding as T +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.NonElementParentNode as Dom +import GHCJS.DOM.Types (JSM, Element, JSString) +import Prelude hiding (init, error) + +import Common.Model (InitResult(InitEmpty)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import qualified View.App as App + +main :: JSM () +main = do + initResult <- readInit + putStrLn . show $ initResult + App.widget initResult + +readInit :: JSM InitResult +readInit = do + document <- Dom.currentDocumentUnchecked + initNode <- Dom.getElementById document "init" + case initNode of + Just node -> do + text <- textFromJSString <$> js_getInnerText node + return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of + Just init -> init + Nothing -> initParseError + _ -> + return initParseError + where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + +foreign import javascript unsafe "$1[\"innerText\"]" + js_getInnerText :: Element -> IO JSString diff --git a/src/client/Model.elm b/src/client/Model.elm deleted file mode 100644 index 7f62416..0000000 --- a/src/client/Model.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Model exposing - ( Model - , init - ) - -import Time exposing (Time) -import Json.Decode as Decode - -import Navigation exposing (Location) - -import Html as Html - -import Page exposing (Page) -import Init as Init exposing (Init) -import Msg exposing (Msg) - -import Model.View exposing (..) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import LoggedIn.Model as LoggedInModel -import SignIn.Model as SignInModel - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -type alias Model = - { view : View - , currentTime : Time - , translations : Translations - , conf : Conf - , page : Page - , errors : List String - , dialog : Dialog.Model DialogModel.Model DialogMsg.Msg Msg - , tooltip : Tooltip.Model - } - -init : Decode.Value -> Location -> (Model, Cmd Msg) -init payload location = - let model = - case Decode.decodeValue Init.decoder payload of - Ok { time, translations, conf, result, windowSize } -> - { view = - case result of - InitEmpty -> - SignInView (SignInModel.init Nothing) - InitSuccess init -> - LoggedInView (LoggedInModel.init time init) - InitError error -> - SignInView (SignInModel.init (Just error)) - , currentTime = time - , translations = translations - , conf = conf - , page = Page.fromLocation location - , errors = [] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init windowSize.width windowSize.height - } - Err error -> - { view = SignInView (SignInModel.init (Just error)) - , currentTime = 0 - , translations = [] - , conf = { currency = "" } - , page = Page.fromLocation location - , errors = [ error ] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init 0 0 - } - in (model, Cmd.none) diff --git a/src/client/Model/Category.elm b/src/client/Model/Category.elm deleted file mode 100644 index 8b653a7..0000000 --- a/src/client/Model/Category.elm +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Category exposing - ( Categories - , Category - , CategoryId - , categoriesDecoder - , categoryIdDecoder - , empty - ) - -import Json.Decode as Decode exposing (Decoder) -import Utils.Json as Json -import Dict exposing (Dict) - -type alias Categories = Dict CategoryId Category - -type alias CategoryId = Int - -type alias Category = - { name : String - , color : String - } - -categoriesDecoder : Decoder Categories -categoriesDecoder = - Json.dictDecoder (Decode.field "id" categoryIdDecoder) <| - Decode.map2 - Category - (Decode.field "name" Decode.string) - (Decode.field "color" Decode.string) - -categoryIdDecoder : Decoder CategoryId -categoryIdDecoder = Decode.int - -empty : Categories -empty = Dict.empty diff --git a/src/client/Model/Conf.elm b/src/client/Model/Conf.elm deleted file mode 100644 index 308fa04..0000000 --- a/src/client/Model/Conf.elm +++ /dev/null @@ -1,13 +0,0 @@ -module Model.Conf exposing - ( Conf - , confDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Conf = - { currency : String - } - -confDecoder : Decoder Conf -confDecoder = Decode.map Conf (Decode.field "currency" Decode.string) diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm deleted file mode 100644 index bfba02f..0000000 --- a/src/client/Model/Date.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Model.Date exposing - ( timeDecoder - , dateDecoder - ) - -import Date as Date exposing (Date) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import Time exposing (Time) - -timeDecoder : Decoder Time -timeDecoder = Decode.map Date.toTime dateDecoder - -dateDecoder : Decoder Date -dateDecoder = Decode.string |> Decode.andThen (Date.fromString >> Decode.fromResult) diff --git a/src/client/Model/Frequency.elm b/src/client/Model/Frequency.elm deleted file mode 100644 index 40f9893..0000000 --- a/src/client/Model/Frequency.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Model.Frequency exposing - ( Frequency(..) - , decoder - , validate - , fromString - ) - -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode - -import Form.Validate as Validate exposing (Validation) - -type Frequency = Punctual | Monthly - -decoder : Decoder Frequency -decoder = - let frequencyResult input = - fromString input - |> Result.fromMaybe ("Could not deduce Punctual nor Monthly from " ++ input) - in Decode.string |> Decode.andThen (Decode.fromResult << frequencyResult) - -validate : Validation String Frequency -validate = - Validate.customValidation Validate.string (\str -> - fromString str - |> Result.fromMaybe (Validate.customError "InvalidFrequency") - ) - -fromString : String -> Maybe Frequency -fromString str = - if str == toString Punctual then - Just Punctual - else if str == toString Monthly then - Just Monthly - else - Nothing diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm deleted file mode 100644 index aa5f05f..0000000 --- a/src/client/Model/Income.elm +++ /dev/null @@ -1,101 +0,0 @@ -module Model.Income exposing - ( Incomes - , Income - , IncomeId - , incomesDecoder - , incomeIdDecoder - , incomeDefinedForAll - , userCumulativeIncomeSince - , cumulativeIncomesSince - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List exposing (..) -import Maybe.Extra as Maybe -import Time exposing (Time, hour) -import Utils.Json as Json - -import Model.Date exposing (timeDecoder) -import Model.User exposing (UserId, userIdDecoder) - -type alias Incomes = Dict IncomeId Income - -type alias IncomeId = Int - -type alias Income = - { userId : UserId - , time : Float - , amount : Int - } - -incomesDecoder : Decoder Incomes -incomesDecoder = - Json.dictDecoder (Decode.field "id" incomeIdDecoder) <| - Decode.map3 Income - (Decode.field "userId" userIdDecoder) - (Decode.field "date" timeDecoder) - (Decode.field "amount" Decode.int) - -incomeIdDecoder : Decoder IncomeId -incomeIdDecoder = Decode.int - -incomeDefinedForAll : List UserId -> Incomes -> Maybe Time -incomeDefinedForAll userIds incomes = - let userIncomes = List.map (\userId -> List.filter ((==) userId << .userId) << Dict.values <| incomes) userIds - firstIncomes = map (head << sortBy .time) userIncomes - in if all Maybe.isJust firstIncomes - then head << reverse << List.sort << map .time << Maybe.values <| firstIncomes - else Nothing - -userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int -userCumulativeIncomeSince currentTime since incomes userId = - incomes - |> Dict.values - |> List.filter (\income -> income.userId == userId) - |> cumulativeIncomesSince currentTime since - -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 = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> income.time >= time) incomes - in (Maybe.toList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt : Time -> List Income -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if x.time < time - then Just { userId = x.userId, time = time, amount = x.amount } - else Nothing - x1 :: x2 :: xs -> - if x1.time < time && x2.time >= time - then Just { userId = x1.userId, time = time, amount = x1.amount } - else getIncomeAt time (x2 :: xs) - [] -> - Nothing - -cumulativeIncome : Time -> List Income -> Int -cumulativeIncome currentTime incomes = - getIncomesWithDuration currentTime (List.sortBy .time incomes) - |> map durationIncome - |> sum - -getIncomesWithDuration : Time -> List Income -> List (Float, Int) -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(currentTime - income.time, income.amount)] - (income1 :: income2 :: xs) -> - (income2.time - income1.time, income1.amount) :: (getIncomesWithDuration currentTime (income2 :: xs)) - -durationIncome : (Float, Int) -> Int -durationIncome (duration, income) = - duration * toFloat income / (hour * 24 * 365 / 12) - |> truncate diff --git a/src/client/Model/Init.elm b/src/client/Model/Init.elm deleted file mode 100644 index db7069f..0000000 --- a/src/client/Model/Init.elm +++ /dev/null @@ -1,31 +0,0 @@ -module Model.Init exposing - ( Init - , initDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Payment exposing (Payments, paymentsDecoder) -import Model.User exposing (Users, UserId, usersDecoder, userIdDecoder) -import Model.Income exposing (Incomes, incomesDecoder) -import Model.Category exposing (Categories, categoriesDecoder) -import Model.PaymentCategory exposing (PaymentCategories, paymentCategoriesDecoder) - -type alias Init = - { users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -initDecoder : Decoder Init -initDecoder = - Decode.map6 Init - (Decode.field "users" usersDecoder) - (Decode.field "me" userIdDecoder) - (Decode.field "payments" paymentsDecoder) - (Decode.field "incomes" incomesDecoder) - (Decode.field "categories" categoriesDecoder) - (Decode.field "paymentCategories" paymentCategoriesDecoder) diff --git a/src/client/Model/InitResult.elm b/src/client/Model/InitResult.elm deleted file mode 100644 index 7ce0be2..0000000 --- a/src/client/Model/InitResult.elm +++ /dev/null @@ -1,28 +0,0 @@ -module Model.InitResult exposing - ( InitResult(..) - , initResultDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Init exposing (Init, initDecoder) - -type InitResult = - InitEmpty - | InitSuccess Init - | InitError String - -initResultDecoder : Decoder InitResult -initResultDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen initResultDecoderWithTag - -initResultDecoderWithTag : String -> Decoder InitResult -initResultDecoderWithTag tag = - case tag of - "InitEmpty" -> - Decode.succeed InitEmpty - "InitSuccess" -> - Decode.map InitSuccess (Decode.field "contents" initDecoder) - "InitError" -> - Decode.map InitError (Decode.field "contents" Decode.string) - _ -> - Decode.fail <| "got " ++ tag ++ " for InitResult" diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm deleted file mode 100644 index 4d9190e..0000000 --- a/src/client/Model/Payer.elm +++ /dev/null @@ -1,137 +0,0 @@ -module Model.Payer exposing - ( Payers - , Payer - , ExceedingPayer - , getOrderedExceedingPayers - , useIncomesFrom - ) - -import Dict exposing (..) -import List -import Maybe -import Time exposing (Time) -import Date - -import Model.Payment exposing (Payments, totalPayments) -import Model.User exposing (Users, UserId, userIdDecoder) -import Model.Income exposing (..) - -import Utils.Dict exposing (mapValues) - -type alias Payers = Dict UserId Payer - -type alias Payer = - { preIncomePaymentSum : Int - , postIncomePaymentSum : Int - , incomes : List Income - } - -type alias PostPaymentPayer = - { preIncomePaymentSum : Int - , cumulativeIncome : Int - , ratio : Float - } - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer -getOrderedExceedingPayers currentTime users incomes payments = - let payers = getPayers currentTime users incomes payments - exceedingPayersOnPreIncome = - payers - |> mapValues .preIncomePaymentSum - |> Dict.toList - |> exceedingPayersFromAmounts - mbSince = useIncomesFrom users incomes payments - in case mbSince of - Just since -> - let postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - postPaymentPayers - |> Dict.toList - |> List.map (.ratio << Tuple.second) - |> List.maximum - in case mbMaxRatio of - Just maxRatio -> - postPaymentPayers - |> mapValues (getFinalDiff maxRatio) - |> Dict.toList - |> exceedingPayersFromAmounts - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom : Users -> Incomes -> Payments -> Maybe Time -useIncomesFrom users incomes payments = - let firstPaymentTime = - payments - |> List.map (Date.toTime << .date) - |> List.sort - |> List.head - mbIncomeTime = incomeDefinedForAll (Dict.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just paymentTime, Just incomeTime) -> - Just (max paymentTime incomeTime) - _ -> - Nothing - -getPayers : Time -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Dict.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in userIds - |> List.map (\userId -> - ( userId - , { preIncomePaymentSum = - totalPayments - (\p -> (Date.toTime p.date) < (Maybe.withDefault currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> (Date.toTime p.date) >= t - ) - userId - payments - , incomes = List.filter ((==) userId << .userId) (Dict.values incomes) - } - ) - ) - |> Dict.fromList - -exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer -exceedingPayersFromAmounts userAmounts = - let mbMinAmount = List.minimum << List.map Tuple.second <| userAmounts - in case mbMinAmount of - Nothing -> - [] - Just minAmount -> - userAmounts - |> List.map (\userAmount -> - { userId = Tuple.first userAmount - , amount = Tuple.second userAmount - minAmount - } - ) - |> List.filter (\payer -> payer.amount > 0) - -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 204f9f5..0000000 --- a/src/client/Model/Payment.elm +++ /dev/null @@ -1,117 +0,0 @@ -module Model.Payment exposing - ( perPage - , Payments - , Payment - , PaymentId - , paymentsDecoder - , paymentIdDecoder - , find - , edit - , delete - , totalPayments - , punctual - , monthly - , groupAndSortByMonth - , search - ) - -import Date exposing (..) -import Date.Extra.Core exposing (monthToInt, intToMonth) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import List -import List.Extra as List - -import Form.Validate as Validate exposing (Validation) -import Model.Date exposing (dateDecoder) -import Model.Frequency as Frequency exposing (Frequency(..)) -import Model.User exposing (UserId, userIdDecoder) -import Utils.List as List -import Utils.Search as Search - -perPage : Int -perPage = 7 - -type alias Payments = List Payment - -type alias Payment = - { id : PaymentId - , name : String - , cost : Int - , date : Date - , userId : UserId - , frequency : Frequency - } - -type alias PaymentId = Int - -paymentsDecoder : Decoder Payments -paymentsDecoder = Decode.list paymentDecoder - -paymentDecoder : Decoder Payment -paymentDecoder = - Decode.map6 Payment - (Decode.field "id" paymentIdDecoder) - (Decode.field "name" Decode.string) - (Decode.field "cost" Decode.int) - (Decode.field "date" dateDecoder) - (Decode.field "userId" userIdDecoder) - (Decode.field "frequency" Frequency.decoder) - -paymentIdDecoder : Decoder PaymentId -paymentIdDecoder = Decode.int - -find : PaymentId -> Payments -> Maybe Payment -find paymentId payments = - payments - |> List.find (\p -> p.id == paymentId) - -edit : Payment -> Payments -> Payments -edit payment payments = payment :: delete payment.id payments - -delete : PaymentId -> Payments -> Payments -delete paymentId = List.filter (((/=) paymentId) << .id) - -totalPayments : (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - payments - |> List.filter (\payment -> - paymentFilter payment - && payment.userId == userId - ) - |> List.map .cost - |> List.sum - -punctual : Payments -> Payments -punctual = List.filter ((==) Punctual << .frequency) - -monthly : Payments -> Payments -monthly = List.filter ((==) Monthly << .frequency) - -groupAndSortByMonth : Payments -> List ((Month, Int), Payments) -groupAndSortByMonth payments = - payments - |> List.groupBy (\payment -> (Date.year payment.date, monthToInt << Date.month <| payment.date)) - |> List.sortBy Tuple.first - |> List.map (\((year, month), payments) -> ((intToMonth month, year), payments)) - -search : String -> Frequency -> Payments -> Payments -search name frequency payments = - payments - |> List.filter ((==) frequency << .frequency) - |> paymentSort frequency - |> List.filter (searchSuccess name) - -paymentSort : Frequency -> Payments -> Payments -paymentSort frequency = - case frequency of - Punctual -> List.reverse << List.sortBy (Date.toTime << .date) - Monthly -> List.sortBy (String.toLower << .name) - -searchSuccess : String -> Payment -> Bool -searchSuccess search { name, cost } = - let searchSuccessWord word = - ( String.contains (Search.format word) (Search.format name) - || String.contains word (toString cost) - ) - in List.all searchSuccessWord (String.words search) diff --git a/src/client/Model/PaymentCategory.elm b/src/client/Model/PaymentCategory.elm deleted file mode 100644 index a4fceb1..0000000 --- a/src/client/Model/PaymentCategory.elm +++ /dev/null @@ -1,61 +0,0 @@ -module Model.PaymentCategory exposing - ( PaymentCategories - , paymentCategoriesDecoder - , search - , groupPaymentsByCategory - , isCategoryUnused - , save - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List.Extra as List -import Maybe.Extra as Maybe - -import Model.Category exposing (CategoryId, categoryIdDecoder) -import Model.Payment exposing (Payments) -import Utils.Json as Json -import Utils.List as List -import Utils.Search as Search - -type alias PaymentCategories = List PaymentCategory - -type alias PaymentCategory = - { name : String - , category : CategoryId - } - -paymentCategoriesDecoder : Decoder PaymentCategories -paymentCategoriesDecoder = - Decode.list <| Decode.map2 PaymentCategory - (Decode.field "name" Decode.string) - (Decode.field "category" categoryIdDecoder) - -groupPaymentsByCategory : PaymentCategories -> Payments -> List (CategoryId, Payments) -groupPaymentsByCategory paymentCategories payments = - payments - |> List.groupBy (\payment -> - search payment.name paymentCategories - |> Maybe.withDefault -1 - ) - |> List.filterMap (\(category, payments) -> - case category of - -1 -> Nothing - _ -> Just (category, payments) - ) - -search : String -> PaymentCategories -> Maybe CategoryId -search paymentName paymentCategories = - paymentCategories - |> List.find (\pc -> Search.format pc.name == Search.format paymentName) - |> Maybe.map .category - -isCategoryUnused : CategoryId -> PaymentCategories -> Bool -isCategoryUnused category paymentCategories = - paymentCategories - |> List.find ((==) category << .category) - |> Maybe.isNothing - -save : String -> CategoryId -> PaymentCategories -> PaymentCategories -save name category paymentCategories = - { name = name, category = category } :: List.filter (\pc -> not <| Search.format pc.name == Search.format name) paymentCategories diff --git a/src/client/Model/Size.elm b/src/client/Model/Size.elm deleted file mode 100644 index f40fb01..0000000 --- a/src/client/Model/Size.elm +++ /dev/null @@ -1,17 +0,0 @@ -module Model.Size exposing - ( Size - , sizeDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Size = - { width: Int - , height: Int - } - -sizeDecoder : Decoder Size -sizeDecoder = - Decode.map2 Size - (Decode.field "width" Decode.int) - (Decode.field "height" Decode.int) diff --git a/src/client/Model/Translations.elm b/src/client/Model/Translations.elm deleted file mode 100644 index 9b314e1..0000000 --- a/src/client/Model/Translations.elm +++ /dev/null @@ -1,68 +0,0 @@ -module Model.Translations exposing - ( translationsDecoder - , Translations - , Translation - , getMessage - , getParamMessage - ) - -import Maybe exposing (withDefault) -import Json.Decode as Decode exposing (Decoder) -import String - -type alias Translations = List Translation - -translationsDecoder : Decoder Translations -translationsDecoder = Decode.list translationDecoder - -type alias Translation = - { key : String - , message : List MessagePart - } - -getTranslation : String -> Translations -> Maybe (List MessagePart) -getTranslation key translations = - translations - |> List.filter (\translation -> String.toLower translation.key == String.toLower key) - |> List.head - |> Maybe.map .message - -translationDecoder : Decoder Translation -translationDecoder = - Decode.map2 Translation - (Decode.field "key" Decode.string) - (Decode.field "message" (Decode.list partDecoder)) - -type MessagePart = - Order Int - | Str String - -partDecoder : Decoder MessagePart -partDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen partDecoderWithTag - -partDecoderWithTag : String -> Decoder MessagePart -partDecoderWithTag tag = - case tag of - "Order" -> Decode.map Order (Decode.field "contents" Decode.int) - _ -> Decode.map Str (Decode.field "contents" Decode.string) - ------ - -getMessage : Translations -> String -> String -getMessage = getParamMessage [] - -getParamMessage : List String -> Translations -> String -> String -getParamMessage values translations key = - 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 f6e8147..0000000 --- a/src/client/Model/User.elm +++ /dev/null @@ -1,44 +0,0 @@ -module Model.User exposing - ( Users - , usersDecoder - , User - , userDecoder - , UserId - , userIdDecoder - , getUserName - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -type alias Users = Dict UserId User - -type alias UserId = Int - -type alias User = - { name : String - , email : String - } - -usersDecoder : Decoder Users -usersDecoder = Decode.map Dict.fromList (Decode.list userWithIdDecoder) - -userWithIdDecoder : Decode.Decoder (UserId, User) -userWithIdDecoder = - Decode.map2 (,) - (Decode.field "id" userIdDecoder) - userDecoder - -userIdDecoder : Decoder UserId -userIdDecoder = Decode.int - -userDecoder : Decoder User -userDecoder = - Decode.map2 User - (Decode.field "name" Decode.string) - (Decode.field "email" Decode.string) - -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 61d42a7..0000000 --- a/src/client/Model/View.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Model.View exposing - ( View(..) - ) - -import Model.Payment exposing (Payments) - -import SignIn.Model as SignInModel -import LoggedIn.Model as LoggedInModel - -type View = - SignInView SignInModel.Model - | LoggedInView LoggedInModel.Model diff --git a/src/client/Msg.elm b/src/client/Msg.elm deleted file mode 100644 index 5970747..0000000 --- a/src/client/Msg.elm +++ /dev/null @@ -1,49 +0,0 @@ -module Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) -import Time exposing (Time) - -import Page exposing (Page) - -import Model.Init exposing (Init) -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Category exposing (CategoryId) - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -import SignIn.Msg as SignInMsg -import LoggedIn.Msg as LoggedInMsg - -type Msg = - NoOp - | UpdatePage Page - | SignIn String - | UpdateTime Time - | GoLoggedInView Init - | UpdateSignIn SignInMsg.Msg - | UpdateLoggedIn LoggedInMsg.Msg - | GoSignInView - | SignOut - | Error String - | Dialog (Dialog.Msg DialogModel.Model DialogMsg.Msg Msg) - | Tooltip Tooltip.Msg - - | CreatePayment String Int Date CategoryId Frequency - | EditPayment PaymentId String Int Date CategoryId Frequency - | DeletePayment PaymentId - - | CreateIncome Int Date - | EditIncome IncomeId Int Date - | DeleteIncome IncomeId - - | CreateCategory String String - | EditCategory CategoryId String String - | DeleteCategory CategoryId diff --git a/src/client/Page.elm b/src/client/Page.elm deleted file mode 100644 index 39232e0..0000000 --- a/src/client/Page.elm +++ /dev/null @@ -1,43 +0,0 @@ -module Page exposing - ( Page(..) - , toHash - , fromLocation - ) - -import Navigation exposing (Location) -import UrlParser exposing (Parser, (), s) -import String - -type Page = - Home - | Income - | Categories - | Statistics - | NotFound - -toHash : Page -> String -toHash page = - case page of - Home -> "#" - Income -> "#income" - Categories -> "#categories" - Statistics -> "#statistics" - NotFound -> "#notFound" - -fromLocation : Location -> Page -fromLocation location = - if location.hash == "" - then - Home - else - case UrlParser.parseHash pageParser location of - Just page -> page - Nothing -> NotFound - -pageParser : Parser (Page -> a) a -pageParser = - UrlParser.oneOf - [ UrlParser.map Income (s "income") - , UrlParser.map Categories (s "categories") - , UrlParser.map Statistics (s "statistics") - ] diff --git a/src/client/Server.elm b/src/client/Server.elm deleted file mode 100644 index c44b777..0000000 --- a/src/client/Server.elm +++ /dev/null @@ -1,115 +0,0 @@ -module Server exposing - ( signIn - , createPayment - , editPayment - , deletePayment - , createIncome - , editIncome - , deleteIncome - , createCategory - , editCategory - , deleteCategory - , signOut - ) - -import Task as Task exposing (Task) -import Http exposing (Error) -import Date -import Json.Decode as Decode -import Json.Encode as Encode -import Date exposing (Date) - -import Date.Extra.Format as DateFormat - -import Utils.Http as HttpUtils - -import Model.Payment exposing (..) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (incomeIdDecoder, IncomeId) -import Model.Category exposing (categoryIdDecoder, CategoryId) -import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder) -import Model.Init exposing (Init) - -signIn : String -> (Result Error String -> msg) -> Cmd msg -signIn email = HttpUtils.request "POST" ("/signIn?email=" ++ email) Http.expectString - -createPayment : String -> Int -> Date -> CategoryId -> Frequency -> (Result Error PaymentId -> msg) -> Cmd msg -createPayment name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - expect = Http.expectJson (Decode.field "id" paymentIdDecoder) - in HttpUtils.jsonRequest "POST" "/payment" expect handleResult json - -editPayment : PaymentId -> String -> Int -> Date -> CategoryId -> Frequency -> (Result Error String -> msg) -> Cmd msg -editPayment paymentId name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("id", Encode.int paymentId) - , ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - in HttpUtils.jsonRequest "PUT" "/payment" Http.expectString handleResult json - -deletePayment : PaymentId -> (Result Error String -> msg) -> Cmd msg -deletePayment paymentId = - HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) Http.expectString - -createIncome : Int -> Date -> (Result Error IncomeId -> msg) -> Cmd msg -createIncome amount date handleResult = - let json = - Encode.object - [ ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - expect = Http.expectJson (Decode.field "id" incomeIdDecoder) - in HttpUtils.jsonRequest "POST" "/income" expect handleResult json - -editIncome : IncomeId -> Int -> Date -> (Result Error String -> msg) -> Cmd msg -editIncome incomeId amount date handleResult = - let json = - Encode.object - [ ("id", Encode.int incomeId) - , ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - in HttpUtils.jsonRequest "PUT" "/income" Http.expectString handleResult json - -deleteIncome : IncomeId -> (Result Error String -> msg) -> Cmd msg -deleteIncome incomeId = - HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) Http.expectString - -createCategory : String -> String -> (Result Error CategoryId -> msg) -> Cmd msg -createCategory name color handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("color", Encode.string color) - ] - expect = Http.expectJson (Decode.field "id" categoryIdDecoder) - in HttpUtils.jsonRequest "POST" "/category" expect handleResult json - -editCategory : CategoryId -> String -> String -> (Result Error String -> msg) -> Cmd msg -editCategory categoryId name color handleResult = - let json = - Encode.object - [ ("id", Encode.int categoryId) - , ("name", Encode.string name) - , ("color", Encode.string color) - ] - in HttpUtils.jsonRequest "PUT" "/category" Http.expectString handleResult json - -deleteCategory : CategoryId -> (Result Error String -> msg) -> Cmd msg -deleteCategory categoryId = - HttpUtils.request "DELETE" ("/category?id=" ++ (toString categoryId)) Http.expectString - -signOut : (Result Error String -> msg) -> Cmd msg -signOut = HttpUtils.request "POST" "/signOut" Http.expectString diff --git a/src/client/SignIn/Model.elm b/src/client/SignIn/Model.elm deleted file mode 100644 index 19d4305..0000000 --- a/src/client/SignIn/Model.elm +++ /dev/null @@ -1,17 +0,0 @@ -module SignIn.Model exposing - ( Model - , init - ) - -type alias Model = - { login : String - , waitingServer : Bool - , result : Maybe (Result String String) - } - -init : Maybe String -> Model -init mbSignInError = - { login = "" - , waitingServer = False - , result = Maybe.map Err mbSignInError - } diff --git a/src/client/SignIn/Msg.elm b/src/client/SignIn/Msg.elm deleted file mode 100644 index f753ebd..0000000 --- a/src/client/SignIn/Msg.elm +++ /dev/null @@ -1,9 +0,0 @@ -module SignIn.Msg exposing - ( Msg(..) - ) - -type Msg = - UpdateLogin String - | WaitingServer - | ValidLogin - | ErrorLogin String diff --git a/src/client/SignIn/Update.elm b/src/client/SignIn/Update.elm deleted file mode 100644 index 98de777..0000000 --- a/src/client/SignIn/Update.elm +++ /dev/null @@ -1,31 +0,0 @@ -module SignIn.Update exposing - ( update - ) - -import SignIn.Model exposing (..) -import SignIn.Msg exposing (..) - -import Model.Translations exposing (getMessage, Translations) - -update : Translations -> Msg -> Model -> Model -update translations msg signInView = - case msg of - UpdateLogin login -> - { signInView | - login = login - } - WaitingServer -> - { signInView - | waitingServer = True - } - ValidLogin -> - { signInView - | login = "" - , result = Just (Ok (getMessage translations "SignInEmailSent")) - , waitingServer = False - } - ErrorLogin message -> - { signInView - | result = Just (Err message) - , waitingServer = False - } diff --git a/src/client/SignIn/View.elm b/src/client/SignIn/View.elm deleted file mode 100644 index 88f74b0..0000000 --- a/src/client/SignIn/View.elm +++ /dev/null @@ -1,63 +0,0 @@ -module SignIn.View exposing - ( view - ) - -import Json.Decode as Decode - -import FontAwesome -import View.Color as Color - -import Html as H exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import SignIn.Msg as SignInMsg -import SignIn.Model as SignInModel - -import Update exposing (..) - -import Model exposing (Model) -import Msg exposing (..) -import Model.Translations exposing (getMessage) - -import View.Events exposing (onSubmitPrevDefault) - -view : Model -> SignInModel.Model -> Html Msg -view model signInModel = - div - [ class "signIn" ] - [ H.form - [ onSubmitPrevDefault (SignIn signInModel.login) ] - [ input - [ value signInModel.login - , on "input" (targetValue |> (Decode.map <| (UpdateSignIn << SignInMsg.UpdateLogin))) - , name "email" - ] - [] - , button - [] - [ if signInModel.waitingServer - then FontAwesome.spinner Color.white 20 - else text (getMessage model.translations "SignIn") - ] - ] - , div - [ class "result" ] - [ signInResult model signInModel ] - ] - -signInResult : Model -> SignInModel.Model -> Html Msg -signInResult model signInModel = - case signInModel.result of - Just result -> - case result of - Ok login -> - div - [ class "success" ] - [ text (getMessage model.translations "SignInEmailSent") ] - Err error -> - div - [ class "error" ] - [ text (getMessage model.translations error) ] - Nothing -> - text "" diff --git a/src/client/Tooltip.elm b/src/client/Tooltip.elm deleted file mode 100644 index 4f70cda..0000000 --- a/src/client/Tooltip.elm +++ /dev/null @@ -1,113 +0,0 @@ -module Tooltip exposing - ( Msg(..) - , Model - , init - , subscription - , update - , view - , show - ) - -import Platform.Cmd - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Mouse exposing (Position) -import Window exposing (Size) - -type Msg = - UpdateMousePosition Position - | UpdateWindowSize Size - | ShowMessage String - | HideMessage - -type alias Model = - { mousePosition : Maybe Position - , windowSize : Size - , message : Maybe String - } - -init : Int -> Int -> Model -init width height = - { mousePosition = Nothing - , windowSize = - { width = width - , height = height - } - , message = Nothing - } - -subscription : Sub Msg -subscription = - Sub.batch - [ Mouse.moves UpdateMousePosition - , Window.resizes UpdateWindowSize - ] - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - UpdateMousePosition position -> - ( { model | mousePosition = Just position } - , Cmd.none - ) - - UpdateWindowSize size -> - ( { model | windowSize = size } - , Cmd.none - ) - - ShowMessage message -> - ( { model | message = Just message } - , Cmd.none - ) - - HideMessage -> - ( { model | message = Nothing } - , Cmd.none - ) - -view : Model -> Html Msg -view { mousePosition, windowSize, message } = - case (mousePosition, message) of - (Just pos, Just msg) -> - div - [ class "tooltip" - , style - [ ("position", "absolute") - , horizontalPosition windowSize pos - , ("top", px <| pos.y + 15) - ] - ] - [ text msg ] - _ -> - text "" - -horizontalPosition : Size -> Position -> (String, String) -horizontalPosition size position = - if isLeft size position - then ("left", px <| position.x + 5) - else ("right", px <| size.width - position.x) - -verticalPosition : Size -> Position -> (String, String) -verticalPosition size position = - if isTop size position - then ("top", px <| position.y + 20) - else ("bottom", px <| size.height - position.y + 15) - -px : Int -> String -px n = (toString n) ++ "px" - -isLeft : Size -> Position -> Bool -isLeft { width } { x } = x < width // 2 - -isTop : Size -> Position -> Bool -isTop { height } { y } = y < height // 2 - -show : (Msg -> msg) -> String -> List (Attribute msg) -show mapMsg message = - [ onMouseEnter <| mapMsg <| ShowMessage message - , onMouseLeave <| mapMsg <| HideMessage - ] diff --git a/src/client/Update.elm b/src/client/Update.elm deleted file mode 100644 index 4284b65..0000000 --- a/src/client/Update.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Update exposing - ( update - ) - -import Navigation exposing (Location) -import Platform.Cmd exposing (Cmd) -import Task - -import Dialog -import Dialog.Update as DialogUpdate -import LoggedIn.Model as LoggedIn -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Update as LoggedIn -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Model.View as V -import Msg exposing (..) -import Page exposing (Page(..)) -import Server -import SignIn.Model as SignInModel -import SignIn.Msg as SignInMsg -import SignIn.Update as SignInUpdate -import Tooltip -import Utils.Cmd exposing ((:>)) -import Utils.Http exposing (errorKey) - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - - NoOp -> - (model, Cmd.none) - - UpdatePage page -> - ( { model | page = page } - , if page == Statistics - then - let msg = UpdateLoggedIn <| LoggedIn.StatMsg <| Stat.UpdateChart - in Task.perform (\_ -> msg) (Task.succeed ()) - else - Cmd.none - ) - - SignIn email -> - ( applySignIn model (SignInMsg.WaitingServer) - , Server.signIn email (\result -> case result of - Ok _ -> UpdateSignIn SignInMsg.ValidLogin - Err error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error)) - ) - ) - - GoLoggedInView init -> - ( { model | view = V.LoggedInView (LoggedIn.init model.currentTime init) } - , Cmd.none - ) - - UpdateTime time -> - ({ model | currentTime = time }, Cmd.none) - - GoSignInView -> - ({ model | view = V.SignInView (SignInModel.init Nothing) }, Cmd.none) - - UpdateSignIn signInMsg -> - (applySignIn model signInMsg, Cmd.none) - - UpdateLoggedIn loggedInMsg -> - applyLoggedIn model loggedInMsg - - SignOut -> - ( model - , Server.signOut (\result -> case result of - Ok _ -> GoSignInView - Err _ -> Error "SignOutError" - ) - ) - - Error error -> - ({ model | errors = model.errors ++ [ error ] }, Cmd.none) - - Dialog dialogMsg -> - Dialog.update DialogUpdate.update dialogMsg model.dialog.model model.dialog - |> Tuple.mapFirst (\dialog -> { model | dialog = dialog }) - :> update (Tooltip Tooltip.HideMessage) - - Tooltip tooltipMsg -> - let (newTooltip, command) = Tooltip.update tooltipMsg model.tooltip - in ( { model | tooltip = newTooltip } - , Cmd.map Tooltip command - ) - - CreatePayment name cost date category frequency -> - ( model - , Server.createPayment name cost date category frequency (\result -> case result of - Ok paymentId -> UpdateLoggedIn <| LoggedIn.ValidateCreatePayment paymentId name cost date category frequency - Err _ -> Error "CreatePaymentError" - ) - ) - - EditPayment paymentId name cost date category frequency -> - ( model - , Server.editPayment paymentId name cost date category frequency (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditPayment paymentId name cost date category frequency - Err _ -> Error "EditPaymentError" - ) - ) - - DeletePayment paymentId -> - ( model - , Server.deletePayment paymentId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeletePayment paymentId - Err _ -> Error "DeletePaymentError" - ) - ) - - CreateIncome amount date -> - ( model - , Server.createIncome amount date (\result -> case result of - Ok incomeId -> UpdateLoggedIn <| LoggedIn.ValidateCreateIncome incomeId amount date - Err _ -> Error "CreateIncomeError" - ) - ) - - EditIncome incomeId amount date -> - ( model - , Server.editIncome incomeId amount date (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditIncome incomeId amount date - Err _ -> Error "EditIncomeError" - ) - ) - - DeleteIncome incomeId -> - ( model - , Server.deleteIncome incomeId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteIncome incomeId - Err _ -> Error "DeleteIncomeError" - ) - ) - - CreateCategory name color -> - ( model - , Server.createCategory name color (\result -> case result of - Ok categoryId -> UpdateLoggedIn <| LoggedIn.ValidateCreateCategory categoryId name color - Err _ -> Error "CreateCategoryError" - ) - ) - - EditCategory categoryId name color -> - ( model - , Server.editCategory categoryId name color (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditCategory categoryId name color - Err _ -> Error "EditCategoryError" - ) - ) - - DeleteCategory categoryId -> - ( model - , Server.deleteCategory categoryId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteCategory categoryId - Err _ -> Error "DeleteCategoryError" - ) - ) - - -applySignIn : Model -> SignInMsg.Msg -> Model -applySignIn model signInMsg = - case model.view of - V.SignInView signInView -> - { model | view = V.SignInView (SignInUpdate.update model.translations signInMsg signInView) } - _ -> - model - -applyLoggedIn : Model -> LoggedIn.Msg -> (Model, Cmd Msg) -applyLoggedIn model loggedInMsg = - case model.view of - V.LoggedInView loggedInView -> - let (view, cmd) = LoggedIn.update model loggedInMsg loggedInView - in ( { model | view = V.LoggedInView view } - , Cmd.map UpdateLoggedIn cmd - ) - _ -> - (model, Cmd.none) diff --git a/src/client/Utils/Cmd.elm b/src/client/Utils/Cmd.elm deleted file mode 100644 index 5f41cbe..0000000 --- a/src/client/Utils/Cmd.elm +++ /dev/null @@ -1,16 +0,0 @@ -module Utils.Cmd exposing - ( pipeUpdate - , (:>) - ) - -import Platform.Cmd as Cmd - -pipeUpdate : (model, Cmd msg) -> (model -> (model, Cmd msg)) -> (model, Cmd msg) -pipeUpdate (model, cmd) f = - let (newModel, newCmd) = f model - in (newModel, Cmd.batch [ cmd, newCmd ]) - -(:>) : (m, Cmd a) -> (m -> (m, Cmd a)) -> (m, Cmd a) -(:>) = pipeUpdate - -infixl 0 :> diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm deleted file mode 100644 index 7d708e2..0000000 --- a/src/client/Utils/Dict.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Dict exposing - ( mapValues - ) - -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 275fc8c..0000000 --- a/src/client/Utils/Either.elm +++ /dev/null @@ -1,9 +0,0 @@ -module Utils.Either exposing - ( toMaybeError - ) - -toMaybeError : Result a b -> Maybe a -toMaybeError result = - case result of - Ok _ -> Nothing - Err x -> Just x diff --git a/src/client/Utils/Form.elm b/src/client/Utils/Form.elm deleted file mode 100644 index 6793222..0000000 --- a/src/client/Utils/Form.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Form exposing - ( fieldAsText - ) - -import Form exposing (Form) - -fieldAsText : Form a b -> String -> String -fieldAsText form field = - Form.getFieldAsString field form - |> .value - |> Maybe.withDefault "" diff --git a/src/client/Utils/Http.elm b/src/client/Utils/Http.elm deleted file mode 100644 index dd3870a..0000000 --- a/src/client/Utils/Http.elm +++ /dev/null @@ -1,39 +0,0 @@ -module Utils.Http exposing - ( jsonRequest - , request - , errorKey - ) - -import Http exposing (..) -import Task exposing (..) -import Json.Decode as Decode exposing (Decoder, Value) -import Json.Encode as Encode - -jsonRequest : String -> String -> Expect a -> (Result Error a -> msg) -> Encode.Value -> Cmd msg -jsonRequest method url expect handleResult value = - requestWithBody method url (jsonBody value) expect handleResult - -request : String -> String -> Expect a -> (Result Error a -> msg) -> Cmd msg -request method url = requestWithBody method url emptyBody - -requestWithBody : String -> String -> Body -> Expect a -> (Result Error a -> msg) -> Cmd msg -requestWithBody method url body expect handleResult = - let req = Http.request - { method = method - , headers = [] - , url = url - , body = body - , expect = expect - , timeout = Nothing - , withCredentials = False - } - in send handleResult req - -errorKey : Error -> String -errorKey error = - case error of - BadUrl _ -> "BadUrl" - Timeout -> "Timeout" - NetworkError -> "NetworkError" - BadPayload _ _ -> "BadPayload" - BadStatus response -> response.body diff --git a/src/client/Utils/Json.elm b/src/client/Utils/Json.elm deleted file mode 100644 index 29e815b..0000000 --- a/src/client/Utils/Json.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Utils.Json exposing - ( dictDecoder - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -dictDecoder : Decoder comparable -> Decoder a -> Decoder (Dict comparable a) -dictDecoder keyDecoder valueDecoder = - Decode.map2 (,) keyDecoder valueDecoder - |> Decode.list - |> Decode.map Dict.fromList diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm deleted file mode 100644 index 8e26e85..0000000 --- a/src/client/Utils/List.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Utils.List exposing - ( groupBy - , mean - , links - ) - -import Dict -import Maybe.Extra as Maybe - -groupBy : (a -> comparable) -> List a -> List (comparable, List a) -groupBy f xs = - let addItem item dict = - let groupItems = Dict.get (f item) dict |> Maybe.withDefault [] - in Dict.insert (f item) (item :: groupItems) dict - in List.foldr addItem Dict.empty xs - |> Dict.toList - -mean : List Int -> Int -mean xs = (List.sum xs) // (List.length xs) - -links : List a -> List (a, a) -links xs = - let reversed = List.reverse xs - in List.foldr - (\x acc -> - case Maybe.map Tuple.first (List.head acc) of - Just y -> - (x, y) :: acc - _ -> - acc - ) - (case reversed of - x :: y :: _ -> [(y, x)] - _ -> [] - ) - (List.reverse << List.drop 2 <| reversed) diff --git a/src/client/Utils/Search.elm b/src/client/Utils/Search.elm deleted file mode 100644 index 1b70387..0000000 --- a/src/client/Utils/Search.elm +++ /dev/null @@ -1,10 +0,0 @@ -module Utils.Search exposing - ( format - ) - -import String - -import Utils.String as String - -format : String -> String -format = String.unaccent << String.toLower diff --git a/src/client/Utils/String.elm b/src/client/Utils/String.elm deleted file mode 100644 index 90fe68e..0000000 --- a/src/client/Utils/String.elm +++ /dev/null @@ -1,38 +0,0 @@ -module Utils.String exposing - ( unaccent - ) - -unaccent : String -> String -unaccent = String.map unaccentChar - -unaccentChar : Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/client/Validation.elm b/src/client/Validation.elm deleted file mode 100644 index de27963..0000000 --- a/src/client/Validation.elm +++ /dev/null @@ -1,65 +0,0 @@ -module Validation exposing - ( cost - , date - , category - , color - , new - ) - -import Date exposing (Date) -import Date.Extra.Core exposing (intToMonth) -import Date.Extra.Create exposing (dateFromFields) -import Dict -import Regex -import String exposing (toInt, split) - -import Form.Validate as Validate exposing (Validation) -import Form.Error as Error exposing (ErrorValue(CustomError)) - -import Model.Category exposing (Categories, CategoryId) - -cost : Validation String Int -cost = - Validate.customValidation Validate.int (\n -> - if n == 0 - then Err (Validate.customError "CostMustNotBeNull") - else Ok n - ) - -date : Validation String Date -date = - Validate.customValidation Validate.string (\str -> - case split "/" str of - [day, month, year] -> - case (toInt day, toInt month, toInt year) of - (Ok dayNum, Ok monthNum, Ok yearNum) -> - Ok (dateFromFields yearNum (intToMonth monthNum) dayNum 0 0 0 0) - _ -> Err (Validate.customError "InvalidDate") - _ -> Err (Validate.customError "InvalidDate") - ) - -category : Categories -> Validation String CategoryId -category categories = - Validate.customValidation Validate.string (\str -> - case toInt str of - Ok category -> - if List.member category (Dict.keys categories) - then Ok category - else Err (Validate.customError "InvalidCategory") - Err _ -> - Err (Validate.customError "InvalidCategory") - ) - -color : Validation String String -color = - Validate.customValidation Validate.string (\str -> - if Regex.contains (Regex.regex "^#[0-9a-fA-F]{6}$") str - then Ok str - else Err (Validate.customError "InvalidColor") - ) - -new : List x -> x -> Validation String x -new xs x field = - if List.member x xs - then Err (Error.value <| CustomError "AlreadyExists") - else Ok x diff --git a/src/client/View.elm b/src/client/View.elm deleted file mode 100644 index deee272..0000000 --- a/src/client/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Model exposing (Model) -import Msg exposing (Msg) -import Model.View exposing (..) -import LoggedData -import Dialog -import Tooltip - -import View.Header as Header -import View.Errors as Errors - -import SignIn.View as SignInView -import LoggedIn.View as LoggedInView - -view : Model -> Html Msg -view model = - div - [] - [ Header.view model - , case model.view of - SignInView signIn -> - SignInView.view model signIn - LoggedInView loggedIn -> - LoggedInView.view model loggedIn - , Errors.view model.translations model.errors - , Dialog.view model.dialog - , Html.map Msg.Tooltip <| Tooltip.view model.tooltip - ] diff --git a/src/client/View/App.hs b/src/client/View/App.hs new file mode 100644 index 0000000..1466811 --- /dev/null +++ b/src/client/View/App.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.App + ( widget + ) where + +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import Common.Model (InitResult(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import View.Header (HeaderIn(..)) +import View.Payment (PaymentIn(..)) +import qualified View.Header as Header +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn + +widget :: InitResult -> IO () +widget initResult = + R.mainWidget $ do + headerOut <- Header.view $ HeaderIn + { _headerIn_initResult = initResult + } + + let signOut = Header._headerOut_signOut headerOut + + initialContent = case initResult of + InitSuccess initSuccess -> do + _ <- Payment.widget $ PaymentIn + { _paymentIn_init = initSuccess + } + return () + InitEmpty result -> + SignIn.view result + + signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + + _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + + R.blank diff --git a/src/client/View/Color.elm b/src/client/View/Color.elm deleted file mode 100644 index a2a20c7..0000000 --- a/src/client/View/Color.elm +++ /dev/null @@ -1,12 +0,0 @@ -module View.Color exposing (..) - -import Color exposing (Color) - -chestnutRose : Color -chestnutRose = Color.rgb 207 92 86 - -white : Color -white = Color.white - -silver : Color -silver = Color.rgb 200 200 200 diff --git a/src/client/View/Date.elm b/src/client/View/Date.elm deleted file mode 100644 index 6df971b..0000000 --- a/src/client/View/Date.elm +++ /dev/null @@ -1,57 +0,0 @@ -module View.Date exposing - ( shortMonthAndYear - , shortView - , longView - , monthView - ) - -import Date exposing (..) -import Date.Extra.Core as Date -import String - -import Model.Translations exposing (..) - -shortMonthAndYear : Month -> Int -> Translations -> String -shortMonthAndYear month year translations = - let params = - [ String.pad 2 '0' (toString (Date.monthToInt month)) - , toString year - ] - in getParamMessage params translations "ShortMonthAndYear" - -shortView : Date -> Translations -> String -shortView date translations = - let params = - [ String.pad 2 '0' (toString (Date.day date)) - , String.pad 2 '0' (toString (Date.monthToInt (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "ShortDate" - -longView : Date -> Translations -> String -longView date translations = - let params = - [ toString (Date.day date) - , (getMessage translations (getMonthKey (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "LongDate" - -monthView : Translations -> Month -> String -monthView translations month = getMessage translations (getMonthKey month) - -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/Errors.elm b/src/client/View/Errors.elm deleted file mode 100644 index 3e25c99..0000000 --- a/src/client/View/Errors.elm +++ /dev/null @@ -1,21 +0,0 @@ -module View.Errors exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model.Translations exposing (Translations, getMessage) - -view : Translations -> List String -> Html msg -view translations errors = - ul - [ class "errors" ] - ( List.map (errorView translations) errors) - -errorView : Translations -> String -> Html msg -errorView translations error = - li - [ class "error" ] - [ text <| getMessage translations error ] diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm deleted file mode 100644 index d71d67d..0000000 --- a/src/client/View/Events.elm +++ /dev/null @@ -1,15 +0,0 @@ -module View.Events exposing - ( onSubmitPrevDefault - ) - -import Json.Decode as Decode -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -onSubmitPrevDefault : msg -> Attribute msg -onSubmitPrevDefault value = - onWithOptions - "submit" - { defaultOptions | preventDefault = True } - (Decode.succeed value) diff --git a/src/client/View/Form.elm b/src/client/View/Form.elm deleted file mode 100644 index 977ca0a..0000000 --- a/src/client/View/Form.elm +++ /dev/null @@ -1,152 +0,0 @@ -module View.Form exposing - ( textInput - , colorInput - , selectInput - , radioInputs - , hiddenSubmit - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Maybe.Extra as Maybe - -import FontAwesome -import View.Color as Color - -import Form exposing (Form, FieldState) -import Form.Input as Input -import Form.Error as FormError exposing (ErrorValue(..)) -import Form.Field as Field - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Translations as Translations exposing (Translations) - -textInput : Translations -> Form String a -> String -> String -> Html Form.Msg -textInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - fieldId = formName ++ fieldName - in div - [ classList - [ ("textInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ Input.textInput - field - [ id fieldId - , classList [ ("filled", Maybe.isJust field.value) ] - , value (Maybe.withDefault "" field.value) - ] - , label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , button - [ type_ "button" - , onClick (Form.Input fieldName Form.Text Field.EmptyField) - , tabindex -1 - ] - [ FontAwesome.times Color.silver 15 ] - , formError translations field - ] - -colorInput : Translations -> Form String a -> String -> String -> Html Form.Msg -colorInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - in div - [ classList - [ ("colorInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) ] - , Input.textInput - field - [ id (formName ++ fieldName) - , type_ "color" - ] - ] - -radioInputs : Translations -> Form String a -> String -> String -> List String -> Html Form.Msg -radioInputs translations form formName radioName fieldNames = - let field = Form.getFieldAsString radioName form - in div - [ classList - [ ("radioGroup", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ div - [ class "title" ] - [ text (Translations.getMessage translations (formName ++ radioName) ) ] - , div - [ class "radioInputs" ] - (List.map (radioInput translations field formName) fieldNames) - , formError translations field - ] - -radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg -radioInput translations field formName fieldName = - div - [ class "radioInput" ] - [ Input.radioInput - field.path - field - [ id (formName ++ fieldName) - , value fieldName - , checked (field.value == Just fieldName) - ] - , label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) - ] - ] - -selectInput : Translations -> Form String a -> String -> String -> List (String, String) -> Html Form.Msg -selectInput translations form formName selectName options = - let field = Form.getFieldAsString selectName form - fieldId = formName ++ selectName - in div - [ classList - [ ("selectInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , Input.selectInput - (("", "") :: options) - field - [ id fieldId ] - , formError translations field - ] - -formError : Translations -> FieldState String a -> Html msg -formError translations field = - case field.liveError of - Just error -> - let errorElement error params = - div - [ class "errorMessage" ] - [ text (Translations.getParamMessage params translations error) ] - in case error of - CustomError key -> errorElement key [] - SmallerIntThan n -> errorElement "SmallerIntThan" [toString n] - GreaterIntThan n -> errorElement "GreaterIntThan" [toString n] - error -> errorElement (toString error) [] - Nothing -> - text "" - -hiddenSubmit : msg -> Html msg -hiddenSubmit msg = - button - [ style [ ("display", "none") ] - , onClick msg - ] - [] diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm deleted file mode 100644 index 12fb87c..0000000 --- a/src/client/View/Header.elm +++ /dev/null @@ -1,60 +0,0 @@ -module View.Header exposing - ( view - ) - -import Dict - -import FontAwesome -import View.Color as Color - -import Page exposing (..) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Msg exposing (..) -import Model.View exposing (..) - -view : Model -> Html Msg -view model = - header - [] - ( [ div [ class "title" ] [ text (getMessage model.translations "SharedCost") ] ] - ++ let item page name = - a - [ href (Page.toHash page) - , classList - [ ("item", True) - , ("current", model.page == page) - ] - ] - [ text (getMessage model.translations name) - ] - in case model.view of - LoggedInView { me, users } -> - [ item Home "PaymentsTitle" - , item Income "Income" - , item Categories "Categories" - , item Statistics "Statistics" - , div - [ class "nameSignOut" ] - [ div - [ class "name" ] - [ Dict.get me users - |> Maybe.map .name - |> Maybe.withDefault "" - |> text - ] - , button - [ class "signOut item" - , onClick SignOut - ] - [ FontAwesome.power_off Color.white 30 ] - ] - ] - _ -> - [] - ) diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs new file mode 100644 index 0000000..32738f1 --- /dev/null +++ b/src/client/View/Header.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Header + ( view + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), Init(..), User(..)) +import qualified Common.Model.User as User + +import Component.Button (ButtonIn(..)) +import qualified Component.Button as Component +import qualified Icon + +data HeaderIn = HeaderIn + { _headerIn_initResult :: InitResult + } + +data HeaderOut t = HeaderOut + { _headerOut_signOut :: Event t () + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view headerIn = + R.el "header" $ do + + R.divClass "title" $ + R.text $ Message.get Key.App_Title + + signOut <- nameSignOut $ _headerIn_initResult headerIn + + return $ HeaderOut + { _headerOut_signOut = signOut + } + +nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) +nameSignOut initResult = case initResult of + (InitSuccess init) -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case User.find (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never + +signOutButton :: forall t m. MonadWidget t m => m (Event t ()) +signOutButton = do + rec + signOut <- Component.button $ ButtonIn + { Component._buttonIn_class = "signOut item" + , Component._buttonIn_content = Icon.signOut + , Component._buttonIn_waiting = waiting + } + let signOutClic = Component._buttonOut_clic signOut + waiting = R.leftmost + [ fmap (const True) signOutClic + , fmap (const False) signOutSuccess + ] + signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) + + return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess + + where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) + askSignOut signOut = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + getResult = (== 200) . R._xhrResponse_status diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs new file mode 100644 index 0000000..e80790b --- /dev/null +++ b/src/client/View/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment + ( widget + , PaymentIn(..) + , PaymentOut(..) + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init) + +import View.Payment.Table (TableIn(..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +data PaymentOut = PaymentOut + { + } + +widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget paymentIn = do + R.divClass "payment" $ do + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + } + return $ PaymentOut {} diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs new file mode 100644 index 0000000..878e7da --- /dev/null +++ b/src/client/View/Payment/Table.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Table + ( widget + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List as L +import qualified Data.Map as M +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) +import qualified Common.Model.User as User +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format + +import qualified Icon + +data TableIn = TableIn + { _tableIn_init :: Init + } + +data TableOut = TableOut + { + } + +widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +widget tableIn = do + R.divClass "table" $ + R.divClass "lines" $ do + R.divClass "header" $ do + R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name + R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost + R.divClass "cell user" $ R.text $ Message.get Key.Payment_User + R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category + R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + let init = _tableIn_init tableIn + payments = _init_payments init + mapM_ + (paymentRow init) + (take 8 . reverse . L.sortOn _payment_date $ payments) + return $ TableOut {} + +paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow init payment = + R.divClass "row" $ do + R.divClass "cell name" . R.text $ _payment_name payment + R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell user" $ + case User.find (_payment_user payment) (_init_users init) of + Just user -> R.text (_user_name user) + _ -> R.blank + R.divClass "cell category" $ + case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of + Just category -> + R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ + R.text $ _category_name category + _ -> + R.blank + R.divClass "cell date" $ do + R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) + R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.divClass "cell button" . R.el "button" $ Icon.clone + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.edit + else R.blank + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.delete + else R.blank + +findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category +findCategory categories paymentCategories paymentName = do + paymentCategory <- L.find + ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + paymentCategories + L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/src/client/View/Plural.elm b/src/client/View/Plural.elm deleted file mode 100644 index c36eaca..0000000 --- a/src/client/View/Plural.elm +++ /dev/null @@ -1,11 +0,0 @@ -module View.Plural exposing - ( plural - ) - -import Model.Translations exposing (Translations, getMessage) - -plural : Translations -> Int -> String -> String -> String -plural translations n single multiple = - let singleMessage = getMessage translations single - multipleMessage = getMessage translations multiple - in (toString n) ++ " " ++ if n <= 1 then singleMessage else multipleMessage diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs new file mode 100644 index 0000000..e164ee7 --- /dev/null +++ b/src/client/View/SignIn.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.SignIn + ( view + ) where + +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(SignIn)) + +import Component.Input (InputIn(..), InputOut(..)) +import Component.Button (ButtonIn(..), ButtonOut(..)) +import qualified Component.Button as Component +import qualified Component.Input as Component + +view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () +view result = + R.divClass "signIn" $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + } + + let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button + + dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ + [ fmap (const True) userWantsEmailValidation + , fmap (const False) signInResult + ] + + uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail + + let validatedEmail = R.tagPromptlyDyn + (_inputOut_value input) + (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) + + let waiting = R.leftmost + [ fmap (const True) validatedEmail + , fmap (const False) signInResult + ] + + button <- Component.button $ ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_waiting = waiting + } + + signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) + + showSignInResult result signInResult + +askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) +askSignIn email = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + getResult response = + case R._xhrResponse_responseText response of + Just key -> + if R._xhrResponse_status response == 200 then Right key else Left key + _ -> Left "NoKey" + +showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () +showSignInResult result signInResult = do + _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult + R.blank + + where showInitResult (Left error) = showError error + showInitResult (Right (Just success)) = showSuccess success + showInitResult (Right Nothing) = R.blank + + showResult (Left error) = showError error + showResult (Right success) = showSuccess success + + showError = R.divClass "error" . R.text + showSuccess = R.divClass "success" . R.text diff --git a/src/common/Message.hs b/src/common/Message.hs new file mode 100644 index 0000000..9ae735d --- /dev/null +++ b/src/common/Message.hs @@ -0,0 +1,12 @@ +module Common.Message + ( get + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key) +import Common.Message.Lang (Lang(..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/src/common/Message/Key.hs b/src/common/Message/Key.hs new file mode 100644 index 0000000..4127808 --- /dev/null +++ b/src/common/Message/Key.hs @@ -0,0 +1,152 @@ +module Common.Message.Key + ( Key(..) + ) where + +import Data.Text + +data Key = + + App_Title + + | Category_Add + | Category_Clone + | Category_Color + | Category_DeleteConfirm + | Category_Edit + | Category_Empty + | Category_Name + | Category_NotDeleted + | Category_Title + | Category_Used + + | Date_Long Int Text Int + | Date_Short Int Int Int + | Date_ShortMonthAndYear Int Int + + | Dialog_Confirm + | Dialog_Undo + + | Error_CategoryCreate + | Error_CategoryDelete + | Error_CategoryEdit + | Error_IncomeCreate + | Error_IncomeDelete + | Error_IncomeEdit + | Error_PaymentCreate + | Error_PaymentDelete + | Error_PaymentEdit + | Error_SignOut + + | Form_AlreadyExists + | Form_CostMustNotBeNull + | Form_Empty + | Form_GreaterIntThan Int + | Form_InvalidCategory + | Form_InvalidColor + | Form_InvalidDate + | Form_InvalidInt + | Form_InvalidString + | Form_SmallerIntThan Int + + | HttpError_BadPayload + | HttpError_BadUrl + | HttpError_NetworkError + | HttpError_Timeout + + | Income_AddLong + | Income_AddShort + | Income_Amount + | Income_Clone + | Income_CumulativeSince Text + | Income_Date + | Income_DeleteConfirm + | Income_Edit + | Income_Empty + | Income_MonthlyNet + | Income_NotDeleted + | Income_Title + + | Month_January + | Month_February + | Month_March + | Month_April + | Month_May + | Month_June + | Month_July + | Month_August + | Month_September + | Month_October + | Month_November + | Month_December + + | PageNotFound_Title + + | Payment_Add + | Payment_Balanced + | Payment_Category + | Payment_CloneLong + | Payment_CloneShort + | Payment_Cost + | Payment_Date + | Payment_Delete + | Payment_DeleteConfirm + | Payment_EditLong + | Payment_EditShort + | Payment_Empty + | Payment_Frequency + | Payment_InvalidFrequency + | Payment_Many + | Payment_MonthlyFemale + | Payment_MonthlyMale + | Payment_Name + | Payment_NotDeleted + | Payment_One + | Payment_PunctualFemale + | Payment_PunctualMale + | Payment_Title + | Payment_User + | Payment_Worth Text Text + + | Search_Monthly + | Search_Name + | Search_Punctual + + | Secure_Forbidden + | Secure_Unauthorized + + | SignIn_Button + | SignIn_DisconnectSuccess + | SignIn_EmailInvalid + | SignIn_EmailPlaceholder + | SignIn_EmailSendFail + | SignIn_EmailSent + | SignIn_LinkExpired + | SignIn_LinkInvalid + | SignIn_LinkUsed + | SignIn_MailTitle + | SignIn_MailBody Text Text + | SignIn_ParseError + + | Statistic_Title + | Statistic_ByMonthsAndMean Text + | Statistic_By Text Text + | Statistic_Total + + | WeeklyReport_Empty + | WeeklyReport_IncomesCreated Int + | WeeklyReport_IncomesDeleted Int + | WeeklyReport_IncomesEdited Int + | WeeklyReport_IncomeCreated Int + | WeeklyReport_IncomeDeleted Int + | WeeklyReport_IncomeEdited Int + | WeeklyReport_PayedFor Text Text Text Text + | WeeklyReport_PayedForNot Text Text Text Text + | WeeklyReport_PayedFrom Text Text Text + | WeeklyReport_PayedFromNot Text Text Text + | WeeklyReport_PaymentsCreated Int + | WeeklyReport_PaymentsDeleted Int + | WeeklyReport_PaymentsEdited Int + | WeeklyReport_PaymentCreated Int + | WeeklyReport_PaymentDeleted Int + | WeeklyReport_PaymentEdited Int + | WeeklyReport_Title diff --git a/src/common/Message/Lang.hs b/src/common/Message/Lang.hs new file mode 100644 index 0000000..0a32ede --- /dev/null +++ b/src/common/Message/Lang.hs @@ -0,0 +1,7 @@ +module Common.Message.Lang + ( Lang(..) + ) where + +data Lang = + English + | French diff --git a/src/common/Message/Translation.hs b/src/common/Message/Translation.hs new file mode 100644 index 0000000..900a9e9 --- /dev/null +++ b/src/common/Message/Translation.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.Message.Translation + ( get + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Common.Message.Key +import Common.Message.Lang (Lang(..)) + +get :: Lang -> Key -> Text +get = m + +m :: Lang -> Key -> Text + +m l App_Title = + case l of + English -> "Shared Cost" + French -> "Partage des frais" + +m l Category_Add = + case l of + English -> "Add an category" + French -> "Ajouter une catégorie" + +m l Category_Clone = + case l of + English -> "Clone an category" + French -> "Cloner une catégorie" + +m l Category_Color = + case l of + English -> "Color" + French -> "Couleur" + +m l Category_DeleteConfirm = + case l of + English -> "Are you sure to delete this category ?" + French -> "Voulez-vous vraiment supprimer cette catégorie ?" + +m l Category_Edit = + case l of + English -> "Edit an category" + French -> "Modifier une catégorie" + +m l Category_Empty = + case l of + English -> "No category." + French -> "Aucune catégorie." + +m l Category_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Category_NotDeleted = + case l of + English -> "The category could not have been deleted." + French -> "La catégorie n’a pas pu être supprimé." + +m l Category_Title = + case l of + English -> "Categories" + French -> "Catégories" + +m l Category_Used = + case l of + English -> "This category is currently being used" + French -> "Cette catégorie est actuellement utilisée" + +m l (Date_Short day month year) = + case l of + English -> + T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] + French -> + T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] + where padded num pad = + let str = show num + in T.pack $ replicate (pad - length str) '0' ++ str + +m l (Date_ShortMonthAndYear month year) = + case l of + English -> + T.intercalate "-" . map (T.pack . show) $ [ year, month ] + French -> + T.intercalate "/" . map (T.pack . show) $ [ month, year ] + +m l (Date_Long day month year) = + case l of + English -> + T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] + French -> + T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] + +m l Dialog_Confirm = + case l of + English -> "Confirm" + French -> "Confirmer" + +m l Dialog_Undo = + case l of + English -> "Undo" + French -> "Annuler" + +m l Error_CategoryCreate = + case l of + English -> "Error at category creation" + French -> "Erreur lors de la création de la catégorie" + +m l Error_CategoryDelete = + case l of + English -> "Error at category deletion" + French -> "Erreur lors de la suppression de la catégorie" + +m l Error_CategoryEdit = + case l of + English -> "Error at category edition" + French -> "Erreur lors de la modification de la catégorie" + +m l Error_IncomeCreate = + case l of + English -> "Error at income creation" + French -> "Erreur lors de la création du revenu" + +m l Error_IncomeDelete = + case l of + English -> "Error at income deletion" + French -> "Erreur lors de la suppression du revenu" + +m l Error_IncomeEdit = + case l of + English -> "Error at income edition" + French -> "Erreur lors de la modification du revenu" + +m l Error_PaymentCreate = + case l of + English -> "Error at payment creation" + French -> "Erreur lors de la création du paiement" + +m l Error_PaymentDelete = + case l of + English -> "Error at payment deletion" + French -> "Erreur lors de la suppression du paiement" + +m l Error_PaymentEdit = + case l of + English -> "Error at payment edition" + French -> "Erreur lors de la modification du paiement" + +m l Error_SignOut = + case l of + English -> "Error at sign out" + French -> "Erreur lors de la déconnexion" + +m l Form_AlreadyExists = + case l of + English -> "Dupplicate field" + French -> "Doublon" + +m l Form_CostMustNotBeNull = + case l of + English -> "Cost must not be zero" + French -> "Le coût ne doît pas être nul" + +m l Form_Empty = + case l of + English -> "Required field" + French -> "Champ requis" + +m l (Form_GreaterIntThan number) = + case l of + English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] + +m l Form_InvalidCategory = + case l of + English -> "Invalid category" + French -> "Catégorie invalide" + +m l Form_InvalidColor = + case l of + English -> "Invalid color" + French -> "Couleur invalide" + +m l Form_InvalidDate = + case l of + English -> "day/month/year required" + French -> "jour/mois/année requis" + +m l Form_InvalidInt = + case l of + English -> "Integer required" + French -> "Entier requis" + +m l Form_InvalidString = + case l of + English -> "String required" + French -> "Chaîne de caractères requise" + +m l (Form_SmallerIntThan number) = + case l of + English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] + +m l HttpError_BadPayload = + case l of + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" + +m l HttpError_BadUrl = + case l of + English -> "URL not valid" + French -> "l’URL n’est pas valide" + +m l HttpError_NetworkError = + case l of + English -> "Network can not be reached" + French -> "Le serveur n’est pas accessible" + +m l HttpError_Timeout = + case l of + English -> "Timeout server error" + French -> "Le serveur met trop de temps à répondre" + +m l Income_AddLong = + case l of + English -> "Add an income" + French -> "Ajouter un revenu" + +m l Income_AddShort = + case l of + English -> "Add" + French -> "Ajouter" + +m l Income_Amount = + case l of + English -> "Amount" + French -> "Montant" + +m l Income_Clone = + case l of + English -> "Clone an income" + French -> "Cloner un revenu" + +m l (Income_CumulativeSince since) = + case l of + English -> T.concat [ "Cumulative incomes since ", since ] + French -> T.concat [ "Revenus nets cumulés depuis le ", since ] + +m l Income_Date = + case l of + English -> "Date" + French -> "Date" + +m l Income_DeleteConfirm = + case l of + English -> "Are you sure to delete this income ?" + French -> "Voulez-vous vraiment supprimer ce revenu ?" + +m l Income_Edit = + case l of + English -> "Edit an income" + French -> "Modifier un revenu" + +m l Income_Empty = + case l of + English -> "No income." + French -> "Aucun revenu." + +m l Income_MonthlyNet = + case l of + English -> "Net monthly incomes" + French -> "Revenus mensuels nets" + +m l Income_NotDeleted = + case l of + English -> "The income could not have been deleted." + French -> "Le revenu n’a pas pu être supprimé." + +m l Income_Title = + case l of + English -> "Income" + French -> "Revenu" + +m l Month_January = + case l of + English -> "january" + French -> "janvier" + +m l Month_February = + case l of + English -> "february" + French -> "février" + +m l Month_March = + case l of + English -> "march" + French -> "mars" + +m l Month_April = + case l of + English -> "april" + French -> "avril" + +m l Month_May = + case l of + English -> "may" + French -> "mai" + +m l Month_June = + case l of + English -> "june" + French -> "juin" + +m l Month_July = + case l of + English -> "july" + French -> "juillet" + +m l Month_August = + case l of + English -> "august" + French -> "août" + +m l Month_September = + case l of + English -> "september" + French -> "septembre" + +m l Month_October = + case l of + English -> "october" + French -> "octobre" + +m l Month_November = + case l of + English -> "november" + French -> "novembre" + +m l Month_December = + case l of + English -> "december" + French -> "décembre" + +m l PageNotFound_Title = + case l of + English -> "Page not found" + French -> "Page introuvable" + +m l Payment_Add = + case l of + English -> "Add a payment" + French -> "Ajouter un paiement" + +m l Payment_Balanced = + case l of + English -> "Payments are balanced." + French -> "Les paiements sont équilibrés." + +m l Payment_Category = + case l of + English -> "Category" + French -> "Catégorie" + +m l Payment_CloneLong = + case l of + English -> "Clone a payment" + French -> "Cloner un paiement" + +m l Payment_CloneShort = + case l of + English -> "Clone" + French -> "Cloner" + +m l Payment_Cost = + case l of + English -> "Cost" + French -> "Coût" + +m l Payment_Date = + case l of + English -> "Date" + French -> "Date" + +m l Payment_Delete = + case l of + English -> "Delete" + French -> "Supprimer" + +m l Payment_DeleteConfirm = + case l of + English -> "Are you sure to delete this payment ?" + French -> "Voulez-vous vraiment supprimer ce paiement ?" + +m l Payment_EditLong = + case l of + English -> "Edit a payment" + French -> "Modifier un paiement" + +m l Payment_EditShort = + case l of + English -> "Edit" + French -> "Modifier" + +m l Payment_Empty = + case l of + English -> "No payment found from your search criteria." + French -> "Aucun paiement ne correspond à vos critères de recherches." + +m l Payment_Frequency = + case l of + English -> "Frequency" + French -> "Fréquence" + +m l Payment_InvalidFrequency = + case l of + English -> "Invalid frequency" + French -> "Fréquence invalide" + +m l Payment_Many = + case l of + English -> "payments" + French -> "paiements" + +m l Payment_MonthlyFemale = + case l of + English -> "Monthly" + French -> "Mensuelle" + +m l Payment_MonthlyMale = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Payment_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Payment_NotDeleted = + case l of + English -> "The payment could not have been deleted." + French -> "Le paiement n’a pas pu être supprimé." + +m l Payment_One = + case l of + English -> "payment" + French -> "paiement" + +m l Payment_PunctualFemale = + case l of + English -> "Punctual" + French -> "Ponctuelle" + +m l Payment_PunctualMale = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Payment_Title = + case l of + English -> "Payments" + French -> "Paiements" + +m l Payment_User = + case l of + English -> "Payer" + French -> "Payeur" + +m l (Payment_Worth subject amount) = + case l of + English -> T.concat [ subject, " worth ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] + +m l Search_Monthly = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Search_Name = + case l of + English -> "Search" + French -> "Recherche" + +m l Search_Punctual = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Secure_Unauthorized = + case l of + English -> "You are not authorized to sign in." + French -> "Tu n’es pas autorisé à te connecter." + +m l Secure_Forbidden = + case l of + English -> "You need to be logged in to perform this action" + French -> "Tu dois te connecter pour effectuer cette action" + +m l SignIn_Button = + case l of + English -> "Sign in" + French -> "Connexion" + +m l SignIn_DisconnectSuccess = + case l of + English -> "You have successfully disconnected" + French -> "Vous êtes à présent déconnecté." + +m l SignIn_EmailInvalid = + case l of + English -> "Your email is not valid." + French -> "Votre courriel n’est pas valide." + +m l SignIn_EmailPlaceholder = + case l of + English -> "Email" + French -> "Courriel" + +m l SignIn_EmailSendFail = + case l of + English -> "You are authorized to sign in, but we failed to send you the sign up email." + French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." + +m l SignIn_EmailSent = + case l of + English -> "We sent you an email with a connexion link." + French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." + +m l SignIn_LinkExpired = + 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 SignIn_LinkInvalid = + 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 SignIn_LinkUsed = + 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 SignIn_MailTitle = + case l of + English -> T.concat [ "Sign in to ", m l App_Title ] + French -> T.concat [ "Connexion à ", m l App_Title ] + +m l (SignIn_MailBody name url) = + T.intercalate + "\n" + ( case l of + English -> + [ T.concat [ "Hi ", name, "," ] + , "" + , T.concat + [ "Click to the following link in order to sign in to Shared Cost:" + , m l App_Title + , ":" + ] + , url + , "" + , "See you soon!" + ] + French -> + [ T.concat [ "Salut ", name, "," ] + , "" + , T.concat + [ "Clique sur le lien suivant pour te connecter à " + , m l App_Title + , ":" + ] + , url + , "" + , "À très vite !" + ] + ) + +m l SignIn_ParseError = + case l of + English -> "Error while reading initial data." + French -> "Erreur lors de la lecture des données initiales." + +m l (Statistic_By key value) = + case l of + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] + +m l (Statistic_ByMonthsAndMean amount) = + case l of + English -> + T.concat [ "Payments by category by month months (", amount, "on average)" ] + French -> + T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] + +m l Statistic_Title = + case l of + English -> "Statistics" + French -> "Statistiques" + +m l Statistic_Total = + case l of + English -> "Total" + French -> "Total" + +m l WeeklyReport_Empty = + case l of + English -> "No activity the previous week." + French -> "Pas d’activité la semaine passée." + +m l (WeeklyReport_IncomesCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes created:" ] + French -> T.concat [ T.pack . show $ count, " revenus créés :" ] + +m l (WeeklyReport_IncomesDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] + +m l (WeeklyReport_IncomesEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes edited:" ] + French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] + +m l (WeeklyReport_IncomeCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " income created:" ] + French -> T.concat [ T.pack . show $ count, " revenu créé :" ] + +m l (WeeklyReport_IncomeDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " income deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] + +m l (WeeklyReport_IncomeEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " income edited:" ] + French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] + +m l (WeeklyReport_PayedFor name amount for at) = + case l of + English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedForNot name amount for at) = + case l of + English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedFrom name amount for) = + case l of + English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PayedFromNot name amount for) = + case l of + English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PaymentsCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments created:" ] + French -> T.concat [ T.pack . show $ count, " paiements créés :" ] + +m l (WeeklyReport_PaymentsDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] + +m l (WeeklyReport_PaymentsEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments edited:" ] + French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] + +m l (WeeklyReport_PaymentCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment created:" ] + French -> T.concat [ T.pack . show $ count, " paiement créé :" ] + +m l (WeeklyReport_PaymentDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] + +m l (WeeklyReport_PaymentEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment edited:" ] + French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] + +m l WeeklyReport_Title = + case l of + English -> "Weekly report" + French -> "Rapport hebdomadaire" diff --git a/src/common/Model.hs b/src/common/Model.hs new file mode 100644 index 0000000..075021f --- /dev/null +++ b/src/common/Model.hs @@ -0,0 +1,40 @@ +module Common.Model + ( Category(..) + , CategoryId + , CreateCategory(..) + , CreateIncome(..) + , CreatePayment(..) + , Currency(..) + , EditCategory(..) + , EditIncome(..) + , EditPayment(..) + , Frequency(..) + , Income(..) + , IncomeId + , Init(..) + , InitResult(..) + , Payment(..) + , PaymentId + , PaymentCategory(..) + , PaymentCategoryId + , SignIn(..) + , User(..) + , UserId + ) where + +import Common.Model.Category (Category(..), CategoryId) +import Common.Model.CreateCategory (CreateCategory(..)) +import Common.Model.CreateIncome (CreateIncome(..)) +import Common.Model.CreatePayment (CreatePayment(..)) +import Common.Model.Currency (Currency(..)) +import Common.Model.EditCategory (EditCategory(..)) +import Common.Model.EditIncome (EditIncome(..)) +import Common.Model.EditPayment (EditPayment(..)) +import Common.Model.Frequency (Frequency(..)) +import Common.Model.Income (Income(..), IncomeId) +import Common.Model.Init (Init(..)) +import Common.Model.InitResult (InitResult(..)) +import Common.Model.Payment (Payment(..), PaymentId) +import Common.Model.PaymentCategory (PaymentCategory(..), PaymentCategoryId) +import Common.Model.SignIn (SignIn(..)) +import Common.Model.User (User(..), UserId) diff --git a/src/common/Model/Category.hs b/src/common/Model/Category.hs new file mode 100644 index 0000000..53a6bdb --- /dev/null +++ b/src/common/Model/Category.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Category + ( CategoryId + , Category(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type CategoryId = Int64 + +data Category = Category + { _category_id :: CategoryId + , _category_name :: Text + , _category_color :: Text + , _category_createdAt :: UTCTime + , _category_editedAt :: Maybe UTCTime + , _category_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Category +instance ToJSON Category diff --git a/src/common/Model/CreateCategory.hs b/src/common/Model/CreateCategory.hs new file mode 100644 index 0000000..bfe24c5 --- /dev/null +++ b/src/common/Model/CreateCategory.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategory diff --git a/src/common/Model/CreateIncome.hs b/src/common/Model/CreateIncome.hs new file mode 100644 index 0000000..4ee3a50 --- /dev/null +++ b/src/common/Model/CreateIncome.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +data CreateIncome = CreateIncome + { _createIncome_date :: Day + , _createIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON CreateIncome diff --git a/src/common/Model/CreatePayment.hs b/src/common/Model/CreatePayment.hs new file mode 100644 index 0000000..b5b6256 --- /dev/null +++ b/src/common/Model/CreatePayment.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON CreatePayment diff --git a/src/common/Model/Currency.hs b/src/common/Model/Currency.hs new file mode 100644 index 0000000..7c12545 --- /dev/null +++ b/src/common/Model/Currency.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Currency + ( Currency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Currency = Currency Text deriving (Show, Generic) + +instance FromJSON Currency +instance ToJSON Currency diff --git a/src/common/Model/EditCategory.hs b/src/common/Model/EditCategory.hs new file mode 100644 index 0000000..2a3a697 --- /dev/null +++ b/src/common/Model/EditCategory.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategory diff --git a/src/common/Model/EditIncome.hs b/src/common/Model/EditIncome.hs new file mode 100644 index 0000000..a55c39e --- /dev/null +++ b/src/common/Model/EditIncome.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_date :: Day + , _editIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON EditIncome diff --git a/src/common/Model/EditPayment.hs b/src/common/Model/EditPayment.hs new file mode 100644 index 0000000..172c0c1 --- /dev/null +++ b/src/common/Model/EditPayment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON EditPayment diff --git a/src/common/Model/Frequency.hs b/src/common/Model/Frequency.hs new file mode 100644 index 0000000..7c46605 --- /dev/null +++ b/src/common/Model/Frequency.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Frequency + ( Frequency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Frequency = + Punctual + | Monthly + deriving (Eq, Read, Show, Generic) + +instance FromJSON Frequency +instance ToJSON Frequency diff --git a/src/common/Model/Income.hs b/src/common/Model/Income.hs new file mode 100644 index 0000000..280812f --- /dev/null +++ b/src/common/Model/Income.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Income + ( IncomeId + , Income(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +type IncomeId = Int64 + +data Income = Income + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int + , _income_createdAt :: UTCTime + , _income_editedAt :: Maybe UTCTime + , _income_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Income +instance ToJSON Income diff --git a/src/common/Model/Init.hs b/src/common/Model/Init.hs new file mode 100644 index 0000000..68fcfb8 --- /dev/null +++ b/src/common/Model/Init.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Init + ( Init(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category) +import Common.Model.Currency (Currency) +import Common.Model.Income (Income) +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.User (UserId, User) + +data Init = Init + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] + , _init_paymentCategories :: [PaymentCategory] + , _init_currency :: Currency + } deriving (Show, Generic) + +instance FromJSON Init +instance ToJSON Init diff --git a/src/common/Model/InitResult.hs b/src/common/Model/InitResult.hs new file mode 100644 index 0000000..43c16f9 --- /dev/null +++ b/src/common/Model/InitResult.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.InitResult + ( InitResult(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Init (Init) + +data InitResult = + InitSuccess Init + | InitEmpty (Either Text (Maybe Text)) + deriving (Show, Generic) + +instance FromJSON InitResult +instance ToJSON InitResult diff --git a/src/common/Model/Payment.hs b/src/common/Model/Payment.hs new file mode 100644 index 0000000..804b501 --- /dev/null +++ b/src/common/Model/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Payment + ( PaymentId + , Payment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Frequency +import Common.Model.User (UserId) + +type PaymentId = Int64 + +data Payment = Payment + { _payment_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day + , _payment_frequency :: Frequency + , _payment_createdAt :: UTCTime + , _payment_editedAt :: Maybe UTCTime + , _payment_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Payment +instance ToJSON Payment diff --git a/src/common/Model/PaymentCategory.hs b/src/common/Model/PaymentCategory.hs new file mode 100644 index 0000000..a0e94f9 --- /dev/null +++ b/src/common/Model/PaymentCategory.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.PaymentCategory + ( PaymentCategoryId + , PaymentCategory(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +type PaymentCategoryId = Int64 + +data PaymentCategory = PaymentCategory + { _paymentCategory_id :: PaymentCategoryId + , _paymentCategory_name :: Text + , _paymentCategory_category :: CategoryId + , _paymentCategory_createdAt :: UTCTime + , _paymentCategory_editedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON PaymentCategory +instance ToJSON PaymentCategory diff --git a/src/common/Model/SignIn.hs b/src/common/Model/SignIn.hs new file mode 100644 index 0000000..f4da97f --- /dev/null +++ b/src/common/Model/SignIn.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.SignIn + ( SignIn(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data SignIn = SignIn + { _signIn_email :: Text + } deriving (Show, Generic) + +instance FromJSON SignIn +instance ToJSON SignIn diff --git a/src/common/Model/User.hs b/src/common/Model/User.hs new file mode 100644 index 0000000..8c64bc2 --- /dev/null +++ b/src/common/Model/User.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.User + ( UserId + , User(..) + , find + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.List as L +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type UserId = Int64 + +data User = User + { _user_id :: UserId + , _user_creation :: UTCTime + , _user_email :: Text + , _user_name :: Text + } deriving (Show, Generic) + +instance FromJSON User +instance ToJSON User + +find :: UserId -> [User] -> Maybe User +find userId users = L.find ((== userId) . _user_id) users diff --git a/src/common/Util/Text.hs b/src/common/Util/Text.hs new file mode 100644 index 0000000..4af7a4c --- /dev/null +++ b/src/common/Util/Text.hs @@ -0,0 +1,41 @@ +module Common.Util.Text + ( unaccent + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +unaccent :: Text -> Text +unaccent = T.map unaccentChar + +unaccentChar :: Char -> Char +unaccentChar c = case c of + 'à' -> 'a' + 'á' -> 'a' + 'â' -> 'a' + 'ã' -> 'a' + 'ä' -> 'a' + 'ç' -> 'c' + 'è' -> 'e' + 'é' -> 'e' + 'ê' -> 'e' + 'ë' -> 'e' + 'ì' -> 'i' + 'í' -> 'i' + 'î' -> 'i' + 'ï' -> 'i' + 'ñ' -> 'n' + 'ò' -> 'o' + 'ó' -> 'o' + 'ô' -> 'o' + 'õ' -> 'o' + 'ö' -> 'o' + 'š' -> 's' + 'ù' -> 'u' + 'ú' -> 'u' + 'û' -> 'u' + 'ü' -> 'u' + 'ý' -> 'y' + 'ÿ' -> 'y' + 'ž' -> 'z' + _ -> c diff --git a/src/common/View/Format.hs b/src/common/View/Format.hs new file mode 100644 index 0000000..a7fa4e3 --- /dev/null +++ b/src/common/View/Format.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.View.Format + ( shortDay + , longDay + , price + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, toGregorian) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.Currency (Currency(..)) + +shortDay :: Day -> Text +shortDay date = + Message.get $ Key.Date_Short + day + month + (fromIntegral year) + where (year, month, day) = toGregorian date + +longDay :: Day -> Text +longDay date = + Message.get $ Key.Date_Long + day + (fromMaybe "−" . fmap Message.get . monthToKey $ month) + (fromIntegral year) + where (year, month, day) = toGregorian date + + monthToKey 1 = Just Key.Month_January + monthToKey 2 = Just Key.Month_February + monthToKey 3 = Just Key.Month_March + monthToKey 4 = Just Key.Month_April + monthToKey 5 = Just Key.Month_May + monthToKey 6 = Just Key.Month_June + monthToKey 7 = Just Key.Month_July + monthToKey 8 = Just Key.Month_August + monthToKey 9 = Just Key.Month_September + monthToKey 10 = Just Key.Month_October + monthToKey 11 = Just Key.Month_November + monthToKey 12 = Just Key.Month_December + monthToKey _ = Nothing + +price :: Currency -> Int -> Text +price (Currency currency) amount = T.concat [ number amount, " ", currency ] + +number :: Int -> Text +number n = + T.pack + . (++) (if n < 0 then "-" else "") + . reverse + . concat + . intersperse " " + . group 3 + . reverse + . show + . abs $ n + +group :: Int -> [a] -> [[a]] +group n xs = + if length xs <= n + then [xs] + else (take n xs) : (group n (drop n xs)) diff --git a/src/migrations/2.sql b/src/migrations/2.sql new file mode 100644 index 0000000..ec0d1b0 --- /dev/null +++ b/src/migrations/2.sql @@ -0,0 +1,23 @@ +BEGIN TRANSACTION; + +ALTER TABLE payment RENAME TO tmp_payment; + +CREATE TABLE IF NOT EXISTS "payment"( + "id" INTEGER PRIMARY KEY, + "user" INTEGER NOT NULL REFERENCES "user", + "name" VARCHAR NOT NULL, + "cost" INTEGER NOT NULL, + "date" DATE NOT NULL, + "frequency" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +INSERT INTO payment(id, user, name, cost, date, frequency, created_at, edited_at, deleted_at) +SELECT id, user_id, name, cost, date, frequency, created_at, edited_at, deleted_at +FROM tmp_payment; + +DROP TABLE tmp_payment; + +COMMIT; diff --git a/src/server/Common b/src/server/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/server/Common @@ -0,0 +1 @@ +../common \ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs index a05349d..92df4e9 100644 --- a/src/server/Conf.hs +++ b/src/server/Conf.hs @@ -10,11 +10,13 @@ import qualified Data.Text as T import qualified Data.ConfigManager as Conf import Data.Time.Clock (NominalDiffTime) +import Common.Model.Currency (Currency(..)) + data Conf = Conf { hostname :: Text , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Text + , currency :: Currency , noReplyMail :: Text , https :: Bool } deriving Show @@ -28,7 +30,7 @@ get path = do Conf.lookup "hostname" conf <*> Conf.lookup "port" conf <*> Conf.lookup "signInExpiration" conf <*> - Conf.lookup "currency" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> Conf.lookup "https" conf ) diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 3f800da..1a44083 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -11,12 +11,14 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty hiding (delete) +import Common.Model.Category (CategoryId) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.CreateCategory as Json +import qualified Common.Model.EditCategory as Json + import Json (jsonId) -import Model.Category (CategoryId) import qualified Model.Category as Category -import qualified Model.Json.CreateCategory as Json -import qualified Model.Json.EditCategory as Json -import qualified Model.Message.Key as Key import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query import qualified Secure @@ -49,5 +51,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.CategoryNotDeleted + text . TL.fromStrict $ Message.get Key.Category_NotDeleted ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 18394d0..148b713 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -11,26 +11,25 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + import Json (jsonId) -import Model.Income (IncomeId) import qualified Model.Income as Income -import qualified Model.Json.CreateIncome as Json -import qualified Model.Json.EditIncome as Json -import qualified Model.Message.Key as Key import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure -create :: Json.CreateIncome -> ActionM () -create (Json.CreateIncome date amount) = +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId ) -editOwn :: Json.EditIncome -> ActionM () -editOwn (Json.EditIncome incomeId date amount) = +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -45,5 +44,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.IncomeNotDeleted + text . TL.fromStrict $ Message.get Key.Income_NotDeleted ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 9fb2aa0..8473c5c 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -7,15 +7,17 @@ import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) import Web.Scotty hiding (get) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + import Conf (Conf(..)) import Model.Init (getInit) -import Model.Json.Init (InitResult(..)) -import Model.Message.Key -import Model.User (User) import qualified LoginSession -import qualified Model.Json.Conf as M import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -29,17 +31,17 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitError $ errorKey + return . InitEmpty . Left . Message.get $ errorKey Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return InitEmpty + return . InitEmpty . Right $ Nothing Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) initResult + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -52,23 +54,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ SignInInvalid + return . Left $ Key.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ SignInUsed + return . Left $ Key.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ SignInExpired + return . Left $ Key.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn + User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left UnauthorizedSignIn + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d71b451..6a9ede7 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -11,37 +11,36 @@ import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status (ok200, badRequest400) import Web.Scotty +import qualified Common.Model.CreatePayment as M +import qualified Common.Model.EditPayment as M +import Common.Model (PaymentId, User(..)) + import Json (jsonId) -import Model.Payment (PaymentId) -import qualified Model.Json.CreatePayment as Json -import qualified Model.Json.EditPayment as Json -import qualified Model.Json.Payment as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json + (liftIO . Query.run $ Payment.list) >>= json ) -create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date category frequency) = +create :: M.CreatePayment -> ActionM () +create (M.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> (liftIO . Query.run $ do PaymentCategory.save name category - Payment.create (User.id user) name cost date frequency + Payment.create (_user_id user) name cost date frequency ) >>= jsonId ) -editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date category frequency) = +editOwn :: M.EditPayment -> ActionM () +editOwn (M.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (User.id user) paymentId name cost date frequency + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -54,7 +53,7 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId if deleted then status ok200 else status badRequest400 diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 152168c..932ce53 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -5,15 +5,17 @@ module Controller.SignIn ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.SignIn as M + import Conf (Conf) -import Model.Message.Key import qualified Conf import qualified Model.Query as Query import qualified Model.SignIn as SignIn @@ -22,30 +24,24 @@ import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn -signIn :: Conf -> Text -> ActionM () -signIn conf login = - if Email.isValid (TE.encodeUtf8 login) +signIn :: Conf -> M.SignIn -> ActionM () +signIn conf (M.SignIn email) = + if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.getUser login + maybeUser <- liftIO . Query.run $ User.get email case maybeUser of Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login + token <- liftIO . Query.run $ SignIn.createSignInToken email let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, "?signInToken=", token ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> - status ok200 - Left _ -> do - status badRequest400 - text . TL.pack . show $ SendEmailFail - Nothing -> do - status badRequest400 - text . TL.pack . show $ UnauthorizedSignIn - else do - status badRequest400 - text . TL.pack . show $ EnterValidEmail + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs deleted file mode 100644 index d8604ac..0000000 --- a/src/server/Controller/User.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.User - ( getUsers - ) where - -import Web.Scotty - -import Control.Monad.IO.Class (liftIO) - -import qualified Secure - -import Model.Database -import qualified Model.User as User - -getUsers :: ActionM () -getUsers = - Secure.loggedAction (\_ -> - (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json - ) diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index afc601f..06c468e 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -7,6 +7,9 @@ import qualified Clay.Color as C white :: C.Color white = C.white +black :: C.Color +black = C.black + chestnutRose :: C.Color chestnutRose = C.rgb 207 92 86 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index e742978..47ea4a9 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -8,9 +8,7 @@ import Clay import Data.Text.Lazy (Text) -import qualified Design.Header as Header -import qualified Design.SignIn as SignIn -import qualified Design.LoggedIn as LoggedIn +import qualified Design.Views as Views import qualified Design.Form as Form import qualified Design.Errors as Errors import qualified Design.Dialog as Dialog @@ -26,13 +24,10 @@ globalDesign = renderWith compact [] global global :: Css global = do - - header ? Header.design - ".signIn" ? SignIn.design - ".loggedIn" ? LoggedIn.design ".errors" ? Errors.design ".dialog" ? Dialog.design ".tooltip" ? Tooltip.design + Views.design Form.design body ? do @@ -49,6 +44,8 @@ global = do a ? cursor pointer + input ? fontSize inherit + h1 ? do color Color.chestnutRose marginBottom (em 1) diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs deleted file mode 100644 index 8feac64..0000000 --- a/src/server/Design/Header.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - let headerPadding = "padding" -: "0 20px" - display flex - "flex-wrap" -: "wrap" - lineHeightMedia - position relative - backgroundColor Color.chestnutRose - color Color.white - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - Media.mobile $ marginBottom (em 1.5) - - ".title" <> ".item" ? headerPadding - - ".title" ? do - height (pct 100) - textAlign (alignSide sideLeft) - - Media.mobile $ fontSize (px 22) - Media.mobileTablet $ width (pct 100) - Media.tabletDesktop $ do - display inlineBlock - fontSize (px 35) - - ".item" ? do - display inlineBlock - transition "background-color" (ms 50) easeIn (sec 0) - ".current" & backgroundColor (Color.chestnutRose -. 20) - Media.mobile $ fontSize (px 13) - - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) - - ".nameSignOut" ? do - display flex - heightMedia - position absolute - top (px 0) - right (px 0) - - ".name" ? do - Media.mobile $ display none - Media.tabletDesktop $ headerPadding - - ".signOut" ? do - heightMedia - svg ? do - Media.mobile $ width (px 20) - -lineHeightMedia :: Css -lineHeightMedia = do - Media.desktop $ lineHeight (px 80) - Media.tablet $ lineHeight (px 65) - Media.mobile $ lineHeight (px 50) - -heightMedia :: Css -heightMedia = do - Media.desktop $ height (px 80) - Media.tablet $ height (px 65) - Media.mobile $ height (px 50) diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index 869616d..41528ed 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -3,8 +3,8 @@ module Design.Helper ( clearFix , button + , waitable , input - , iconButton , centeredWithMargin , verticalCentering ) where @@ -13,8 +13,6 @@ import Prelude hiding (span) import Clay hiding (button, input) -import Data.Monoid ((<>)) - import Design.Constants import Design.Color as Color @@ -27,6 +25,9 @@ clearFix = button :: Color -> Color -> Size a -> (Color -> Color) -> Css button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center backgroundColor backgroundCol padding (px 0) (px 10) (px 0) (px 10) color textCol @@ -38,19 +39,20 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) + waitable -iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css -iconButton backgroundCol textCol h focusOp = do - button backgroundCol textCol h focusOp - i <> span ? do - height h - lineHeight h - span ? do - display inlineBlock - marginLeft (px 20) - i ? do - marginLeft (px 15) - marginRight (px 20) +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation input :: Double -> Css input h = do @@ -72,3 +74,17 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/LoggedIn.hs deleted file mode 100644 index 4a21832..0000000 --- a/src/server/Design/LoggedIn.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home as Home -import qualified Design.LoggedIn.Stat as Stat -import qualified Design.LoggedIn.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".home" ? Home.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Design/LoggedIn/Home.hs b/src/server/Design/LoggedIn/Home.hs deleted file mode 100644 index 7845434..0000000 --- a/src/server/Design/LoggedIn/Home.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home.Header as Header -import qualified Design.LoggedIn.Home.Table as Table -import qualified Design.LoggedIn.Home.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/LoggedIn/Home/Header.hs b/src/server/Design/LoggedIn/Home/Header.hs deleted file mode 100644 index 5fd2d79..0000000 --- a/src/server/Design/LoggedIn/Home/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/LoggedIn/Home/Pages.hs b/src/server/Design/LoggedIn/Home/Pages.hs deleted file mode 100644 index 71f3254..0000000 --- a/src/server/Design/LoggedIn/Home/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/LoggedIn/Home/Table.hs deleted file mode 100644 index cb46ac9..0000000 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Table - ( design - ) where - -import Clay - -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) diff --git a/src/server/Design/LoggedIn/Stat.hs b/src/server/Design/LoggedIn/Stat.hs deleted file mode 100644 index 62028cb..0000000 --- a/src/server/Design/LoggedIn/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Stat - ( design - ) where - -import Clay - -design :: Css -design = do - h1 ? paddingBottom (px 0) - - ".exceedingPayers" ? ".userName" ? marginRight (px 5) - - ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs deleted file mode 100644 index 44b001a..0000000 --- a/src/server/Design/LoggedIn/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Table - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".emptyTableMsg" ? do - margin (em 2) (em 2) (em 2) (em 2) - textAlign (alignSide sideCenter) - - ".lines" ? do - Media.tabletDesktop $ display displayTable - width (pct 100) - textAlign (alignSide (sideCenter)) - - ".header" <> ".row" ? do - Media.tabletDesktop $ display tableRow - - ".header" ? do - Media.desktop $ do - fontSize (px 18) - height (px 70) - - Media.tabletDesktop $ do - backgroundColor Color.gothic - color Color.white - - Media.tablet $ do - fontSize (px 16) - height (px 60) - - Media.mobile $ do - display none - - ".row" ? do - nthChild "even" & backgroundColor Color.wildSand - - Media.desktop $ do - fontSize (px 18) - height (px 60) - - Media.tablet $ do - height (px 50) - - Media.mobile $ do - lineHeight (px 25) - paddingTop (px 10) - paddingBottom (px 10) - - ".cell" ? do - Media.tabletDesktop $ display tableCell - position relative - verticalAlign middle - - firstChild & do - Media.mobile $ do - fontSize (px 20) - lineHeight (px 30) - color Color.gothic - - ".refund" & color Color.mossGreen - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - hover & "svg path" ? do - "fill" -: "rgb(237, 122, 116)" - - Media.tabletDesktop $ width (pct 3) - - Media.mobile $ do - display inlineBlock - button ? display flex diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs deleted file mode 100644 index 75f2f98..0000000 --- a/src/server/Design/SignIn.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.SignIn - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - - form ? do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - Helper.iconButton Color.gothic Color.white (px inputHeight) Constants.focusLighten - display block - width (pct 100) - fontSize (em 1.2) - ".waitingServer" & ("cursor" -: "not-allowed") - - ".result" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs new file mode 100644 index 0000000..20627e6 --- /dev/null +++ b/src/server/Design/View/Header.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + let headerPadding = "padding" -: "0 20px" + display flex + "flex-wrap" -: "wrap" + lineHeightMedia + position relative + backgroundColor Color.chestnutRose + color Color.white + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + Media.mobile $ marginBottom (em 1.5) + + ".title" <> ".item" ? headerPadding + + ".title" ? do + height (pct 100) + textAlign (alignSide sideLeft) + + Media.mobile $ fontSize (px 22) + Media.mobileTablet $ width (pct 100) + Media.tabletDesktop $ do + display inlineBlock + fontSize (px 35) + + ".item" ? do + display inlineBlock + transition "background-color" (ms 50) easeIn (sec 0) + ".current" & backgroundColor (Color.chestnutRose -. 20) + Media.mobile $ fontSize (px 13) + + (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) + (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + + ".nameSignOut" ? do + display flex + heightMedia + position absolute + top (px 0) + right (px 0) + + ".name" ? do + Media.mobile $ display none + Media.tabletDesktop $ headerPadding + + ".signOut" ? do + Helper.waitable + heightMedia + svg ? do + Media.tabletDesktop $ width (px 30) + Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") + +lineHeightMedia :: Css +lineHeightMedia = do + Media.desktop $ lineHeight (px 80) + Media.tablet $ lineHeight (px 65) + Media.mobile $ lineHeight (px 50) + +heightMedia :: Css +heightMedia = do + Media.desktop $ height (px 80) + Media.tablet $ height (px 65) + Media.mobile $ height (px 50) diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/src/server/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs new file mode 100644 index 0000000..f02da8a --- /dev/null +++ b/src/server/Design/View/Payment/Header.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Constants + +import qualified Design.Helper as Helper +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + marginLeft (pct blockPercentMargin) + marginRight (pct blockPercentMargin) + + ".payerAndAdd" ? do + Media.tabletDesktop $ display flex + marginBottom (em 1) + + ".exceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + + Media.tabletDesktop $ do + "flex-grow" -: "1" + marginRight (px 15) + + Media.mobile $ do + marginBottom (em 1) + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + + ".searchLine" ? do + marginBottom (em 1) + form ? do + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none + + ".infos" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs new file mode 100644 index 0000000..ade81a8 --- /dev/null +++ b/src/server/Design/View/Payment/Pages.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + textAlign (alignSide sideCenter) + Helper.clearFix + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs new file mode 100644 index 0000000..a866b40 --- /dev/null +++ b/src/server/Design/View/Payment/Table.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Table + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".cell" ? do + ".name" & do + Media.tabletDesktop $ width (pct 30) + + ".cost" & do + Media.tabletDesktop $ width (pct 10) + + ".user" & do + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) + + ".date" & do + Media.tabletDesktop $ width (pct 15) + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/src/server/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs new file mode 100644 index 0000000..0a5b258 --- /dev/null +++ b/src/server/Design/View/Stat.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Stat + ( design + ) where + +import Clay + +design :: Css +design = do + h1 ? paddingBottom (px 0) + + ".exceedingPayers" ? ".userName" ? marginRight (px 5) + + ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs new file mode 100644 index 0000000..95abf90 --- /dev/null +++ b/src/server/Design/View/Table.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Table + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".emptyTableMsg" ? do + margin (em 2) (em 2) (em 2) (em 2) + textAlign (alignSide sideCenter) + + ".lines" ? do + Media.tabletDesktop $ display displayTable + width (pct 100) + textAlign (alignSide (sideCenter)) + + ".header" <> ".row" ? do + Media.tabletDesktop $ display tableRow + + ".header" ? do + Media.desktop $ do + fontSize (px 18) + height (px 70) + + Media.tabletDesktop $ do + backgroundColor Color.gothic + color Color.white + + Media.tablet $ do + fontSize (px 16) + height (px 60) + + Media.mobile $ do + display none + + ".row" ? do + nthChild "even" & backgroundColor Color.wildSand + + Media.desktop $ do + fontSize (px 18) + height (px 60) + + Media.tablet $ do + height (px 50) + + Media.mobile $ do + lineHeight (px 25) + paddingTop (px 10) + paddingBottom (px 10) + + ".cell" ? do + Media.tabletDesktop $ display tableCell + position relative + verticalAlign middle + + firstChild & do + Media.mobile $ do + fontSize (px 20) + lineHeight (px 30) + color Color.gothic + + ".refund" & color Color.mossGreen + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + hover & "svg path" ? do + "fill" -: "rgb(237, 122, 116)" + + Media.tabletDesktop $ width (pct 3) + + Media.mobile $ do + display inlineBlock + button ? display flex diff --git a/src/server/Design/Views.hs b/src/server/Design/Views.hs new file mode 100644 index 0000000..bc6ac83 --- /dev/null +++ b/src/server/Design/Views.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.View.Header as Header +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design + ".stat" ? Stat.design + Table.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index 8c11ccf..ba24cca 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -4,7 +4,8 @@ module Job.MonthlyPayment import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Frequency +import Common.Model (Frequency(..), Payment(..)) + import qualified Model.Payment as Payment import Utils.Time (timeToDay) import qualified Model.Query as Query @@ -14,6 +15,12 @@ monthlyPayment _ = do monthlyPayments <- Query.run Payment.listMonthly now <- getCurrentTime actualDay <- timeToDay now - let punctualPayments = map (\p -> p { Payment.frequency = Punctual, Payment.date = actualDay, Payment.createdAt = now }) monthlyPayments + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments _ <- Query.run (Payment.createMany punctualPayments) return now diff --git a/src/server/Main.hs b/src/server/Main.hs index 17c2594..db73474 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -1,16 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + import Network.Wai.Middleware.Static import qualified Data.Text.Lazy as LT import Web.Scotty -import Job.Daemon (runDaemons) import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment import qualified Controller.SignIn as SignIn +import Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query main :: IO () main = do @@ -19,13 +28,19 @@ main = do scotty (Conf.port conf) $ do middleware . staticPolicy $ noDots >-> addBase "public" + get "/exceedingPayer" $ do + time <- liftIO Time.getCurrentTime + (users, incomes, payments) <- liftIO . Query.run $ + liftA3 (,,) UserM.list IncomeM.list PaymentM.list + let exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + get "/" $ do signInToken <- mbParam "signInToken" Index.get conf signInToken post "/signIn" $ do - email <- param "email" - SignIn.signIn conf email + jsonData >>= SignIn.signIn conf post "/signOut" $ Index.signOut conf diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs index 9597bd9..6b7a488 100644 --- a/src/server/Model/Category.hs +++ b/src/server/Model/Category.hs @@ -1,34 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category - ( CategoryId - , Category(..) - , list + ( list , create , edit , delete ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Model.Query (Query(Query)) - -type CategoryId = Int64 +import Common.Model (Category(..), CategoryId) -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow Category where fromRow = Category <$> diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs index f9958e1..4f7b83d 100644 --- a/src/server/Model/Frequency.hs +++ b/src/server/Model/Frequency.hs @@ -1,28 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Model.Frequency - ( Frequency(..) - ) where +module Model.Frequency () where -import Data.Aeson import Database.SQLite.Simple (SQLData(SQLText)) import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) import Database.SQLite.Simple.ToField (ToField(toField)) -import GHC.Generics import qualified Data.Text as T -import Web.Scotty (parseParam, Parsable, readEither) -data Frequency = - Punctual - | Monthly - deriving (Eq, Show, Read, Generic) - -instance Parsable Frequency where parseParam = readEither -instance FromJSON Frequency -instance ToJSON Frequency +import Common.Model.Frequency (Frequency) instance FromField Frequency where fromField field = case fieldData field of diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index c6cdb55..bbe7657 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income - ( IncomeId - , Income(..) - , list + ( list , create , editOwn , deleteOwn , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime, getCurrentTime) @@ -18,27 +16,15 @@ import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite +import Common.Model (Income(..), IncomeId, User(..), UserId) + import Model.Query (Query(Query)) -import Model.User (User, UserId) -import qualified Model.User as User import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type IncomeId = Int64 - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Income where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt instance FromRow Income where fromRow = Income <$> @@ -70,7 +56,7 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == incomeUserId + if _income_userId income == incomeUserId then do now <- getCurrentTime SQLite.execute @@ -90,7 +76,7 @@ deleteOwn user incomeId = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == User.id user + if _income_userId income == _user_id user then do now <- getCurrentTime SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 7a9ccea..8c6a961 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -4,27 +4,24 @@ module Model.Init ( getInit ) where -import Model.Json.Init (Init) +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf import Model.Query (Query) -import Model.User (User) import qualified Model.Category as Category import qualified Model.Income as Income -import qualified Model.Json.Category as Json -import qualified Model.Json.Income as Json -import qualified Model.Json.Init as Init -import qualified Model.Json.Payment as Json -import qualified Model.Json.PaymentCategory as Json -import qualified Model.Json.User as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.User as User -getInit :: User -> Query Init -getInit user = - Init.Init <$> - (map Json.fromUser <$> User.list) <*> - (return . User.id $ user) <*> - (map Json.fromPayment <$> Payment.list) <*> - (map Json.fromIncome <$> Income.list) <*> - (map Json.fromCategory <$> Category.list) <*> - (map Json.fromPaymentCategory <$> PaymentCategory.list) +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs deleted file mode 100644 index 8b5e527..0000000 --- a/src/server/Model/Json/Category.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Category - ( Category(..) - , fromCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.Category as M - -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance ToJSON Category - -fromCategory :: M.Category -> Category -fromCategory category = Category (M.id category) (M.name category) (M.color category) diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs deleted file mode 100644 index a66fb55..0000000 --- a/src/server/Model/Json/Conf.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Conf - ( Conf(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -data Conf = Conf - { currency :: Text - } deriving (Show, Generic) - -instance FromJSON Conf -instance ToJSON Conf diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs deleted file mode 100644 index fffc882..0000000 --- a/src/server/Model/Json/CreateCategory.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateCategory - ( CreateCategory(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text (Text) - -data CreateCategory = CreateCategory - { name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/server/Model/Json/CreateIncome.hs b/src/server/Model/Json/CreateIncome.hs deleted file mode 100644 index cf9b1c3..0000000 --- a/src/server/Model/Json/CreateIncome.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateIncome - ( CreateIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -data CreateIncome = CreateIncome - { date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs deleted file mode 100644 index 6ab3a5b..0000000 --- a/src/server/Model/Json/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs deleted file mode 100644 index a10ce39..0000000 --- a/src/server/Model/Json/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) - -data EditCategory = EditCategory - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs deleted file mode 100644 index 9b29379..0000000 --- a/src/server/Model/Json/EditIncome.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditIncome - ( EditIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -import Model.Income (IncomeId) - -data EditIncome = EditIncome - { id :: IncomeId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs deleted file mode 100644 index b7d4d7d..0000000 --- a/src/server/Model/Json/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) -import Model.Payment (PaymentId) - -data EditPayment = EditPayment - { id :: PaymentId - , name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs deleted file mode 100644 index 7e23a84..0000000 --- a/src/server/Model/Json/Income.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Income - ( Income(..) - , fromIncome - ) where - -import Data.Aeson -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Income (IncomeId) -import Model.User (UserId) -import qualified Model.Income as M - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance ToJSON Income - -fromIncome :: M.Income -> Income -fromIncome income = Income (M.id income) (M.userId income) (M.date income) (M.amount income) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs deleted file mode 100644 index 530c3b7..0000000 --- a/src/server/Model/Json/Init.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Init - ( Init(..) - , InitResult(..) - ) where - -import Data.Aeson -import GHC.Generics - -import Model.Json.Category (Category) -import Model.Json.Income (Income) -import Model.Json.Payment (Payment) -import Model.Json.PaymentCategory (PaymentCategory) -import Model.Json.User (User) -import Model.Message.Key (Key) -import Model.User (UserId) - -data Init = Init - { users :: [User] - , me :: UserId - , payments :: [Payment] - , incomes :: [Income] - , categories :: [Category] - , paymentCategories :: [PaymentCategory] - } deriving (Show, Generic) - -instance ToJSON Init - -data InitResult = - InitEmpty - | InitSuccess Init - | InitError Key - deriving (Show, Generic) - -instance ToJSON InitResult diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs deleted file mode 100644 index 0753d7c..0000000 --- a/src/server/Model/Json/MessagePart.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.MessagePart - ( MessagePart(..) - ) where - -import Data.Text (Text) - -import Data.Aeson -import GHC.Generics - -data MessagePart = - Order Int - | Str Text - deriving (Eq, Show, Generic) - -instance FromJSON MessagePart -instance ToJSON MessagePart diff --git a/src/server/Model/Json/Number.hs b/src/server/Model/Json/Number.hs deleted file mode 100644 index 52c9da8..0000000 --- a/src/server/Model/Json/Number.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Number - ( Number(..) - ) where - -import Data.Aeson -import GHC.Generics - -data Number = Number - { number :: Int - } deriving (Show, Generic) - -instance FromJSON Number -instance ToJSON Number diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs deleted file mode 100644 index e406c0f..0000000 --- a/src/server/Model/Json/Payment.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Payment - ( Payment(..) - , fromPayment - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics -import Prelude hiding (id) - -import Model.Frequency -import Model.Payment (PaymentId) -import Model.User (UserId) -import qualified Model.Payment as M - -data Payment = Payment - { id :: PaymentId - , date :: Day - , name :: Text - , cost :: Int - , userId :: UserId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment - -fromPayment :: M.Payment -> Payment -fromPayment payment = - Payment - { id = M.id payment - , date = M.date payment - , name = M.name payment - , cost = M.cost payment - , userId = M.userId payment - , frequency = M.frequency payment - } diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs deleted file mode 100644 index fd97674..0000000 --- a/src/server/Model/Json/PaymentCategory.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.PaymentCategory - ( PaymentCategory(..) - , fromPaymentCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.PaymentCategory as M - -data PaymentCategory = PaymentCategory - { name :: Text - , category :: CategoryId - } deriving (Show, Generic) - -instance ToJSON PaymentCategory - -fromPaymentCategory :: M.PaymentCategory -> PaymentCategory -fromPaymentCategory pc = PaymentCategory (M.name pc) (M.category pc) diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs deleted file mode 100644 index 9dcfe80..0000000 --- a/src/server/Model/Json/Translation.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Translation - ( Translation(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -import Model.Json.MessagePart - -data Translation = Translation - { key :: Text - , message :: [MessagePart] - } deriving (Show, Generic) - -instance FromJSON Translation -instance ToJSON Translation diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs deleted file mode 100644 index c289fe0..0000000 --- a/src/server/Model/Json/User.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.User - ( User(..) - , fromUser - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.User (UserId) -import qualified Model.User as M - -data User = User - { id :: UserId - , name :: Text - , email :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -fromUser :: M.User -> User -fromUser user = User (M.id user) (M.name user) (M.email user) diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs deleted file mode 100644 index 026967f..0000000 --- a/src/server/Model/Message.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Message - ( getMessage - , getParamMessage - , getTranslations - , plural - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key (Key) -import Model.Message.Lang -import Model.Message.Translations (getNonFormattedMessage) -import Model.Message.Parts - -import Model.Json.Translation - -getMessage :: Key -> Text -getMessage = getParamMessage [] - -getParamMessage :: [Text] -> Key -> Text -getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey) - -getTranslations :: [Translation] -getTranslations = (map getTranslation [minBound..]) - -getTranslation :: Key -> Translation -getTranslation translationKey = - Translation - (T.pack . show $ translationKey) - (getParts $ getNonFormattedMessage lang translationKey) - -plural :: Int -> Key -> Key -> Text -plural count singularKey pluralKey = - getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs deleted file mode 100644 index 18f16f0..0000000 --- a/src/server/Model/Message/Key.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Message.Key - ( Key(..) - ) where - -import qualified Data.Aeson as Json -import qualified Data.Text as T - -data Key = - - -- Title - - SharedCost - - -- Sign - - | Email - | SignIn - | SendEmailFail - | InvalidEmail - | UnauthorizedSignIn - | Forbidden - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid - | SignInMailTitle - | SignInMail - | SignInEmailSent - - -- Dates - - | January - | February - | March - | April - | May - | June - | July - | August - | September - | October - | November - | December - - | ShortDate - | ShortMonthAndYear - | LongDate - - -- Search - - | SearchName - | SearchPunctual - | SearchMonthly - - -- Payments - - | PaymentsAreBalanced - | Name - | Cost - | Payer - | Date - | Frequency - | InvalidFrequency - | AddPayment - | ClonePayment - | EditPayment - | PaymentNotDeleted - | Punctual - | Monthly - - | PaymentsTitle - | Payment - | Payments - | Worth - | NoPayment - - | PaymentName - | PaymentCost - | PaymentDate - | PaymentCategory - | PaymentPunctual - | PaymentMonthly - - | Clone - | Edit - | Delete - | ConfirmPaymentDelete - - -- Categories - - | Categories - | NoCategories - | CategoryNotDeleted - | AddCategory - | CloneCategory - | EditCategory - | ConfirmCategoryDelete - | CategoryName - | CategoryColor - | Color - | UsedCategory - - -- Statistics - - | Statistics - | ByMonthsAndMean - | By - | Total - - -- Income - - | CumulativeIncomesSince - | NoIncome - | Income - | MonthlyNetIncomes - | AddIncome - | CloneIncome - | EditIncome - | IncomeNotDeleted - | IncomeAmount - | IncomeDate - | ConfirmIncomeDelete - | Add - - -- Form - - | Empty - | InvalidString - | InvalidDate - | CostMustNotBeNull - | InvalidInt - | InvalidCategory - | InvalidColor - | AlreadyExists - | SmallerIntThan - | GreaterIntThan - - -- Errors - - | CreatePaymentError - | EditPaymentError - | DeletePaymentError - | CreateIncomeError - | EditIncomeError - | DeleteIncomeError - | CreateCategoryError - | EditCategoryError - | DeleteCategoryError - | SignOutError - - -- Dialog - - | Confirm - | Undo - - -- Page not found - - | PageNotFound - - -- Weekly report - - | WeeklyReport - | WeeklyReportEmpty - | PaymentCreated - | PaymentsCreated - | PaymentEdited - | PaymentsEdited - | PaymentDeleted - | PaymentsDeleted - | IncomeCreated - | IncomesCreated - | IncomeEdited - | IncomesEdited - | IncomeDeleted - | IncomesDeleted - | PayedFor - | DidNotPayFor - | IsPayedFrom - | IsNotPayedFrom - - -- Http error - - | BadUrl - | Timeout - | NetworkError - | BadPayload - - deriving (Enum, Bounded, Show) - -instance Json.ToJSON Key where - toJSON = Json.String . T.pack . show diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs deleted file mode 100644 index f515c96..0000000 --- a/src/server/Model/Message/Lang.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Model.Message.Lang - ( Lang(..) - , lang - ) where - -data Lang = - English - | French - -lang :: Lang -lang = French diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs deleted file mode 100644 index d065cf2..0000000 --- a/src/server/Model/Message/Parts.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Parts - ( replaceParts - , getParts - ) where - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T - -import Text.ParserCombinators.Parsec - -import Model.Json.MessagePart - -replaceParts :: [Text] -> Text -> Text -replaceParts values message = - T.concat . map (replacePart values) $ getParts message - -replacePart :: [Text] -> MessagePart -> Text -replacePart _ (Str str) = str -replacePart values (Order n) = - fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values - -getParts :: Text -> [MessagePart] -getParts str = - case parse partsParser "" (T.unpack str) of - Right parts -> parts - Left _ -> [] - -partsParser :: Parser [MessagePart] -partsParser = many partParser - -partParser :: Parser MessagePart -partParser = - (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n)) - <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str)) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs deleted file mode 100644 index 7d26c3f..0000000 --- a/src/server/Model/Message/Translations.hs +++ /dev/null @@ -1,729 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Translations - ( getNonFormattedMessage - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key -import Model.Message.Lang - -getNonFormattedMessage :: Lang -> Key -> Text -getNonFormattedMessage = m - -m :: Lang -> Key -> Text - --- Title - -m l SharedCost = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - --- Sign in - -m l Email = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn = - case l of - English -> "Sign in" - French -> "Connexion" - -m l InvalidEmail = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n'est pas valide." - -m l UnauthorizedSignIn = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n'es pas autorisé à te connecter." - -m l Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SendEmailFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n'avons pas pu t'envoyer le courriel de connexion." - -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] - French -> T.concat ["Connexion à ", 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 - English -> "We sent you an email with a connexion link." - French -> "Nous t'avons envoyé un courriel avec un lien pour te connecter." - --- Date - -m l January = - case l of - English -> "january" - French -> "janvier" - -m l February = - case l of - English -> "february" - French -> "février" - -m l March = - case l of - English -> "march" - French -> "mars" - -m l April = - case l of - English -> "april" - French -> "avril" - -m l May = - case l of - English -> "may" - French -> "mai" - -m l June = - case l of - English -> "june" - French -> "juin" - -m l July = - case l of - English -> "july" - French -> "juillet" - -m l August = - case l of - English -> "august" - French -> "août" - -m l September = - case l of - English -> "september" - French -> "septembre" - -m l October = - case l of - English -> "october" - French -> "octobre" - -m l November = - case l of - English -> "november" - French -> "novembre" - -m l December = - case l of - English -> "december" - French -> "décembre" - -m l ShortDate = - case l of - English -> "{3}-{2}-{1}" - French -> "{1}/{2}/{3}" - -m l ShortMonthAndYear = - case l of - English -> "{2}-{1}" - French -> "{1}/{2}" - -m l LongDate = - case l of - English -> "{2} {1}, {3}" - French -> "{1} {2} {3}" - --- Search - -m l SearchName = - case l of - English -> "Search" - French -> "Recherche" - -m l SearchPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l SearchMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - --- Payments - -m l PaymentsAreBalanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Name = - case l of - English -> "Name" - French -> "Nom" - -m l Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payer = - case l of - English -> "Payer" - French -> "Payeur" - -m l Date = - case l of - English -> "Date" - French -> "Date" - -m l Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l AddPayment = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l ClonePayment = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l EditPayment = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l PaymentNotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n'a pas pu être supprimé." - -m l Punctual = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Monthly = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l PaymentsTitle = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment = - case l of - English -> "payment" - French -> "paiement" - -m l Payments = - case l of - English -> "payments" - French -> "paiements" - -m l Worth = - case l of - English -> "{1} worth {2}" - French -> "{1} comptabilisant {2}" - -m l NoPayment = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l PaymentName = - case l of - English -> "Name" - French -> "Nom" - -m l PaymentCost = - case l of - English -> "Cost" - French -> "Coût" - -m l PaymentDate = - case l of - English -> "Date" - French -> "Date" - -m l PaymentCategory = - case l of - English -> "Category" - French -> "Catégorie" - -m l PaymentPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l PaymentMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l ConfirmPaymentDelete = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Edit = - case l of - English -> "Edit" - French -> "Modifier" - -m l Clone = - case l of - English -> "Clone" - French -> "Cloner" - -m l Delete = - case l of - English -> "Delete" - French -> "Supprimer" - --- Categories - -m l Categories = - case l of - English -> "Categories" - French -> "Catégories" - -m l NoCategories = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l CategoryNotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n'a pas pu être supprimé." - -m l AddCategory = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l CloneCategory = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l EditCategory = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l ConfirmCategoryDelete = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l CategoryName = - case l of - English -> "Name" - French -> "Nom" - -m l CategoryColor = - case l of - English -> "Color" - French -> "Couleur" - -m l Color = - case l of - English -> "Color" - French -> "Couleur" - -m l UsedCategory = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - --- Statistics - -m l Statistics = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l ByMonthsAndMean = - case l of - English -> "Payments by category by month months ({1} on average)" - French -> "Paiements par catégorie par mois (en moyenne {1})" - -m l By = - case l of - English -> "{1}: {2}" - French -> "{1} : {2}" - -m l Total = - case l of - English -> "Total" - French -> "Total" - --- Income - -m l CumulativeIncomesSince = - case l of - English -> "Cumulative incomes since {1}" - French -> "Revenus nets cumulés depuis le {1}" - -m l NoIncome = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income = - case l of - English -> "Income" - French -> "Revenu" - -m l MonthlyNetIncomes = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l AddIncome = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l CloneIncome = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l EditIncome = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l IncomeNotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n'a pas pu être supprimé." - -m l IncomeAmount = - case l of - English -> "Amount" - French -> "Montant" - -m l IncomeDate = - case l of - English -> "Date" - French -> "Date" - -m l ConfirmIncomeDelete = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Add = - case l of - English -> "Add" - French -> "Ajouter" - --- Form error - -m l Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l SmallerIntThan = - case l of - English -> "Integer bigger than {1} or equal required" - French -> "Entier supérieur ou égal à {1} requis" - -m l GreaterIntThan = - case l of - English -> "Integer smaller than {1} or equal required" - French -> "Entier inférieur ou égal à {1} requis" - --- Errors - -m l CreatePaymentError = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l EditPaymentError = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l DeletePaymentError = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l CreateIncomeError = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l EditIncomeError = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l DeleteIncomeError = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l CreateCategoryError = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l EditCategoryError = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l DeleteCategoryError = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l SignOutError = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - --- Dialog - -m l Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Undo = - case l of - English -> "Undo" - French -> "Annuler" - --- Page not found - -m l PageNotFound = - case l of - English -> "Page not found" - French -> "Page introuvable" - --- Weekly report - -m l WeeklyReport = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" - -m l WeeklyReportEmpty = - case l of - English -> "No activity the previous week." - French -> "Pas d'activité la semaine passée." - -m l PaymentCreated = - case l of - English -> "{1} payment created:" - French -> "{1} paiement créé :" - -m l PaymentsCreated = - case l of - English -> "{1} payments created:" - French -> "{1} paiements créés :" - -m l PaymentEdited = - case l of - English -> "{1} payment edited:" - French -> "{1} paiement modifié :" - -m l PaymentsEdited = - case l of - English -> "{1} payments edited:" - French -> "{1} paiements modifiés :" - -m l PaymentDeleted = - case l of - English -> "{1} payment deleted:" - French -> "{1} paiement supprimé :" - -m l PaymentsDeleted = - case l of - English -> "{1} payments deleted:" - French -> "{1} paiements supprimés :" - -m l IncomeCreated = - case l of - English -> "{1} income created:" - French -> "{1} revenu créé :" - -m l IncomesCreated = - case l of - English -> "{1} incomes created:" - French -> "{1} revenus créés :" - -m l IncomeEdited = - case l of - English -> "{1} income edited:" - French -> "{1} revenu modifié :" - -m l IncomesEdited = - case l of - English -> "{1} incomes edited:" - French -> "{1} revenus modifiés :" - -m l IncomeDeleted = - case l of - English -> "{1} income deleted:" - French -> "{1} revenu supprimé :" - -m l IncomesDeleted = - case l of - English -> "{1} incomes deleted:" - French -> "{1} revenus supprimés :" - -m l PayedFor = - case l of - English -> "{1} payed {2} for “{3}” at {4}" - French -> "{1} a payé {2} concernant « {3} » le {4}" - -m l DidNotPayFor = - case l of - English -> "{1} didn't pay {2} for “{3}” at {4}" - French -> "{1} n'a pas payé {2} concernant « {3} » le {4}" - -m l IsPayedFrom = - case l of - English -> "{1} is payed {2} of net monthly income from {3}" - French -> "{1} est payé {2} net par mois à partir du {3}" - -m l IsNotPayedFrom = - case l of - English -> "{1} isn't payed {2} of net monthly income from {3}" - French -> "{1} n'est pas payé {2} net par mois à partir du {3}" - --- Http error - -m l BadUrl = - case l of - English -> "URL not valid" - French -> "l'URL n'est pas valide" - -m l Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n'est pas accessible" - -m l BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/src/server/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5414d18..5b576c5 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment - ( PaymentId - , Payment(..) + ( Payment(..) , find , list , listMonthly @@ -13,7 +13,6 @@ module Model.Payment , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time (UTCTime) @@ -24,29 +23,19 @@ import Database.SQLite.Simple.ToField (ToField(toField)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Frequency +import Common.Model.Frequency +import Common.Model.Payment (Payment(..)) +import Common.Model.User (UserId) +import Common.Model.Payment (PaymentId) + +import Model.Frequency () import Model.Query (Query(Query)) -import Model.User (UserId) import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type PaymentId = Int64 - -data Payment = Payment - { id :: PaymentId - , userId :: UserId - , name :: Text - , cost :: Int - , date :: Day - , frequency :: Frequency - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Payment where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt instance FromRow Payment where fromRow = Payment <$> @@ -62,12 +51,12 @@ instance FromRow Payment where instance ToRow Payment where toRow p = - [ toField (userId p) - , toField (name p) - , toField (cost p) - , toField (date p) - , toField (frequency p) - , toField (createdAt p) + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_frequency p) + , toField (_payment_createdAt p) ] find :: PaymentId -> Query (Maybe Payment) @@ -92,13 +81,13 @@ listMonthly = ) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create paymentUserId paymentName paymentCost paymentDate paymentFrequency = +create userId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do now <- getCurrentTime SQLite.execute conn "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" - (paymentUserId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -112,13 +101,13 @@ createMany payments = ) editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequency = +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute @@ -133,13 +122,13 @@ editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequ ) deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn paymentUserId paymentId = +deleteOwn userId paymentId = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs index 7c504dc..6e1d304 100644 --- a/src/server/Model/PaymentCategory.hs +++ b/src/server/Model/PaymentCategory.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - , list + ( list , listByCategory , save ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Data.Text as T import qualified Database.SQLite.Simple as SQLite -import Model.Category (CategoryId) -import Model.Query (Query(Query)) -import qualified Utils.Text as T - -type PaymentCategoryId = Int64 +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T -data PaymentCategory = PaymentCategory - { id :: PaymentCategoryId - , name :: Text - , category :: CategoryId - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index c8a0d53..eb78a69 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User - ( UserId - , User(..) - , list - , getUser - , findUser + ( list + , get , createUser , deleteUser ) where -import Data.Int (Int64) -import Data.List (find) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) - -type UserId = Int64 +import Common.Model (UserId, User(..)) -data User = User - { id :: UserId - , creation :: UTCTime - , email :: Text - , name :: Text - } deriving Show +import Model.Query (Query(Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field @@ -37,15 +25,12 @@ instance FromRow User where list :: Query [User] list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") -getUser :: Text -> Query (Maybe User) -getUser userEmail = +get :: Text -> Query (Maybe User) +get userEmail = Query (\conn -> listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -findUser :: UserId -> [User] -> Maybe User -findUser userId = find ((==) userId . id) - createUser :: Text -> Text -> Query UserId createUser userEmail userName = Query (\conn -> do diff --git a/src/server/Secure.hs b/src/server/Secure.hs index da48878..f427304 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -11,11 +11,12 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import Model.Message (getMessage) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + import Model.Query (Query) -import Model.User (User) import qualified LoginSession -import qualified Model.Message.Key as Key import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -31,16 +32,16 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.UnauthorizedSignIn + html . fromStrict . Message.get $ Key.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.Forbidden + html . fromStrict . Message.get $ Key.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do mbSignIn <- SignIn.getSignIn token case mbSignIn of Just signIn -> - User.getUser (SignIn.email signIn) + User.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/src/server/Utils/Text.hs b/src/server/Utils/Text.hs deleted file mode 100644 index 5ed77e4..0000000 --- a/src/server/Utils/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Utils.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs index 4a247e9..97457c7 100644 --- a/src/server/Utils/Time.hs +++ b/src/server/Utils/Time.hs @@ -2,7 +2,6 @@ module Utils.Time ( belongToCurrentMonth , belongToCurrentWeek , timeToDay - , monthToKey ) where import Data.Time.Clock (UTCTime, getCurrentTime) @@ -10,9 +9,6 @@ import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate (toWeekDate) -import Model.Message.Key (Key) -import qualified Model.Message.Key as K - belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time @@ -27,18 +23,3 @@ belongToCurrentWeek time = do timeToDay :: UTCTime -> IO Day timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time - -monthToKey :: Int -> Maybe Key -monthToKey 1 = Just K.January -monthToKey 2 = Just K.February -monthToKey 3 = Just K.March -monthToKey 4 = Just K.April -monthToKey 5 = Just K.May -monthToKey 6 = Just K.June -monthToKey 7 = Just K.July -monthToKey 8 = Just K.August -monthToKey 9 = Just K.September -monthToKey 10 = Just K.October -monthToKey 11 = Just K.November -monthToKey 12 = Just K.December -monthToKey _ = Nothing diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs deleted file mode 100644 index 354d46a..0000000 --- a/src/server/View/Format.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Format - ( price - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) - -import Conf (Conf) -import qualified Conf - -price :: Conf -> Int -> Text -price conf amount = T.concat [number amount, " ", Conf.currency conf] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index c7d40d8..12c4f34 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -6,10 +6,11 @@ module View.Mail.SignIn import Data.Text (Text) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.User (User(..)) + import Conf (Conf) -import Model.Message -import Model.Message.Key -import Model.User (User(..)) import qualified Conf as Conf import qualified Model.Mail as M @@ -18,6 +19,6 @@ mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = (getMessage SignInMailTitle) - , M.plainBody = getParamMessage [name user, url] SignInMail + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index 1a80b95..0bafb70 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -9,38 +9,34 @@ import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime) import qualified Data.Map as M import qualified Data.Text as T -import Resource (Status(..), groupByStatus, statuses) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model.User as User +import qualified Common.View.Format as Format -import Model.Income (Income) import Model.Mail (Mail(Mail)) -import Model.Message (getMessage, getParamMessage, plural) -import Model.Payment (Payment) -import Model.User (findUser) -import Model.User (User, UserId) -import qualified Model.Income as Income +import Model.Payment () +import qualified Model.Income () import qualified Model.Mail as M -import qualified Model.Message.Key as K -import qualified Model.Payment as Payment -import qualified Model.User as User - +import Resource (Status(..), groupByStatus, statuses) import Conf (Conf) import qualified Conf as Conf -import qualified View.Format as Format - -import Utils.Time (monthToKey) - mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = Mail { M.from = Conf.noReplyMail conf - , M.to = map User.email users - , M.subject = T.concat [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport] + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -48,7 +44,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - getMessage K.WeeklyReportEmpty + Message.get Key.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -57,65 +53,45 @@ body conf users paymentsByStatus incomesByStatus = paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = - section - (plural (length payments) singleKey pluralKey) - (map (payedFor status conf users) . sortOn Payment.date $ payments) - where (singleKey, pluralKey) = - case status of - Created -> (K.PaymentCreated, K.PaymentsCreated) - Edited -> (K.PaymentEdited, K.PaymentsEdited) - Deleted -> (K.PaymentDeleted, K.PaymentsDeleted) + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = - getParamMessage - [ formatUserName (Payment.userId payment) users - , Format.price conf . Payment.cost $ payment - , Payment.name payment - , formatDay $ Payment.date payment - ] - ( case status of - Created -> K.PayedFor - Edited -> K.PayedFor - Deleted -> K.DidNotPayFor - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = - section - (plural (length incomes) singleKey pluralKey) - (map (isPayedFrom status conf users) . sortOn Income.date $ incomes) - where (singleKey, pluralKey) = - case status of - Created -> (K.IncomeCreated, K.IncomesCreated) - Edited -> (K.IncomeEdited, K.IncomesEdited) - Deleted -> (K.IncomeDeleted, K.IncomesDeleted) + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = - getParamMessage - [ formatUserName (Income.userId income) users - , Format.price conf . Income.amount $ income - , formatDay $ Income.date income - ] - ( case status of - Created -> K.IsPayedFrom - Edited -> K.IsPayedFrom - Deleted -> K.IsNotPayedFrom - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income formatUserName :: UserId -> [User] -> Text -formatUserName userId = fromMaybe "−" . fmap User.name . findUser userId - -formatDay :: Day -> Text -formatDay d = - let (year, month, day) = toGregorian d - in getParamMessage - [ T.pack . show $ day - , fromMaybe "−" . fmap getMessage . monthToKey $ month - , T.pack . show $ year - ] - K.LongDate +formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId section :: Text -> [Text] -> Text section title items = diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 5a2e4f8..1c072a4 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -16,29 +16,24 @@ import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text (renderHtml) -import Design.Global (globalDesign) +import qualified Common.Message as Message +import Common.Model.InitResult (InitResult) +import qualified Common.Message.Key as Key -import Model.Message -import Model.Json.Conf -import Model.Json.Init (InitResult) -import Model.Message.Key (Key(SharedCost)) +import Design.Global (globalDesign) -page :: Conf -> InitResult -> Text -page conf initResult = +page :: InitResult -> Text +page initResult = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ getMessage SharedCost) - script ! src "javascripts/client.js" $ "" - jsonScript "translations" getTranslations - jsonScript "conf" conf - jsonScript "result" initResult + H.title (toHtml $ Message.get Key.App_Title) + script ! src "javascript/main.js" $ "" + jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign - body $ do - script ! src "javascripts/main.js" $ "" jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = -- cgit v1.2.3 From 903108a3b64758fa58783878756931e6cf187e53 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 7 Nov 2017 09:43:25 +0100 Subject: Reformat payment queries --- src/server/Model/Payment.hs | 36 +++++++++++++++++++++++++++++++----- src/server/Model/User.hs | 12 ++++++------ 2 files changed, 37 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5b576c5..3893850 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -15,6 +15,7 @@ module Model.Payment import Data.Maybe (listToMaybe) import Data.Text (Text) +import qualified Data.Text as T import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Time.Clock (getCurrentTime) @@ -76,7 +77,12 @@ listMonthly = Query (\conn -> SQLite.query conn - "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ? ORDER BY name DESC" + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) (Only Monthly) ) @@ -86,7 +92,10 @@ create userId paymentName paymentCost paymentDate paymentFrequency = now <- getCurrentTime SQLite.execute conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -96,7 +105,10 @@ createMany payments = Query (\conn -> SQLite.executeMany conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) payments ) @@ -112,7 +124,15 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = now <- getCurrentTime SQLite.execute conn - "UPDATE payment SET edited_at = ?, name = ?, cost = ?, date = ?, frequency = ? WHERE id = ?" + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) return True else @@ -147,6 +167,12 @@ modifiedDuring start end = Query (\conn -> SQLite.query conn - "SELECT * FROM payment WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE (created_at >= ? AND created_at <= ?)" + , " OR (edited_at >= ? AND edited_at <= ?)" + , " OR (deleted_at >= ? AND deleted_at <= ?)" + ]) (start, end, start, end, start, end) ) diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index eb78a69..e14fcef 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -4,8 +4,8 @@ module Model.User ( list , get - , createUser - , deleteUser + , create + , delete ) where import Data.Maybe (listToMaybe) @@ -31,8 +31,8 @@ get userEmail = SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -createUser :: Text -> Text -> Query UserId -createUser userEmail userName = +create :: Text -> Text -> Query UserId +create userEmail userName = Query (\conn -> do now <- getCurrentTime SQLite.execute @@ -42,8 +42,8 @@ createUser userEmail userName = SQLite.lastInsertRowId conn ) -deleteUser :: Text -> Query () -deleteUser userEmail = +delete :: Text -> Query () +delete userEmail = Query (\conn -> SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) ) -- cgit v1.2.3 From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- src/client/Common | 1 - src/client/Component/Button.hs | 53 --- src/client/Component/Input.hs | 34 -- src/client/Debug.hs | 17 - src/client/Icon.hs | 44 -- src/client/Main.hs | 41 -- src/client/View/App.hs | 44 -- src/client/View/Header.hs | 86 ---- src/client/View/Payment.hs | 33 -- src/client/View/Payment/Table.hs | 90 ---- src/client/View/SignIn.hs | 86 ---- src/common/Message.hs | 12 - src/common/Message/Key.hs | 152 ------- src/common/Message/Lang.hs | 7 - src/common/Message/Translation.hs | 697 ------------------------------- src/common/Model.hs | 40 -- src/common/Model/Category.hs | 26 -- src/common/Model/CreateCategory.hs | 16 - src/common/Model/CreateIncome.hs | 16 - src/common/Model/CreatePayment.hs | 23 - src/common/Model/Currency.hs | 14 - src/common/Model/EditCategory.hs | 19 - src/common/Model/EditIncome.hs | 19 - src/common/Model/EditPayment.hs | 25 -- src/common/Model/Frequency.hs | 16 - src/common/Model/Income.hs | 29 -- src/common/Model/Init.hs | 28 -- src/common/Model/InitResult.hs | 19 - src/common/Model/Payment.hs | 33 -- src/common/Model/PaymentCategory.hs | 27 -- src/common/Model/SignIn.hs | 16 - src/common/Model/User.hs | 29 -- src/common/Util/Text.hs | 41 -- src/common/View/Format.hs | 69 --- src/migrations/1.sql | 65 --- src/migrations/2.sql | 23 - src/server/Common | 1 - src/server/Conf.hs | 39 -- src/server/Controller/Category.hs | 55 --- src/server/Controller/Income.hs | 48 --- src/server/Controller/Index.hs | 86 ---- src/server/Controller/Payment.hs | 60 --- src/server/Controller/SignIn.hs | 47 --- src/server/Cookie.hs | 56 --- src/server/Design/Color.hs | 35 -- src/server/Design/Constants.hs | 27 -- src/server/Design/Dialog.hs | 24 -- src/server/Design/Errors.hs | 55 --- src/server/Design/Form.hs | 130 ------ src/server/Design/Global.hs | 75 ---- src/server/Design/Helper.hs | 90 ---- src/server/Design/Media.hs | 36 -- src/server/Design/Tooltip.hs | 16 - src/server/Design/View/Header.hs | 78 ---- src/server/Design/View/Payment.hs | 17 - src/server/Design/View/Payment/Header.hs | 84 ---- src/server/Design/View/Payment/Pages.hs | 54 --- src/server/Design/View/Payment/Table.hs | 42 -- src/server/Design/View/SignIn.hs | 42 -- src/server/Design/View/Stat.hs | 15 - src/server/Design/View/Table.hs | 84 ---- src/server/Design/Views.hs | 49 --- src/server/Job/Daemon.hs | 36 -- src/server/Job/Frequency.hs | 13 - src/server/Job/Kind.hs | 22 - src/server/Job/Model.hs | 47 --- src/server/Job/MonthlyPayment.hs | 26 -- src/server/Job/WeeklyReport.hs | 28 -- src/server/Json.hs | 19 - src/server/LoginSession.hs | 53 --- src/server/Main.hs | 79 ---- src/server/MimeMail.hs | 672 ----------------------------- src/server/Model/Category.hs | 79 ---- src/server/Model/Frequency.hs | 22 - src/server/Model/Income.hs | 97 ----- src/server/Model/Init.hs | 27 -- src/server/Model/Mail.hs | 12 - src/server/Model/Payer.hs | 216 ---------- src/server/Model/Payment.hs | 178 -------- src/server/Model/PaymentCategory.hs | 62 --- src/server/Model/Query.hs | 32 -- src/server/Model/SignIn.hs | 66 --- src/server/Model/UUID.hs | 10 - src/server/Model/User.hs | 49 --- src/server/Resource.hs | 54 --- src/server/Secure.hs | 47 --- src/server/SendMail.hs | 44 -- src/server/Utils/Time.hs | 25 -- src/server/Validation.hs | 23 - src/server/View/Mail/SignIn.hs | 24 -- src/server/View/Mail/WeeklyReport.hs | 102 ----- src/server/View/Page.hs | 43 -- 92 files changed, 5542 deletions(-) delete mode 120000 src/client/Common delete mode 100644 src/client/Component/Button.hs delete mode 100644 src/client/Component/Input.hs delete mode 100644 src/client/Debug.hs delete mode 100644 src/client/Icon.hs delete mode 100644 src/client/Main.hs delete mode 100644 src/client/View/App.hs delete mode 100644 src/client/View/Header.hs delete mode 100644 src/client/View/Payment.hs delete mode 100644 src/client/View/Payment/Table.hs delete mode 100644 src/client/View/SignIn.hs delete mode 100644 src/common/Message.hs delete mode 100644 src/common/Message/Key.hs delete mode 100644 src/common/Message/Lang.hs delete mode 100644 src/common/Message/Translation.hs delete mode 100644 src/common/Model.hs delete mode 100644 src/common/Model/Category.hs delete mode 100644 src/common/Model/CreateCategory.hs delete mode 100644 src/common/Model/CreateIncome.hs delete mode 100644 src/common/Model/CreatePayment.hs delete mode 100644 src/common/Model/Currency.hs delete mode 100644 src/common/Model/EditCategory.hs delete mode 100644 src/common/Model/EditIncome.hs delete mode 100644 src/common/Model/EditPayment.hs delete mode 100644 src/common/Model/Frequency.hs delete mode 100644 src/common/Model/Income.hs delete mode 100644 src/common/Model/Init.hs delete mode 100644 src/common/Model/InitResult.hs delete mode 100644 src/common/Model/Payment.hs delete mode 100644 src/common/Model/PaymentCategory.hs delete mode 100644 src/common/Model/SignIn.hs delete mode 100644 src/common/Model/User.hs delete mode 100644 src/common/Util/Text.hs delete mode 100644 src/common/View/Format.hs delete mode 100644 src/migrations/1.sql delete mode 100644 src/migrations/2.sql delete mode 120000 src/server/Common delete mode 100644 src/server/Conf.hs delete mode 100644 src/server/Controller/Category.hs delete mode 100644 src/server/Controller/Income.hs delete mode 100644 src/server/Controller/Index.hs delete mode 100644 src/server/Controller/Payment.hs delete mode 100644 src/server/Controller/SignIn.hs delete mode 100644 src/server/Cookie.hs delete mode 100644 src/server/Design/Color.hs delete mode 100644 src/server/Design/Constants.hs delete mode 100644 src/server/Design/Dialog.hs delete mode 100644 src/server/Design/Errors.hs delete mode 100644 src/server/Design/Form.hs delete mode 100644 src/server/Design/Global.hs delete mode 100644 src/server/Design/Helper.hs delete mode 100644 src/server/Design/Media.hs delete mode 100644 src/server/Design/Tooltip.hs delete mode 100644 src/server/Design/View/Header.hs delete mode 100644 src/server/Design/View/Payment.hs delete mode 100644 src/server/Design/View/Payment/Header.hs delete mode 100644 src/server/Design/View/Payment/Pages.hs delete mode 100644 src/server/Design/View/Payment/Table.hs delete mode 100644 src/server/Design/View/SignIn.hs delete mode 100644 src/server/Design/View/Stat.hs delete mode 100644 src/server/Design/View/Table.hs delete mode 100644 src/server/Design/Views.hs delete mode 100644 src/server/Job/Daemon.hs delete mode 100644 src/server/Job/Frequency.hs delete mode 100644 src/server/Job/Kind.hs delete mode 100644 src/server/Job/Model.hs delete mode 100644 src/server/Job/MonthlyPayment.hs delete mode 100644 src/server/Job/WeeklyReport.hs delete mode 100644 src/server/Json.hs delete mode 100644 src/server/LoginSession.hs delete mode 100644 src/server/Main.hs delete mode 100644 src/server/MimeMail.hs delete mode 100644 src/server/Model/Category.hs delete mode 100644 src/server/Model/Frequency.hs delete mode 100644 src/server/Model/Income.hs delete mode 100644 src/server/Model/Init.hs delete mode 100644 src/server/Model/Mail.hs delete mode 100644 src/server/Model/Payer.hs delete mode 100644 src/server/Model/Payment.hs delete mode 100644 src/server/Model/PaymentCategory.hs delete mode 100644 src/server/Model/Query.hs delete mode 100644 src/server/Model/SignIn.hs delete mode 100644 src/server/Model/UUID.hs delete mode 100644 src/server/Model/User.hs delete mode 100644 src/server/Resource.hs delete mode 100644 src/server/Secure.hs delete mode 100644 src/server/SendMail.hs delete mode 100644 src/server/Utils/Time.hs delete mode 100644 src/server/Validation.hs delete mode 100644 src/server/View/Mail/SignIn.hs delete mode 100644 src/server/View/Mail/WeeklyReport.hs delete mode 100644 src/server/View/Page.hs (limited to 'src') diff --git a/src/client/Common b/src/client/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/client/Common +++ /dev/null @@ -1 +0,0 @@ -../common \ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs deleted file mode 100644 index f21798c..0000000 --- a/src/client/Component/Button.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Component.Button - ( ButtonIn(..) - , buttonInDefault - , ButtonOut(..) - , button - ) where - -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R - -import qualified Icon - -data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool - } - -buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m -buttonInDefault = ButtonIn - { _buttonIn_class = "" - , _buttonIn_content = R.blank - , _buttonIn_waiting = R.never - } - -data ButtonOut t = ButtonOut - { _buttonOut_clic :: Event t () - } - -button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) -button buttonIn = do - attr <- R.holdDyn - (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) - (fmap - (\w -> M.fromList $ - [ ("type", "button") ] - <> if w - then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] - else [("class", _buttonIn_class buttonIn)]) - (_buttonIn_waiting buttonIn)) - (e, _) <- R.elDynAttr' "button" attr $ do - Icon.loading - R.divClass "content" $ _buttonIn_content buttonIn - return $ ButtonOut - { _buttonOut_clic = R.domEvent R.Click e - } diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs deleted file mode 100644 index 7111630..0000000 --- a/src/client/Component/Input.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Component.Input - ( InputIn(..) - , InputOut(..) - , input - ) where - -import Data.Text (Text) -import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) -import qualified Reflex.Dom as R - -data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_placeHolder :: Text - } - -data InputOut t = InputOut - { _inputOut_value :: Dynamic t Text - , _inputOut_enter :: Event t () - } - -input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = do - let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) - let value = fmap (const "") (_inputIn_reset inputIn) - textInput <- R.textInput $ R.def & R.attributes .~ placeHolder - & R.setValue .~ value - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_value = R._textInput_value textInput - , _inputOut_enter = enter - } diff --git a/src/client/Debug.hs b/src/client/Debug.hs deleted file mode 100644 index 0c5c979..0000000 --- a/src/client/Debug.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Debug - ( event - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event, Dynamic) -import qualified Reflex.Dom as R - -event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () -event name e = do - count <- R.count e :: m (Dynamic t Int) - let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count - R.el "div" $ R.dynText text diff --git a/src/client/Icon.hs b/src/client/Icon.hs deleted file mode 100644 index 7223def..0000000 --- a/src/client/Icon.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Icon - ( loading - , signOut - , clone - , edit - , delete - ) where - -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank - -clone :: forall t m. MonadWidget t m => m () -clone = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank - -edit :: forall t m. MonadWidget t m => m () -edit = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank - -delete :: forall t m. MonadWidget t m => m () -delete = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank - -svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a -svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/src/client/Main.hs b/src/client/Main.hs deleted file mode 100644 index c5f2c50..0000000 --- a/src/client/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Main - ( main - ) where - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LB -import Data.JSString.Text (textFromJSString) -import qualified Data.Text.Encoding as T -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.NonElementParentNode as Dom -import GHCJS.DOM.Types (JSM, Element, JSString) -import Prelude hiding (init, error) - -import Common.Model (InitResult(InitEmpty)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key - -import qualified View.App as App - -main :: JSM () -main = do - initResult <- readInit - putStrLn . show $ initResult - App.widget initResult - -readInit :: JSM InitResult -readInit = do - document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document "init" - case initNode of - Just node -> do - text <- textFromJSString <$> js_getInnerText node - return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of - Just init -> init - Nothing -> initParseError - _ -> - return initParseError - where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) - -foreign import javascript unsafe "$1[\"innerText\"]" - js_getInnerText :: Element -> IO JSString diff --git a/src/client/View/App.hs b/src/client/View/App.hs deleted file mode 100644 index 1466811..0000000 --- a/src/client/View/App.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.App - ( widget - ) where - -import qualified Reflex.Dom as R -import Prelude hiding (init, error) - -import Common.Model (InitResult(..)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key - -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn - -widget :: InitResult -> IO () -widget initResult = - R.mainWidget $ do - headerOut <- Header.view $ HeaderIn - { _headerIn_initResult = initResult - } - - let signOut = Header._headerOut_signOut headerOut - - initialContent = case initResult of - InitSuccess initSuccess -> do - _ <- Payment.widget $ PaymentIn - { _paymentIn_init = initSuccess - } - return () - InitEmpty result -> - SignIn.view result - - signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) - - _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) - - R.blank diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs deleted file mode 100644 index 32738f1..0000000 --- a/src/client/View/Header.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Header - ( view - , HeaderIn(..) - , HeaderOut(..) - ) where - -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model.User as User - -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component -import qualified Icon - -data HeaderIn = HeaderIn - { _headerIn_initResult :: InitResult - } - -data HeaderOut t = HeaderOut - { _headerOut_signOut :: Event t () - } - -view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) -view headerIn = - R.el "header" $ do - - R.divClass "title" $ - R.text $ Message.get Key.App_Title - - signOut <- nameSignOut $ _headerIn_initResult headerIn - - return $ HeaderOut - { _headerOut_signOut = signOut - } - -nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) -nameSignOut initResult = case initResult of - (InitSuccess init) -> do - rec - attr <- R.holdDyn - (M.singleton "class" "nameSignOut") - (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) - - signOut <- R.elDynAttr "nameSignOut" attr $ do - case User.find (_init_currentUser init) (_init_users init) of - Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank - signOutButton - - return signOut - _ -> - return R.never - -signOutButton :: forall t m. MonadWidget t m => m (Event t ()) -signOutButton = do - rec - signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = "signOut item" - , Component._buttonIn_content = Icon.signOut - , Component._buttonIn_waiting = waiting - } - let signOutClic = Component._buttonOut_clic signOut - waiting = R.leftmost - [ fmap (const True) signOutClic - , fmap (const False) signOutSuccess - ] - signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) - - return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess - - where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) - askSignOut signOut = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut - getResult = (== 200) . R._xhrResponse_status diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs deleted file mode 100644 index e80790b..0000000 --- a/src/client/View/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Payment - ( widget - , PaymentIn(..) - , PaymentOut(..) - ) where - -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init) - -import View.Payment.Table (TableIn(..)) -import qualified View.Payment.Table as Table - -data PaymentIn = PaymentIn - { _paymentIn_init :: Init - } - -data PaymentOut = PaymentOut - { - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut -widget paymentIn = do - R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - return $ PaymentOut {} diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs deleted file mode 100644 index 878e7da..0000000 --- a/src/client/View/Payment/Table.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Payment.Table - ( widget - , TableIn(..) - , TableOut(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model.User as User -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format - -import qualified Icon - -data TableIn = TableIn - { _tableIn_init :: Init - } - -data TableOut = TableOut - { - } - -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut -widget tableIn = do - R.divClass "table" $ - R.divClass "lines" $ do - R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name - R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost - R.divClass "cell user" $ R.text $ Message.get Key.Payment_User - R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category - R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - let init = _tableIn_init tableIn - payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) - return $ TableOut {} - -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () -paymentRow init payment = - R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment - R.divClass "cell user" $ - case User.find (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) - R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank - -findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category -findCategory categories paymentCategories paymentName = do - paymentCategory <- L.find - ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) - paymentCategories - L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs deleted file mode 100644 index e164ee7..0000000 --- a/src/client/View/SignIn.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.SignIn - ( view - ) where - -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) - -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component - -view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () -view result = - R.divClass "signIn" $ do - rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder - } - - let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button - - dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ - [ fmap (const True) userWantsEmailValidation - , fmap (const False) signInResult - ] - - uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail - - let validatedEmail = R.tagPromptlyDyn - (_inputOut_value input) - (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) - - let waiting = R.leftmost - [ fmap (const True) validatedEmail - , fmap (const False) signInResult - ] - - button <- Component.button $ ButtonIn - { _buttonIn_class = "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) - , _buttonIn_waiting = waiting - } - - signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) - - showSignInResult result signInResult - -askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) -askSignIn email = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email - getResult response = - case R._xhrResponse_responseText response of - Just key -> - if R._xhrResponse_status response == 200 then Right key else Left key - _ -> Left "NoKey" - -showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () -showSignInResult result signInResult = do - _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult - R.blank - - where showInitResult (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank - - showResult (Left error) = showError error - showResult (Right success) = showSuccess success - - showError = R.divClass "error" . R.text - showSuccess = R.divClass "success" . R.text diff --git a/src/common/Message.hs b/src/common/Message.hs deleted file mode 100644 index 9ae735d..0000000 --- a/src/common/Message.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Common.Message - ( get - ) where - -import Data.Text (Text) - -import Common.Message.Key (Key) -import Common.Message.Lang (Lang(..)) -import qualified Common.Message.Translation as Translation - -get :: Key -> Text -get = Translation.get French diff --git a/src/common/Message/Key.hs b/src/common/Message/Key.hs deleted file mode 100644 index 4127808..0000000 --- a/src/common/Message/Key.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Common.Message.Key - ( Key(..) - ) where - -import Data.Text - -data Key = - - App_Title - - | Category_Add - | Category_Clone - | Category_Color - | Category_DeleteConfirm - | Category_Edit - | Category_Empty - | Category_Name - | Category_NotDeleted - | Category_Title - | Category_Used - - | Date_Long Int Text Int - | Date_Short Int Int Int - | Date_ShortMonthAndYear Int Int - - | Dialog_Confirm - | Dialog_Undo - - | Error_CategoryCreate - | Error_CategoryDelete - | Error_CategoryEdit - | Error_IncomeCreate - | Error_IncomeDelete - | Error_IncomeEdit - | Error_PaymentCreate - | Error_PaymentDelete - | Error_PaymentEdit - | Error_SignOut - - | Form_AlreadyExists - | Form_CostMustNotBeNull - | Form_Empty - | Form_GreaterIntThan Int - | Form_InvalidCategory - | Form_InvalidColor - | Form_InvalidDate - | Form_InvalidInt - | Form_InvalidString - | Form_SmallerIntThan Int - - | HttpError_BadPayload - | HttpError_BadUrl - | HttpError_NetworkError - | HttpError_Timeout - - | Income_AddLong - | Income_AddShort - | Income_Amount - | Income_Clone - | Income_CumulativeSince Text - | Income_Date - | Income_DeleteConfirm - | Income_Edit - | Income_Empty - | Income_MonthlyNet - | Income_NotDeleted - | Income_Title - - | Month_January - | Month_February - | Month_March - | Month_April - | Month_May - | Month_June - | Month_July - | Month_August - | Month_September - | Month_October - | Month_November - | Month_December - - | PageNotFound_Title - - | Payment_Add - | Payment_Balanced - | Payment_Category - | Payment_CloneLong - | Payment_CloneShort - | Payment_Cost - | Payment_Date - | Payment_Delete - | Payment_DeleteConfirm - | Payment_EditLong - | Payment_EditShort - | Payment_Empty - | Payment_Frequency - | Payment_InvalidFrequency - | Payment_Many - | Payment_MonthlyFemale - | Payment_MonthlyMale - | Payment_Name - | Payment_NotDeleted - | Payment_One - | Payment_PunctualFemale - | Payment_PunctualMale - | Payment_Title - | Payment_User - | Payment_Worth Text Text - - | Search_Monthly - | Search_Name - | Search_Punctual - - | Secure_Forbidden - | Secure_Unauthorized - - | SignIn_Button - | SignIn_DisconnectSuccess - | SignIn_EmailInvalid - | SignIn_EmailPlaceholder - | SignIn_EmailSendFail - | SignIn_EmailSent - | SignIn_LinkExpired - | SignIn_LinkInvalid - | SignIn_LinkUsed - | SignIn_MailTitle - | SignIn_MailBody Text Text - | SignIn_ParseError - - | Statistic_Title - | Statistic_ByMonthsAndMean Text - | Statistic_By Text Text - | Statistic_Total - - | WeeklyReport_Empty - | WeeklyReport_IncomesCreated Int - | WeeklyReport_IncomesDeleted Int - | WeeklyReport_IncomesEdited Int - | WeeklyReport_IncomeCreated Int - | WeeklyReport_IncomeDeleted Int - | WeeklyReport_IncomeEdited Int - | WeeklyReport_PayedFor Text Text Text Text - | WeeklyReport_PayedForNot Text Text Text Text - | WeeklyReport_PayedFrom Text Text Text - | WeeklyReport_PayedFromNot Text Text Text - | WeeklyReport_PaymentsCreated Int - | WeeklyReport_PaymentsDeleted Int - | WeeklyReport_PaymentsEdited Int - | WeeklyReport_PaymentCreated Int - | WeeklyReport_PaymentDeleted Int - | WeeklyReport_PaymentEdited Int - | WeeklyReport_Title diff --git a/src/common/Message/Lang.hs b/src/common/Message/Lang.hs deleted file mode 100644 index 0a32ede..0000000 --- a/src/common/Message/Lang.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Common.Message.Lang - ( Lang(..) - ) where - -data Lang = - English - | French diff --git a/src/common/Message/Translation.hs b/src/common/Message/Translation.hs deleted file mode 100644 index 900a9e9..0000000 --- a/src/common/Message/Translation.hs +++ /dev/null @@ -1,697 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Common.Message.Translation - ( get - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Common.Message.Key -import Common.Message.Lang (Lang(..)) - -get :: Lang -> Key -> Text -get = m - -m :: Lang -> Key -> Text - -m l App_Title = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - -m l Category_Add = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l Category_Clone = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l Category_Color = - case l of - English -> "Color" - French -> "Couleur" - -m l Category_DeleteConfirm = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l Category_Edit = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l Category_Empty = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l Category_Name = - case l of - English -> "Name" - French -> "Nom" - -m l Category_NotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n’a pas pu être supprimé." - -m l Category_Title = - case l of - English -> "Categories" - French -> "Catégories" - -m l Category_Used = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - -m l (Date_Short day month year) = - case l of - English -> - T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] - French -> - T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] - where padded num pad = - let str = show num - in T.pack $ replicate (pad - length str) '0' ++ str - -m l (Date_ShortMonthAndYear month year) = - case l of - English -> - T.intercalate "-" . map (T.pack . show) $ [ year, month ] - French -> - T.intercalate "/" . map (T.pack . show) $ [ month, year ] - -m l (Date_Long day month year) = - case l of - English -> - T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] - French -> - T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] - -m l Dialog_Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Dialog_Undo = - case l of - English -> "Undo" - French -> "Annuler" - -m l Error_CategoryCreate = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l Error_CategoryDelete = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l Error_CategoryEdit = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l Error_IncomeCreate = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l Error_IncomeDelete = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l Error_IncomeEdit = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l Error_PaymentCreate = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l Error_PaymentDelete = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l Error_PaymentEdit = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l Error_SignOut = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - -m l Form_AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l Form_CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l Form_Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l (Form_GreaterIntThan number) = - case l of - English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] - French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] - -m l Form_InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l Form_InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l Form_InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l Form_InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l Form_InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l (Form_SmallerIntThan number) = - case l of - English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] - French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] - -m l HttpError_BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" - -m l HttpError_BadUrl = - case l of - English -> "URL not valid" - French -> "l’URL n’est pas valide" - -m l HttpError_NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n’est pas accessible" - -m l HttpError_Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l Income_AddLong = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l Income_AddShort = - case l of - English -> "Add" - French -> "Ajouter" - -m l Income_Amount = - case l of - English -> "Amount" - French -> "Montant" - -m l Income_Clone = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l (Income_CumulativeSince since) = - case l of - English -> T.concat [ "Cumulative incomes since ", since ] - French -> T.concat [ "Revenus nets cumulés depuis le ", since ] - -m l Income_Date = - case l of - English -> "Date" - French -> "Date" - -m l Income_DeleteConfirm = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Income_Edit = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l Income_Empty = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income_MonthlyNet = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l Income_NotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n’a pas pu être supprimé." - -m l Income_Title = - case l of - English -> "Income" - French -> "Revenu" - -m l Month_January = - case l of - English -> "january" - French -> "janvier" - -m l Month_February = - case l of - English -> "february" - French -> "février" - -m l Month_March = - case l of - English -> "march" - French -> "mars" - -m l Month_April = - case l of - English -> "april" - French -> "avril" - -m l Month_May = - case l of - English -> "may" - French -> "mai" - -m l Month_June = - case l of - English -> "june" - French -> "juin" - -m l Month_July = - case l of - English -> "july" - French -> "juillet" - -m l Month_August = - case l of - English -> "august" - French -> "août" - -m l Month_September = - case l of - English -> "september" - French -> "septembre" - -m l Month_October = - case l of - English -> "october" - French -> "octobre" - -m l Month_November = - case l of - English -> "november" - French -> "novembre" - -m l Month_December = - case l of - English -> "december" - French -> "décembre" - -m l PageNotFound_Title = - case l of - English -> "Page not found" - French -> "Page introuvable" - -m l Payment_Add = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l Payment_Balanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Payment_Category = - case l of - English -> "Category" - French -> "Catégorie" - -m l Payment_CloneLong = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l Payment_CloneShort = - case l of - English -> "Clone" - French -> "Cloner" - -m l Payment_Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payment_Date = - case l of - English -> "Date" - French -> "Date" - -m l Payment_Delete = - case l of - English -> "Delete" - French -> "Supprimer" - -m l Payment_DeleteConfirm = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Payment_EditLong = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l Payment_EditShort = - case l of - English -> "Edit" - French -> "Modifier" - -m l Payment_Empty = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l Payment_Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l Payment_InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l Payment_Many = - case l of - English -> "payments" - French -> "paiements" - -m l Payment_MonthlyFemale = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l Payment_MonthlyMale = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l Payment_Name = - case l of - English -> "Name" - French -> "Nom" - -m l Payment_NotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n’a pas pu être supprimé." - -m l Payment_One = - case l of - English -> "payment" - French -> "paiement" - -m l Payment_PunctualFemale = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Payment_PunctualMale = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l Payment_Title = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment_User = - case l of - English -> "Payer" - French -> "Payeur" - -m l (Payment_Worth subject amount) = - case l of - English -> T.concat [ subject, " worth ", amount ] - French -> T.concat [ subject, " comptabilisant ", amount ] - -m l Search_Monthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l Search_Name = - case l of - English -> "Search" - French -> "Recherche" - -m l Search_Punctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l Secure_Unauthorized = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n’es pas autorisé à te connecter." - -m l Secure_Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SignIn_Button = - case l of - English -> "Sign in" - French -> "Connexion" - -m l SignIn_DisconnectSuccess = - case l of - English -> "You have successfully disconnected" - French -> "Vous êtes à présent déconnecté." - -m l SignIn_EmailInvalid = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n’est pas valide." - -m l SignIn_EmailPlaceholder = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn_EmailSendFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." - -m l SignIn_EmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." - -m l SignIn_LinkExpired = - 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 SignIn_LinkInvalid = - 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 SignIn_LinkUsed = - 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 SignIn_MailTitle = - case l of - English -> T.concat [ "Sign in to ", m l App_Title ] - French -> T.concat [ "Connexion à ", m l App_Title ] - -m l (SignIn_MailBody name url) = - T.intercalate - "\n" - ( case l of - English -> - [ T.concat [ "Hi ", name, "," ] - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l App_Title - , ":" - ] - , url - , "" - , "See you soon!" - ] - French -> - [ T.concat [ "Salut ", name, "," ] - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l App_Title - , ":" - ] - , url - , "" - , "À très vite !" - ] - ) - -m l SignIn_ParseError = - case l of - English -> "Error while reading initial data." - French -> "Erreur lors de la lecture des données initiales." - -m l (Statistic_By key value) = - case l of - English -> T.concat [ key, ": ", value ] - French -> T.concat [ key, " : ", value ] - -m l (Statistic_ByMonthsAndMean amount) = - case l of - English -> - T.concat [ "Payments by category by month months (", amount, "on average)" ] - French -> - T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] - -m l Statistic_Title = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l Statistic_Total = - case l of - English -> "Total" - French -> "Total" - -m l WeeklyReport_Empty = - case l of - English -> "No activity the previous week." - French -> "Pas d’activité la semaine passée." - -m l (WeeklyReport_IncomesCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes created:" ] - French -> T.concat [ T.pack . show $ count, " revenus créés :" ] - -m l (WeeklyReport_IncomesDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] - French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] - -m l (WeeklyReport_IncomesEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes edited:" ] - French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] - -m l (WeeklyReport_IncomeCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " income created:" ] - French -> T.concat [ T.pack . show $ count, " revenu créé :" ] - -m l (WeeklyReport_IncomeDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " income deleted:" ] - French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] - -m l (WeeklyReport_IncomeEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " income edited:" ] - French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] - -m l (WeeklyReport_PayedFor name amount for at) = - case l of - English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] - -m l (WeeklyReport_PayedForNot name amount for at) = - case l of - English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] - -m l (WeeklyReport_PayedFrom name amount for) = - case l of - English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] - -m l (WeeklyReport_PayedFromNot name amount for) = - case l of - English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] - -m l (WeeklyReport_PaymentsCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments created:" ] - French -> T.concat [ T.pack . show $ count, " paiements créés :" ] - -m l (WeeklyReport_PaymentsDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments deleted:" ] - French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] - -m l (WeeklyReport_PaymentsEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments edited:" ] - French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] - -m l (WeeklyReport_PaymentCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment created:" ] - French -> T.concat [ T.pack . show $ count, " paiement créé :" ] - -m l (WeeklyReport_PaymentDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment deleted:" ] - French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] - -m l (WeeklyReport_PaymentEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment edited:" ] - French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] - -m l WeeklyReport_Title = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" diff --git a/src/common/Model.hs b/src/common/Model.hs deleted file mode 100644 index 075021f..0000000 --- a/src/common/Model.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Common.Model - ( Category(..) - , CategoryId - , CreateCategory(..) - , CreateIncome(..) - , CreatePayment(..) - , Currency(..) - , EditCategory(..) - , EditIncome(..) - , EditPayment(..) - , Frequency(..) - , Income(..) - , IncomeId - , Init(..) - , InitResult(..) - , Payment(..) - , PaymentId - , PaymentCategory(..) - , PaymentCategoryId - , SignIn(..) - , User(..) - , UserId - ) where - -import Common.Model.Category (Category(..), CategoryId) -import Common.Model.CreateCategory (CreateCategory(..)) -import Common.Model.CreateIncome (CreateIncome(..)) -import Common.Model.CreatePayment (CreatePayment(..)) -import Common.Model.Currency (Currency(..)) -import Common.Model.EditCategory (EditCategory(..)) -import Common.Model.EditIncome (EditIncome(..)) -import Common.Model.EditPayment (EditPayment(..)) -import Common.Model.Frequency (Frequency(..)) -import Common.Model.Income (Income(..), IncomeId) -import Common.Model.Init (Init(..)) -import Common.Model.InitResult (InitResult(..)) -import Common.Model.Payment (Payment(..), PaymentId) -import Common.Model.PaymentCategory (PaymentCategory(..), PaymentCategoryId) -import Common.Model.SignIn (SignIn(..)) -import Common.Model.User (User(..), UserId) diff --git a/src/common/Model/Category.hs b/src/common/Model/Category.hs deleted file mode 100644 index 53a6bdb..0000000 --- a/src/common/Model/Category.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Category - ( CategoryId - , Category(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -type CategoryId = Int64 - -data Category = Category - { _category_id :: CategoryId - , _category_name :: Text - , _category_color :: Text - , _category_createdAt :: UTCTime - , _category_editedAt :: Maybe UTCTime - , _category_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Category -instance ToJSON Category diff --git a/src/common/Model/CreateCategory.hs b/src/common/Model/CreateCategory.hs deleted file mode 100644 index bfe24c5..0000000 --- a/src/common/Model/CreateCategory.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreateCategory - ( CreateCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data CreateCategory = CreateCategory - { _createCategory_name :: Text - , _createCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/common/Model/CreateIncome.hs b/src/common/Model/CreateIncome.hs deleted file mode 100644 index 4ee3a50..0000000 --- a/src/common/Model/CreateIncome.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreateIncome - ( CreateIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -data CreateIncome = CreateIncome - { _createIncome_date :: Day - , _createIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/common/Model/CreatePayment.hs b/src/common/Model/CreatePayment.hs deleted file mode 100644 index b5b6256..0000000 --- a/src/common/Model/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { _createPayment_name :: Text - , _createPayment_cost :: Int - , _createPayment_date :: Day - , _createPayment_category :: CategoryId - , _createPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/common/Model/Currency.hs b/src/common/Model/Currency.hs deleted file mode 100644 index 7c12545..0000000 --- a/src/common/Model/Currency.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Currency - ( Currency(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -newtype Currency = Currency Text deriving (Show, Generic) - -instance FromJSON Currency -instance ToJSON Currency diff --git a/src/common/Model/EditCategory.hs b/src/common/Model/EditCategory.hs deleted file mode 100644 index 2a3a697..0000000 --- a/src/common/Model/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text - , _editCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/common/Model/EditIncome.hs b/src/common/Model/EditIncome.hs deleted file mode 100644 index a55c39e..0000000 --- a/src/common/Model/EditIncome.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditIncome - ( EditIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Income (IncomeId) - -data EditIncome = EditIncome - { _editIncome_id :: IncomeId - , _editIncome_date :: Day - , _editIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/common/Model/EditPayment.hs b/src/common/Model/EditPayment.hs deleted file mode 100644 index 172c0c1..0000000 --- a/src/common/Model/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) -import Common.Model.Payment (PaymentId) - -data EditPayment = EditPayment - { _editPayment_id :: PaymentId - , _editPayment_name :: Text - , _editPayment_cost :: Int - , _editPayment_date :: Day - , _editPayment_category :: CategoryId - , _editPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/common/Model/Frequency.hs b/src/common/Model/Frequency.hs deleted file mode 100644 index 7c46605..0000000 --- a/src/common/Model/Frequency.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Frequency - ( Frequency(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -data Frequency = - Punctual - | Monthly - deriving (Eq, Read, Show, Generic) - -instance FromJSON Frequency -instance ToJSON Frequency diff --git a/src/common/Model/Income.hs b/src/common/Model/Income.hs deleted file mode 100644 index 280812f..0000000 --- a/src/common/Model/Income.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Income - ( IncomeId - , Income(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.User (UserId) - -type IncomeId = Int64 - -data Income = Income - { _income_id :: IncomeId - , _income_userId :: UserId - , _income_date :: Day - , _income_amount :: Int - , _income_createdAt :: UTCTime - , _income_editedAt :: Maybe UTCTime - , _income_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Income -instance ToJSON Income diff --git a/src/common/Model/Init.hs b/src/common/Model/Init.hs deleted file mode 100644 index 68fcfb8..0000000 --- a/src/common/Model/Init.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Init - ( Init(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Category (Category) -import Common.Model.Currency (Currency) -import Common.Model.Income (Income) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.User (UserId, User) - -data Init = Init - { _init_users :: [User] - , _init_currentUser :: UserId - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - , _init_currency :: Currency - } deriving (Show, Generic) - -instance FromJSON Init -instance ToJSON Init diff --git a/src/common/Model/InitResult.hs b/src/common/Model/InitResult.hs deleted file mode 100644 index 43c16f9..0000000 --- a/src/common/Model/InitResult.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.InitResult - ( InitResult(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Init (Init) - -data InitResult = - InitSuccess Init - | InitEmpty (Either Text (Maybe Text)) - deriving (Show, Generic) - -instance FromJSON InitResult -instance ToJSON InitResult diff --git a/src/common/Model/Payment.hs b/src/common/Model/Payment.hs deleted file mode 100644 index 804b501..0000000 --- a/src/common/Model/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Payment - ( PaymentId - , Payment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Frequency -import Common.Model.User (UserId) - -type PaymentId = Int64 - -data Payment = Payment - { _payment_id :: PaymentId - , _payment_user :: UserId - , _payment_name :: Text - , _payment_cost :: Int - , _payment_date :: Day - , _payment_frequency :: Frequency - , _payment_createdAt :: UTCTime - , _payment_editedAt :: Maybe UTCTime - , _payment_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment diff --git a/src/common/Model/PaymentCategory.hs b/src/common/Model/PaymentCategory.hs deleted file mode 100644 index a0e94f9..0000000 --- a/src/common/Model/PaymentCategory.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -type PaymentCategoryId = Int64 - -data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId - , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON PaymentCategory -instance ToJSON PaymentCategory diff --git a/src/common/Model/SignIn.hs b/src/common/Model/SignIn.hs deleted file mode 100644 index f4da97f..0000000 --- a/src/common/Model/SignIn.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.SignIn - ( SignIn(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data SignIn = SignIn - { _signIn_email :: Text - } deriving (Show, Generic) - -instance FromJSON SignIn -instance ToJSON SignIn diff --git a/src/common/Model/User.hs b/src/common/Model/User.hs deleted file mode 100644 index 8c64bc2..0000000 --- a/src/common/Model/User.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.User - ( UserId - , User(..) - , find - ) where - -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.List as L -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -type UserId = Int64 - -data User = User - { _user_id :: UserId - , _user_creation :: UTCTime - , _user_email :: Text - , _user_name :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -find :: UserId -> [User] -> Maybe User -find userId users = L.find ((== userId) . _user_id) users diff --git a/src/common/Util/Text.hs b/src/common/Util/Text.hs deleted file mode 100644 index 4af7a4c..0000000 --- a/src/common/Util/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Common.Util.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/common/View/Format.hs b/src/common/View/Format.hs deleted file mode 100644 index a7fa4e3..0000000 --- a/src/common/View/Format.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Common.View.Format - ( shortDay - , longDay - , price - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, toGregorian) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.Currency (Currency(..)) - -shortDay :: Day -> Text -shortDay date = - Message.get $ Key.Date_Short - day - month - (fromIntegral year) - where (year, month, day) = toGregorian date - -longDay :: Day -> Text -longDay date = - Message.get $ Key.Date_Long - day - (fromMaybe "−" . fmap Message.get . monthToKey $ month) - (fromIntegral year) - where (year, month, day) = toGregorian date - - monthToKey 1 = Just Key.Month_January - monthToKey 2 = Just Key.Month_February - monthToKey 3 = Just Key.Month_March - monthToKey 4 = Just Key.Month_April - monthToKey 5 = Just Key.Month_May - monthToKey 6 = Just Key.Month_June - monthToKey 7 = Just Key.Month_July - monthToKey 8 = Just Key.Month_August - monthToKey 9 = Just Key.Month_September - monthToKey 10 = Just Key.Month_October - monthToKey 11 = Just Key.Month_November - monthToKey 12 = Just Key.Month_December - monthToKey _ = Nothing - -price :: Currency -> Int -> Text -price (Currency currency) amount = T.concat [ number amount, " ", currency ] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/migrations/1.sql b/src/migrations/1.sql deleted file mode 100644 index d7c300e..0000000 --- a/src/migrations/1.sql +++ /dev/null @@ -1,65 +0,0 @@ -CREATE TABLE IF NOT EXISTS "user" ( - "id" INTEGER PRIMARY KEY, - "creation" TIMESTAMP NOT NULL, - "email" VARCHAR NOT NULL, - "name" VARCHAR NOT NULL, - CONSTRAINT "uniq_user_email" UNIQUE ("email"), - CONSTRAINT "uniq_user_name" UNIQUE ("name") -); - -CREATE TABLE IF NOT EXISTS "job" ( - "id" INTEGER PRIMARY KEY, - "kind" VARCHAR NOT NULL, - "last_execution" TIMESTAMP NULL, - "last_check" TIMESTAMP NULL, - CONSTRAINT "uniq_job_kind" UNIQUE ("kind") -); - -CREATE TABLE IF NOT EXISTS "sign_in"( - "id" INTEGER PRIMARY KEY, - "token" VARCHAR NOT NULL, - "creation" TIMESTAMP NOT NULL, - "email" VARCHAR NOT NULL, - "is_used" BOOLEAN NOT NULL, - CONSTRAINT "uniq_sign_in_token" UNIQUE ("token") -); - -CREATE TABLE IF NOT EXISTS "payment"( - "id" INTEGER PRIMARY KEY, - "user_id" INTEGER NOT NULL REFERENCES "user", - "name" VARCHAR NOT NULL, - "cost" INTEGER NOT NULL, - "date" DATE NOT NULL, - "frequency" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "income"( - "id" INTEGER PRIMARY KEY, - "user_id" INTEGER NOT NULL REFERENCES "user", - "date" DATE NOT NULL, - "amount" INTEGERNOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "category"( - "id" INTEGER PRIMARY KEY, - "name" VARCHAR NOT NULL, - "color" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "payment_category"( - "id" INTEGER PRIMARY KEY, - "name" VARCHAR NOT NULL, - "category" INTEGER NOT NULL REFERENCES "category", - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - CONSTRAINT "uniq_payment_category_name" UNIQUE ("name") -); diff --git a/src/migrations/2.sql b/src/migrations/2.sql deleted file mode 100644 index ec0d1b0..0000000 --- a/src/migrations/2.sql +++ /dev/null @@ -1,23 +0,0 @@ -BEGIN TRANSACTION; - -ALTER TABLE payment RENAME TO tmp_payment; - -CREATE TABLE IF NOT EXISTS "payment"( - "id" INTEGER PRIMARY KEY, - "user" INTEGER NOT NULL REFERENCES "user", - "name" VARCHAR NOT NULL, - "cost" INTEGER NOT NULL, - "date" DATE NOT NULL, - "frequency" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -INSERT INTO payment(id, user, name, cost, date, frequency, created_at, edited_at, deleted_at) -SELECT id, user_id, name, cost, date, frequency, created_at, edited_at, deleted_at -FROM tmp_payment; - -DROP TABLE tmp_payment; - -COMMIT; diff --git a/src/server/Common b/src/server/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/server/Common +++ /dev/null @@ -1 +0,0 @@ -../common \ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs deleted file mode 100644 index 92df4e9..0000000 --- a/src/server/Conf.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Conf - ( get - , Conf(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) - -import Common.Model.Currency (Currency(..)) - -data Conf = Conf - { hostname :: Text - , port :: Int - , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: Bool - } deriving Show - -get :: FilePath -> IO Conf -get path = do - conf <- - (flip fmap) (Conf.readConfig path) (\configOrError -> do - conf <- configOrError - Conf <$> - Conf.lookup "hostname" conf <*> - Conf.lookup "port" conf <*> - Conf.lookup "signInExpiration" conf <*> - fmap Currency (Conf.lookup "currency" conf) <*> - Conf.lookup "noReplyMail" conf <*> - Conf.lookup "https" conf - ) - case conf of - Left msg -> error (T.unpack msg) - Right c -> return c diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs deleted file mode 100644 index 1a44083..0000000 --- a/src/server/Controller/Category.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Category - ( create - , edit - , delete - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty hiding (delete) - -import Common.Model.Category (CategoryId) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.CreateCategory as Json -import qualified Common.Model.EditCategory as Json - -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -create :: Json.CreateCategory -> ActionM () -create (Json.CreateCategory name color) = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Category.create name color) >>= jsonId - ) - -edit :: Json.EditCategory -> ActionM () -edit (Json.EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color - if updated - then status ok200 - else status badRequest400 - ) - -delete :: CategoryId -> ActionM () -delete categoryId = - Secure.loggedAction (\_ -> do - deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId - if null paymentCategories - then Category.delete categoryId - else return False - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted - ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs deleted file mode 100644 index 148b713..0000000 --- a/src/server/Controller/Income.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Income - ( create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) - -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query -import qualified Secure - -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId - ) - -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted - ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs deleted file mode 100644 index 8473c5c..0000000 --- a/src/server/Controller/Index.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Controller.Index - ( get - , signOut - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) - -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) - -import Conf (Conf(..)) -import Model.Init (getInit) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) - -get :: Conf -> Maybe Text -> ActionM () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of - Nothing -> - return . Left $ Key.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Key.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Key.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized - Just user -> Right user - -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of - Nothing -> - return Nothing - Just token -> do - liftIO . Query.run . getUserFromToken $ token - -signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs deleted file mode 100644 index 6a9ede7..0000000 --- a/src/server/Controller/Payment.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Payment - ( list - , create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import qualified Common.Model.CreatePayment as M -import qualified Common.Model.EditPayment as M -import Common.Model (PaymentId, User(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json - ) - -create :: M.CreatePayment -> ActionM () -create (M.CreatePayment name cost date category frequency) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId - ) - -editOwn :: M.EditPayment -> ActionM () -editOwn (M.EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency - _ <- if edited - then PaymentCategory.save name category >> return () - else return () - return edited - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId - if deleted - then status ok200 - else status badRequest400 - ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs deleted file mode 100644 index 932ce53..0000000 --- a/src/server/Controller/SignIn.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.SignIn as M - -import Conf (Conf) -import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn - -signIn :: Conf -> M.SignIn -> ActionM () -signIn conf (M.SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Cookie.hs b/src/server/Cookie.hs deleted file mode 100644 index 96d45da..0000000 --- a/src/server/Cookie.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Cookie - ( makeSimpleCookie - , setCookie - , setSimpleCookie - , getCookie - , getCookies - , deleteCookie - ) where - -import Control.Monad ( liftM ) - -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy.Encoding as TL - -import Conf (Conf) -import qualified Conf - -import qualified Data.Map as Map - -import qualified Data.ByteString.Lazy as BSL - -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) - -import Blaze.ByteString.Builder ( toLazyByteString ) - -import Web.Scotty.Trans -import Web.Cookie - -makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie -makeSimpleCookie conf name value = - def - { setCookieName = TS.encodeUtf8 name - , setCookieValue = TS.encodeUtf8 value - , setCookiePath = Just $ TS.encodeUtf8 "/" - , setCookieSecure = Conf.https conf - } - -setCookie :: (Monad m) => SetCookie -> ActionT e m () -setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) - -setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () -setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value - -getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) -getCookie name = liftM (Map.lookup name) getCookies - -getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) -getCookies = - liftM (Map.fromList . maybe [] parse) $ header "Cookie" - where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 - -deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () -deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs deleted file mode 100644 index 06c468e..0000000 --- a/src/server/Design/Color.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.Color where - -import qualified Clay.Color as C - --- http://chir.ag/projects/name-that-color/#969696 - -white :: C.Color -white = C.white - -black :: C.Color -black = C.black - -chestnutRose :: C.Color -chestnutRose = C.rgb 207 92 86 - -unknown :: C.Color -unknown = C.rgb 86 92 207 - -mossGreen :: C.Color -mossGreen = C.rgb 159 210 165 - -gothic :: C.Color -gothic = C.rgb 108 162 164 - -negroni :: C.Color -negroni = C.rgb 255 223 196 - -wildSand :: C.Color -wildSand = C.rgb 245 245 245 - -silver :: C.Color -silver = C.rgb 200 200 200 - -dustyGray :: C.Color -dustyGray = C.rgb 150 150 150 diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs deleted file mode 100644 index 4e2b8cc..0000000 --- a/src/server/Design/Constants.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Design.Constants where - -import Clay - -iconFontSize :: Size LengthUnit -iconFontSize = px 32 - -radius :: Size LengthUnit -radius = px 3 - -blockPadding :: Size LengthUnit -blockPadding = px 15 - -blockPercentWidth :: Double -blockPercentWidth = 90 - -blockPercentMargin :: Double -blockPercentMargin = (100 - blockPercentWidth) / 2 - -inputHeight :: Double -inputHeight = 40 - -focusLighten :: Color -> Color -focusLighten baseColor = baseColor +. 20 - -focusDarken :: Color -> Color -focusDarken baseColor = baseColor -. 20 diff --git a/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs deleted file mode 100644 index 4678633..0000000 --- a/src/server/Design/Dialog.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/src/server/Design/Errors.hs b/src/server/Design/Errors.hs deleted file mode 100644 index 57aaeee..0000000 --- a/src/server/Design/Errors.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Errors - ( design - ) where - -import Clay - -import Design.Color as Color - -design :: Css -design = do - position fixed - top (px 20) - left (pct 50) - "transform" -: "translateX(-50%)" - margin (px 0) (px 0) (px 0) (px 0) - disapearKeyframes - - ".error" ? do - disapearAnimation - let errorColor = Color.chestnutRose -. 15 - color errorColor - border solid (px 2) errorColor - backgroundColor Color.white - borderRadius (px 5) (px 5) (px 5) (px 5) - padding (px 5) (px 5) (px 5) (px 5) - - before & display none - -disapearAnimation :: Css -disapearAnimation = do - animationName "disapear" - animationDelay (sec 5) - animationDuration (sec 1) - animationFillMode forwards - -disapearKeyframes :: Css -disapearKeyframes = keyframes - "disapear" - [ ( 10 - , do - opacity 0 - height (px 40) - lineHeight (px 40) - marginBottom (px 10) - ) - , ( 100 - , do - opacity 0 - height (px 0) - lineHeight (px 0) - marginBottom (px 0) - ) - ] diff --git a/src/server/Design/Form.hs b/src/server/Design/Form.hs deleted file mode 100644 index ebb8ac8..0000000 --- a/src/server/Design/Form.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Form - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color - -design :: Css -design = do - - let inputHeight = 30 - let inputTop = 22 - let inputPaddingBottom = 3 - let inputZIndex = 1 - - label ? do - cursor pointer - color Color.silver - - ".textInput" ? do - position relative - marginBottom (em 1.5) - paddingTop (px inputTop) - marginTop (px (-10)) - - input ? do - width (pct 100) - position relative - zIndex inputZIndex - backgroundColor transparent - paddingBottom (px inputPaddingBottom) - borderStyle none - borderBottom solid (px 1) Color.dustyGray - marginBottom (px 5) - height (px inputHeight) - lineHeight (px inputHeight) - focus & do - borderWidth (px 2) - paddingBottom (px $ inputPaddingBottom - 1) - - label ? do - lineHeight (px inputHeight) - position absolute - top (px inputTop) - left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) - - button ? do - position absolute - right (px 0) - top (px 27) - zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" - - (input # ".filled" |+ label) <> (input # focus |+ label) ? do - top (px 0) - fontSize (pct 80) - - ".error" & do - input ? do - borderBottomColor Color.chestnutRose - - ".errorMessage" ? do - position absolute - color Color.chestnutRose - fontSize (pct 80) - - ".colorInput" ? do - display flex - alignItems center - marginBottom (em 1.5) - - input ? do - borderColor transparent - backgroundColor transparent - - ".radioGroup" ? do - position relative - marginBottom (em 2) - - ".title" ? do - color Color.silver - marginBottom (em 0.8) - - ".radioInputs" ? do - display flex - "justify-content" -: "center" - - ".radioInput:not(:last-child)::after" ? do - content (stringContent "/") - marginLeft (px 10) - marginRight (px 10) - - input ? do - opacity 0 - width (px 30) - margin (px 0) (px (-15)) (px 0) (px (-15)) - - "input:focus + label" ? do - textDecoration underline - - "input:checked + label" ? do - color Color.chestnutRose - fontWeight bold - - ".selectInput" ? do - label ? do - display block - marginBottom (px 10) - fontSize (pct 80) - select ? do - backgroundColor Color.white - border solid (px 1) Color.silver - sym borderRadius (px 3) - sym2 padding (px 5) (px 8) - option ? do - firstChild & display none - sym2 padding (px 5) (px 8) - ".error" & do - select ? borderColor Color.chestnutRose - ".errorMessage" ? do - color Color.chestnutRose - fontSize (pct 80) - marginTop (em 0.5) diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs deleted file mode 100644 index 47ea4a9..0000000 --- a/src/server/Design/Global.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Global - ( globalDesign - ) where - -import Clay - -import Data.Text.Lazy (Text) - -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -globalDesign :: Text -globalDesign = renderWith compact [] global - -global :: Css -global = do - ".errors" ? Errors.design - ".dialog" ? Dialog.design - ".tooltip" ? Tooltip.design - Views.design - Form.design - - body ? do - minWidth (px 320) - fontFamily ["Cantarell"] [sansSerif] - Media.tablet $ do - fontSize (px 15) - button ? fontSize (px 15) - input ? fontSize (px 15) - Media.mobile $ do - fontSize (px 14) - button ? fontSize (px 14) - input ? fontSize (px 14) - - a ? cursor pointer - - input ? fontSize inherit - - h1 ? do - color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) - - Media.desktop $ fontSize (px 24) - Media.tablet $ fontSize (px 22) - Media.mobile $ fontSize (px 20) - - ul ? do - "margin-bottom" -: "3vh" - "margin-left" -: "1vh" - li Color -> Size a -> (Color -> Color) -> Css -button backgroundCol textCol h focusOp = do - display flex - alignItems center - justifyContent center - backgroundColor backgroundCol - padding (px 0) (px 10) (px 0) (px 10) - color textCol - borderRadius radius radius radius radius - verticalAlign middle - cursor pointer - lineHeight h - height h - textAlign (alignSide sideCenter) - hover & backgroundColor (focusOp backgroundCol) - focus & backgroundColor (focusOp backgroundCol) - waitable - -waitable :: Css -waitable = do - svg # ".loader" ? display none - ".waiting" & do - ".content" ? do - display flex - fontSize (px 0) - opacity 0 - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation - -input :: Double -> Css -input h = do - height (px h) - padding (px 10) (px 10) (px 10) (px 10) - borderRadius radius radius radius radius - border solid (px 1) Color.dustyGray - focus & borderColor Color.silver - verticalAlign middle - -centeredWithMargin :: Css -centeredWithMargin = do - width (pct blockPercentWidth) - marginLeft auto - marginRight auto - -verticalCentering :: Css -verticalCentering = do - position absolute - top (pct 50) - "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/src/server/Design/Media.hs b/src/server/Design/Media.hs deleted file mode 100644 index 77220ee..0000000 --- a/src/server/Design/Media.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Design.Media - ( mobile - , mobileTablet - , tablet - , tabletDesktop - , desktop - ) where - -import Clay hiding (query) -import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media - -mobile :: Css -> Css -mobile = query [Media.maxWidth mobileTabletLimit] - -mobileTablet :: Css -> Css -mobileTablet = query [Media.maxWidth tabletDesktopLimit] - -tablet :: Css -> Css -tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] - -tabletDesktop :: Css -> Css -tabletDesktop = query [Media.minWidth mobileTabletLimit] - -desktop :: Css -> Css -desktop = query [Media.minWidth tabletDesktopLimit] - -query :: [Feature] -> Css -> Css -query = Clay.query Media.screen - -mobileTabletLimit :: Size LengthUnit -mobileTabletLimit = (px 520) - -tabletDesktopLimit :: Size LengthUnit -tabletDesktopLimit = (px 950) diff --git a/src/server/Design/Tooltip.hs b/src/server/Design/Tooltip.hs deleted file mode 100644 index 1da8764..0000000 --- a/src/server/Design/Tooltip.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Tooltip - ( design - ) where - -import Clay - -import Design.Color as Color - -design :: Css -design = do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - padding (px 5) (px 5) (px 5) (px 5) - color Color.white diff --git a/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs deleted file mode 100644 index 20627e6..0000000 --- a/src/server/Design/View/Header.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Media as Media - -design :: Css -design = do - let headerPadding = "padding" -: "0 20px" - display flex - "flex-wrap" -: "wrap" - lineHeightMedia - position relative - backgroundColor Color.chestnutRose - color Color.white - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - Media.mobile $ marginBottom (em 1.5) - - ".title" <> ".item" ? headerPadding - - ".title" ? do - height (pct 100) - textAlign (alignSide sideLeft) - - Media.mobile $ fontSize (px 22) - Media.mobileTablet $ width (pct 100) - Media.tabletDesktop $ do - display inlineBlock - fontSize (px 35) - - ".item" ? do - display inlineBlock - transition "background-color" (ms 50) easeIn (sec 0) - ".current" & backgroundColor (Color.chestnutRose -. 20) - Media.mobile $ fontSize (px 13) - - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) - - ".nameSignOut" ? do - display flex - heightMedia - position absolute - top (px 0) - right (px 0) - - ".name" ? do - Media.mobile $ display none - Media.tabletDesktop $ headerPadding - - ".signOut" ? do - Helper.waitable - heightMedia - svg ? do - Media.tabletDesktop $ width (px 30) - Media.mobile $ width (px 20) - "path" ? ("fill" -: "white") - -lineHeightMedia :: Css -lineHeightMedia = do - Media.desktop $ lineHeight (px 80) - Media.tablet $ lineHeight (px 65) - Media.mobile $ lineHeight (px 50) - -heightMedia :: Css -heightMedia = do - Media.desktop $ height (px 80) - Media.tablet $ height (px 65) - Media.mobile $ height (px 50) diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs deleted file mode 100644 index d3c7650..0000000 --- a/src/server/Design/View/Payment.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment - ( design - ) where - -import Clay - -import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs deleted file mode 100644 index f02da8a..0000000 --- a/src/server/Design/View/Payment/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs deleted file mode 100644 index ade81a8..0000000 --- a/src/server/Design/View/Payment/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs deleted file mode 100644 index a866b40..0000000 --- a/src/server/Design/View/Payment/Table.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Table - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) - - ".button" & svg ? do - "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) - width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs deleted file mode 100644 index 214e663..0000000 --- a/src/server/Design/View/SignIn.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.SignIn - ( design - ) where - -import Clay -import Data.Monoid ((<>)) - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten - display flex - alignItems center - justifyContent center - width (pct 100) - fontSize (em 1.2) - svg ? "path" ? ("fill" -: "white") - - ".success" <> ".error" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs deleted file mode 100644 index 0a5b258..0000000 --- a/src/server/Design/View/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Stat - ( design - ) where - -import Clay - -design :: Css -design = do - h1 ? paddingBottom (px 0) - - ".exceedingPayers" ? ".userName" ? marginRight (px 5) - - ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs deleted file mode 100644 index 95abf90..0000000 --- a/src/server/Design/View/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Table - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".emptyTableMsg" ? do - margin (em 2) (em 2) (em 2) (em 2) - textAlign (alignSide sideCenter) - - ".lines" ? do - Media.tabletDesktop $ display displayTable - width (pct 100) - textAlign (alignSide (sideCenter)) - - ".header" <> ".row" ? do - Media.tabletDesktop $ display tableRow - - ".header" ? do - Media.desktop $ do - fontSize (px 18) - height (px 70) - - Media.tabletDesktop $ do - backgroundColor Color.gothic - color Color.white - - Media.tablet $ do - fontSize (px 16) - height (px 60) - - Media.mobile $ do - display none - - ".row" ? do - nthChild "even" & backgroundColor Color.wildSand - - Media.desktop $ do - fontSize (px 18) - height (px 60) - - Media.tablet $ do - height (px 50) - - Media.mobile $ do - lineHeight (px 25) - paddingTop (px 10) - paddingBottom (px 10) - - ".cell" ? do - Media.tabletDesktop $ display tableCell - position relative - verticalAlign middle - - firstChild & do - Media.mobile $ do - fontSize (px 20) - lineHeight (px 30) - color Color.gothic - - ".refund" & color Color.mossGreen - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - hover & "svg path" ? do - "fill" -: "rgb(237, 122, 116)" - - Media.tabletDesktop $ width (pct 3) - - Media.mobile $ do - display inlineBlock - button ? display flex diff --git a/src/server/Design/Views.hs b/src/server/Design/Views.hs deleted file mode 100644 index bc6ac83..0000000 --- a/src/server/Design/Views.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Views - ( design - ) where - -import Clay - -import qualified Design.View.Header as Header -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - header ? Header.design - ".payment" ? Payment.design - ".signIn" ? SignIn.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs deleted file mode 100644 index 0bc6f6e..0000000 --- a/src/server/Job/Daemon.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Job.Daemon - ( runDaemons - ) where - -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) - -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) - -runDaemons :: Conf -> IO () -runDaemons conf = do - _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment - _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) - return () - -runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId -runDaemon kind frequency isLastExecutionTooOld runJob = - forkIO . forever $ do - mbLastExecution <- Query.run $ do - actualizeLastCheck kind - getLastExecution kind - hasToRun <- case mbLastExecution of - Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True - if hasToRun - then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) - else return () - threadDelay . microSeconds $ frequency diff --git a/src/server/Job/Frequency.hs b/src/server/Job/Frequency.hs deleted file mode 100644 index 263f6e6..0000000 --- a/src/server/Job/Frequency.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Job.Frequency - ( Frequency(..) - , microSeconds - ) where - -data Frequency = - EveryHour - | EveryDay - deriving (Eq, Read, Show) - -microSeconds :: Frequency -> Int -microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/src/server/Job/Kind.hs b/src/server/Job/Kind.hs deleted file mode 100644 index af5d4f8..0000000 --- a/src/server/Job/Kind.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Job.Kind - ( Kind(..) - ) where - -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T - -data Kind = - MonthlyPayment - | WeeklyReport - deriving (Eq, Show, Read) - -instance FromField Kind where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Kind) - _ -> Errors [error "SQLText field required for job kind"] - -instance ToField Kind where - toField kind = SQLText . T.pack . show $ kind diff --git a/src/server/Job/Model.hs b/src/server/Job/Model.hs deleted file mode 100644 index e1a3c77..0000000 --- a/src/server/Job/Model.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Job.Model - ( Job(..) - , getLastExecution - , actualizeLastExecution - , actualizeLastCheck - ) where - -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Job.Kind -import Model.Query (Query(Query)) - -data Job = Job - { id :: String - , kind :: Kind - , lastExecution :: Maybe UTCTime - , lastCheck :: Maybe UTCTime - } deriving (Show) - -getLastExecution :: Kind -> Query (Maybe UTCTime) -getLastExecution jobKind = - Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time - ) - -actualizeLastExecution :: Kind -> UTCTime -> Query () -actualizeLastExecution jobKind time = - Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result - then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) - else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) - ) - -actualizeLastCheck :: Kind -> Query () -actualizeLastCheck jobKind = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) - ) diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs deleted file mode 100644 index ba24cca..0000000 --- a/src/server/Job/MonthlyPayment.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Job.MonthlyPayment - ( monthlyPayment - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Common.Model (Frequency(..), Payment(..)) - -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query - -monthlyPayment :: Maybe UTCTime -> IO UTCTime -monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly - now <- getCurrentTime - actualDay <- timeToDay now - let punctualPayments = map - (\p -> p - { _payment_frequency = Punctual - , _payment_date = actualDay - , _payment_createdAt = now - }) - monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) - return now diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs deleted file mode 100644 index 5737c75..0000000 --- a/src/server/Job/WeeklyReport.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Job.WeeklyReport - ( weeklyReport - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import qualified Model.User as User -import qualified SendMail -import qualified View.Mail.WeeklyReport as WeeklyReport - -weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime -weeklyReport conf mbLastExecution = do - now <- getCurrentTime - case mbLastExecution of - Nothing -> return () - Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) - return () - return now diff --git a/src/server/Json.hs b/src/server/Json.hs deleted file mode 100644 index cc6327a..0000000 --- a/src/server/Json.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} - -module Json - ( jsonObject - , jsonId - ) where - -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs deleted file mode 100644 index 6f6d620..0000000 --- a/src/server/LoginSession.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LoginSession - ( put - , get - , delete - ) where - -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS - -import Control.Monad.IO.Class (liftIO) - -import Data.Text (Text) -import qualified Data.Text.Encoding as TE - -import Conf (Conf) - -sessionName :: Text -sessionName = "SESSION" - -sessionKeyFile :: FilePath -sessionKeyFile = "sessionKey" - -put :: Conf -> Text -> ActionM () -put conf value = do - encrypted <- liftIO $ encrypt value - setSimpleCookie conf sessionName encrypted - -encrypt :: Text -> IO Text -encrypt value = do - iv <- CS.randomIV - key <- CS.getKey sessionKeyFile - return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) - -get :: ActionM (Maybe Text) -get = do - maybeEncrypted <- getCookie sessionName - case maybeEncrypted of - Just encrypted -> - liftIO $ decrypt encrypted - Nothing -> - return Nothing - -decrypt :: Text -> IO (Maybe Text) -decrypt encrypted = do - key <- CS.getKey sessionKeyFile - let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) - return decrypted - -delete :: Conf -> ActionM () -delete conf = deleteCookie conf sessionName diff --git a/src/server/Main.hs b/src/server/Main.hs deleted file mode 100644 index db73474..0000000 --- a/src/server/Main.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) - -import Network.Wai.Middleware.Static -import qualified Data.Text.Lazy as LT -import Web.Scotty - -import qualified Conf -import qualified Controller.Category as Category -import qualified Controller.Income as Income -import qualified Controller.Index as Index -import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query - -main :: IO () -main = do - conf <- Conf.get "application.conf" - _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware . staticPolicy $ noDots >-> addBase "public" - - get "/exceedingPayer" $ do - time <- liftIO Time.getCurrentTime - (users, incomes, payments) <- liftIO . Query.run $ - liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments - text . LT.pack . show $ exceedingPayers - - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken - - post "/signIn" $ do - jsonData >>= SignIn.signIn conf - - post "/signOut" $ - Index.signOut conf - - post "/payment" $ - jsonData >>= Payment.create - - put "/payment" $ - jsonData >>= Payment.editOwn - - delete "/payment" $ do - paymentId <- param "id" - Payment.deleteOwn paymentId - - post "/income" $ - jsonData >>= Income.create - - put "/income" $ - jsonData >>= Income.editOwn - - delete "/income" $ do - incomeId <- param "id" - Income.deleteOwn incomeId - - post "/category" $ - jsonData >>= Category.create - - put "/category" $ - jsonData >>= Category.edit - - delete "/category" $ do - categoryId <- param "id" - Category.delete categoryId - -mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) -mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/src/server/MimeMail.hs b/src/server/MimeMail.hs deleted file mode 100644 index 0faaf98..0000000 --- a/src/server/MimeMail.hs +++ /dev/null @@ -1,672 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module MimeMail - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , sendmailCustomCaptureOutput - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachmentCid - , addAttachments - , addAttachmentBS - , addAttachmentBSCid - , addAttachmentsBS - , renderAddress - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM, void) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii, isControl) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - ((:) ("Content-Type", contentType)) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - $ headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\n" - , finalBuilder - ] - --- | Format an E-Mail address according to the name-addr form (see: RFC5322 --- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') --- This can be handy for adding custom headers that require such format. --- --- @since 0.4.11 -renderAddress :: Address -> Text -renderAddress address = - TE.decodeUtf8 $ toByteString $ showAddress address - --- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) -sanitizeFieldName :: S.ByteString -> S.ByteString -sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString (sanitizeFieldName k) - , fromByteString ": " - , encodeIfNeeded (sanitizeHeader v) - , fromByteString "\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (sanitizeHeader $ addressEmail a) - , fromByteString ">" - ] - --- Filter out control characters to prevent CRLF injection. -sanitizeHeader :: Text -> Text -sanitizeHeader = T.filter (not . isControl) - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\n" - , mconcat $ map showHeader headers - , fromByteString "\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -sendmailPath = "sendmail" - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs - --- | Like 'sendmailCustom', but also returns sendmail's output to stderr and --- stdout as strict ByteStrings. --- --- Since 0.4.9 -sendmailCustomCaptureOutput :: FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs - -sendmailCustomAux :: Bool - -> FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomAux captureOut sm opts lbs = do - let baseOpts = (proc sm opts) { std_in = CreatePipe } - pOpts = if captureOut - then baseOpts { std_out = CreatePipe - , std_err = CreatePipe - } - else baseOpts - (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts - L.hPut hin lbs - hClose hin - errMVar <- newEmptyMVar - outMVar <- newEmptyMVar - case (mHOut, mHErr) of - (Nothing, Nothing) -> return () - (Just hOut, Just hErr) -> do - void . forkIO $ S.hGetContents hOut >>= putMVar outMVar - void . forkIO $ S.hGetContents hErr >>= putMVar errMVar - _ -> error "error in sendmailCustomAux: missing a handle" - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> if captureOut - then do - errOutput <- takeMVar errMVar - outOutput <- takeMVar outMVar - return (outOutput, errOutput) - else return (S.empty, S.empty) - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - part <- getAttachmentPart ct fn - return $ addPart [part] mail - --- | Add an attachment from a file and construct a 'Part' --- with the specified content id in the Content-ID header. --- --- @since 0.4.12 -addAttachmentCid :: Text -- ^ content type - -> FilePath -- ^ file name - -> Text -- ^ content ID - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = - getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = getAttachmentPartBS ct fn content - in addPart [part] mail - --- | @since 0.4.12 -addAttachmentBSCid :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Text -- ^ content ID - -> Mail -> Mail -addAttachmentBSCid ct fn content cid mail = - let part = addHeader $ getAttachmentPartBS ct fn content - in addPart [part] mail - where - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -getAttachmentPartBS :: Text - -> Text - -> L.ByteString - -> Part -getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content - -getAttachmentPart :: Text -> FilePath -> IO Part -getAttachmentPart ct fn = do - content <- L.readFile fn - return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 46 = QPCEscape - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs deleted file mode 100644 index 6b7a488..0000000 --- a/src/server/Model/Category.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category - ( list - , create - , edit - , delete - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (Category(..), CategoryId) - -import Model.Query (Query(Query)) - -instance FromRow Category where - fromRow = Category <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Category] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" - ) - -create :: Text -> Text -> Query CategoryId -create categoryName categoryColor = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn - ) - -edit :: CategoryId -> Text -> Text -> Query Bool -edit categoryId categoryName categoryColor = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) - return True - else - return False - ) - -delete :: CategoryId -> Query Bool -delete categoryId = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) - return True - else - return False - ) diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs deleted file mode 100644 index 4f7b83d..0000000 --- a/src/server/Model/Frequency.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where - -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T - -import Common.Model.Frequency (Frequency) - -instance FromField Frequency where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Frequency) - _ -> Errors [error "SQLText field required for frequency"] - -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs deleted file mode 100644 index bbe7657..0000000 --- a/src/server/Model/Income.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income - ( list - , create - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (Income(..), IncomeId, User(..), UserId) - -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) - -instance Resource Income where - resourceCreatedAt = _income_createdAt - resourceEditedAt = _income_editedAt - resourceDeletedAt = _income_deletedAt - -instance FromRow Income where - fromRow = Income <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Income] -list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") - -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn - ) - -editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool -editOwn incomeUserId incomeId incomeDate incomeAmount = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False - ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Income] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" - (start, end, start, end, start, end) - ) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs deleted file mode 100644 index 8c6a961..0000000 --- a/src/server/Model/Init.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Init - ( getInit - ) where - -import Common.Model (Init(Init), User(..)) - -import Conf (Conf) -import qualified Conf -import Model.Query (Query) -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.User as User - -getInit :: User -> Conf -> Query Init -getInit user conf = - Init <$> - User.list <*> - (return . _user_id $ user) <*> - Payment.list <*> - Income.list <*> - Category.list <*> - PaymentCategory.list <*> - (return . Conf.currency $ conf) diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs deleted file mode 100644 index 9a4db73..0000000 --- a/src/server/Model/Mail.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Model.Mail - ( Mail(..) - ) where - -import Data.Text (Text) - -data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text - , plainBody :: Text - } deriving (Eq, Show) diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs deleted file mode 100644 index de4abd1..0000000 --- a/src/server/Model/Payer.hs +++ /dev/null @@ -1,216 +0,0 @@ -module Model.Payer - ( getOrderedExceedingPayers - ) where - -import Data.Map (Map) -import Data.Time (UTCTime(..), NominalDiffTime) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Time as Time - -import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) - -type Users = Map UserId User - -type Payers = Map UserId Payer - -type Incomes = Map IncomeId Income - -type Payments = [Payment] - -data Payer = Payer - { preIncomePaymentSum :: Int - , postIncomePaymentSum :: Int - , _incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float - } - -data ExceedingPayer = ExceedingPayer - { _userId :: UserId - , amount :: Int - } deriving (Show) - -getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] -getOrderedExceedingPayers currentTime users incomes payments = - let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users - incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes - payers = getPayers currentTime usersMap incomesMap payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts - . Map.toList - . Map.map preIncomePaymentSum - $ payers - mbSince = useIncomesFrom usersMap incomesMap payments - in case mbSince of - Just since -> - let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - safeMaximum - . map (ratio . snd) - . Map.toList - $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . Map.toList - . Map.map (getFinalDiff maxRatio) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime -useIncomesFrom users incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing - -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date - -getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Map.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in Map.fromList - . map (\userId -> - ( userId - , Payer - { preIncomePaymentSum = - totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> paymentTime p >= t - ) - userId - payments - , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) - } - ) - ) - $ userIds - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _preIncomePaymentSum = preIncomePaymentSum payer - , _cumulativeIncome = cumulativeIncome - , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) - in postIncomeDiff + _preIncomePaymentSum payer - -incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } - else Nothing - x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs deleted file mode 100644 index 3893850..0000000 --- a/src/server/Model/Payment.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment - ( Payment(..) - , find - , list - , listMonthly - , create - , createMany - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) -import Database.SQLite.Simple.ToField (ToField(toField)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model.Frequency -import Common.Model.Payment (Payment(..)) -import Common.Model.User (UserId) -import Common.Model.Payment (PaymentId) - -import Model.Frequency () -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) - -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt - -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -instance ToRow Payment where - toRow p = - [ toField (_payment_user p) - , toField (_payment_name p) - , toField (_payment_cost p) - , toField (_payment_date p) - , toField (_payment_frequency p) - , toField (_payment_createdAt p) - ] - -find :: PaymentId -> Query (Maybe Payment) -find paymentId = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - ) - -list :: Query [Payment] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" - ) - -listMonthly :: Query [Payment] -listMonthly = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" - , "ORDER BY name DESC" - ]) - (Only Monthly) - ) - -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False - ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE (created_at >= ? AND created_at <= ?)" - , " OR (edited_at >= ? AND edited_at <= ?)" - , " OR (deleted_at >= ? AND deleted_at <= ?)" - ]) - (start, end, start, end, start, end) - ) diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs deleted file mode 100644 index 6e1d304..0000000 --- a/src/server/Model/PaymentCategory.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory - ( list - , listByCategory - , save - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Data.Text as T -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory(..)) -import qualified Common.Util.Text as T - -import Model.Query (Query(Query)) - -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [PaymentCategory] -list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query () -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) - ) - where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower diff --git a/src/server/Model/Query.hs b/src/server/Model/Query.hs deleted file mode 100644 index d15fb5f..0000000 --- a/src/server/Model/Query.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Model.Query - ( Query(..) - , run - ) where - -import Data.Functor (Functor) -import Database.SQLite.Simple (Connection) -import qualified Database.SQLite.Simple as SQLite - -data Query a = Query (Connection -> IO a) - -instance Functor Query where - fmap f (Query call) = Query (fmap f . call) - -instance Applicative Query where - pure x = Query (const $ return x) - (Query callF) <*> (Query callX) = Query (\conn -> do - x <- callX conn - f <- callF conn - return (f x)) - -instance Monad Query where - (Query callX) >>= f = Query (\conn -> do - x <- callX conn - case f x of Query callY -> callY conn) - -run :: Query a -> IO a -run (Query call) = do - conn <- SQLite.open "database" - result <- call conn - _ <- SQLite.close conn - return result diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs deleted file mode 100644 index c5182f0..0000000 --- a/src/server/Model/SignIn.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.SignIn - ( SignIn(..) - , createSignInToken - , getSignIn - , signInTokenToUsed - , isLastTokenValid - ) where - -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Database.SQLite.Simple as SQLite - -import Model.Query (Query(Query)) -import Model.UUID (generateUUID) - -type SignInId = Int64 - -data SignIn = SignIn - { id :: SignInId - , token :: Text - , creation :: UTCTime - , email :: Text - , isUsed :: Bool - } deriving Show - -instance FromRow SignIn where - fromRow = SignIn <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -createSignInToken :: Text -> Query Text -createSignInToken signInEmail = - Query (\conn -> do - now <- getCurrentTime - signInToken <- generateUUID - SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) - return signInToken - ) - -getSignIn :: Text -> Query (Maybe SignIn) -getSignIn signInToken = - Query (\conn -> do - listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) - ) - -signInTokenToUsed :: SignInId -> Query () -signInTokenToUsed tokenId = - Query (\conn -> - SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) - ) - -isLastTokenValid :: SignIn -> Query Bool -isLastTokenValid signIn = - Query (\conn -> do - [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) - return . maybe False (== (token signIn)) $ lastToken - ) diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs deleted file mode 100644 index 6cb7ce0..0000000 --- a/src/server/Model/UUID.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Model.UUID - ( generateUUID - ) where - -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import Data.Text (Text, pack) - -generateUUID :: IO Text -generateUUID = pack . toString <$> nextRandom diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs deleted file mode 100644 index e14fcef..0000000 --- a/src/server/Model/User.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.User - ( list - , get - , create - , delete - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (UserId, User(..)) - -import Model.Query (Query(Query)) - -instance FromRow User where - fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field - -list :: Query [User] -list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") - -get :: Text -> Query (Maybe User) -get userEmail = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) - ) - -create :: Text -> Text -> Query UserId -create userEmail userName = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" - (now, userEmail, userName) - SQLite.lastInsertRowId conn - ) - -delete :: Text -> Query () -delete userEmail = - Query (\conn -> - SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) - ) diff --git a/src/server/Resource.hs b/src/server/Resource.hs deleted file mode 100644 index f52bbfa..0000000 --- a/src/server/Resource.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Resource - ( Resource - , resourceCreatedAt - , resourceEditedAt - , resourceDeletedAt - , Status(..) - , statuses - , groupByStatus - , statusDuring - ) where - -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) - -class Resource a where - resourceCreatedAt :: a -> UTCTime - resourceEditedAt :: a -> Maybe UTCTime - resourceDeletedAt :: a -> Maybe UTCTime - -data Status = - Created - | Edited - | Deleted - deriving (Eq, Show, Read, Ord, Enum, Bounded) - -statuses :: [Status] -statuses = [minBound..] - -groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] -groupByStatus start end resources = - foldl - (\m resource -> - case statusDuring start end resource of - Just status -> M.insertWith (++) status [resource] m - Nothing -> m - ) - M.empty - resources - -statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status -statusDuring start end resource - | created && not deleted = Just Created - | not created && edited && not deleted = Just Edited - | not created && deleted = Just Deleted - | otherwise = Nothing - where - created = belongs (resourceCreatedAt resource) start end - edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) - deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) - -belongs :: UTCTime -> UTCTime -> UTCTime -> Bool -belongs time start end = time >= start && time < end diff --git a/src/server/Secure.hs b/src/server/Secure.hs deleted file mode 100644 index f427304..0000000 --- a/src/server/Secure.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Secure - ( loggedAction - , getUserFromToken - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) - -import Model.Query (Query) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User - -loggedAction :: (User -> ActionM ()) -> ActionM () -loggedAction action = do - maybeToken <- LoginSession.get - case maybeToken of - Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token - case maybeUser of - Just user -> - action user - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - User.get (SignIn.email signIn) - Nothing -> - return Nothing diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs deleted file mode 100644 index f7ba3fd..0000000 --- a/src/server/SendMail.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module SendMail - ( sendMail - ) where - -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) - -import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified MimeMail as M - -import Model.Mail (Mail(Mail)) - -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = do - result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) - if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) - else putStrLn "OK" - return result - -getMimeMail :: Mail -> M.Mail -getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = - let fromMail = M.emptyMail (address mailFrom) - in fromMail - { M.mailTo = map address mailTo - , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] - , M.mailHeaders = [("Subject", mailSubject)] - } - -address :: Text -> M.Address -address addressEmail = - M.Address - { M.addressName = Nothing - , M.addressEmail = addressEmail - } - -strictToLazy :: Text -> LT.Text -strictToLazy = toLazyText . fromText diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs deleted file mode 100644 index 97457c7..0000000 --- a/src/server/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/src/server/Validation.hs b/src/server/Validation.hs deleted file mode 100644 index 1f332c9..0000000 --- a/src/server/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs deleted file mode 100644 index 12c4f34..0000000 --- a/src/server/View/Mail/SignIn.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.User (User(..)) - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) - } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs deleted file mode 100644 index 0bafb70..0000000 --- a/src/server/View/Mail/WeeklyReport.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.WeeklyReport - ( mail - ) where - -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model.User as User -import qualified Common.View.Format as Format - -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf - -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = - Mail - { M.from = Conf.noReplyMail conf - , M.to = map _user_email users - , M.subject = T.concat - [ Message.get Key.App_Title - , " − " - , Message.get Key.WeeklyReport_Title - ] - , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) - } - -body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text -body conf users paymentsByStatus incomesByStatus = - if M.null paymentsByStatus && M.null incomesByStatus - then - Message.get Key.WeeklyReport_Empty - else - T.intercalate "\n" . catMaybes . concat $ - [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses - , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses - ] - -paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text -paymentSection status conf users payments = - section sectionTitle sectionItems - where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count - sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments - -payedFor :: Status -> Conf -> [User] -> Payment -> Text -payedFor status conf users payment = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) - where name = formatUserName (_payment_user payment) users - amount = Format.price (Conf.currency conf) . _payment_cost $ payment - for = _payment_name payment - at = Format.longDay $ _payment_date payment - -incomeSection :: Status -> Conf -> [User] -> [Income] -> Text -incomeSection status conf users incomes = - section sectionTitle sectionItems - where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count - sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes - -isPayedFrom :: Status -> Conf -> [User] -> Income -> Text -isPayedFrom status conf users income = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) - where name = formatUserName (_income_userId income) users - amount = Format.price (Conf.currency conf) . _income_amount $ income - for = Format.longDay $ _income_date income - -formatUserName :: UserId -> [User] -> Text -formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId - -section :: Text -> [Text] -> Text -section title items = - T.concat - [ title - , "\n\n" - , T.unlines . map (" - " <>) $ items - ] diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs deleted file mode 100644 index 1c072a4..0000000 --- a/src/server/View/Page.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Page - ( page - ) where - -import Data.Text.Internal.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Aeson (encode) -import qualified Data.Aeson.Types as Json - -import Text.Blaze.Html -import Text.Blaze.Html5 -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) - -import qualified Common.Message as Message -import Common.Model.InitResult (InitResult) -import qualified Common.Message.Key as Key - -import Design.Global (globalDesign) - -page :: InitResult -> Text -page initResult = - renderHtml . docTypeHtml $ do - H.head $ do - meta ! charset "UTF-8" - meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ Message.get Key.App_Title) - script ! src "javascript/main.js" $ "" - jsonScript "init" initResult - link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" - link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" - H.style $ toHtml globalDesign - -jsonScript :: Json.ToJSON a => Text -> a -> Html -jsonScript scriptId json = - script - ! A.id (toValue scriptId) - ! type_ "application/json" - $ toHtml . decodeUtf8 . encode $ json -- cgit v1.2.3