aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/Chart/Api.elm41
-rw-r--r--src/client/Chart/Model.elm73
-rw-r--r--src/client/Chart/View.elm182
-rw-r--r--src/client/Dialog.elm165
-rw-r--r--src/client/Dialog/AddCategory/Model.elm54
-rw-r--r--src/client/Dialog/AddCategory/View.elm72
-rw-r--r--src/client/Dialog/AddIncome/Model.elm53
-rw-r--r--src/client/Dialog/AddIncome/View.elm72
-rw-r--r--src/client/Dialog/AddPayment/Model.elm70
-rw-r--r--src/client/Dialog/AddPayment/View.elm95
-rw-r--r--src/client/Dialog/Model.elm23
-rw-r--r--src/client/Dialog/Msg.elm15
-rw-r--r--src/client/Dialog/Update.elm74
-rw-r--r--src/client/Init.elm30
-rw-r--r--src/client/LoggedData.elm44
-rw-r--r--src/client/LoggedIn/Category/Table.elm123
-rw-r--r--src/client/LoggedIn/Category/View.elm34
-rw-r--r--src/client/LoggedIn/Home/Header/View.elm105
-rw-r--r--src/client/LoggedIn/Home/Model.elm44
-rw-r--r--src/client/LoggedIn/Home/Msg.elm13
-rw-r--r--src/client/LoggedIn/Home/Update.elm44
-rw-r--r--src/client/LoggedIn/Home/View.elm43
-rw-r--r--src/client/LoggedIn/Home/View/ExceedingPayers.elm45
-rw-r--r--src/client/LoggedIn/Home/View/Paging.elm109
-rw-r--r--src/client/LoggedIn/Home/View/Table.elm167
-rw-r--r--src/client/LoggedIn/Income/Table.elm128
-rw-r--r--src/client/LoggedIn/Income/View.elm104
-rw-r--r--src/client/LoggedIn/Model.elm38
-rw-r--r--src/client/LoggedIn/Msg.elm26
-rw-r--r--src/client/LoggedIn/Stat/Model.elm34
-rw-r--r--src/client/LoggedIn/Stat/Msg.elm7
-rw-r--r--src/client/LoggedIn/Stat/Update.elm24
-rw-r--r--src/client/LoggedIn/Stat/View.elm77
-rw-r--r--src/client/LoggedIn/Update.elm137
-rw-r--r--src/client/LoggedIn/View.elm33
-rw-r--r--src/client/LoggedIn/View/Format.elm37
-rw-r--r--src/client/Main.elm26
-rw-r--r--src/client/Model.elm72
-rw-r--r--src/client/Model/Category.elm35
-rw-r--r--src/client/Model/Conf.elm13
-rw-r--r--src/client/Model/Date.elm15
-rw-r--r--src/client/Model/Frequency.elm36
-rw-r--r--src/client/Model/Income.elm101
-rw-r--r--src/client/Model/Init.elm31
-rw-r--r--src/client/Model/InitResult.elm28
-rw-r--r--src/client/Model/Payer.elm137
-rw-r--r--src/client/Model/Payment.elm117
-rw-r--r--src/client/Model/PaymentCategory.elm61
-rw-r--r--src/client/Model/Size.elm17
-rw-r--r--src/client/Model/Translations.elm68
-rw-r--r--src/client/Model/User.elm44
-rw-r--r--src/client/Model/View.elm12
-rw-r--r--src/client/Msg.elm49
-rw-r--r--src/client/Page.elm43
-rw-r--r--src/client/Server.elm115
-rw-r--r--src/client/SignIn/Model.elm17
-rw-r--r--src/client/SignIn/Msg.elm9
-rw-r--r--src/client/SignIn/Update.elm31
-rw-r--r--src/client/SignIn/View.elm63
-rw-r--r--src/client/Tooltip.elm113
-rw-r--r--src/client/Update.elm182
-rw-r--r--src/client/Utils/Cmd.elm16
-rw-r--r--src/client/Utils/Dict.elm11
-rw-r--r--src/client/Utils/Either.elm9
-rw-r--r--src/client/Utils/Form.elm11
-rw-r--r--src/client/Utils/Http.elm39
-rw-r--r--src/client/Utils/Json.elm12
-rw-r--r--src/client/Utils/List.elm36
-rw-r--r--src/client/Utils/Search.elm10
-rw-r--r--src/client/Utils/String.elm38
-rw-r--r--src/client/Validation.elm65
-rw-r--r--src/client/View.elm34
-rw-r--r--src/client/View/Color.elm12
-rw-r--r--src/client/View/Date.elm57
-rw-r--r--src/client/View/Errors.elm21
-rw-r--r--src/client/View/Events.elm15
-rw-r--r--src/client/View/Form.elm152
-rw-r--r--src/client/View/Header.elm60
-rw-r--r--src/client/View/Plural.elm11
-rw-r--r--src/migrations/1.sql65
-rw-r--r--src/server/Conf.hs37
-rw-r--r--src/server/Controller/Category.hs53
-rw-r--r--src/server/Controller/Income.hs49
-rw-r--r--src/server/Controller/Index.hs84
-rw-r--r--src/server/Controller/Payment.hs61
-rw-r--r--src/server/Controller/SignIn.hs51
-rw-r--r--src/server/Controller/User.hs20
-rw-r--r--src/server/Cookie.hs56
-rw-r--r--src/server/Design/Color.hs32
-rw-r--r--src/server/Design/Constants.hs27
-rw-r--r--src/server/Design/Dialog.hs24
-rw-r--r--src/server/Design/Errors.hs55
-rw-r--r--src/server/Design/Form.hs130
-rw-r--r--src/server/Design/Global.hs78
-rw-r--r--src/server/Design/Header.hs74
-rw-r--r--src/server/Design/Helper.hs74
-rw-r--r--src/server/Design/LoggedIn.hs45
-rw-r--r--src/server/Design/LoggedIn/Home.hs17
-rw-r--r--src/server/Design/LoggedIn/Home/Header.hs84
-rw-r--r--src/server/Design/LoggedIn/Home/Pages.hs54
-rw-r--r--src/server/Design/LoggedIn/Home/Table.hs37
-rw-r--r--src/server/Design/LoggedIn/Stat.hs15
-rw-r--r--src/server/Design/LoggedIn/Table.hs84
-rw-r--r--src/server/Design/Media.hs36
-rw-r--r--src/server/Design/SignIn.hs40
-rw-r--r--src/server/Design/Tooltip.hs16
-rw-r--r--src/server/Job/Daemon.hs36
-rw-r--r--src/server/Job/Frequency.hs13
-rw-r--r--src/server/Job/Kind.hs22
-rw-r--r--src/server/Job/Model.hs47
-rw-r--r--src/server/Job/MonthlyPayment.hs19
-rw-r--r--src/server/Job/WeeklyReport.hs28
-rw-r--r--src/server/Json.hs19
-rw-r--r--src/server/LoginSession.hs53
-rw-r--r--src/server/Main.hs64
-rw-r--r--src/server/MimeMail.hs672
-rw-r--r--src/server/Model/Category.hs90
-rw-r--r--src/server/Model/Frequency.hs33
-rw-r--r--src/server/Model/Income.hs111
-rw-r--r--src/server/Model/Init.hs30
-rw-r--r--src/server/Model/Json/Category.hs24
-rw-r--r--src/server/Model/Json/Conf.hs17
-rw-r--r--src/server/Model/Json/CreateCategory.hs17
-rw-r--r--src/server/Model/Json/CreateIncome.hs17
-rw-r--r--src/server/Model/Json/CreatePayment.hs23
-rw-r--r--src/server/Model/Json/EditCategory.hs19
-rw-r--r--src/server/Model/Json/EditIncome.hs20
-rw-r--r--src/server/Model/Json/EditPayment.hs25
-rw-r--r--src/server/Model/Json/Income.hs26
-rw-r--r--src/server/Model/Json/Init.hs36
-rw-r--r--src/server/Model/Json/MessagePart.hs18
-rw-r--r--src/server/Model/Json/Number.hs15
-rw-r--r--src/server/Model/Json/Payment.hs40
-rw-r--r--src/server/Model/Json/PaymentCategory.hs23
-rw-r--r--src/server/Model/Json/Translation.hs20
-rw-r--r--src/server/Model/Json/User.hs25
-rw-r--r--src/server/Model/Mail.hs12
-rw-r--r--src/server/Model/Message.hs35
-rw-r--r--src/server/Model/Message/Key.hs193
-rw-r--r--src/server/Model/Message/Lang.hs11
-rw-r--r--src/server/Model/Message/Parts.hs37
-rw-r--r--src/server/Model/Message/Translations.hs729
-rw-r--r--src/server/Model/Payment.hs163
-rw-r--r--src/server/Model/PaymentCategory.hs74
-rw-r--r--src/server/Model/Query.hs32
-rw-r--r--src/server/Model/SignIn.hs66
-rw-r--r--src/server/Model/UUID.hs10
-rw-r--r--src/server/Model/User.hs64
-rw-r--r--src/server/Resource.hs54
-rw-r--r--src/server/Secure.hs46
-rw-r--r--src/server/SendMail.hs44
-rw-r--r--src/server/Utils/Text.hs41
-rw-r--r--src/server/Utils/Time.hs44
-rw-r--r--src/server/Validation.hs23
-rw-r--r--src/server/View/Format.hs33
-rw-r--r--src/server/View/Mail/SignIn.hs23
-rw-r--r--src/server/View/Mail/WeeklyReport.hs126
-rw-r--r--src/server/View/Page.hs48
158 files changed, 0 insertions, 9387 deletions
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/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/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/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/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/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/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/server/Conf.hs b/src/server/Conf.hs
deleted file mode 100644
index a05349d..0000000
--- a/src/server/Conf.hs
+++ /dev/null
@@ -1,37 +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)
-
-data Conf = Conf
- { hostname :: Text
- , port :: Int
- , signInExpiration :: NominalDiffTime
- , currency :: Text
- , 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 <*>
- 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 3f800da..0000000
--- a/src/server/Controller/Category.hs
+++ /dev/null
@@ -1,53 +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 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
-
-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.pack . show $ Key.CategoryNotDeleted
- )
diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs
deleted file mode 100644
index 18394d0..0000000
--- a/src/server/Controller/Income.hs
+++ /dev/null
@@ -1,49 +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 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) =
- Secure.loggedAction (\user ->
- (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId
- )
-
-editOwn :: Json.EditIncome -> ActionM ()
-editOwn (Json.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.pack . show $ Key.IncomeNotDeleted
- )
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
deleted file mode 100644
index 9fb2aa0..0000000
--- a/src/server/Controller/Index.hs
+++ /dev/null
@@ -1,84 +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 Web.Scotty hiding (get)
-
-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
-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 . InitError $ errorKey
- Right user ->
- liftIO . Query.run . fmap InitSuccess . getInit $ user
- Nothing -> do
- mbLoggedUser <- getLoggedUser
- case mbLoggedUser of
- Nothing ->
- return InitEmpty
- Just user ->
- liftIO . Query.run . fmap InitSuccess . getInit $ user
- html $ page (M.Conf { M.currency = currency conf }) 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 $ SignInInvalid
- Just signIn ->
- if SignIn.isUsed signIn
- then
- return . Left $ SignInUsed
- else
- let diffTime = now `diffUTCTime` (SignIn.creation signIn)
- in if diffTime > signInExpiration conf
- then
- return . Left $ SignInExpired
- else do
- LoginSession.put conf (SignIn.token signIn)
- mbUser <- liftIO . Query.run $ do
- SignIn.signInTokenToUsed . SignIn.id $ signIn
- User.getUser . SignIn.email $ signIn
- return $ case mbUser of
- Nothing -> Left UnauthorizedSignIn
- 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 d71b451..0000000
--- a/src/server/Controller/Payment.hs
+++ /dev/null
@@ -1,61 +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 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
- )
-
-create :: Json.CreatePayment -> ActionM ()
-create (Json.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 :: Json.EditPayment -> ActionM ()
-editOwn (Json.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 152168c..0000000
--- a/src/server/Controller/SignIn.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Controller.SignIn
- ( 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 Conf (Conf)
-import Model.Message.Key
-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 -> Text -> ActionM ()
-signIn conf login =
- if Email.isValid (TE.encodeUtf8 login)
- then do
- maybeUser <- liftIO . Query.run $ User.getUser login
- case maybeUser of
- Just user -> do
- token <- liftIO . Query.run $ SignIn.createSignInToken login
- 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]
- 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
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/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 afc601f..0000000
--- a/src/server/Design/Color.hs
+++ /dev/null
@@ -1,32 +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
-
-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 e742978..0000000
--- a/src/server/Design/Global.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Design.Global
- ( globalDesign
- ) where
-
-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.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
-
- header ? Header.design
- ".signIn" ? SignIn.design
- ".loggedIn" ? LoggedIn.design
- ".errors" ? Errors.design
- ".dialog" ? Dialog.design
- ".tooltip" ? Tooltip.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
-
- 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 <? do
- "margin-bottom" -: "2vh"
- before & do
- content (stringContent "• ")
- color Color.chestnutRose
- "margin-right" -: "0.3vw"
- ul <? do
- "margin-left" -: "3vh"
- "margin-top" -: "2vh"
-
- ".dialog" ? ".content" ? button ? do
- ".confirm" & Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
- ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
-
- svg ? height (pct 100)
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
deleted file mode 100644
index 869616d..0000000
--- a/src/server/Design/Helper.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Design.Helper
- ( clearFix
- , button
- , input
- , iconButton
- , centeredWithMargin
- , verticalCentering
- ) where
-
-import Prelude hiding (span)
-
-import Clay hiding (button, input)
-
-import Data.Monoid ((<>))
-
-import Design.Constants
-import Design.Color as Color
-
-clearFix :: Css
-clearFix =
- after & do
- content (stringContent "")
- display displayTable
- clear both
-
-button :: Color -> Color -> Size a -> (Color -> Color) -> Css
-button backgroundCol textCol h focusOp = do
- 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)
-
-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)
-
-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%)"
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/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/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/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/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 8c11ccf..0000000
--- a/src/server/Job/MonthlyPayment.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Job.MonthlyPayment
- ( monthlyPayment
- ) where
-
-import Data.Time.Clock (UTCTime, getCurrentTime)
-
-import Model.Frequency
-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 17c2594..0000000
--- a/src/server/Main.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-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
-
-main :: IO ()
-main = do
- conf <- Conf.get "application.conf"
- _ <- runDaemons conf
- scotty (Conf.port conf) $ do
- middleware . staticPolicy $ noDots >-> addBase "public"
-
- get "/" $ do
- signInToken <- mbParam "signInToken"
- Index.get conf signInToken
-
- post "/signIn" $ do
- email <- param "email"
- SignIn.signIn conf email
-
- 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 9597bd9..0000000
--- a/src/server/Model/Category.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Category
- ( CategoryId
- , Category(..)
- , 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 Model.Query (Query(Query))
-
-type CategoryId = Int64
-
-data Category = Category
- { id :: CategoryId
- , name :: Text
- , color :: Text
- , createdAt :: UTCTime
- , editedAt :: Maybe UTCTime
- , deletedAt :: Maybe UTCTime
- } deriving Show
-
-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 f9958e1..0000000
--- a/src/server/Model/Frequency.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Model.Frequency
- ( 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
-
-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 c6cdb55..0000000
--- a/src/server/Model/Income.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Income
- ( IncomeId
- , Income(..)
- , 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)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
-import Prelude hiding (id)
-import qualified Database.SQLite.Simple as SQLite
-
-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
-
-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 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 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 7a9ccea..0000000
--- a/src/server/Model/Init.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Init
- ( getInit
- ) where
-
-import Model.Json.Init (Init)
-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)
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/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/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/Payment.hs b/src/server/Model/Payment.hs
deleted file mode 100644
index 5414d18..0000000
--- a/src/server/Model/Payment.hs
+++ /dev/null
@@ -1,163 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Payment
- ( PaymentId
- , Payment(..)
- , find
- , list
- , listMonthly
- , create
- , createMany
- , editOwn
- , deleteOwn
- , modifiedDuring
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-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 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
-
-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 (userId p)
- , toField (name p)
- , toField (cost p)
- , toField (date p)
- , toField (frequency p)
- , toField (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
- "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 paymentUserId 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)
- SQLite.lastInsertRowId conn
- )
-
-createMany :: [Payment] -> Query ()
-createMany payments =
- Query (\conn ->
- SQLite.executeMany
- conn
- "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)"
- payments
- )
-
-editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
-editOwn paymentUserId 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
- then do
- now <- getCurrentTime
- SQLite.execute
- conn
- "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 paymentUserId 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
- 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
- "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 7c504dc..0000000
--- a/src/server/Model/PaymentCategory.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.PaymentCategory
- ( PaymentCategoryId
- , PaymentCategory(..)
- , 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
-
-data PaymentCategory = PaymentCategory
- { id :: PaymentCategoryId
- , name :: Text
- , category :: CategoryId
- , createdAt :: UTCTime
- , editedAt :: Maybe UTCTime
- } deriving Show
-
-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 c8a0d53..0000000
--- a/src/server/Model/User.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.User
- ( UserId
- , User(..)
- , list
- , getUser
- , findUser
- , 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
-
-data User = User
- { id :: UserId
- , creation :: UTCTime
- , email :: Text
- , name :: Text
- } deriving Show
-
-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")
-
-getUser :: Text -> Query (Maybe User)
-getUser 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
- now <- getCurrentTime
- SQLite.execute
- conn
- "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)"
- (now, userEmail, userName)
- SQLite.lastInsertRowId conn
- )
-
-deleteUser :: Text -> Query ()
-deleteUser 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 da48878..0000000
--- a/src/server/Secure.hs
+++ /dev/null
@@ -1,46 +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 Model.Message (getMessage)
-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
-
-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 . getMessage $ Key.UnauthorizedSignIn
- Nothing -> do
- status forbidden403
- html . fromStrict . getMessage $ Key.Forbidden
-
-getUserFromToken :: Text -> Query (Maybe User)
-getUserFromToken token = do
- mbSignIn <- SignIn.getSignIn token
- case mbSignIn of
- Just signIn ->
- User.getUser (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/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
deleted file mode 100644
index 4a247e9..0000000
--- a/src/server/Utils/Time.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Utils.Time
- ( belongToCurrentMonth
- , belongToCurrentWeek
- , timeToDay
- , monthToKey
- ) where
-
-import Data.Time.Clock (UTCTime, getCurrentTime)
-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
- (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
-
-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/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/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
deleted file mode 100644
index c7d40d8..0000000
--- a/src/server/View/Mail/SignIn.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module View.Mail.SignIn
- ( mail
- ) where
-
-import Data.Text (Text)
-
-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
-
-mail :: Conf -> User -> Text -> [Text] -> M.Mail
-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
- }
diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs
deleted file mode 100644
index 1a80b95..0000000
--- a/src/server/View/Mail/WeeklyReport.hs
+++ /dev/null
@@ -1,126 +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.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 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 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 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.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
- getMessage K.WeeklyReportEmpty
- 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
- (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)
-
-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
- )
-
-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)
-
-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
- )
-
-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
-
-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 5a2e4f8..0000000
--- a/src/server/View/Page.hs
+++ /dev/null
@@ -1,48 +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 Design.Global (globalDesign)
-
-import Model.Message
-import Model.Json.Conf
-import Model.Json.Init (InitResult)
-import Model.Message.Key (Key(SharedCost))
-
-page :: Conf -> InitResult -> Text
-page conf 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
- 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 =
- script
- ! A.id (toValue scriptId)
- ! type_ "application/json"
- $ toHtml . decodeUtf8 . encode $ json