diff options
author | Joris | 2017-09-24 22:14:48 +0200 |
---|---|---|
committer | Joris | 2017-11-07 09:33:01 +0100 |
commit | 898e7ed11ab0958fcdaf65b99b33f7b04787630a (patch) | |
tree | 8b5ab951c36d7d27550a7c4eaad16bbd2cd0edb1 /src | |
parent | 14bdbc8c937f5d0b35c61350dba28cb41c3737cd (diff) |
Bootstrap with GHCJS and reflex:
- setup login and logout,
- first draft of payment view.
Diffstat (limited to 'src')
170 files changed, 2162 insertions, 6033 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/Common b/src/client/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/client/Common @@ -0,0 +1 @@ +../common
\ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs new file mode 100644 index 0000000..f21798c --- /dev/null +++ b/src/client/Component/Button.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Button + ( ButtonIn(..) + , buttonInDefault + , ButtonOut(..) + , button + ) where + +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Icon + +data ButtonIn t m = ButtonIn + { _buttonIn_class :: Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + } + +buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault = ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.blank + , _buttonIn_waiting = R.never + } + +data ButtonOut t = ButtonOut + { _buttonOut_clic :: Event t () + } + +button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) +button buttonIn = do + attr <- R.holdDyn + (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) + (fmap + (\w -> M.fromList $ + [ ("type", "button") ] + <> if w + then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] + else [("class", _buttonIn_class buttonIn)]) + (_buttonIn_waiting buttonIn)) + (e, _) <- R.elDynAttr' "button" attr $ do + Icon.loading + R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut + { _buttonOut_clic = R.domEvent R.Click e + } diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs new file mode 100644 index 0000000..7111630 --- /dev/null +++ b/src/client/Component/Input.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Input + ( InputIn(..) + , InputOut(..) + , input + ) where + +import Data.Text (Text) +import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import qualified Reflex.Dom as R + +data InputIn t a b = InputIn + { _inputIn_reset :: Event t a + , _inputIn_placeHolder :: Text + } + +data InputOut t = InputOut + { _inputOut_value :: Dynamic t Text + , _inputOut_enter :: Event t () + } + +input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) +input inputIn = do + let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) + let value = fmap (const "") (_inputIn_reset inputIn) + textInput <- R.textInput $ R.def & R.attributes .~ placeHolder + & R.setValue .~ value + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + return $ InputOut + { _inputOut_value = R._textInput_value textInput + , _inputOut_enter = enter + } diff --git a/src/client/Debug.hs b/src/client/Debug.hs new file mode 100644 index 0000000..0c5c979 --- /dev/null +++ b/src/client/Debug.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Debug + ( event + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event, Dynamic) +import qualified Reflex.Dom as R + +event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () +event name e = do + count <- R.count e :: m (Dynamic t Int) + let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count + R.el "div" $ R.dynText text diff --git a/src/client/Dialog.elm b/src/client/Dialog.elm deleted file mode 100644 index a7e059a..0000000 --- a/src/client/Dialog.elm +++ /dev/null @@ -1,165 +0,0 @@ -module Dialog exposing - ( Msg(..) - , Model - , Config - , init - , update - , view - ) - -import Platform.Cmd exposing (Cmd) -import Task exposing (Task) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - --- Model - -type alias Model model modelMsg msg = - { config : Maybe (Config model msg) - , mapMsg : Msg model modelMsg msg -> msg - , model : model - } - -type alias Config model msg = - { className : String - , title : String - , body : model -> Html msg - , confirm : String - , confirmMsg : model -> msg - , undo : String - } - -init : model -> (Msg model modelMsg msg -> msg) -> Model model modelMsg msg -init model mapMsg = - { config = Nothing - , mapMsg = mapMsg - , model = model - } - --- Update - -type Msg model modelMsg msg = - NoOp - | Update modelMsg - | UpdateAndClose msg - | OpenWithUpdate (Config model msg) modelMsg - | Open (Config model msg) - | Close - -update : (modelMsg -> model -> (model, Cmd modelMsg)) -> Msg model modelMsg msg -> model -> Model model modelMsg msg -> (Model model modelMsg msg, Cmd msg) -update updateModel msg baseModel model = - case msg of - NoOp -> - ( model - , Cmd.none - ) - - Update modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model | model = newModel } - , Cmd.map (model.mapMsg << Update) effects - ) - - UpdateAndClose msg -> - ( { model | config = Nothing } - , Task.perform (always msg) (Task.succeed msg) - ) - - OpenWithUpdate config modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model - | model = newModel - , config = Just config - } - , Cmd.map (model.mapMsg << Update) effects - ) - - Open config -> - ( { model | config = Just config } - , Cmd.none - ) - - Close -> - ( { model | config = Nothing } - , Cmd.none - ) - --- View - -view : Model model modelMsg msg -> Html msg -view { mapMsg, config, model } = - let isVisible = - case config of - Just _ -> True - Nothing -> False - in div - [ class "dialog" ] - [ curtain mapMsg isVisible - , case config of - Nothing -> - text "" - Just c -> - dialog model mapMsg c - ] - -curtain : (Msg model modelMsg msg -> msg) -> Bool -> Html msg -curtain mapMsg isVisible = - div - [ class "curtain" - , style - [ ("position", "fixed") - , ("top", "0") - , ("left", "0") - , ("width", "100%") - , ("height", "100%") - , ("background-color", "rgba(0, 0, 0, 0.5)") - , ("z-index", if isVisible then "1000" else "-1") - , ("opacity", if isVisible then "1" else "0") - , ("transition", "all 0.2s ease") - ] - , onClick (mapMsg Close) - ] - [] - -dialog : model -> (Msg model modelMsg msg -> msg) -> Config model msg -> Html msg -dialog model mapMsg { className, title, body, confirm, confirmMsg, undo } = - div - [ class ("content " ++ className) - , style - [ ("position", "fixed") - , ("top", "25%") - , ("left", "50%") - , ("transform", "translate(-50%, -25%)") - , ("z-index", "1000") - , ("background-color", "white") - , ("padding", "20px") - , ("border-radius", "5px") - , ("box-shadow", "0px 0px 15px rgba(0, 0, 0, 0.5)") - ] - ] - [ h1 [] [ text title ] - , body model - , div - [ style - [ ("float", "right") - ] - ] - [ button - [ class "confirm" - , onClick (confirmMsg model) - , style - [ ("margin-right", "15px") - ] - ] - [ text confirm ] - , button - [ class "undo" - , onClick (mapMsg Close) - ] - [ text undo ] - ] - ] diff --git a/src/client/Dialog/AddCategory/Model.elm b/src/client/Dialog/AddCategory/Model.elm deleted file mode 100644 index 3b70482..0000000 --- a/src/client/Dialog/AddCategory/Model.elm +++ /dev/null @@ -1,54 +0,0 @@ -module Dialog.AddCategory.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import Dict - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Category exposing (Categories, Category, CategoryId) -import Model.Translations exposing (Translations) -import Validation -import View.Date as Date - -type alias Model = - { id : Maybe CategoryId - , name : String - , color : String - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> List (String, Field) -initialAdd translations = - [ ("color", Field.string "#000000") - ] - -initialClone : Translations -> Category -> List (String, Field) -initialClone translations category = - [ ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -initialEdit : Translations -> CategoryId -> Category -> List (String, Field) -initialEdit translations categoryId category = - [ ("id", Field.string (toString categoryId)) - , ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "color" Validation.color) diff --git a/src/client/Dialog/AddCategory/View.elm b/src/client/Dialog/AddCategory/View.elm deleted file mode 100644 index dc55b60..0000000 --- a/src/client/Dialog/AddCategory/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddCategory.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "categoryDialog" - , title = getMessage loggedData.translations title - , body = \model -> addCategoryForm loggedData model.addCategory - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addCategory - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "categoryname" (DialogMsg.AddCategoryMsg (Form.Reset initialForm)))) ] - ) - [ buttonContent ] - -addCategoryForm : LoggedData -> Form String AddCategory.Model -> Html Msg -addCategoryForm loggedData addCategory = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddCategoryMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addCategory "category" "name" - , htmlMap <| Form.colorInput loggedData.translations addCategory "category" "color" - , Form.hiddenSubmit (submitForm addCategory) - ] - -submitForm : Form String AddCategory.Model -> Msg -submitForm addCategory = - case Form.getOutput addCategory of - Just data -> - case data.id of - Just categoryId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditCategory categoryId (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateCategory (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddCategoryMsg <| Form.Submit diff --git a/src/client/Dialog/AddIncome/Model.elm b/src/client/Dialog/AddIncome/Model.elm deleted file mode 100644 index 5e2ccf1..0000000 --- a/src/client/Dialog/AddIncome/Model.elm +++ /dev/null @@ -1,53 +0,0 @@ -module Dialog.AddIncome.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Translations exposing (Translations) -import Model.Income exposing (Income, IncomeId) - -type alias Model = - { id : Maybe IncomeId - , amount : Int - , date : Date - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> Date -> List (String, Field) -initialAdd translations date = - [ ("date", Field.string (Date.shortView date translations)) - ] - -initialClone : Translations -> Date -> Income -> List (String, Field) -initialClone translations date income = - [ ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView date translations)) - ] - -initialEdit : Translations -> IncomeId -> Income -> List (String, Field) -initialEdit translations incomeId income = - [ ("id", Field.string (toString incomeId)) - , ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView (Date.fromTime income.time) translations)) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 0))) - (Validate.field "date" Validation.date) diff --git a/src/client/Dialog/AddIncome/View.elm b/src/client/Dialog/AddIncome/View.elm deleted file mode 100644 index b413308..0000000 --- a/src/client/Dialog/AddIncome/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddIncome.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "incomeDialog" - , title = getMessage loggedData.translations title - , body = \model -> addIncomeForm loggedData model.addIncome - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addIncome - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "incomeamount" (DialogMsg.AddIncomeMsg <| Form.Reset initialForm))) ] - ) - [ buttonContent ] - -addIncomeForm : LoggedData -> Form String AddIncome.Model -> Html Msg -addIncomeForm loggedData addIncome = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddIncomeMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addIncome "income" "amount" - , htmlMap <| Form.textInput loggedData.translations addIncome "income" "date" - , Form.hiddenSubmit (submitForm addIncome) - ] - -submitForm : Form String AddIncome.Model -> Msg -submitForm addIncome = - case Form.getOutput addIncome of - Just data -> - case data.id of - Just incomeId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditIncome incomeId data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateIncome data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddIncomeMsg <| Form.Submit diff --git a/src/client/Dialog/AddPayment/Model.elm b/src/client/Dialog/AddPayment/Model.elm deleted file mode 100644 index 07e7cbb..0000000 --- a/src/client/Dialog/AddPayment/Model.elm +++ /dev/null @@ -1,70 +0,0 @@ -module Dialog.AddPayment.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Category as Category exposing (Categories, CategoryId) -import Model.Frequency as Frequency -import Model.Payment as Payment exposing (Payment, PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Translations exposing (Translations) - -type alias Model = - { id : Maybe PaymentId - , name : String - , cost : Int - , date : Date - , category : CategoryId - , frequency : Frequency - } - -init : Form String Model -init = Form.initial [] (validation Category.empty) - -initialAdd : Translations -> Date -> Frequency -> List (String, Field) -initialAdd translations date frequency = - [ ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString frequency)) - , ("category", Field.string "") - ] - -initialClone : Translations -> Date -> Maybe CategoryId -> Payment -> List (String, Field) -initialClone translations date category payment = - [ ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -initialEdit : Translations -> Maybe CategoryId -> Payment -> List (String, Field) -initialEdit translations category payment = - [ ("id", Field.string (toString payment.id)) - , ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView payment.date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -validation : Categories -> Validation String Model -validation categories = - Validate.map6 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "cost" Validation.cost) - (Validate.field "date" Validation.date) - (Validate.field "category" (Validation.category categories)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/Dialog/AddPayment/View.elm b/src/client/Dialog/AddPayment/View.elm deleted file mode 100644 index 584adcd..0000000 --- a/src/client/Dialog/AddPayment/View.elm +++ /dev/null @@ -1,95 +0,0 @@ -module Dialog.AddPayment.View exposing - ( button - ) - -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Events exposing (onSubmitPrevDefault) -import View.Form as Form - -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Msg as LoggedInMsg -import Msg exposing (Msg) - -import Model.Category exposing (Categories) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "paymentDialog" - , title = getMessage loggedData.translations title - , body = \model -> addPaymentForm loggedData model.addPayment - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm loggedData.categories loggedData.paymentCategories << .addPayment - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ class "addPayment" - , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "paymentname" (DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories <| Form.Reset initialForm))) - ] - ) - [ buttonContent ] - -addPaymentForm : LoggedData -> Form String AddPayment.Model -> Html Msg -addPaymentForm loggedData addPayment = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories) - categoryOptions = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - |> List.map (\(id, category) -> (toString id, category.name)) - in Html.form - [ class "addPayment" - , onSubmitPrevDefault Msg.NoOp - ] - [ htmlMap <| Form.textInput loggedData.translations addPayment "payment" "name" - , htmlMap <| Form.textInput loggedData.translations addPayment "payment" "cost" - , if (Form.getFieldAsString "frequency" addPayment).value == Just (toString Punctual) - then htmlMap <| Form.textInput loggedData.translations addPayment "payment" "date" - else text "" - , htmlMap <| Form.selectInput loggedData.translations addPayment "payment" "category" categoryOptions - - , htmlMap <| Form.radioInputs loggedData.translations addPayment "payment" "frequency" [ toString Punctual, toString Monthly ] - , Form.hiddenSubmit (submitForm loggedData.categories loggedData.paymentCategories addPayment) - ] - -submitForm : Categories -> PaymentCategories -> Form String AddPayment.Model -> Msg -submitForm categories paymentCategories addPayment = - case Form.getOutput addPayment of - Just data -> - case data.id of - Just paymentId -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.EditPayment paymentId (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.CreatePayment (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg categories paymentCategories <| Form.Submit diff --git a/src/client/Dialog/Model.elm b/src/client/Dialog/Model.elm deleted file mode 100644 index ff8bc57..0000000 --- a/src/client/Dialog/Model.elm +++ /dev/null @@ -1,23 +0,0 @@ -module Dialog.Model exposing - ( Model - , init - ) - -import Form exposing (Form) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddCategory.Model as AddCategory - -type alias Model = - { addPayment : Form String AddPayment.Model - , addIncome : Form String AddIncome.Model - , addCategory : Form String AddCategory.Model - } - -init : Model -init = - { addPayment = AddPayment.init - , addIncome = AddIncome.init - , addCategory = AddCategory.init - } diff --git a/src/client/Dialog/Msg.elm b/src/client/Dialog/Msg.elm deleted file mode 100644 index 68ed146..0000000 --- a/src/client/Dialog/Msg.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Dialog.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -type Msg = - NoOp - | Init String Msg - | AddPaymentMsg Categories PaymentCategories Form.Msg - | AddIncomeMsg Form.Msg - | AddCategoryMsg Form.Msg diff --git a/src/client/Dialog/Update.elm b/src/client/Dialog/Update.elm deleted file mode 100644 index 3915548..0000000 --- a/src/client/Dialog/Update.elm +++ /dev/null @@ -1,74 +0,0 @@ -module Dialog.Update exposing - ( update - ) - -import Dom exposing (Id) -import Form exposing (Form) -import Form.Field as Field -import Task - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddPayment.Model as AddPayment -import Dialog.Model as Dialog -import Dialog.Msg as Dialog - -import Model.Category exposing (Categories) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -update : Dialog.Msg -> Dialog.Model -> (Dialog.Model, Cmd Dialog.Msg) -update msg model = - case msg of - - Dialog.NoOp -> - ( model - , Cmd.none - ) - - Dialog.Init inputId dialogMsg -> - update dialogMsg model - |> Tuple.mapSecond (\cmd -> Cmd.batch [cmd, inputFocus inputId]) - - Dialog.AddPaymentMsg categories paymentCategories formMsg -> - ( { model - | addPayment = - Form.update (AddPayment.validation categories) formMsg model.addPayment - |> updateCategory categories paymentCategories formMsg - } - , Cmd.none - ) - - Dialog.AddIncomeMsg formMsg -> - ( { model - | addIncome = Form.update AddIncome.validation formMsg model.addIncome - } - , Cmd.none - ) - - Dialog.AddCategoryMsg formMsg -> - ( { model - | addCategory = Form.update AddCategory.validation formMsg model.addCategory - } - , Cmd.none - ) - -inputFocus : Id -> Cmd Dialog.Msg -inputFocus id = - Dom.focus id - |> Task.map (always Dialog.NoOp) - |> Task.onError (\_ -> Task.succeed Dialog.NoOp) - |> Task.perform (always Dialog.NoOp) - -updateCategory : Categories -> PaymentCategories -> Form.Msg -> (Form String AddPayment.Model -> Form String AddPayment.Model) -updateCategory categories paymentCategories formMsg = - case formMsg of - Form.Input "name" Form.Text (Field.String paymentName) -> - case PaymentCategory.search paymentName paymentCategories of - Just category -> - Form.update - (AddPayment.validation categories) - (Form.Input "category" Form.Text (Field.String <| toString category)) - Nothing -> - identity - _ -> - identity diff --git a/src/client/Icon.hs b/src/client/Icon.hs new file mode 100644 index 0000000..7223def --- /dev/null +++ b/src/client/Icon.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Icon + ( loading + , signOut + , clone + , edit + , delete + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/src/client/Init.elm b/src/client/Init.elm deleted file mode 100644 index d87e870..0000000 --- a/src/client/Init.elm +++ /dev/null @@ -1,30 +0,0 @@ -module Init exposing - ( Init - , decoder - ) - -import Time exposing (..) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import Model.Size exposing (..) - -type alias Init = - { time : Time - , translations : Translations - , conf : Conf - , result : InitResult - , windowSize : Size - } - -decoder : Decoder Init -decoder = - Decode.map5 Init - (Decode.field "time" Decode.float) - (Decode.field "translations" translationsDecoder) - (Decode.field "conf" confDecoder) - (Decode.field "result" initResultDecoder) - (Decode.field "windowSize" sizeDecoder) diff --git a/src/client/LoggedData.elm b/src/client/LoggedData.elm deleted file mode 100644 index e048247..0000000 --- a/src/client/LoggedData.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedData exposing - ( LoggedData - , build - ) - -import Time exposing (Time) - -import Msg exposing (Msg) - -import Model exposing (Model) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.Payment exposing (Payments) -import Model.User exposing (Users, UserId) -import Model.Income exposing (Incomes) -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -import LoggedIn.Model as LoggedInModel - -type alias LoggedData = - { currentTime : Time - , translations : Translations - , conf : Conf - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -build : Time -> Translations -> Conf -> LoggedInModel.Model -> LoggedData -build currentTime translations conf loggedIn = - { currentTime = currentTime - , translations = translations - , conf = conf - , users = loggedIn.users - , me = loggedIn.me - , payments = loggedIn.payments - , incomes = loggedIn.incomes - , categories = loggedIn.categories - , paymentCategories = loggedIn.paymentCategories - } diff --git a/src/client/LoggedIn/Category/Table.elm b/src/client/LoggedIn/Category/Table.elm deleted file mode 100644 index 9405e57..0000000 --- a/src/client/LoggedIn/Category/Table.elm +++ /dev/null @@ -1,123 +0,0 @@ -module LoggedIn.Category.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Category as Category exposing (CategoryId, Category) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let categories = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) categories) - , if List.isEmpty (Dict.toList loggedData.categories) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoCategories" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell category" ] [ text <| getMessage loggedData.translations "Color" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (CategoryId, Category) -> Html Msg -paymentLine loggedData (categoryId, category) = - div - [ class "row" ] - [ div - [ class "cell category" ] - [ text category.name ] - , div - [ class "cell category" ] - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.color ] - ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddCategory.button - loggedData - (AddCategory.initialClone loggedData.translations category) - "CloneCategory" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ AddCategory.button - loggedData - (AddCategory.initialEdit loggedData.translations categoryId category) - "EditCategory" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if PaymentCategory.isCategoryUnused categoryId loggedData.paymentCategories - then - let dialogConfig = - { className = "deleteCategoryDialog" - , title = getMessage loggedData.translations "ConfirmCategoryDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteCategory categoryId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - else - span - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "UsedCategory") ) - [ FontAwesome.trash Color.silver 18 ] - ] - ] diff --git a/src/client/LoggedIn/Category/View.elm b/src/client/LoggedIn/Category/View.elm deleted file mode 100644 index bba51b7..0000000 --- a/src/client/LoggedIn/Category/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Category.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import LoggedData exposing (LoggedData) - -import Msg exposing (Msg) - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import LoggedIn.Category.Table as Table - -import Model.Translations exposing (getMessage, getParamMessage) - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "categories" ] - [ div - [ class "titleButton withMargin" ] - [ h1 [] [ text <| getMessage loggedData.translations "Categories" ] - , AddCategory.button - loggedData - (AddCategory.initialAdd loggedData.translations) - "AddCategory" - (text (getMessage loggedData.translations "AddCategory")) - Nothing - ] - , Table.view loggedData - ] diff --git a/src/client/LoggedIn/Home/Header/View.elm b/src/client/LoggedIn/Home/Header/View.elm deleted file mode 100644 index 14d90d7..0000000 --- a/src/client/LoggedIn/Home/Header/View.elm +++ /dev/null @@ -1,105 +0,0 @@ -module LoggedIn.Home.Header.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import String -import Dict -import Date - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import Model.Translations exposing (getParamMessage) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.Translations exposing (getMessage) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import LoggedIn.Home.View.ExceedingPayers as ExceedingPayers -import LoggedIn.View.Format as Format -import View.Plural exposing (plural) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg -view loggedData { search } payments frequency = - let currentDate = Date.fromTime loggedData.currentTime - in Html.div - [ class "header" ] - [ div - [ class "payerAndAdd" ] - [ ExceedingPayers.view loggedData - , AddPayment.button - loggedData - (AddPayment.initialAdd loggedData.translations currentDate frequency) - "AddPayment" - (text (getMessage loggedData.translations "AddPayment")) - Nothing - ] - , Html.div - [ class "searchLine" ] - [ searchForm loggedData search ] - , infos loggedData payments - ] - -searchForm : LoggedData -> Form String Home.Search -> Html Msg -searchForm loggedData search = - Html.map (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.SearchMsg) <| - Html.form - [ onSubmitPrevDefault Form.NoOp ] - [ Form.textInput loggedData.translations search "search" "name" - , if List.isEmpty (Payment.monthly loggedData.payments) - then text "" - else Form.radioInputs loggedData.translations search "search" "frequency" [ toString Punctual, toString Monthly ] - ] - -infos : LoggedData -> Payments -> Html Msg -infos loggedData payments = - let paymentsCount = List.length payments - in if paymentsCount == 0 - then text "" - else - let count = plural loggedData.translations (List.length payments) "Payment" "Payments" - sum = paymentsSum loggedData.conf payments - in div - [ class "infos" ] - [ span - [ class "total" ] - [ text <| getParamMessage [ count, sum ] loggedData.translations "Worth" ] - , span - [ class "partition" ] - [ text <| paymentsPartition loggedData payments ] - ] - -paymentsPartition : LoggedData -> Payments -> String -paymentsPartition loggedData payments = - String.join - ", " - ( loggedData.users - |> Dict.toList - |> List.map (Tuple.mapFirst (\userId -> Payment.totalPayments (always True) userId payments)) - |> List.filter (\(sum, _) -> sum > 0) - |> List.sortBy Tuple.first - |> List.reverse - |> List.map (\(sum, user) -> - getParamMessage [ user.name, Format.price loggedData.conf sum ] loggedData.translations "By" - ) - ) - -paymentsSum : Conf -> Payments -> String -paymentsSum conf payments = - payments - |> List.map .cost - |> List.sum - |> Format.price conf diff --git a/src/client/LoggedIn/Home/Model.elm b/src/client/LoggedIn/Home/Model.elm deleted file mode 100644 index e5381f6..0000000 --- a/src/client/LoggedIn/Home/Model.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Model exposing - ( Model - , Search - , init - , searchInitial - , validation - ) - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Frequency as Frequency -import Model.Payer exposing (Payers) -import Model.Payment as Payment exposing (PaymentId, Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.User exposing (Users, UserId) - -type alias Model = - { punctualPage : Int - , monthlyPage : Int - , search : Form String Search - } - -type alias Search = - { name : Maybe String - , frequency : Frequency - } - -init : Model -init = - { punctualPage = 1 - , monthlyPage = 1 - , search = Form.initial (searchInitial Punctual) validation - } - -searchInitial : Frequency -> List (String, Field) -searchInitial frequency = [ ("frequency", Field.string (toString frequency)) ] - -validation : Validation String Search -validation = - Validate.map2 Search - (Validate.field "name" (Validate.maybe Validate.string)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/LoggedIn/Home/Msg.elm b/src/client/LoggedIn/Home/Msg.elm deleted file mode 100644 index 69f15ad..0000000 --- a/src/client/LoggedIn/Home/Msg.elm +++ /dev/null @@ -1,13 +0,0 @@ -module LoggedIn.Home.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) - -type Msg = - NoOp - | UpdatePage Int - | SearchMsg Form.Msg diff --git a/src/client/LoggedIn/Home/Update.elm b/src/client/LoggedIn/Home/Update.elm deleted file mode 100644 index 06c2c7e..0000000 --- a/src/client/LoggedIn/Home/Update.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Update exposing - ( update - ) - -import Form exposing (Form) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import Model.Frequency as Frequency exposing (Frequency(..)) - -update : LoggedData -> Home.Msg -> Home.Model -> (Home.Model, Cmd Home.Msg) -update loggedData msg model = - case msg of - - Home.NoOp -> - ( model - , Cmd.none - ) - - Home.UpdatePage page -> - ( updatePage page model - , Cmd.none - ) - - Home.SearchMsg formMsg -> - let newModel = - case formMsg of - Form.Input "name" _ _ -> updatePage 1 model - _ -> model - in ( { model | search = Form.update Home.validation formMsg model.search } - , Cmd.none - ) - -updatePage : Int -> Home.Model -> Home.Model -updatePage page model = - let frequency = - Form.getFieldAsString "frequency" model.search - |> .value - |> Maybe.andThen Frequency.fromString - in case frequency of - Just Punctual -> { model | punctualPage = page } - Just Monthly -> { model | monthlyPage = page } - Nothing -> model diff --git a/src/client/LoggedIn/Home/View.elm b/src/client/LoggedIn/Home/View.elm deleted file mode 100644 index fba3f7c..0000000 --- a/src/client/LoggedIn/Home/View.elm +++ /dev/null @@ -1,43 +0,0 @@ -module LoggedIn.Home.View exposing - ( view - ) - -import Date -import Html exposing (..) -import Html.Attributes exposing (..) - -import Form -import Utils.Form as Form - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Header.View as Header -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Home.View.Paging as Paging -import LoggedIn.Home.View.Table as Table -import LoggedIn.Msg as LoggedInMsg -import Model.Payment as Payment -import Model.Frequency exposing (Frequency(..)) -import Msg exposing (Msg) - -view : LoggedData -> Home.Model -> Html Msg -view loggedData home = - let (name, frequency) = - case Form.getOutput home.search of - Just data -> (Maybe.withDefault "" data.name, data.frequency) - Nothing -> ("", Punctual) - payments = Payment.search name frequency loggedData.payments - page = - case frequency of - Punctual -> home.punctualPage - Monthly -> home.monthlyPage - in div - [ class "home" ] - [ Header.view loggedData home payments frequency - , Table.view loggedData home payments frequency page - , Paging.view - page - (List.length payments) - Msg.NoOp - (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage) - ] diff --git a/src/client/LoggedIn/Home/View/ExceedingPayers.elm b/src/client/LoggedIn/Home/View/ExceedingPayers.elm deleted file mode 100644 index 6f2439c..0000000 --- a/src/client/LoggedIn/Home/View/ExceedingPayers.elm +++ /dev/null @@ -1,45 +0,0 @@ -module LoggedIn.Home.View.ExceedingPayers exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.View.Format as Format - -import Model exposing (Model) -import Model.User exposing (getUserName) -import Model.Payment as Payment -import Model.Payer exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let payments = Payment.punctual loggedData.payments - exceedingPayers = getOrderedExceedingPayers loggedData.currentTime loggedData.users loggedData.incomes payments - in div - [ class "exceedingPayers" ] - ( if List.isEmpty exceedingPayers - then [ text <| getMessage loggedData.translations "PaymentsAreBalanced" ] - else (List.map (exceedingPayer loggedData) exceedingPayers) - ) - -exceedingPayer : LoggedData -> ExceedingPayer -> Html Msg -exceedingPayer loggedData payer = - span - [ class "exceedingPayer" ] - [ span - [ class "userName" ] - [ payer.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , span - [ class "amount" ] - [ text ("+ " ++ (Format.price loggedData.conf payer.amount)) ] - ] diff --git a/src/client/LoggedIn/Home/View/Paging.elm b/src/client/LoggedIn/Home/View/Paging.elm deleted file mode 100644 index dffe061..0000000 --- a/src/client/LoggedIn/Home/View/Paging.elm +++ /dev/null @@ -1,109 +0,0 @@ -module LoggedIn.Home.View.Paging exposing - ( view - ) - -import Color exposing (Color) - -import FontAwesome - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import LoggedData exposing (LoggedData) -import Model.Payment as Payment exposing (Payments, perPage) - -showedPages : Int -showedPages = 5 - -view : Int -> Int -> msg -> (Int -> msg) -> Html msg -view currentPage payments noOp pageMsg = - let maxPage = ceiling (toFloat payments / toFloat perPage) - pages = truncatePages currentPage (List.range 1 maxPage) - in if maxPage <= 1 - then - text "" - else - div - [ class "pages" ] - ( [ firstPage currentPage pageMsg - , previousPage currentPage noOp pageMsg - ] - ++ ( List.map (paymentsPage currentPage noOp pageMsg) pages) - ++ [ nextPage currentPage maxPage noOp pageMsg - , lastPage currentPage maxPage pageMsg - ] - ) - -truncatePages : Int -> List Int -> List Int -truncatePages currentPage pages = - let totalPages = List.length pages - showedLeftPages = ceiling ((toFloat showedPages - 1) / 2) - showedRightPages = floor ((toFloat showedPages - 1) / 2) - truncatedPages = - if currentPage <= showedLeftPages then - (List.range 1 showedPages) - else if currentPage > totalPages - showedRightPages then - (List.range (totalPages - showedPages + 1) totalPages) - else - (List.range (currentPage - showedLeftPages) (currentPage + showedRightPages)) - in List.filter (flip List.member pages) truncatedPages - -firstPage : Int -> (Int -> msg) -> Html msg -firstPage currentPage pageMsg = - button - [ classList - [ ("page", True) - , ("disable", currentPage <= 1) - ] - , onClick (pageMsg 1) - ] - [ FontAwesome.fast_backward grey 13 ] - -previousPage : Int -> msg -> (Int -> msg) -> Html msg -previousPage currentPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage > 1 - then (pageMsg <| currentPage - 1) - else noOp - ] - [ FontAwesome.backward grey 13 ] - -nextPage : Int -> Int -> msg -> (Int -> msg) -> Html msg -nextPage currentPage maxPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage < maxPage - then (pageMsg <| currentPage + 1) - else noOp - ] - [ FontAwesome.forward grey 13 ] - -lastPage : Int -> Int -> (Int -> msg) -> Html msg -lastPage currentPage maxPage pageMsg = - button - [ class "page" - , onClick (pageMsg maxPage) - ] - [ FontAwesome.fast_forward grey 13 ] - -paymentsPage : Int -> msg -> (Int -> msg) -> Int -> Html msg -paymentsPage currentPage noOp pageMsg page = - let onCurrentPage = page == currentPage - in button - [ classList - [ ("page", True) - , ("current", onCurrentPage) - ] - , onClick <| - if onCurrentPage - then noOp - else pageMsg page - ] - [ text (toString page) ] - -grey : Color -grey = Color.greyscale 0.35 diff --git a/src/client/LoggedIn/Home/View/Table.elm b/src/client/LoggedIn/Home/View/Table.elm deleted file mode 100644 index f94bb19..0000000 --- a/src/client/LoggedIn/Home/View/Table.elm +++ /dev/null @@ -1,167 +0,0 @@ -module LoggedIn.Home.View.Table exposing - ( view - ) - -import Date exposing (Date) -import Dict exposing (..) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import LoggedIn.Home.Model as Home -import LoggedIn.View.Format as Format -import View.Date as Date - -import Model.Payment as Payment exposing (..) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) -import Model.User exposing (getUserName) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Int -> Html Msg -view loggedData homeModel payments frequency page = - let visiblePayments = - payments - |> List.drop ((page - 1) * perPage) - |> List.take perPage - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData frequency :: List.map (paymentLine loggedData homeModel frequency) visiblePayments ) - , if List.isEmpty visiblePayments - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoPayment" ] - else - text "" - ] - -headerLine : LoggedData -> Frequency -> Html Msg -headerLine loggedData frequency = - div - [ class "header" ] - [ div [ class "cell category" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell cost" ] [ text <| getMessage loggedData.translations "Cost" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "Payer" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "PaymentCategory" ] - , case frequency of - Punctual -> div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - Monthly -> text "" - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> Home.Model -> Frequency -> Payment -> Html Msg -paymentLine loggedData homeModel frequency payment = - div - [ class "row" ] - [ div [ class "cell name" ] [ text payment.name ] - , div - [ classList - [ ("cell cost", True) - , ("refund", payment.cost < 0) - ] - ] - [ text (Format.price loggedData.conf payment.cost) ] - , div - [ class "cell user" ] - [ payment.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell category" ] - ( let mbCategory = - PaymentCategory.search payment.name loggedData.paymentCategories - |> Maybe.andThen (\category -> Dict.get category loggedData.categories) - in case mbCategory of - Just category -> - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.name ] - ] - Nothing -> - [] - ) - , case frequency of - Punctual -> - div - [ class "cell date" ] - [ span - [ class "shortDate" ] - [ text (Date.shortView payment.date loggedData.translations) ] - , span - [ class "longDate" ] - [ text (Date.longView payment.date loggedData.translations) ] - ] - Monthly -> - text "" - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialClone loggedData.translations currentDate category payment) - "ClonePayment" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialEdit loggedData.translations category payment) - "EditPayment" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let dialogConfig = - { className = "deletePaymentDialog" - , title = getMessage loggedData.translations "ConfirmPaymentDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeletePayment payment.id - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/Table.elm b/src/client/LoggedIn/Income/Table.elm deleted file mode 100644 index f10a552..0000000 --- a/src/client/LoggedIn/Income/Table.elm +++ /dev/null @@ -1,128 +0,0 @@ -module LoggedIn.Income.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Income as Income exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let incomes = - loggedData.incomes - |> Dict.toList - |> List.sortBy (.time << Tuple.second) - |> List.reverse - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) incomes) - , if List.isEmpty (Dict.toList loggedData.incomes) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoIncome" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell income" ] [ text <| getMessage loggedData.translations "Income" ] - , div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (IncomeId, Income) -> Html Msg -paymentLine loggedData (incomeId, income) = - div - [ class "row" ] - [ div - [ class "cell name" ] - [ income.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell income" ] - [ text (Format.price loggedData.conf income.amount) ] - , div - [ class "cell date" ] - [ text (Date.longView (Date.fromTime income.time) loggedData.translations) ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddIncome.button - loggedData - (AddIncome.initialClone loggedData.translations currentDate income) - "CloneIncome" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - AddIncome.button - loggedData - (AddIncome.initialEdit loggedData.translations incomeId income) - "EditIncome" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/View.elm b/src/client/LoggedIn/Income/View.elm deleted file mode 100644 index 85b0dc3..0000000 --- a/src/client/LoggedIn/Income/View.elm +++ /dev/null @@ -1,104 +0,0 @@ -module LoggedIn.Income.View exposing - ( view - ) - -import Dict -import Date -import Time exposing (Time) -import Task - -import FontAwesome - -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Income exposing (IncomeId, Income, userCumulativeIncomeSince) -import Model.Translations exposing (getMessage, getParamMessage) -import Model.Payer exposing (useIncomesFrom) -import Model.User exposing (UserId, User) -import Model.View as View - -import View.Date as Date -import LoggedIn.View.Format as Format -import View.Color as Color -import LoggedIn.Income.Table as Table - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "income" ] - [ div - [ class "withMargin" ] - [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of - Just since -> cumulativeIncomesView loggedData since - Nothing -> text "" - , div - [ class "titleButton" ] - [ h1 [] [ text <| getMessage loggedData.translations "MonthlyNetIncomes" ] - , AddIncome.button - loggedData - (AddIncome.initialAdd loggedData.translations (Date.fromTime loggedData.currentTime)) - "AddIncome" - (text (getMessage loggedData.translations "AddIncome")) - Nothing - ] - ] - , Table.view loggedData - ] - -cumulativeIncomesView : LoggedData -> Time -> Html Msg -cumulativeIncomesView loggedData since = - let longDate = Date.longView (Date.fromTime since) loggedData.translations - in div - [] - [ h1 [] [ text <| getParamMessage [longDate] loggedData.translations "CumulativeIncomesSince" ] - , ul - [] - ( Dict.toList loggedData.users - |> List.map (\(userId, user) -> - (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId) - ) - |> List.sortBy Tuple.second - |> List.map (\(userName, cumulativeIncome) -> - li - [] - [ text userName - , text " − " - , text <| Format.price loggedData.conf cumulativeIncome - ] - ) - ) - ] - -incomeView : LoggedData -> (IncomeId, Income) -> Html Msg -incomeView loggedData (incomeId, income) = - li - [] - [ text <| Date.shortView (Date.fromTime income.time) loggedData.translations - , text " − " - , text <| Format.price loggedData.conf income.amount - , let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - [ FontAwesome.trash Color.chestnutRose 14 ] - ] diff --git a/src/client/LoggedIn/Model.elm b/src/client/LoggedIn/Model.elm deleted file mode 100644 index f4fad94..0000000 --- a/src/client/LoggedIn/Model.elm +++ /dev/null @@ -1,38 +0,0 @@ -module LoggedIn.Model exposing - ( Model - , init - ) - -import Time exposing (Time) - -import LoggedIn.Home.Model as Home -import LoggedIn.Stat.Model as Stat -import Model.Category exposing (Categories) -import Model.Income exposing (Incomes) -import Model.Init exposing (..) -import Model.Payment exposing (Payments) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.User exposing (Users, UserId) - -type alias Model = - { home : Home.Model - , stat : Stat.Model - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -init : Time -> Init -> Model -init time { users, me, payments, incomes, categories, paymentCategories } = - { home = Home.init - , stat = Stat.init time paymentCategories payments - , users = users - , me = me - , payments = payments - , incomes = incomes - , categories = categories - , paymentCategories = paymentCategories - } diff --git a/src/client/LoggedIn/Msg.elm b/src/client/LoggedIn/Msg.elm deleted file mode 100644 index d9b3bce..0000000 --- a/src/client/LoggedIn/Msg.elm +++ /dev/null @@ -1,26 +0,0 @@ -module LoggedIn.Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) - -import LoggedIn.Home.Msg as Home -import LoggedIn.Stat.Msg as Stat -import Model.Category exposing (CategoryId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Payment exposing (PaymentId) - -type Msg = - NoOp - | HomeMsg Home.Msg - | StatMsg Stat.Msg - | ValidateCreatePayment PaymentId String Int Date CategoryId Frequency - | ValidateEditPayment PaymentId String Int Date CategoryId Frequency - | ValidateDeletePayment PaymentId - | ValidateCreateIncome IncomeId Int Date - | ValidateEditIncome IncomeId Int Date - | ValidateDeleteIncome IncomeId - | ValidateCreateCategory CategoryId String String - | ValidateEditCategory CategoryId String String - | ValidateDeleteCategory CategoryId diff --git a/src/client/LoggedIn/Stat/Model.elm b/src/client/LoggedIn/Stat/Model.elm deleted file mode 100644 index bfc66f2..0000000 --- a/src/client/LoggedIn/Stat/Model.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Stat.Model exposing - ( Model - , init - , getPaymentsByMonthByCategory - ) - -import Date exposing (Month) -import List.Extra as List -import Time exposing (Time) - -import Model.Category exposing (CategoryId) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -type alias Model = - { paymentsByMonthByCategory : List ((Month, Int), List (CategoryId, Int)) - } - -init : Time -> PaymentCategories -> Payments -> Model -init currentTime paymentCategories payments = - { paymentsByMonthByCategory = getPaymentsByMonthByCategory currentTime paymentCategories payments - } - -getPaymentsByMonthByCategory : Time -> PaymentCategories -> Payments -> List ((Month, Int), List (CategoryId, Int)) -getPaymentsByMonthByCategory currentTime paymentCategories payments = - Payment.punctual payments - |> Payment.groupAndSortByMonth - |> List.map (\(m, payments) -> - ( m - , PaymentCategory.groupPaymentsByCategory paymentCategories payments - |> List.map (Tuple.mapSecond (List.sum << List.map .cost)) - ) - ) diff --git a/src/client/LoggedIn/Stat/Msg.elm b/src/client/LoggedIn/Stat/Msg.elm deleted file mode 100644 index d517544..0000000 --- a/src/client/LoggedIn/Stat/Msg.elm +++ /dev/null @@ -1,7 +0,0 @@ -module LoggedIn.Stat.Msg exposing - ( Msg(..) - ) - -type Msg = - NoOp - | UpdateChart diff --git a/src/client/LoggedIn/Stat/Update.elm b/src/client/LoggedIn/Stat/Update.elm deleted file mode 100644 index 2415733..0000000 --- a/src/client/LoggedIn/Stat/Update.elm +++ /dev/null @@ -1,24 +0,0 @@ -module LoggedIn.Stat.Update exposing - ( update - ) - -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat - -update : LoggedData -> Stat.Msg -> Stat.Model -> (Stat.Model, Cmd Stat.Msg) -update loggedData msg model = - case msg of - - Stat.NoOp -> - ( model - , Cmd.none - ) - - Stat.UpdateChart -> - let { currentTime, paymentCategories, payments } = loggedData - in ( { model - | paymentsByMonthByCategory = Stat.getPaymentsByMonthByCategory currentTime paymentCategories payments - } - , Cmd.none - ) diff --git a/src/client/LoggedIn/Stat/View.elm b/src/client/LoggedIn/Stat/View.elm deleted file mode 100644 index e389c67..0000000 --- a/src/client/LoggedIn/Stat/View.elm +++ /dev/null @@ -1,77 +0,0 @@ -module LoggedIn.Stat.View exposing - ( view - ) - -import Date exposing (Month) -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import List.Extra as List -import Time exposing (Time) - -import Chart.Api as Chart -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.View.Format as Format -import Model.Category exposing (CategoryId, Categories) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (Translations, getMessage, getParamMessage) -import Msg exposing (Msg) -import Utils.List as List -import View.Date as Date -import View.Plural exposing (plural) - -view : LoggedData -> Stat.Model -> Html Msg -view loggedData { paymentsByMonthByCategory } = - div - [ class "stat withMargin" ] - [ renderChart loggedData paymentsByMonthByCategory ] - -renderChart : LoggedData -> List ((Month, Int), List (CategoryId, Int)) -> Html msg -renderChart { currentTime, paymentCategories, categories, conf, translations } paymentsByMonthByCategory = - let monthPaymentMean = getMonthPaymentMean currentTime paymentsByMonthByCategory - title = getParamMessage [ Format.price conf monthPaymentMean ] translations "ByMonthsAndMean" - keys = - paymentsByMonthByCategory - |> List.map (\((month, year), _) -> Date.shortMonthAndYear month year translations) - series = - categories - |> Dict.toList - |> List.map (\(categoryId, category) -> - { values = - List.map - (\(_, paymentsByCategory) -> - paymentsByCategory - |> List.find (\(c, _) -> c == categoryId) - |> Maybe.map (toFloat << Tuple.second) - |> Maybe.withDefault 0 - ) - paymentsByMonthByCategory - , color = category.color - , label = category.name - } - ) - totalSerie = - { values = - List.transpose (List.map .values series) - |> List.map List.sum - , color = "black" - , label = getMessage translations "Total" - } - in Chart.from keys (series ++ [totalSerie]) - |> Chart.withSize { x = 2000, y = 900 } - |> Chart.withTitle title - |> Chart.withOrdinate 10 (Format.price conf << truncate) - |> Chart.toHtml - -getMonthPaymentMean : Time -> List ((Month, Int), List (CategoryId, Int)) -> Int -getMonthPaymentMean currentTime paymentsByMonthByCategory = - paymentsByMonthByCategory - |> List.filter (\((month, year), _) -> - let currentDate = Date.fromTime currentTime - in not (Date.month currentDate == month && Date.year currentDate == year) - ) - |> List.map (List.sum << List.map Tuple.second << Tuple.second) - |> List.mean diff --git a/src/client/LoggedIn/Update.elm b/src/client/LoggedIn/Update.elm deleted file mode 100644 index a1d5f7d..0000000 --- a/src/client/LoggedIn/Update.elm +++ /dev/null @@ -1,137 +0,0 @@ -module LoggedIn.Update exposing - ( update - ) - -import Date exposing (Date) -import Dict -import Form -import Http exposing (Error(..)) -import Platform.Cmd exposing (Cmd) -import String -import Task - -import LoggedData -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import LoggedIn.Home.Update as Home -import LoggedIn.Model as LoggedInModel -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Stat.Update as Stat -import Model exposing (Model) -import Model.Category exposing (Category) -import Model.Frequency exposing (Frequency(..)) -import Model.Income as Income exposing (Income) -import Model.Payment as Payment exposing (Payment) -import Model.PaymentCategory as PaymentCategory -import Server - -import Utils.Cmd exposing ((:>)) - -update : Model -> LoggedIn.Msg -> LoggedInModel.Model -> (LoggedInModel.Model, Cmd LoggedIn.Msg) -update model msg loggedIn = - let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case msg of - - LoggedIn.NoOp -> - ( loggedIn - , Cmd.none - ) - - LoggedIn.HomeMsg homeMsg -> - case Home.update loggedData homeMsg loggedIn.home of - (home, effects) -> - ( { loggedIn | home = home } - , Cmd.map LoggedIn.HomeMsg effects - ) - - LoggedIn.StatMsg statMsg -> - case Stat.update loggedData statMsg loggedIn.stat of - (stat, effects) -> - ( { loggedIn | stat = stat } - , Cmd.map LoggedIn.StatMsg effects - ) - - LoggedIn.ValidateCreatePayment paymentId name cost date category frequency -> - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial frequency))) loggedIn - :> update model (LoggedIn.HomeMsg <| Home.UpdatePage 1) - :> (\loggedIn -> - let newPayment = Payment paymentId name cost date loggedIn.me frequency - in ( { loggedIn - | payments = newPayment :: loggedIn.payments - , paymentCategories = PaymentCategory.save name category loggedIn.paymentCategories - } - , Cmd.none - ) - ) - - LoggedIn.ValidateEditPayment paymentId name cost date category frequency -> - let updatedPayment = Payment paymentId name cost date loggedIn.me frequency - mbOldPayment = Payment.find paymentId loggedIn.payments - in ( { loggedIn - | payments = Payment.edit updatedPayment loggedIn.payments - , paymentCategories = - case mbOldPayment of - Just oldPayment -> - PaymentCategory.save name category loggedIn.paymentCategories - Nothing -> - loggedData.paymentCategories - } - , Cmd.none - ) - - LoggedIn.ValidateDeletePayment paymentId -> - let payments = Payment.delete paymentId loggedIn.payments - frequency = - case Form.getOutput loggedIn.home.search of - Just data -> data.frequency - Nothing -> Punctual - switchToPunctual = - ( frequency == Monthly - && List.isEmpty (Payment.monthly payments) - ) - in if switchToPunctual - then - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial Punctual))) loggedIn - :> (\loggedIn -> - ( { loggedIn | payments = payments } - , Cmd.none - ) - ) - else - ( { loggedIn | payments = payments } - , Cmd.none - ) - - LoggedIn.ValidateCreateIncome incomeId amount date -> - let newIncome = { userId = loggedIn.me, amount = amount, time = Date.toTime date } - in ( { loggedIn | incomes = Dict.insert incomeId newIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateEditIncome incomeId amount date -> - let updateIncome _ = Just <| Income loggedIn.me (Date.toTime date) amount - in ( { loggedIn | incomes = Dict.update incomeId updateIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateDeleteIncome incomeId -> - ( { loggedIn | incomes = Dict.remove incomeId loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateCreateCategory categoryId name color -> - let newCategory = { name = name, color = color } - in ( { loggedIn | categories = Dict.insert categoryId newCategory loggedIn.categories } - , Cmd.none - ) - - LoggedIn.ValidateEditCategory categoryId name color -> - let updateCategory _ = Just <| Category name color - in ( { loggedIn | categories = Dict.update categoryId updateCategory loggedIn.categories } , Cmd.none) - - LoggedIn.ValidateDeleteCategory categoryId -> - ( { loggedIn | categories = Dict.remove categoryId loggedIn.categories } - , Cmd.none - ) diff --git a/src/client/LoggedIn/View.elm b/src/client/LoggedIn/View.elm deleted file mode 100644 index 4936c6e..0000000 --- a/src/client/LoggedIn/View.elm +++ /dev/null @@ -1,33 +0,0 @@ -module LoggedIn.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Page - -import Msg exposing (Msg) -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import LoggedData - -import LoggedIn.Model as LoggedInModel - -import LoggedIn.Home.View as Home -import LoggedIn.Income.View as Income -import LoggedIn.Category.View as Categories -import LoggedIn.Stat.View as Stat - -view : Model -> LoggedInModel.Model -> Html Msg -view model loggedIn = - div - [ class "loggedIn" ] - [ let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case model.page of - Page.Home -> Home.view loggedData loggedIn.home - Page.Income -> Income.view loggedData - Page.Categories -> Categories.view loggedData - Page.Statistics -> Stat.view loggedData loggedIn.stat - Page.NotFound -> div [] [ text (getMessage model.translations "PageNotFound") ] - ] diff --git a/src/client/LoggedIn/View/Format.elm b/src/client/LoggedIn/View/Format.elm deleted file mode 100644 index f41e2cd..0000000 --- a/src/client/LoggedIn/View/Format.elm +++ /dev/null @@ -1,37 +0,0 @@ -module LoggedIn.View.Format exposing - ( price - ) - -import String exposing (..) - -import Model.Conf exposing (Conf) - -price : Conf -> Int -> String -price conf amount = - ( number amount - ++ " " - ++ conf.currency - ) - -number : Int -> String -number n = - abs n - |> toString - |> toList - |> List.reverse - |> group 3 - |> List.intersperse [' '] - |> List.concat - |> List.reverse - |> fromList - |> append (if n < 0 then "-" else "") - -group : Int -> List a -> List (List a) -group n xs = - if List.length xs <= n - then - [xs] - else - let take = List.take n xs - drop = List.drop n xs - in take :: (group n drop) diff --git a/src/client/Main.elm b/src/client/Main.elm deleted file mode 100644 index 7981a1c..0000000 --- a/src/client/Main.elm +++ /dev/null @@ -1,26 +0,0 @@ -module Main exposing - ( main - ) - -import Navigation -import Time -import Msg exposing (Msg(UpdatePage)) - -import Model exposing (init) -import Update exposing (update) -import View exposing (view) -import Page -import Tooltip - -main = - Navigation.programWithFlags (UpdatePage << Page.fromLocation) - { init = init - , view = view - , update = update - , subscriptions = (\model -> - Sub.batch - [ Time.every 60000 Msg.UpdateTime - , Sub.map Msg.Tooltip Tooltip.subscription - ] - ) - } diff --git a/src/client/Main.hs b/src/client/Main.hs new file mode 100644 index 0000000..c5f2c50 --- /dev/null +++ b/src/client/Main.hs @@ -0,0 +1,41 @@ +module Main + ( main + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import Data.JSString.Text (textFromJSString) +import qualified Data.Text.Encoding as T +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.NonElementParentNode as Dom +import GHCJS.DOM.Types (JSM, Element, JSString) +import Prelude hiding (init, error) + +import Common.Model (InitResult(InitEmpty)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import qualified View.App as App + +main :: JSM () +main = do + initResult <- readInit + putStrLn . show $ initResult + App.widget initResult + +readInit :: JSM InitResult +readInit = do + document <- Dom.currentDocumentUnchecked + initNode <- Dom.getElementById document "init" + case initNode of + Just node -> do + text <- textFromJSString <$> js_getInnerText node + return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of + Just init -> init + Nothing -> initParseError + _ -> + return initParseError + where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + +foreign import javascript unsafe "$1[\"innerText\"]" + js_getInnerText :: Element -> IO JSString diff --git a/src/client/Model.elm b/src/client/Model.elm deleted file mode 100644 index 7f62416..0000000 --- a/src/client/Model.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Model exposing - ( Model - , init - ) - -import Time exposing (Time) -import Json.Decode as Decode - -import Navigation exposing (Location) - -import Html as Html - -import Page exposing (Page) -import Init as Init exposing (Init) -import Msg exposing (Msg) - -import Model.View exposing (..) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import LoggedIn.Model as LoggedInModel -import SignIn.Model as SignInModel - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -type alias Model = - { view : View - , currentTime : Time - , translations : Translations - , conf : Conf - , page : Page - , errors : List String - , dialog : Dialog.Model DialogModel.Model DialogMsg.Msg Msg - , tooltip : Tooltip.Model - } - -init : Decode.Value -> Location -> (Model, Cmd Msg) -init payload location = - let model = - case Decode.decodeValue Init.decoder payload of - Ok { time, translations, conf, result, windowSize } -> - { view = - case result of - InitEmpty -> - SignInView (SignInModel.init Nothing) - InitSuccess init -> - LoggedInView (LoggedInModel.init time init) - InitError error -> - SignInView (SignInModel.init (Just error)) - , currentTime = time - , translations = translations - , conf = conf - , page = Page.fromLocation location - , errors = [] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init windowSize.width windowSize.height - } - Err error -> - { view = SignInView (SignInModel.init (Just error)) - , currentTime = 0 - , translations = [] - , conf = { currency = "" } - , page = Page.fromLocation location - , errors = [ error ] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init 0 0 - } - in (model, Cmd.none) diff --git a/src/client/Model/Category.elm b/src/client/Model/Category.elm deleted file mode 100644 index 8b653a7..0000000 --- a/src/client/Model/Category.elm +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Category exposing - ( Categories - , Category - , CategoryId - , categoriesDecoder - , categoryIdDecoder - , empty - ) - -import Json.Decode as Decode exposing (Decoder) -import Utils.Json as Json -import Dict exposing (Dict) - -type alias Categories = Dict CategoryId Category - -type alias CategoryId = Int - -type alias Category = - { name : String - , color : String - } - -categoriesDecoder : Decoder Categories -categoriesDecoder = - Json.dictDecoder (Decode.field "id" categoryIdDecoder) <| - Decode.map2 - Category - (Decode.field "name" Decode.string) - (Decode.field "color" Decode.string) - -categoryIdDecoder : Decoder CategoryId -categoryIdDecoder = Decode.int - -empty : Categories -empty = Dict.empty diff --git a/src/client/Model/Conf.elm b/src/client/Model/Conf.elm deleted file mode 100644 index 308fa04..0000000 --- a/src/client/Model/Conf.elm +++ /dev/null @@ -1,13 +0,0 @@ -module Model.Conf exposing - ( Conf - , confDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Conf = - { currency : String - } - -confDecoder : Decoder Conf -confDecoder = Decode.map Conf (Decode.field "currency" Decode.string) diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm deleted file mode 100644 index bfba02f..0000000 --- a/src/client/Model/Date.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Model.Date exposing - ( timeDecoder - , dateDecoder - ) - -import Date as Date exposing (Date) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import Time exposing (Time) - -timeDecoder : Decoder Time -timeDecoder = Decode.map Date.toTime dateDecoder - -dateDecoder : Decoder Date -dateDecoder = Decode.string |> Decode.andThen (Date.fromString >> Decode.fromResult) diff --git a/src/client/Model/Frequency.elm b/src/client/Model/Frequency.elm deleted file mode 100644 index 40f9893..0000000 --- a/src/client/Model/Frequency.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Model.Frequency exposing - ( Frequency(..) - , decoder - , validate - , fromString - ) - -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode - -import Form.Validate as Validate exposing (Validation) - -type Frequency = Punctual | Monthly - -decoder : Decoder Frequency -decoder = - let frequencyResult input = - fromString input - |> Result.fromMaybe ("Could not deduce Punctual nor Monthly from " ++ input) - in Decode.string |> Decode.andThen (Decode.fromResult << frequencyResult) - -validate : Validation String Frequency -validate = - Validate.customValidation Validate.string (\str -> - fromString str - |> Result.fromMaybe (Validate.customError "InvalidFrequency") - ) - -fromString : String -> Maybe Frequency -fromString str = - if str == toString Punctual then - Just Punctual - else if str == toString Monthly then - Just Monthly - else - Nothing diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm deleted file mode 100644 index aa5f05f..0000000 --- a/src/client/Model/Income.elm +++ /dev/null @@ -1,101 +0,0 @@ -module Model.Income exposing - ( Incomes - , Income - , IncomeId - , incomesDecoder - , incomeIdDecoder - , incomeDefinedForAll - , userCumulativeIncomeSince - , cumulativeIncomesSince - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List exposing (..) -import Maybe.Extra as Maybe -import Time exposing (Time, hour) -import Utils.Json as Json - -import Model.Date exposing (timeDecoder) -import Model.User exposing (UserId, userIdDecoder) - -type alias Incomes = Dict IncomeId Income - -type alias IncomeId = Int - -type alias Income = - { userId : UserId - , time : Float - , amount : Int - } - -incomesDecoder : Decoder Incomes -incomesDecoder = - Json.dictDecoder (Decode.field "id" incomeIdDecoder) <| - Decode.map3 Income - (Decode.field "userId" userIdDecoder) - (Decode.field "date" timeDecoder) - (Decode.field "amount" Decode.int) - -incomeIdDecoder : Decoder IncomeId -incomeIdDecoder = Decode.int - -incomeDefinedForAll : List UserId -> Incomes -> Maybe Time -incomeDefinedForAll userIds incomes = - let userIncomes = List.map (\userId -> List.filter ((==) userId << .userId) << Dict.values <| incomes) userIds - firstIncomes = map (head << sortBy .time) userIncomes - in if all Maybe.isJust firstIncomes - then head << reverse << List.sort << map .time << Maybe.values <| firstIncomes - else Nothing - -userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int -userCumulativeIncomeSince currentTime since incomes userId = - incomes - |> Dict.values - |> List.filter (\income -> income.userId == userId) - |> cumulativeIncomesSince currentTime since - -cumulativeIncomesSince : Time -> Time -> (List Income) -> Int -cumulativeIncomesSince currentTime since incomes = - cumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince : Time -> List Income -> List Income -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> income.time >= time) incomes - in (Maybe.toList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt : Time -> List Income -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if x.time < time - then Just { userId = x.userId, time = time, amount = x.amount } - else Nothing - x1 :: x2 :: xs -> - if x1.time < time && x2.time >= time - then Just { userId = x1.userId, time = time, amount = x1.amount } - else getIncomeAt time (x2 :: xs) - [] -> - Nothing - -cumulativeIncome : Time -> List Income -> Int -cumulativeIncome currentTime incomes = - getIncomesWithDuration currentTime (List.sortBy .time incomes) - |> map durationIncome - |> sum - -getIncomesWithDuration : Time -> List Income -> List (Float, Int) -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(currentTime - income.time, income.amount)] - (income1 :: income2 :: xs) -> - (income2.time - income1.time, income1.amount) :: (getIncomesWithDuration currentTime (income2 :: xs)) - -durationIncome : (Float, Int) -> Int -durationIncome (duration, income) = - duration * toFloat income / (hour * 24 * 365 / 12) - |> truncate diff --git a/src/client/Model/Init.elm b/src/client/Model/Init.elm deleted file mode 100644 index db7069f..0000000 --- a/src/client/Model/Init.elm +++ /dev/null @@ -1,31 +0,0 @@ -module Model.Init exposing - ( Init - , initDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Payment exposing (Payments, paymentsDecoder) -import Model.User exposing (Users, UserId, usersDecoder, userIdDecoder) -import Model.Income exposing (Incomes, incomesDecoder) -import Model.Category exposing (Categories, categoriesDecoder) -import Model.PaymentCategory exposing (PaymentCategories, paymentCategoriesDecoder) - -type alias Init = - { users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -initDecoder : Decoder Init -initDecoder = - Decode.map6 Init - (Decode.field "users" usersDecoder) - (Decode.field "me" userIdDecoder) - (Decode.field "payments" paymentsDecoder) - (Decode.field "incomes" incomesDecoder) - (Decode.field "categories" categoriesDecoder) - (Decode.field "paymentCategories" paymentCategoriesDecoder) diff --git a/src/client/Model/InitResult.elm b/src/client/Model/InitResult.elm deleted file mode 100644 index 7ce0be2..0000000 --- a/src/client/Model/InitResult.elm +++ /dev/null @@ -1,28 +0,0 @@ -module Model.InitResult exposing - ( InitResult(..) - , initResultDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Init exposing (Init, initDecoder) - -type InitResult = - InitEmpty - | InitSuccess Init - | InitError String - -initResultDecoder : Decoder InitResult -initResultDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen initResultDecoderWithTag - -initResultDecoderWithTag : String -> Decoder InitResult -initResultDecoderWithTag tag = - case tag of - "InitEmpty" -> - Decode.succeed InitEmpty - "InitSuccess" -> - Decode.map InitSuccess (Decode.field "contents" initDecoder) - "InitError" -> - Decode.map InitError (Decode.field "contents" Decode.string) - _ -> - Decode.fail <| "got " ++ tag ++ " for InitResult" diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm deleted file mode 100644 index 4d9190e..0000000 --- a/src/client/Model/Payer.elm +++ /dev/null @@ -1,137 +0,0 @@ -module Model.Payer exposing - ( Payers - , Payer - , ExceedingPayer - , getOrderedExceedingPayers - , useIncomesFrom - ) - -import Dict exposing (..) -import List -import Maybe -import Time exposing (Time) -import Date - -import Model.Payment exposing (Payments, totalPayments) -import Model.User exposing (Users, UserId, userIdDecoder) -import Model.Income exposing (..) - -import Utils.Dict exposing (mapValues) - -type alias Payers = Dict UserId Payer - -type alias Payer = - { preIncomePaymentSum : Int - , postIncomePaymentSum : Int - , incomes : List Income - } - -type alias PostPaymentPayer = - { preIncomePaymentSum : Int - , cumulativeIncome : Int - , ratio : Float - } - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer -getOrderedExceedingPayers currentTime users incomes payments = - let payers = getPayers currentTime users incomes payments - exceedingPayersOnPreIncome = - payers - |> mapValues .preIncomePaymentSum - |> Dict.toList - |> exceedingPayersFromAmounts - mbSince = useIncomesFrom users incomes payments - in case mbSince of - Just since -> - let postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - postPaymentPayers - |> Dict.toList - |> List.map (.ratio << Tuple.second) - |> List.maximum - in case mbMaxRatio of - Just maxRatio -> - postPaymentPayers - |> mapValues (getFinalDiff maxRatio) - |> Dict.toList - |> exceedingPayersFromAmounts - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom : Users -> Incomes -> Payments -> Maybe Time -useIncomesFrom users incomes payments = - let firstPaymentTime = - payments - |> List.map (Date.toTime << .date) - |> List.sort - |> List.head - mbIncomeTime = incomeDefinedForAll (Dict.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just paymentTime, Just incomeTime) -> - Just (max paymentTime incomeTime) - _ -> - Nothing - -getPayers : Time -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Dict.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in userIds - |> List.map (\userId -> - ( userId - , { preIncomePaymentSum = - totalPayments - (\p -> (Date.toTime p.date) < (Maybe.withDefault currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> (Date.toTime p.date) >= t - ) - userId - payments - , incomes = List.filter ((==) userId << .userId) (Dict.values incomes) - } - ) - ) - |> Dict.fromList - -exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer -exceedingPayersFromAmounts userAmounts = - let mbMinAmount = List.minimum << List.map Tuple.second <| userAmounts - in case mbMinAmount of - Nothing -> - [] - Just minAmount -> - userAmounts - |> List.map (\userAmount -> - { userId = Tuple.first userAmount - , amount = Tuple.second userAmount - minAmount - } - ) - |> List.filter (\payer -> payer.amount > 0) - -getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes - in { preIncomePaymentSum = payer.preIncomePaymentSum - , cumulativeIncome = cumulativeIncome - , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome - } - -getFinalDiff : Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome - |> truncate - in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm deleted file mode 100644 index 204f9f5..0000000 --- a/src/client/Model/Payment.elm +++ /dev/null @@ -1,117 +0,0 @@ -module Model.Payment exposing - ( perPage - , Payments - , Payment - , PaymentId - , paymentsDecoder - , paymentIdDecoder - , find - , edit - , delete - , totalPayments - , punctual - , monthly - , groupAndSortByMonth - , search - ) - -import Date exposing (..) -import Date.Extra.Core exposing (monthToInt, intToMonth) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import List -import List.Extra as List - -import Form.Validate as Validate exposing (Validation) -import Model.Date exposing (dateDecoder) -import Model.Frequency as Frequency exposing (Frequency(..)) -import Model.User exposing (UserId, userIdDecoder) -import Utils.List as List -import Utils.Search as Search - -perPage : Int -perPage = 7 - -type alias Payments = List Payment - -type alias Payment = - { id : PaymentId - , name : String - , cost : Int - , date : Date - , userId : UserId - , frequency : Frequency - } - -type alias PaymentId = Int - -paymentsDecoder : Decoder Payments -paymentsDecoder = Decode.list paymentDecoder - -paymentDecoder : Decoder Payment -paymentDecoder = - Decode.map6 Payment - (Decode.field "id" paymentIdDecoder) - (Decode.field "name" Decode.string) - (Decode.field "cost" Decode.int) - (Decode.field "date" dateDecoder) - (Decode.field "userId" userIdDecoder) - (Decode.field "frequency" Frequency.decoder) - -paymentIdDecoder : Decoder PaymentId -paymentIdDecoder = Decode.int - -find : PaymentId -> Payments -> Maybe Payment -find paymentId payments = - payments - |> List.find (\p -> p.id == paymentId) - -edit : Payment -> Payments -> Payments -edit payment payments = payment :: delete payment.id payments - -delete : PaymentId -> Payments -> Payments -delete paymentId = List.filter (((/=) paymentId) << .id) - -totalPayments : (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - payments - |> List.filter (\payment -> - paymentFilter payment - && payment.userId == userId - ) - |> List.map .cost - |> List.sum - -punctual : Payments -> Payments -punctual = List.filter ((==) Punctual << .frequency) - -monthly : Payments -> Payments -monthly = List.filter ((==) Monthly << .frequency) - -groupAndSortByMonth : Payments -> List ((Month, Int), Payments) -groupAndSortByMonth payments = - payments - |> List.groupBy (\payment -> (Date.year payment.date, monthToInt << Date.month <| payment.date)) - |> List.sortBy Tuple.first - |> List.map (\((year, month), payments) -> ((intToMonth month, year), payments)) - -search : String -> Frequency -> Payments -> Payments -search name frequency payments = - payments - |> List.filter ((==) frequency << .frequency) - |> paymentSort frequency - |> List.filter (searchSuccess name) - -paymentSort : Frequency -> Payments -> Payments -paymentSort frequency = - case frequency of - Punctual -> List.reverse << List.sortBy (Date.toTime << .date) - Monthly -> List.sortBy (String.toLower << .name) - -searchSuccess : String -> Payment -> Bool -searchSuccess search { name, cost } = - let searchSuccessWord word = - ( String.contains (Search.format word) (Search.format name) - || String.contains word (toString cost) - ) - in List.all searchSuccessWord (String.words search) diff --git a/src/client/Model/PaymentCategory.elm b/src/client/Model/PaymentCategory.elm deleted file mode 100644 index a4fceb1..0000000 --- a/src/client/Model/PaymentCategory.elm +++ /dev/null @@ -1,61 +0,0 @@ -module Model.PaymentCategory exposing - ( PaymentCategories - , paymentCategoriesDecoder - , search - , groupPaymentsByCategory - , isCategoryUnused - , save - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List.Extra as List -import Maybe.Extra as Maybe - -import Model.Category exposing (CategoryId, categoryIdDecoder) -import Model.Payment exposing (Payments) -import Utils.Json as Json -import Utils.List as List -import Utils.Search as Search - -type alias PaymentCategories = List PaymentCategory - -type alias PaymentCategory = - { name : String - , category : CategoryId - } - -paymentCategoriesDecoder : Decoder PaymentCategories -paymentCategoriesDecoder = - Decode.list <| Decode.map2 PaymentCategory - (Decode.field "name" Decode.string) - (Decode.field "category" categoryIdDecoder) - -groupPaymentsByCategory : PaymentCategories -> Payments -> List (CategoryId, Payments) -groupPaymentsByCategory paymentCategories payments = - payments - |> List.groupBy (\payment -> - search payment.name paymentCategories - |> Maybe.withDefault -1 - ) - |> List.filterMap (\(category, payments) -> - case category of - -1 -> Nothing - _ -> Just (category, payments) - ) - -search : String -> PaymentCategories -> Maybe CategoryId -search paymentName paymentCategories = - paymentCategories - |> List.find (\pc -> Search.format pc.name == Search.format paymentName) - |> Maybe.map .category - -isCategoryUnused : CategoryId -> PaymentCategories -> Bool -isCategoryUnused category paymentCategories = - paymentCategories - |> List.find ((==) category << .category) - |> Maybe.isNothing - -save : String -> CategoryId -> PaymentCategories -> PaymentCategories -save name category paymentCategories = - { name = name, category = category } :: List.filter (\pc -> not <| Search.format pc.name == Search.format name) paymentCategories diff --git a/src/client/Model/Size.elm b/src/client/Model/Size.elm deleted file mode 100644 index f40fb01..0000000 --- a/src/client/Model/Size.elm +++ /dev/null @@ -1,17 +0,0 @@ -module Model.Size exposing - ( Size - , sizeDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Size = - { width: Int - , height: Int - } - -sizeDecoder : Decoder Size -sizeDecoder = - Decode.map2 Size - (Decode.field "width" Decode.int) - (Decode.field "height" Decode.int) diff --git a/src/client/Model/Translations.elm b/src/client/Model/Translations.elm deleted file mode 100644 index 9b314e1..0000000 --- a/src/client/Model/Translations.elm +++ /dev/null @@ -1,68 +0,0 @@ -module Model.Translations exposing - ( translationsDecoder - , Translations - , Translation - , getMessage - , getParamMessage - ) - -import Maybe exposing (withDefault) -import Json.Decode as Decode exposing (Decoder) -import String - -type alias Translations = List Translation - -translationsDecoder : Decoder Translations -translationsDecoder = Decode.list translationDecoder - -type alias Translation = - { key : String - , message : List MessagePart - } - -getTranslation : String -> Translations -> Maybe (List MessagePart) -getTranslation key translations = - translations - |> List.filter (\translation -> String.toLower translation.key == String.toLower key) - |> List.head - |> Maybe.map .message - -translationDecoder : Decoder Translation -translationDecoder = - Decode.map2 Translation - (Decode.field "key" Decode.string) - (Decode.field "message" (Decode.list partDecoder)) - -type MessagePart = - Order Int - | Str String - -partDecoder : Decoder MessagePart -partDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen partDecoderWithTag - -partDecoderWithTag : String -> Decoder MessagePart -partDecoderWithTag tag = - case tag of - "Order" -> Decode.map Order (Decode.field "contents" Decode.int) - _ -> Decode.map Str (Decode.field "contents" Decode.string) - ------ - -getMessage : Translations -> String -> String -getMessage = getParamMessage [] - -getParamMessage : List String -> Translations -> String -> String -getParamMessage values translations key = - getTranslation key translations - |> Maybe.map (\parts -> String.concat (List.map (replacePart values) parts)) - |> withDefault key - -replacePart : List String -> MessagePart -> String -replacePart values part = - case part of - Str str -> str - Order n -> - values - |> List.drop (n - 1) - |> List.head - |> withDefault ("{" ++ (toString n) ++ "}") diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm deleted file mode 100644 index f6e8147..0000000 --- a/src/client/Model/User.elm +++ /dev/null @@ -1,44 +0,0 @@ -module Model.User exposing - ( Users - , usersDecoder - , User - , userDecoder - , UserId - , userIdDecoder - , getUserName - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -type alias Users = Dict UserId User - -type alias UserId = Int - -type alias User = - { name : String - , email : String - } - -usersDecoder : Decoder Users -usersDecoder = Decode.map Dict.fromList (Decode.list userWithIdDecoder) - -userWithIdDecoder : Decode.Decoder (UserId, User) -userWithIdDecoder = - Decode.map2 (,) - (Decode.field "id" userIdDecoder) - userDecoder - -userIdDecoder : Decoder UserId -userIdDecoder = Decode.int - -userDecoder : Decoder User -userDecoder = - Decode.map2 User - (Decode.field "name" Decode.string) - (Decode.field "email" Decode.string) - -getUserName : Users -> UserId -> Maybe String -getUserName users userId = - Dict.get userId users - |> Maybe.map .name diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm deleted file mode 100644 index 61d42a7..0000000 --- a/src/client/Model/View.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Model.View exposing - ( View(..) - ) - -import Model.Payment exposing (Payments) - -import SignIn.Model as SignInModel -import LoggedIn.Model as LoggedInModel - -type View = - SignInView SignInModel.Model - | LoggedInView LoggedInModel.Model diff --git a/src/client/Msg.elm b/src/client/Msg.elm deleted file mode 100644 index 5970747..0000000 --- a/src/client/Msg.elm +++ /dev/null @@ -1,49 +0,0 @@ -module Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) -import Time exposing (Time) - -import Page exposing (Page) - -import Model.Init exposing (Init) -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Category exposing (CategoryId) - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -import SignIn.Msg as SignInMsg -import LoggedIn.Msg as LoggedInMsg - -type Msg = - NoOp - | UpdatePage Page - | SignIn String - | UpdateTime Time - | GoLoggedInView Init - | UpdateSignIn SignInMsg.Msg - | UpdateLoggedIn LoggedInMsg.Msg - | GoSignInView - | SignOut - | Error String - | Dialog (Dialog.Msg DialogModel.Model DialogMsg.Msg Msg) - | Tooltip Tooltip.Msg - - | CreatePayment String Int Date CategoryId Frequency - | EditPayment PaymentId String Int Date CategoryId Frequency - | DeletePayment PaymentId - - | CreateIncome Int Date - | EditIncome IncomeId Int Date - | DeleteIncome IncomeId - - | CreateCategory String String - | EditCategory CategoryId String String - | DeleteCategory CategoryId diff --git a/src/client/Page.elm b/src/client/Page.elm deleted file mode 100644 index 39232e0..0000000 --- a/src/client/Page.elm +++ /dev/null @@ -1,43 +0,0 @@ -module Page exposing - ( Page(..) - , toHash - , fromLocation - ) - -import Navigation exposing (Location) -import UrlParser exposing (Parser, (</>), s) -import String - -type Page = - Home - | Income - | Categories - | Statistics - | NotFound - -toHash : Page -> String -toHash page = - case page of - Home -> "#" - Income -> "#income" - Categories -> "#categories" - Statistics -> "#statistics" - NotFound -> "#notFound" - -fromLocation : Location -> Page -fromLocation location = - if location.hash == "" - then - Home - else - case UrlParser.parseHash pageParser location of - Just page -> page - Nothing -> NotFound - -pageParser : Parser (Page -> a) a -pageParser = - UrlParser.oneOf - [ UrlParser.map Income (s "income") - , UrlParser.map Categories (s "categories") - , UrlParser.map Statistics (s "statistics") - ] diff --git a/src/client/Server.elm b/src/client/Server.elm deleted file mode 100644 index c44b777..0000000 --- a/src/client/Server.elm +++ /dev/null @@ -1,115 +0,0 @@ -module Server exposing - ( signIn - , createPayment - , editPayment - , deletePayment - , createIncome - , editIncome - , deleteIncome - , createCategory - , editCategory - , deleteCategory - , signOut - ) - -import Task as Task exposing (Task) -import Http exposing (Error) -import Date -import Json.Decode as Decode -import Json.Encode as Encode -import Date exposing (Date) - -import Date.Extra.Format as DateFormat - -import Utils.Http as HttpUtils - -import Model.Payment exposing (..) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (incomeIdDecoder, IncomeId) -import Model.Category exposing (categoryIdDecoder, CategoryId) -import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder) -import Model.Init exposing (Init) - -signIn : String -> (Result Error String -> msg) -> Cmd msg -signIn email = HttpUtils.request "POST" ("/signIn?email=" ++ email) Http.expectString - -createPayment : String -> Int -> Date -> CategoryId -> Frequency -> (Result Error PaymentId -> msg) -> Cmd msg -createPayment name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - expect = Http.expectJson (Decode.field "id" paymentIdDecoder) - in HttpUtils.jsonRequest "POST" "/payment" expect handleResult json - -editPayment : PaymentId -> String -> Int -> Date -> CategoryId -> Frequency -> (Result Error String -> msg) -> Cmd msg -editPayment paymentId name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("id", Encode.int paymentId) - , ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - in HttpUtils.jsonRequest "PUT" "/payment" Http.expectString handleResult json - -deletePayment : PaymentId -> (Result Error String -> msg) -> Cmd msg -deletePayment paymentId = - HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) Http.expectString - -createIncome : Int -> Date -> (Result Error IncomeId -> msg) -> Cmd msg -createIncome amount date handleResult = - let json = - Encode.object - [ ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - expect = Http.expectJson (Decode.field "id" incomeIdDecoder) - in HttpUtils.jsonRequest "POST" "/income" expect handleResult json - -editIncome : IncomeId -> Int -> Date -> (Result Error String -> msg) -> Cmd msg -editIncome incomeId amount date handleResult = - let json = - Encode.object - [ ("id", Encode.int incomeId) - , ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - in HttpUtils.jsonRequest "PUT" "/income" Http.expectString handleResult json - -deleteIncome : IncomeId -> (Result Error String -> msg) -> Cmd msg -deleteIncome incomeId = - HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) Http.expectString - -createCategory : String -> String -> (Result Error CategoryId -> msg) -> Cmd msg -createCategory name color handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("color", Encode.string color) - ] - expect = Http.expectJson (Decode.field "id" categoryIdDecoder) - in HttpUtils.jsonRequest "POST" "/category" expect handleResult json - -editCategory : CategoryId -> String -> String -> (Result Error String -> msg) -> Cmd msg -editCategory categoryId name color handleResult = - let json = - Encode.object - [ ("id", Encode.int categoryId) - , ("name", Encode.string name) - , ("color", Encode.string color) - ] - in HttpUtils.jsonRequest "PUT" "/category" Http.expectString handleResult json - -deleteCategory : CategoryId -> (Result Error String -> msg) -> Cmd msg -deleteCategory categoryId = - HttpUtils.request "DELETE" ("/category?id=" ++ (toString categoryId)) Http.expectString - -signOut : (Result Error String -> msg) -> Cmd msg -signOut = HttpUtils.request "POST" "/signOut" Http.expectString diff --git a/src/client/SignIn/Model.elm b/src/client/SignIn/Model.elm deleted file mode 100644 index 19d4305..0000000 --- a/src/client/SignIn/Model.elm +++ /dev/null @@ -1,17 +0,0 @@ -module SignIn.Model exposing - ( Model - , init - ) - -type alias Model = - { login : String - , waitingServer : Bool - , result : Maybe (Result String String) - } - -init : Maybe String -> Model -init mbSignInError = - { login = "" - , waitingServer = False - , result = Maybe.map Err mbSignInError - } diff --git a/src/client/SignIn/Msg.elm b/src/client/SignIn/Msg.elm deleted file mode 100644 index f753ebd..0000000 --- a/src/client/SignIn/Msg.elm +++ /dev/null @@ -1,9 +0,0 @@ -module SignIn.Msg exposing - ( Msg(..) - ) - -type Msg = - UpdateLogin String - | WaitingServer - | ValidLogin - | ErrorLogin String diff --git a/src/client/SignIn/Update.elm b/src/client/SignIn/Update.elm deleted file mode 100644 index 98de777..0000000 --- a/src/client/SignIn/Update.elm +++ /dev/null @@ -1,31 +0,0 @@ -module SignIn.Update exposing - ( update - ) - -import SignIn.Model exposing (..) -import SignIn.Msg exposing (..) - -import Model.Translations exposing (getMessage, Translations) - -update : Translations -> Msg -> Model -> Model -update translations msg signInView = - case msg of - UpdateLogin login -> - { signInView | - login = login - } - WaitingServer -> - { signInView - | waitingServer = True - } - ValidLogin -> - { signInView - | login = "" - , result = Just (Ok (getMessage translations "SignInEmailSent")) - , waitingServer = False - } - ErrorLogin message -> - { signInView - | result = Just (Err message) - , waitingServer = False - } diff --git a/src/client/SignIn/View.elm b/src/client/SignIn/View.elm deleted file mode 100644 index 88f74b0..0000000 --- a/src/client/SignIn/View.elm +++ /dev/null @@ -1,63 +0,0 @@ -module SignIn.View exposing - ( view - ) - -import Json.Decode as Decode - -import FontAwesome -import View.Color as Color - -import Html as H exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import SignIn.Msg as SignInMsg -import SignIn.Model as SignInModel - -import Update exposing (..) - -import Model exposing (Model) -import Msg exposing (..) -import Model.Translations exposing (getMessage) - -import View.Events exposing (onSubmitPrevDefault) - -view : Model -> SignInModel.Model -> Html Msg -view model signInModel = - div - [ class "signIn" ] - [ H.form - [ onSubmitPrevDefault (SignIn signInModel.login) ] - [ input - [ value signInModel.login - , on "input" (targetValue |> (Decode.map <| (UpdateSignIn << SignInMsg.UpdateLogin))) - , name "email" - ] - [] - , button - [] - [ if signInModel.waitingServer - then FontAwesome.spinner Color.white 20 - else text (getMessage model.translations "SignIn") - ] - ] - , div - [ class "result" ] - [ signInResult model signInModel ] - ] - -signInResult : Model -> SignInModel.Model -> Html Msg -signInResult model signInModel = - case signInModel.result of - Just result -> - case result of - Ok login -> - div - [ class "success" ] - [ text (getMessage model.translations "SignInEmailSent") ] - Err error -> - div - [ class "error" ] - [ text (getMessage model.translations error) ] - Nothing -> - text "" diff --git a/src/client/Tooltip.elm b/src/client/Tooltip.elm deleted file mode 100644 index 4f70cda..0000000 --- a/src/client/Tooltip.elm +++ /dev/null @@ -1,113 +0,0 @@ -module Tooltip exposing - ( Msg(..) - , Model - , init - , subscription - , update - , view - , show - ) - -import Platform.Cmd - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Mouse exposing (Position) -import Window exposing (Size) - -type Msg = - UpdateMousePosition Position - | UpdateWindowSize Size - | ShowMessage String - | HideMessage - -type alias Model = - { mousePosition : Maybe Position - , windowSize : Size - , message : Maybe String - } - -init : Int -> Int -> Model -init width height = - { mousePosition = Nothing - , windowSize = - { width = width - , height = height - } - , message = Nothing - } - -subscription : Sub Msg -subscription = - Sub.batch - [ Mouse.moves UpdateMousePosition - , Window.resizes UpdateWindowSize - ] - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - UpdateMousePosition position -> - ( { model | mousePosition = Just position } - , Cmd.none - ) - - UpdateWindowSize size -> - ( { model | windowSize = size } - , Cmd.none - ) - - ShowMessage message -> - ( { model | message = Just message } - , Cmd.none - ) - - HideMessage -> - ( { model | message = Nothing } - , Cmd.none - ) - -view : Model -> Html Msg -view { mousePosition, windowSize, message } = - case (mousePosition, message) of - (Just pos, Just msg) -> - div - [ class "tooltip" - , style - [ ("position", "absolute") - , horizontalPosition windowSize pos - , ("top", px <| pos.y + 15) - ] - ] - [ text msg ] - _ -> - text "" - -horizontalPosition : Size -> Position -> (String, String) -horizontalPosition size position = - if isLeft size position - then ("left", px <| position.x + 5) - else ("right", px <| size.width - position.x) - -verticalPosition : Size -> Position -> (String, String) -verticalPosition size position = - if isTop size position - then ("top", px <| position.y + 20) - else ("bottom", px <| size.height - position.y + 15) - -px : Int -> String -px n = (toString n) ++ "px" - -isLeft : Size -> Position -> Bool -isLeft { width } { x } = x < width // 2 - -isTop : Size -> Position -> Bool -isTop { height } { y } = y < height // 2 - -show : (Msg -> msg) -> String -> List (Attribute msg) -show mapMsg message = - [ onMouseEnter <| mapMsg <| ShowMessage message - , onMouseLeave <| mapMsg <| HideMessage - ] diff --git a/src/client/Update.elm b/src/client/Update.elm deleted file mode 100644 index 4284b65..0000000 --- a/src/client/Update.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Update exposing - ( update - ) - -import Navigation exposing (Location) -import Platform.Cmd exposing (Cmd) -import Task - -import Dialog -import Dialog.Update as DialogUpdate -import LoggedIn.Model as LoggedIn -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Update as LoggedIn -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Model.View as V -import Msg exposing (..) -import Page exposing (Page(..)) -import Server -import SignIn.Model as SignInModel -import SignIn.Msg as SignInMsg -import SignIn.Update as SignInUpdate -import Tooltip -import Utils.Cmd exposing ((:>)) -import Utils.Http exposing (errorKey) - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - - NoOp -> - (model, Cmd.none) - - UpdatePage page -> - ( { model | page = page } - , if page == Statistics - then - let msg = UpdateLoggedIn <| LoggedIn.StatMsg <| Stat.UpdateChart - in Task.perform (\_ -> msg) (Task.succeed ()) - else - Cmd.none - ) - - SignIn email -> - ( applySignIn model (SignInMsg.WaitingServer) - , Server.signIn email (\result -> case result of - Ok _ -> UpdateSignIn SignInMsg.ValidLogin - Err error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error)) - ) - ) - - GoLoggedInView init -> - ( { model | view = V.LoggedInView (LoggedIn.init model.currentTime init) } - , Cmd.none - ) - - UpdateTime time -> - ({ model | currentTime = time }, Cmd.none) - - GoSignInView -> - ({ model | view = V.SignInView (SignInModel.init Nothing) }, Cmd.none) - - UpdateSignIn signInMsg -> - (applySignIn model signInMsg, Cmd.none) - - UpdateLoggedIn loggedInMsg -> - applyLoggedIn model loggedInMsg - - SignOut -> - ( model - , Server.signOut (\result -> case result of - Ok _ -> GoSignInView - Err _ -> Error "SignOutError" - ) - ) - - Error error -> - ({ model | errors = model.errors ++ [ error ] }, Cmd.none) - - Dialog dialogMsg -> - Dialog.update DialogUpdate.update dialogMsg model.dialog.model model.dialog - |> Tuple.mapFirst (\dialog -> { model | dialog = dialog }) - :> update (Tooltip Tooltip.HideMessage) - - Tooltip tooltipMsg -> - let (newTooltip, command) = Tooltip.update tooltipMsg model.tooltip - in ( { model | tooltip = newTooltip } - , Cmd.map Tooltip command - ) - - CreatePayment name cost date category frequency -> - ( model - , Server.createPayment name cost date category frequency (\result -> case result of - Ok paymentId -> UpdateLoggedIn <| LoggedIn.ValidateCreatePayment paymentId name cost date category frequency - Err _ -> Error "CreatePaymentError" - ) - ) - - EditPayment paymentId name cost date category frequency -> - ( model - , Server.editPayment paymentId name cost date category frequency (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditPayment paymentId name cost date category frequency - Err _ -> Error "EditPaymentError" - ) - ) - - DeletePayment paymentId -> - ( model - , Server.deletePayment paymentId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeletePayment paymentId - Err _ -> Error "DeletePaymentError" - ) - ) - - CreateIncome amount date -> - ( model - , Server.createIncome amount date (\result -> case result of - Ok incomeId -> UpdateLoggedIn <| LoggedIn.ValidateCreateIncome incomeId amount date - Err _ -> Error "CreateIncomeError" - ) - ) - - EditIncome incomeId amount date -> - ( model - , Server.editIncome incomeId amount date (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditIncome incomeId amount date - Err _ -> Error "EditIncomeError" - ) - ) - - DeleteIncome incomeId -> - ( model - , Server.deleteIncome incomeId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteIncome incomeId - Err _ -> Error "DeleteIncomeError" - ) - ) - - CreateCategory name color -> - ( model - , Server.createCategory name color (\result -> case result of - Ok categoryId -> UpdateLoggedIn <| LoggedIn.ValidateCreateCategory categoryId name color - Err _ -> Error "CreateCategoryError" - ) - ) - - EditCategory categoryId name color -> - ( model - , Server.editCategory categoryId name color (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditCategory categoryId name color - Err _ -> Error "EditCategoryError" - ) - ) - - DeleteCategory categoryId -> - ( model - , Server.deleteCategory categoryId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteCategory categoryId - Err _ -> Error "DeleteCategoryError" - ) - ) - - -applySignIn : Model -> SignInMsg.Msg -> Model -applySignIn model signInMsg = - case model.view of - V.SignInView signInView -> - { model | view = V.SignInView (SignInUpdate.update model.translations signInMsg signInView) } - _ -> - model - -applyLoggedIn : Model -> LoggedIn.Msg -> (Model, Cmd Msg) -applyLoggedIn model loggedInMsg = - case model.view of - V.LoggedInView loggedInView -> - let (view, cmd) = LoggedIn.update model loggedInMsg loggedInView - in ( { model | view = V.LoggedInView view } - , Cmd.map UpdateLoggedIn cmd - ) - _ -> - (model, Cmd.none) diff --git a/src/client/Utils/Cmd.elm b/src/client/Utils/Cmd.elm deleted file mode 100644 index 5f41cbe..0000000 --- a/src/client/Utils/Cmd.elm +++ /dev/null @@ -1,16 +0,0 @@ -module Utils.Cmd exposing - ( pipeUpdate - , (:>) - ) - -import Platform.Cmd as Cmd - -pipeUpdate : (model, Cmd msg) -> (model -> (model, Cmd msg)) -> (model, Cmd msg) -pipeUpdate (model, cmd) f = - let (newModel, newCmd) = f model - in (newModel, Cmd.batch [ cmd, newCmd ]) - -(:>) : (m, Cmd a) -> (m -> (m, Cmd a)) -> (m, Cmd a) -(:>) = pipeUpdate - -infixl 0 :> diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm deleted file mode 100644 index 7d708e2..0000000 --- a/src/client/Utils/Dict.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Dict exposing - ( mapValues - ) - -import Dict as Dict exposing (..) - -mapValues : (a -> b) -> Dict comparable a -> Dict comparable b -mapValues f = Dict.fromList << List.map (onSecond f) << Dict.toList - -onSecond : (a -> b) -> (comparable, a) -> (comparable, b) -onSecond f tuple = case tuple of (x, y) -> (x, f y) diff --git a/src/client/Utils/Either.elm b/src/client/Utils/Either.elm deleted file mode 100644 index 275fc8c..0000000 --- a/src/client/Utils/Either.elm +++ /dev/null @@ -1,9 +0,0 @@ -module Utils.Either exposing - ( toMaybeError - ) - -toMaybeError : Result a b -> Maybe a -toMaybeError result = - case result of - Ok _ -> Nothing - Err x -> Just x diff --git a/src/client/Utils/Form.elm b/src/client/Utils/Form.elm deleted file mode 100644 index 6793222..0000000 --- a/src/client/Utils/Form.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Form exposing - ( fieldAsText - ) - -import Form exposing (Form) - -fieldAsText : Form a b -> String -> String -fieldAsText form field = - Form.getFieldAsString field form - |> .value - |> Maybe.withDefault "" diff --git a/src/client/Utils/Http.elm b/src/client/Utils/Http.elm deleted file mode 100644 index dd3870a..0000000 --- a/src/client/Utils/Http.elm +++ /dev/null @@ -1,39 +0,0 @@ -module Utils.Http exposing - ( jsonRequest - , request - , errorKey - ) - -import Http exposing (..) -import Task exposing (..) -import Json.Decode as Decode exposing (Decoder, Value) -import Json.Encode as Encode - -jsonRequest : String -> String -> Expect a -> (Result Error a -> msg) -> Encode.Value -> Cmd msg -jsonRequest method url expect handleResult value = - requestWithBody method url (jsonBody value) expect handleResult - -request : String -> String -> Expect a -> (Result Error a -> msg) -> Cmd msg -request method url = requestWithBody method url emptyBody - -requestWithBody : String -> String -> Body -> Expect a -> (Result Error a -> msg) -> Cmd msg -requestWithBody method url body expect handleResult = - let req = Http.request - { method = method - , headers = [] - , url = url - , body = body - , expect = expect - , timeout = Nothing - , withCredentials = False - } - in send handleResult req - -errorKey : Error -> String -errorKey error = - case error of - BadUrl _ -> "BadUrl" - Timeout -> "Timeout" - NetworkError -> "NetworkError" - BadPayload _ _ -> "BadPayload" - BadStatus response -> response.body diff --git a/src/client/Utils/Json.elm b/src/client/Utils/Json.elm deleted file mode 100644 index 29e815b..0000000 --- a/src/client/Utils/Json.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Utils.Json exposing - ( dictDecoder - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -dictDecoder : Decoder comparable -> Decoder a -> Decoder (Dict comparable a) -dictDecoder keyDecoder valueDecoder = - Decode.map2 (,) keyDecoder valueDecoder - |> Decode.list - |> Decode.map Dict.fromList diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm deleted file mode 100644 index 8e26e85..0000000 --- a/src/client/Utils/List.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Utils.List exposing - ( groupBy - , mean - , links - ) - -import Dict -import Maybe.Extra as Maybe - -groupBy : (a -> comparable) -> List a -> List (comparable, List a) -groupBy f xs = - let addItem item dict = - let groupItems = Dict.get (f item) dict |> Maybe.withDefault [] - in Dict.insert (f item) (item :: groupItems) dict - in List.foldr addItem Dict.empty xs - |> Dict.toList - -mean : List Int -> Int -mean xs = (List.sum xs) // (List.length xs) - -links : List a -> List (a, a) -links xs = - let reversed = List.reverse xs - in List.foldr - (\x acc -> - case Maybe.map Tuple.first (List.head acc) of - Just y -> - (x, y) :: acc - _ -> - acc - ) - (case reversed of - x :: y :: _ -> [(y, x)] - _ -> [] - ) - (List.reverse << List.drop 2 <| reversed) diff --git a/src/client/Utils/Search.elm b/src/client/Utils/Search.elm deleted file mode 100644 index 1b70387..0000000 --- a/src/client/Utils/Search.elm +++ /dev/null @@ -1,10 +0,0 @@ -module Utils.Search exposing - ( format - ) - -import String - -import Utils.String as String - -format : String -> String -format = String.unaccent << String.toLower diff --git a/src/client/Utils/String.elm b/src/client/Utils/String.elm deleted file mode 100644 index 90fe68e..0000000 --- a/src/client/Utils/String.elm +++ /dev/null @@ -1,38 +0,0 @@ -module Utils.String exposing - ( unaccent - ) - -unaccent : String -> String -unaccent = String.map unaccentChar - -unaccentChar : Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/client/Validation.elm b/src/client/Validation.elm deleted file mode 100644 index de27963..0000000 --- a/src/client/Validation.elm +++ /dev/null @@ -1,65 +0,0 @@ -module Validation exposing - ( cost - , date - , category - , color - , new - ) - -import Date exposing (Date) -import Date.Extra.Core exposing (intToMonth) -import Date.Extra.Create exposing (dateFromFields) -import Dict -import Regex -import String exposing (toInt, split) - -import Form.Validate as Validate exposing (Validation) -import Form.Error as Error exposing (ErrorValue(CustomError)) - -import Model.Category exposing (Categories, CategoryId) - -cost : Validation String Int -cost = - Validate.customValidation Validate.int (\n -> - if n == 0 - then Err (Validate.customError "CostMustNotBeNull") - else Ok n - ) - -date : Validation String Date -date = - Validate.customValidation Validate.string (\str -> - case split "/" str of - [day, month, year] -> - case (toInt day, toInt month, toInt year) of - (Ok dayNum, Ok monthNum, Ok yearNum) -> - Ok (dateFromFields yearNum (intToMonth monthNum) dayNum 0 0 0 0) - _ -> Err (Validate.customError "InvalidDate") - _ -> Err (Validate.customError "InvalidDate") - ) - -category : Categories -> Validation String CategoryId -category categories = - Validate.customValidation Validate.string (\str -> - case toInt str of - Ok category -> - if List.member category (Dict.keys categories) - then Ok category - else Err (Validate.customError "InvalidCategory") - Err _ -> - Err (Validate.customError "InvalidCategory") - ) - -color : Validation String String -color = - Validate.customValidation Validate.string (\str -> - if Regex.contains (Regex.regex "^#[0-9a-fA-F]{6}$") str - then Ok str - else Err (Validate.customError "InvalidColor") - ) - -new : List x -> x -> Validation String x -new xs x field = - if List.member x xs - then Err (Error.value <| CustomError "AlreadyExists") - else Ok x diff --git a/src/client/View.elm b/src/client/View.elm deleted file mode 100644 index deee272..0000000 --- a/src/client/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Model exposing (Model) -import Msg exposing (Msg) -import Model.View exposing (..) -import LoggedData -import Dialog -import Tooltip - -import View.Header as Header -import View.Errors as Errors - -import SignIn.View as SignInView -import LoggedIn.View as LoggedInView - -view : Model -> Html Msg -view model = - div - [] - [ Header.view model - , case model.view of - SignInView signIn -> - SignInView.view model signIn - LoggedInView loggedIn -> - LoggedInView.view model loggedIn - , Errors.view model.translations model.errors - , Dialog.view model.dialog - , Html.map Msg.Tooltip <| Tooltip.view model.tooltip - ] diff --git a/src/client/View/App.hs b/src/client/View/App.hs new file mode 100644 index 0000000..1466811 --- /dev/null +++ b/src/client/View/App.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.App + ( widget + ) where + +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import Common.Model (InitResult(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import View.Header (HeaderIn(..)) +import View.Payment (PaymentIn(..)) +import qualified View.Header as Header +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn + +widget :: InitResult -> IO () +widget initResult = + R.mainWidget $ do + headerOut <- Header.view $ HeaderIn + { _headerIn_initResult = initResult + } + + let signOut = Header._headerOut_signOut headerOut + + initialContent = case initResult of + InitSuccess initSuccess -> do + _ <- Payment.widget $ PaymentIn + { _paymentIn_init = initSuccess + } + return () + InitEmpty result -> + SignIn.view result + + signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + + _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + + R.blank diff --git a/src/client/View/Color.elm b/src/client/View/Color.elm deleted file mode 100644 index a2a20c7..0000000 --- a/src/client/View/Color.elm +++ /dev/null @@ -1,12 +0,0 @@ -module View.Color exposing (..) - -import Color exposing (Color) - -chestnutRose : Color -chestnutRose = Color.rgb 207 92 86 - -white : Color -white = Color.white - -silver : Color -silver = Color.rgb 200 200 200 diff --git a/src/client/View/Date.elm b/src/client/View/Date.elm deleted file mode 100644 index 6df971b..0000000 --- a/src/client/View/Date.elm +++ /dev/null @@ -1,57 +0,0 @@ -module View.Date exposing - ( shortMonthAndYear - , shortView - , longView - , monthView - ) - -import Date exposing (..) -import Date.Extra.Core as Date -import String - -import Model.Translations exposing (..) - -shortMonthAndYear : Month -> Int -> Translations -> String -shortMonthAndYear month year translations = - let params = - [ String.pad 2 '0' (toString (Date.monthToInt month)) - , toString year - ] - in getParamMessage params translations "ShortMonthAndYear" - -shortView : Date -> Translations -> String -shortView date translations = - let params = - [ String.pad 2 '0' (toString (Date.day date)) - , String.pad 2 '0' (toString (Date.monthToInt (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "ShortDate" - -longView : Date -> Translations -> String -longView date translations = - let params = - [ toString (Date.day date) - , (getMessage translations (getMonthKey (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "LongDate" - -monthView : Translations -> Month -> String -monthView translations month = getMessage translations (getMonthKey month) - -getMonthKey : Month -> String -getMonthKey month = - case month of - Jan -> "January" - Feb -> "February" - Mar -> "March" - Apr -> "April" - May -> "May" - Jun -> "June" - Jul -> "July" - Aug -> "August" - Sep -> "September" - Oct -> "October" - Nov -> "November" - Dec -> "December" diff --git a/src/client/View/Errors.elm b/src/client/View/Errors.elm deleted file mode 100644 index 3e25c99..0000000 --- a/src/client/View/Errors.elm +++ /dev/null @@ -1,21 +0,0 @@ -module View.Errors exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model.Translations exposing (Translations, getMessage) - -view : Translations -> List String -> Html msg -view translations errors = - ul - [ class "errors" ] - ( List.map (errorView translations) errors) - -errorView : Translations -> String -> Html msg -errorView translations error = - li - [ class "error" ] - [ text <| getMessage translations error ] diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm deleted file mode 100644 index d71d67d..0000000 --- a/src/client/View/Events.elm +++ /dev/null @@ -1,15 +0,0 @@ -module View.Events exposing - ( onSubmitPrevDefault - ) - -import Json.Decode as Decode -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -onSubmitPrevDefault : msg -> Attribute msg -onSubmitPrevDefault value = - onWithOptions - "submit" - { defaultOptions | preventDefault = True } - (Decode.succeed value) diff --git a/src/client/View/Form.elm b/src/client/View/Form.elm deleted file mode 100644 index 977ca0a..0000000 --- a/src/client/View/Form.elm +++ /dev/null @@ -1,152 +0,0 @@ -module View.Form exposing - ( textInput - , colorInput - , selectInput - , radioInputs - , hiddenSubmit - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Maybe.Extra as Maybe - -import FontAwesome -import View.Color as Color - -import Form exposing (Form, FieldState) -import Form.Input as Input -import Form.Error as FormError exposing (ErrorValue(..)) -import Form.Field as Field - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Translations as Translations exposing (Translations) - -textInput : Translations -> Form String a -> String -> String -> Html Form.Msg -textInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - fieldId = formName ++ fieldName - in div - [ classList - [ ("textInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ Input.textInput - field - [ id fieldId - , classList [ ("filled", Maybe.isJust field.value) ] - , value (Maybe.withDefault "" field.value) - ] - , label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , button - [ type_ "button" - , onClick (Form.Input fieldName Form.Text Field.EmptyField) - , tabindex -1 - ] - [ FontAwesome.times Color.silver 15 ] - , formError translations field - ] - -colorInput : Translations -> Form String a -> String -> String -> Html Form.Msg -colorInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - in div - [ classList - [ ("colorInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) ] - , Input.textInput - field - [ id (formName ++ fieldName) - , type_ "color" - ] - ] - -radioInputs : Translations -> Form String a -> String -> String -> List String -> Html Form.Msg -radioInputs translations form formName radioName fieldNames = - let field = Form.getFieldAsString radioName form - in div - [ classList - [ ("radioGroup", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ div - [ class "title" ] - [ text (Translations.getMessage translations (formName ++ radioName) ) ] - , div - [ class "radioInputs" ] - (List.map (radioInput translations field formName) fieldNames) - , formError translations field - ] - -radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg -radioInput translations field formName fieldName = - div - [ class "radioInput" ] - [ Input.radioInput - field.path - field - [ id (formName ++ fieldName) - , value fieldName - , checked (field.value == Just fieldName) - ] - , label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) - ] - ] - -selectInput : Translations -> Form String a -> String -> String -> List (String, String) -> Html Form.Msg -selectInput translations form formName selectName options = - let field = Form.getFieldAsString selectName form - fieldId = formName ++ selectName - in div - [ classList - [ ("selectInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , Input.selectInput - (("", "") :: options) - field - [ id fieldId ] - , formError translations field - ] - -formError : Translations -> FieldState String a -> Html msg -formError translations field = - case field.liveError of - Just error -> - let errorElement error params = - div - [ class "errorMessage" ] - [ text (Translations.getParamMessage params translations error) ] - in case error of - CustomError key -> errorElement key [] - SmallerIntThan n -> errorElement "SmallerIntThan" [toString n] - GreaterIntThan n -> errorElement "GreaterIntThan" [toString n] - error -> errorElement (toString error) [] - Nothing -> - text "" - -hiddenSubmit : msg -> Html msg -hiddenSubmit msg = - button - [ style [ ("display", "none") ] - , onClick msg - ] - [] diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm deleted file mode 100644 index 12fb87c..0000000 --- a/src/client/View/Header.elm +++ /dev/null @@ -1,60 +0,0 @@ -module View.Header exposing - ( view - ) - -import Dict - -import FontAwesome -import View.Color as Color - -import Page exposing (..) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Msg exposing (..) -import Model.View exposing (..) - -view : Model -> Html Msg -view model = - header - [] - ( [ div [ class "title" ] [ text (getMessage model.translations "SharedCost") ] ] - ++ let item page name = - a - [ href (Page.toHash page) - , classList - [ ("item", True) - , ("current", model.page == page) - ] - ] - [ text (getMessage model.translations name) - ] - in case model.view of - LoggedInView { me, users } -> - [ item Home "PaymentsTitle" - , item Income "Income" - , item Categories "Categories" - , item Statistics "Statistics" - , div - [ class "nameSignOut" ] - [ div - [ class "name" ] - [ Dict.get me users - |> Maybe.map .name - |> Maybe.withDefault "" - |> text - ] - , button - [ class "signOut item" - , onClick SignOut - ] - [ FontAwesome.power_off Color.white 30 ] - ] - ] - _ -> - [] - ) diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs new file mode 100644 index 0000000..32738f1 --- /dev/null +++ b/src/client/View/Header.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Header + ( view + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), Init(..), User(..)) +import qualified Common.Model.User as User + +import Component.Button (ButtonIn(..)) +import qualified Component.Button as Component +import qualified Icon + +data HeaderIn = HeaderIn + { _headerIn_initResult :: InitResult + } + +data HeaderOut t = HeaderOut + { _headerOut_signOut :: Event t () + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view headerIn = + R.el "header" $ do + + R.divClass "title" $ + R.text $ Message.get Key.App_Title + + signOut <- nameSignOut $ _headerIn_initResult headerIn + + return $ HeaderOut + { _headerOut_signOut = signOut + } + +nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) +nameSignOut initResult = case initResult of + (InitSuccess init) -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case User.find (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never + +signOutButton :: forall t m. MonadWidget t m => m (Event t ()) +signOutButton = do + rec + signOut <- Component.button $ ButtonIn + { Component._buttonIn_class = "signOut item" + , Component._buttonIn_content = Icon.signOut + , Component._buttonIn_waiting = waiting + } + let signOutClic = Component._buttonOut_clic signOut + waiting = R.leftmost + [ fmap (const True) signOutClic + , fmap (const False) signOutSuccess + ] + signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) + + return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess + + where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) + askSignOut signOut = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + getResult = (== 200) . R._xhrResponse_status diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs new file mode 100644 index 0000000..e80790b --- /dev/null +++ b/src/client/View/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment + ( widget + , PaymentIn(..) + , PaymentOut(..) + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init) + +import View.Payment.Table (TableIn(..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +data PaymentOut = PaymentOut + { + } + +widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget paymentIn = do + R.divClass "payment" $ do + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + } + return $ PaymentOut {} diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs new file mode 100644 index 0000000..878e7da --- /dev/null +++ b/src/client/View/Payment/Table.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Table + ( widget + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List as L +import qualified Data.Map as M +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) +import qualified Common.Model.User as User +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format + +import qualified Icon + +data TableIn = TableIn + { _tableIn_init :: Init + } + +data TableOut = TableOut + { + } + +widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +widget tableIn = do + R.divClass "table" $ + R.divClass "lines" $ do + R.divClass "header" $ do + R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name + R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost + R.divClass "cell user" $ R.text $ Message.get Key.Payment_User + R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category + R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + let init = _tableIn_init tableIn + payments = _init_payments init + mapM_ + (paymentRow init) + (take 8 . reverse . L.sortOn _payment_date $ payments) + return $ TableOut {} + +paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow init payment = + R.divClass "row" $ do + R.divClass "cell name" . R.text $ _payment_name payment + R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell user" $ + case User.find (_payment_user payment) (_init_users init) of + Just user -> R.text (_user_name user) + _ -> R.blank + R.divClass "cell category" $ + case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of + Just category -> + R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ + R.text $ _category_name category + _ -> + R.blank + R.divClass "cell date" $ do + R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) + R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.divClass "cell button" . R.el "button" $ Icon.clone + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.edit + else R.blank + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.delete + else R.blank + +findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category +findCategory categories paymentCategories paymentName = do + paymentCategory <- L.find + ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + paymentCategories + L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/src/client/View/Plural.elm b/src/client/View/Plural.elm deleted file mode 100644 index c36eaca..0000000 --- a/src/client/View/Plural.elm +++ /dev/null @@ -1,11 +0,0 @@ -module View.Plural exposing - ( plural - ) - -import Model.Translations exposing (Translations, getMessage) - -plural : Translations -> Int -> String -> String -> String -plural translations n single multiple = - let singleMessage = getMessage translations single - multipleMessage = getMessage translations multiple - in (toString n) ++ " " ++ if n <= 1 then singleMessage else multipleMessage diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs new file mode 100644 index 0000000..e164ee7 --- /dev/null +++ b/src/client/View/SignIn.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.SignIn + ( view + ) where + +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(SignIn)) + +import Component.Input (InputIn(..), InputOut(..)) +import Component.Button (ButtonIn(..), ButtonOut(..)) +import qualified Component.Button as Component +import qualified Component.Input as Component + +view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () +view result = + R.divClass "signIn" $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + } + + let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button + + dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ + [ fmap (const True) userWantsEmailValidation + , fmap (const False) signInResult + ] + + uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail + + let validatedEmail = R.tagPromptlyDyn + (_inputOut_value input) + (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) + + let waiting = R.leftmost + [ fmap (const True) validatedEmail + , fmap (const False) signInResult + ] + + button <- Component.button $ ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_waiting = waiting + } + + signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) + + showSignInResult result signInResult + +askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) +askSignIn email = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + getResult response = + case R._xhrResponse_responseText response of + Just key -> + if R._xhrResponse_status response == 200 then Right key else Left key + _ -> Left "NoKey" + +showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () +showSignInResult result signInResult = do + _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult + R.blank + + where showInitResult (Left error) = showError error + showInitResult (Right (Just success)) = showSuccess success + showInitResult (Right Nothing) = R.blank + + showResult (Left error) = showError error + showResult (Right success) = showSuccess success + + showError = R.divClass "error" . R.text + showSuccess = R.divClass "success" . R.text diff --git a/src/common/Message.hs b/src/common/Message.hs new file mode 100644 index 0000000..9ae735d --- /dev/null +++ b/src/common/Message.hs @@ -0,0 +1,12 @@ +module Common.Message + ( get + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key) +import Common.Message.Lang (Lang(..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/src/common/Message/Key.hs b/src/common/Message/Key.hs new file mode 100644 index 0000000..4127808 --- /dev/null +++ b/src/common/Message/Key.hs @@ -0,0 +1,152 @@ +module Common.Message.Key + ( Key(..) + ) where + +import Data.Text + +data Key = + + App_Title + + | Category_Add + | Category_Clone + | Category_Color + | Category_DeleteConfirm + | Category_Edit + | Category_Empty + | Category_Name + | Category_NotDeleted + | Category_Title + | Category_Used + + | Date_Long Int Text Int + | Date_Short Int Int Int + | Date_ShortMonthAndYear Int Int + + | Dialog_Confirm + | Dialog_Undo + + | Error_CategoryCreate + | Error_CategoryDelete + | Error_CategoryEdit + | Error_IncomeCreate + | Error_IncomeDelete + | Error_IncomeEdit + | Error_PaymentCreate + | Error_PaymentDelete + | Error_PaymentEdit + | Error_SignOut + + | Form_AlreadyExists + | Form_CostMustNotBeNull + | Form_Empty + | Form_GreaterIntThan Int + | Form_InvalidCategory + | Form_InvalidColor + | Form_InvalidDate + | Form_InvalidInt + | Form_InvalidString + | Form_SmallerIntThan Int + + | HttpError_BadPayload + | HttpError_BadUrl + | HttpError_NetworkError + | HttpError_Timeout + + | Income_AddLong + | Income_AddShort + | Income_Amount + | Income_Clone + | Income_CumulativeSince Text + | Income_Date + | Income_DeleteConfirm + | Income_Edit + | Income_Empty + | Income_MonthlyNet + | Income_NotDeleted + | Income_Title + + | Month_January + | Month_February + | Month_March + | Month_April + | Month_May + | Month_June + | Month_July + | Month_August + | Month_September + | Month_October + | Month_November + | Month_December + + | PageNotFound_Title + + | Payment_Add + | Payment_Balanced + | Payment_Category + | Payment_CloneLong + | Payment_CloneShort + | Payment_Cost + | Payment_Date + | Payment_Delete + | Payment_DeleteConfirm + | Payment_EditLong + | Payment_EditShort + | Payment_Empty + | Payment_Frequency + | Payment_InvalidFrequency + | Payment_Many + | Payment_MonthlyFemale + | Payment_MonthlyMale + | Payment_Name + | Payment_NotDeleted + | Payment_One + | Payment_PunctualFemale + | Payment_PunctualMale + | Payment_Title + | Payment_User + | Payment_Worth Text Text + + | Search_Monthly + | Search_Name + | Search_Punctual + + | Secure_Forbidden + | Secure_Unauthorized + + | SignIn_Button + | SignIn_DisconnectSuccess + | SignIn_EmailInvalid + | SignIn_EmailPlaceholder + | SignIn_EmailSendFail + | SignIn_EmailSent + | SignIn_LinkExpired + | SignIn_LinkInvalid + | SignIn_LinkUsed + | SignIn_MailTitle + | SignIn_MailBody Text Text + | SignIn_ParseError + + | Statistic_Title + | Statistic_ByMonthsAndMean Text + | Statistic_By Text Text + | Statistic_Total + + | WeeklyReport_Empty + | WeeklyReport_IncomesCreated Int + | WeeklyReport_IncomesDeleted Int + | WeeklyReport_IncomesEdited Int + | WeeklyReport_IncomeCreated Int + | WeeklyReport_IncomeDeleted Int + | WeeklyReport_IncomeEdited Int + | WeeklyReport_PayedFor Text Text Text Text + | WeeklyReport_PayedForNot Text Text Text Text + | WeeklyReport_PayedFrom Text Text Text + | WeeklyReport_PayedFromNot Text Text Text + | WeeklyReport_PaymentsCreated Int + | WeeklyReport_PaymentsDeleted Int + | WeeklyReport_PaymentsEdited Int + | WeeklyReport_PaymentCreated Int + | WeeklyReport_PaymentDeleted Int + | WeeklyReport_PaymentEdited Int + | WeeklyReport_Title diff --git a/src/common/Message/Lang.hs b/src/common/Message/Lang.hs new file mode 100644 index 0000000..0a32ede --- /dev/null +++ b/src/common/Message/Lang.hs @@ -0,0 +1,7 @@ +module Common.Message.Lang + ( Lang(..) + ) where + +data Lang = + English + | French diff --git a/src/server/Model/Message/Translations.hs b/src/common/Message/Translation.hs index 7d26c3f..900a9e9 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/common/Message/Translation.hs @@ -1,729 +1,697 @@ {-# LANGUAGE OverloadedStrings #-} -module Model.Message.Translations - ( getNonFormattedMessage +module Common.Message.Translation + ( get ) where import Data.Text (Text) import qualified Data.Text as T -import Model.Message.Key -import Model.Message.Lang +import Common.Message.Key +import Common.Message.Lang (Lang(..)) -getNonFormattedMessage :: Lang -> Key -> Text -getNonFormattedMessage = m +get :: Lang -> Key -> Text +get = m m :: Lang -> Key -> Text --- Title - -m l SharedCost = +m l App_Title = 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 = +m l Category_Add = 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." + English -> "Add an category" + French -> "Ajouter une catégorie" -m l Forbidden = +m l Category_Clone = case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" + English -> "Clone an category" + French -> "Cloner une catégorie" -m l SendEmailFail = +m l Category_Color = 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." + English -> "Color" + French -> "Couleur" -m l EnterValidEmail = +m l Category_DeleteConfirm = case l of - English -> "Please enter a valid email address." - French -> "Ton courriel n'est pas valide." + English -> "Are you sure to delete this category ?" + French -> "Voulez-vous vraiment supprimer cette catégorie ?" -m l SignInUsed = +m l Category_Edit = case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." + English -> "Edit an category" + French -> "Modifier une catégorie" -m l SignInExpired = +m l Category_Empty = case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." + English -> "No category." + French -> "Aucune catégorie." -m l SignInInvalid = +m l Category_Name = 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." + English -> "Name" + French -> "Nom" -m l SignInMailTitle = +m l Category_NotDeleted = 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 !" - ] - ) + English -> "The category could not have been deleted." + French -> "La catégorie n’a pas pu être supprimé." -m l SignInEmailSent = +m l Category_Title = 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 + English -> "Categories" + French -> "Catégories" -m l January = +m l Category_Used = case l of - English -> "january" - French -> "janvier" + English -> "This category is currently being used" + French -> "Cette catégorie est actuellement utilisée" -m l February = +m l (Date_Short day month year) = case l of - English -> "february" - French -> "février" + English -> + T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] + French -> + T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] + where padded num pad = + let str = show num + in T.pack $ replicate (pad - length str) '0' ++ str -m l March = +m l (Date_ShortMonthAndYear month year) = case l of - English -> "march" - French -> "mars" + English -> + T.intercalate "-" . map (T.pack . show) $ [ year, month ] + French -> + T.intercalate "/" . map (T.pack . show) $ [ month, year ] -m l April = +m l (Date_Long day month year) = case l of - English -> "april" - French -> "avril" + English -> + T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] + French -> + T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] -m l May = +m l Dialog_Confirm = case l of - English -> "may" - French -> "mai" + English -> "Confirm" + French -> "Confirmer" -m l June = +m l Dialog_Undo = case l of - English -> "june" - French -> "juin" + English -> "Undo" + French -> "Annuler" -m l July = +m l Error_CategoryCreate = case l of - English -> "july" - French -> "juillet" + English -> "Error at category creation" + French -> "Erreur lors de la création de la catégorie" -m l August = +m l Error_CategoryDelete = case l of - English -> "august" - French -> "août" + English -> "Error at category deletion" + French -> "Erreur lors de la suppression de la catégorie" -m l September = +m l Error_CategoryEdit = case l of - English -> "september" - French -> "septembre" + English -> "Error at category edition" + French -> "Erreur lors de la modification de la catégorie" -m l October = +m l Error_IncomeCreate = case l of - English -> "october" - French -> "octobre" + English -> "Error at income creation" + French -> "Erreur lors de la création du revenu" -m l November = +m l Error_IncomeDelete = case l of - English -> "november" - French -> "novembre" + English -> "Error at income deletion" + French -> "Erreur lors de la suppression du revenu" -m l December = +m l Error_IncomeEdit = case l of - English -> "december" - French -> "décembre" + English -> "Error at income edition" + French -> "Erreur lors de la modification du revenu" -m l ShortDate = +m l Error_PaymentCreate = case l of - English -> "{3}-{2}-{1}" - French -> "{1}/{2}/{3}" + English -> "Error at payment creation" + French -> "Erreur lors de la création du paiement" -m l ShortMonthAndYear = +m l Error_PaymentDelete = case l of - English -> "{2}-{1}" - French -> "{1}/{2}" + English -> "Error at payment deletion" + French -> "Erreur lors de la suppression du paiement" -m l LongDate = +m l Error_PaymentEdit = case l of - English -> "{2} {1}, {3}" - French -> "{1} {2} {3}" - --- Search + English -> "Error at payment edition" + French -> "Erreur lors de la modification du paiement" -m l SearchName = +m l Error_SignOut = case l of - English -> "Search" - French -> "Recherche" + English -> "Error at sign out" + French -> "Erreur lors de la déconnexion" -m l SearchPunctual = +m l Form_AlreadyExists = case l of - English -> "Punctual" - French -> "Ponctuel" + English -> "Dupplicate field" + French -> "Doublon" -m l SearchMonthly = +m l Form_CostMustNotBeNull = case l of - English -> "Monthly" - French -> "Mensuel" - --- Payments + English -> "Cost must not be zero" + French -> "Le coût ne doît pas être nul" -m l PaymentsAreBalanced = +m l Form_Empty = case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." + English -> "Required field" + French -> "Champ requis" -m l Name = +m l (Form_GreaterIntThan number) = case l of - English -> "Name" - French -> "Nom" + English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] -m l Cost = +m l Form_InvalidCategory = case l of - English -> "Cost" - French -> "Coût" + English -> "Invalid category" + French -> "Catégorie invalide" -m l Payer = +m l Form_InvalidColor = case l of - English -> "Payer" - French -> "Payeur" + English -> "Invalid color" + French -> "Couleur invalide" -m l Date = +m l Form_InvalidDate = case l of - English -> "Date" - French -> "Date" + English -> "day/month/year required" + French -> "jour/mois/année requis" -m l Frequency = +m l Form_InvalidInt = case l of - English -> "Frequency" - French -> "Fréquence" + English -> "Integer required" + French -> "Entier requis" -m l InvalidFrequency = +m l Form_InvalidString = case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" + English -> "String required" + French -> "Chaîne de caractères requise" -m l AddPayment = +m l (Form_SmallerIntThan number) = case l of - English -> "Add a payment" - French -> "Ajouter un paiement" + English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] -m l ClonePayment = +m l HttpError_BadPayload = case l of - English -> "Clone a payment" - French -> "Cloner un paiement" + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" -m l EditPayment = +m l HttpError_BadUrl = case l of - English -> "Edit a payment" - French -> "Modifier un paiement" + English -> "URL not valid" + French -> "l’URL n’est pas valide" -m l PaymentNotDeleted = +m l HttpError_NetworkError = case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n'a pas pu être supprimé." + English -> "Network can not be reached" + French -> "Le serveur n’est pas accessible" -m l Punctual = +m l HttpError_Timeout = case l of - English -> "Punctual" - French -> "Ponctuelle" + English -> "Timeout server error" + French -> "Le serveur met trop de temps à répondre" -m l Monthly = +m l Income_AddLong = case l of - English -> "Monthly" - French -> "Mensuelle" + English -> "Add an income" + French -> "Ajouter un revenu" -m l PaymentsTitle = +m l Income_AddShort = case l of - English -> "Payments" - French -> "Paiements" + English -> "Add" + French -> "Ajouter" -m l Payment = +m l Income_Amount = case l of - English -> "payment" - French -> "paiement" + English -> "Amount" + French -> "Montant" -m l Payments = +m l Income_Clone = case l of - English -> "payments" - French -> "paiements" + English -> "Clone an income" + French -> "Cloner un revenu" -m l Worth = +m l (Income_CumulativeSince since) = case l of - English -> "{1} worth {2}" - French -> "{1} comptabilisant {2}" + English -> T.concat [ "Cumulative incomes since ", since ] + French -> T.concat [ "Revenus nets cumulés depuis le ", since ] -m l NoPayment = +m l Income_Date = case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." + English -> "Date" + French -> "Date" -m l PaymentName = +m l Income_DeleteConfirm = case l of - English -> "Name" - French -> "Nom" + English -> "Are you sure to delete this income ?" + French -> "Voulez-vous vraiment supprimer ce revenu ?" -m l PaymentCost = +m l Income_Edit = case l of - English -> "Cost" - French -> "Coût" + English -> "Edit an income" + French -> "Modifier un revenu" -m l PaymentDate = +m l Income_Empty = case l of - English -> "Date" - French -> "Date" + English -> "No income." + French -> "Aucun revenu." -m l PaymentCategory = +m l Income_MonthlyNet = case l of - English -> "Category" - French -> "Catégorie" + English -> "Net monthly incomes" + French -> "Revenus mensuels nets" -m l PaymentPunctual = +m l Income_NotDeleted = case l of - English -> "Punctual" - French -> "Ponctuel" + English -> "The income could not have been deleted." + French -> "Le revenu n’a pas pu être supprimé." -m l PaymentMonthly = +m l Income_Title = case l of - English -> "Monthly" - French -> "Mensuel" + English -> "Income" + French -> "Revenu" -m l ConfirmPaymentDelete = +m l Month_January = case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" + English -> "january" + French -> "janvier" -m l Edit = +m l Month_February = case l of - English -> "Edit" - French -> "Modifier" + English -> "february" + French -> "février" -m l Clone = +m l Month_March = case l of - English -> "Clone" - French -> "Cloner" + English -> "march" + French -> "mars" -m l Delete = +m l Month_April = case l of - English -> "Delete" - French -> "Supprimer" - --- Categories + English -> "april" + French -> "avril" -m l Categories = +m l Month_May = case l of - English -> "Categories" - French -> "Catégories" + English -> "may" + French -> "mai" -m l NoCategories = +m l Month_June = case l of - English -> "No category." - French -> "Aucune catégorie." + English -> "june" + French -> "juin" -m l CategoryNotDeleted = +m l Month_July = case l of - English -> "The category could not have been deleted." - French -> "La catégorie n'a pas pu être supprimé." + English -> "july" + French -> "juillet" -m l AddCategory = +m l Month_August = case l of - English -> "Add an category" - French -> "Ajouter une catégorie" + English -> "august" + French -> "août" -m l CloneCategory = +m l Month_September = case l of - English -> "Clone an category" - French -> "Cloner une catégorie" + English -> "september" + French -> "septembre" -m l EditCategory = +m l Month_October = case l of - English -> "Edit an category" - French -> "Modifier une catégorie" + English -> "october" + French -> "octobre" -m l ConfirmCategoryDelete = +m l Month_November = case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" + English -> "november" + French -> "novembre" -m l CategoryName = +m l Month_December = case l of - English -> "Name" - French -> "Nom" + English -> "december" + French -> "décembre" -m l CategoryColor = +m l PageNotFound_Title = case l of - English -> "Color" - French -> "Couleur" + English -> "Page not found" + French -> "Page introuvable" -m l Color = +m l Payment_Add = case l of - English -> "Color" - French -> "Couleur" + English -> "Add a payment" + French -> "Ajouter un paiement" -m l UsedCategory = +m l Payment_Balanced = case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - --- Statistics + English -> "Payments are balanced." + French -> "Les paiements sont équilibrés." -m l Statistics = +m l Payment_Category = case l of - English -> "Statistics" - French -> "Statistiques" + English -> "Category" + French -> "Catégorie" -m l ByMonthsAndMean = +m l Payment_CloneLong = case l of - English -> "Payments by category by month months ({1} on average)" - French -> "Paiements par catégorie par mois (en moyenne {1})" + English -> "Clone a payment" + French -> "Cloner un paiement" -m l By = +m l Payment_CloneShort = case l of - English -> "{1}: {2}" - French -> "{1} : {2}" + English -> "Clone" + French -> "Cloner" -m l Total = +m l Payment_Cost = case l of - English -> "Total" - French -> "Total" - --- Income + English -> "Cost" + French -> "Coût" -m l CumulativeIncomesSince = +m l Payment_Date = case l of - English -> "Cumulative incomes since {1}" - French -> "Revenus nets cumulés depuis le {1}" + English -> "Date" + French -> "Date" -m l NoIncome = +m l Payment_Delete = case l of - English -> "No income." - French -> "Aucun revenu." + English -> "Delete" + French -> "Supprimer" -m l Income = +m l Payment_DeleteConfirm = case l of - English -> "Income" - French -> "Revenu" + English -> "Are you sure to delete this payment ?" + French -> "Voulez-vous vraiment supprimer ce paiement ?" -m l MonthlyNetIncomes = +m l Payment_EditLong = case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" + English -> "Edit a payment" + French -> "Modifier un paiement" -m l AddIncome = +m l Payment_EditShort = case l of - English -> "Add an income" - French -> "Ajouter un revenu" + English -> "Edit" + French -> "Modifier" -m l CloneIncome = +m l Payment_Empty = case l of - English -> "Clone an income" - French -> "Cloner un revenu" + English -> "No payment found from your search criteria." + French -> "Aucun paiement ne correspond à vos critères de recherches." -m l EditIncome = +m l Payment_Frequency = case l of - English -> "Edit an income" - French -> "Modifier un revenu" + English -> "Frequency" + French -> "Fréquence" -m l IncomeNotDeleted = +m l Payment_InvalidFrequency = case l of - English -> "The income could not have been deleted." - French -> "Le revenu n'a pas pu être supprimé." + English -> "Invalid frequency" + French -> "Fréquence invalide" -m l IncomeAmount = +m l Payment_Many = case l of - English -> "Amount" - French -> "Montant" + English -> "payments" + French -> "paiements" -m l IncomeDate = +m l Payment_MonthlyFemale = case l of - English -> "Date" - French -> "Date" + English -> "Monthly" + French -> "Mensuelle" -m l ConfirmIncomeDelete = +m l Payment_MonthlyMale = case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" + English -> "Monthly" + French -> "Mensuel" -m l Add = +m l Payment_Name = case l of - English -> "Add" - French -> "Ajouter" - --- Form error + English -> "Name" + French -> "Nom" -m l Empty = +m l Payment_NotDeleted = case l of - English -> "Required field" - French -> "Champ requis" + English -> "The payment could not have been deleted." + French -> "Le paiement n’a pas pu être supprimé." -m l InvalidString = +m l Payment_One = case l of - English -> "String required" - French -> "Chaîne de caractères requise" + English -> "payment" + French -> "paiement" -m l InvalidDate = +m l Payment_PunctualFemale = case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" + English -> "Punctual" + French -> "Ponctuelle" -m l CostMustNotBeNull = +m l Payment_PunctualMale = case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" + English -> "Punctual" + French -> "Ponctuel" -m l InvalidInt = +m l Payment_Title = case l of - English -> "Integer required" - French -> "Entier requis" + English -> "Payments" + French -> "Paiements" -m l InvalidCategory = +m l Payment_User = case l of - English -> "Invalid category" - French -> "Catégorie invalide" + English -> "Payer" + French -> "Payeur" -m l InvalidColor = +m l (Payment_Worth subject amount) = case l of - English -> "Invalid color" - French -> "Couleur invalide" + English -> T.concat [ subject, " worth ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] -m l AlreadyExists = +m l Search_Monthly = case l of - English -> "Dupplicate field" - French -> "Doublon" + English -> "Monthly" + French -> "Mensuel" -m l SmallerIntThan = +m l Search_Name = case l of - English -> "Integer bigger than {1} or equal required" - French -> "Entier supérieur ou égal à {1} requis" + English -> "Search" + French -> "Recherche" -m l GreaterIntThan = +m l Search_Punctual = case l of - English -> "Integer smaller than {1} or equal required" - French -> "Entier inférieur ou égal à {1} requis" - --- Errors + English -> "Punctual" + French -> "Ponctuel" -m l CreatePaymentError = +m l Secure_Unauthorized = case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" + English -> "You are not authorized to sign in." + French -> "Tu n’es pas autorisé à te connecter." -m l EditPaymentError = +m l Secure_Forbidden = case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" + English -> "You need to be logged in to perform this action" + French -> "Tu dois te connecter pour effectuer cette action" -m l DeletePaymentError = +m l SignIn_Button = case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" + English -> "Sign in" + French -> "Connexion" -m l CreateIncomeError = +m l SignIn_DisconnectSuccess = case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" + English -> "You have successfully disconnected" + French -> "Vous êtes à présent déconnecté." -m l EditIncomeError = +m l SignIn_EmailInvalid = case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" + English -> "Your email is not valid." + French -> "Votre courriel n’est pas valide." -m l DeleteIncomeError = +m l SignIn_EmailPlaceholder = case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" + English -> "Email" + French -> "Courriel" -m l CreateCategoryError = +m l SignIn_EmailSendFail = case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" + 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 EditCategoryError = +m l SignIn_EmailSent = case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" + English -> "We sent you an email with a connexion link." + French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." -m l DeleteCategoryError = +m l SignIn_LinkExpired = case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" + English -> "The link expired, please sign in again." + French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." -m l SignOutError = +m l SignIn_LinkInvalid = case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - --- Dialog + English -> "The link is invalid, please sign in again." + French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." -m l Confirm = +m l SignIn_LinkUsed = case l of - English -> "Confirm" - French -> "Confirmer" + English -> "You already used this link, please sign in again." + French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." -m l Undo = +m l SignIn_MailTitle = case l of - English -> "Undo" - French -> "Annuler" + English -> T.concat [ "Sign in to ", m l App_Title ] + French -> T.concat [ "Connexion à ", m l App_Title ] --- Page not found +m l (SignIn_MailBody name url) = + T.intercalate + "\n" + ( case l of + English -> + [ T.concat [ "Hi ", name, "," ] + , "" + , T.concat + [ "Click to the following link in order to sign in to Shared Cost:" + , m l App_Title + , ":" + ] + , url + , "" + , "See you soon!" + ] + French -> + [ T.concat [ "Salut ", name, "," ] + , "" + , T.concat + [ "Clique sur le lien suivant pour te connecter à " + , m l App_Title + , ":" + ] + , url + , "" + , "À très vite !" + ] + ) -m l PageNotFound = +m l SignIn_ParseError = case l of - English -> "Page not found" - French -> "Page introuvable" - --- Weekly report + English -> "Error while reading initial data." + French -> "Erreur lors de la lecture des données initiales." -m l WeeklyReport = +m l (Statistic_By key value) = case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] -m l WeeklyReportEmpty = +m l (Statistic_ByMonthsAndMean amount) = case l of - English -> "No activity the previous week." - French -> "Pas d'activité la semaine passée." + English -> + T.concat [ "Payments by category by month months (", amount, "on average)" ] + French -> + T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] -m l PaymentCreated = +m l Statistic_Title = case l of - English -> "{1} payment created:" - French -> "{1} paiement créé :" + English -> "Statistics" + French -> "Statistiques" -m l PaymentsCreated = +m l Statistic_Total = case l of - English -> "{1} payments created:" - French -> "{1} paiements créés :" + English -> "Total" + French -> "Total" -m l PaymentEdited = +m l WeeklyReport_Empty = case l of - English -> "{1} payment edited:" - French -> "{1} paiement modifié :" + English -> "No activity the previous week." + French -> "Pas d’activité la semaine passée." -m l PaymentsEdited = +m l (WeeklyReport_IncomesCreated count) = case l of - English -> "{1} payments edited:" - French -> "{1} paiements modifiés :" + English -> T.concat [ T.pack . show $ count, " incomes created:" ] + French -> T.concat [ T.pack . show $ count, " revenus créés :" ] -m l PaymentDeleted = +m l (WeeklyReport_IncomesDeleted count) = case l of - English -> "{1} payment deleted:" - French -> "{1} paiement supprimé :" + English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] -m l PaymentsDeleted = +m l (WeeklyReport_IncomesEdited count) = case l of - English -> "{1} payments deleted:" - French -> "{1} paiements supprimés :" + English -> T.concat [ T.pack . show $ count, " incomes edited:" ] + French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] -m l IncomeCreated = +m l (WeeklyReport_IncomeCreated count) = case l of - English -> "{1} income created:" - French -> "{1} revenu créé :" + English -> T.concat [ T.pack . show $ count, " income created:" ] + French -> T.concat [ T.pack . show $ count, " revenu créé :" ] -m l IncomesCreated = +m l (WeeklyReport_IncomeDeleted count) = case l of - English -> "{1} incomes created:" - French -> "{1} revenus créés :" + English -> T.concat [ T.pack . show $ count, " income deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] -m l IncomeEdited = +m l (WeeklyReport_IncomeEdited count) = case l of - English -> "{1} income edited:" - French -> "{1} revenu modifié :" + English -> T.concat [ T.pack . show $ count, " income edited:" ] + French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] -m l IncomesEdited = +m l (WeeklyReport_PayedFor name amount for at) = case l of - English -> "{1} incomes edited:" - French -> "{1} revenus modifiés :" + English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] -m l IncomeDeleted = +m l (WeeklyReport_PayedForNot name amount for at) = case l of - English -> "{1} income deleted:" - French -> "{1} revenu supprimé :" + English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] -m l IncomesDeleted = +m l (WeeklyReport_PayedFrom name amount for) = case l of - English -> "{1} incomes deleted:" - French -> "{1} revenus supprimés :" + English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] -m l PayedFor = +m l (WeeklyReport_PayedFromNot name amount for) = case l of - English -> "{1} payed {2} for “{3}” at {4}" - French -> "{1} a payé {2} concernant « {3} » le {4}" + English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] -m l DidNotPayFor = +m l (WeeklyReport_PaymentsCreated count) = case l of - English -> "{1} didn't pay {2} for “{3}” at {4}" - French -> "{1} n'a pas payé {2} concernant « {3} » le {4}" + English -> T.concat [ T.pack . show $ count, " payments created:" ] + French -> T.concat [ T.pack . show $ count, " paiements créés :" ] -m l IsPayedFrom = +m l (WeeklyReport_PaymentsDeleted count) = 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}" + English -> T.concat [ T.pack . show $ count, " payments deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] -m l IsNotPayedFrom = +m l (WeeklyReport_PaymentsEdited count) = 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 + English -> T.concat [ T.pack . show $ count, " payments edited:" ] + French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] -m l BadUrl = +m l (WeeklyReport_PaymentCreated count) = case l of - English -> "URL not valid" - French -> "l'URL n'est pas valide" + English -> T.concat [ T.pack . show $ count, " payment created:" ] + French -> T.concat [ T.pack . show $ count, " paiement créé :" ] -m l Timeout = +m l (WeeklyReport_PaymentDeleted count) = case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" + English -> T.concat [ T.pack . show $ count, " payment deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] -m l NetworkError = +m l (WeeklyReport_PaymentEdited count) = case l of - English -> "Network can not be reached" - French -> "Le serveur n'est pas accessible" + English -> T.concat [ T.pack . show $ count, " payment edited:" ] + French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] -m l BadPayload = +m l WeeklyReport_Title = case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" + English -> "Weekly report" + French -> "Rapport hebdomadaire" diff --git a/src/common/Model.hs b/src/common/Model.hs new file mode 100644 index 0000000..075021f --- /dev/null +++ b/src/common/Model.hs @@ -0,0 +1,40 @@ +module Common.Model + ( Category(..) + , CategoryId + , CreateCategory(..) + , CreateIncome(..) + , CreatePayment(..) + , Currency(..) + , EditCategory(..) + , EditIncome(..) + , EditPayment(..) + , Frequency(..) + , Income(..) + , IncomeId + , Init(..) + , InitResult(..) + , Payment(..) + , PaymentId + , PaymentCategory(..) + , PaymentCategoryId + , SignIn(..) + , User(..) + , UserId + ) where + +import Common.Model.Category (Category(..), CategoryId) +import Common.Model.CreateCategory (CreateCategory(..)) +import Common.Model.CreateIncome (CreateIncome(..)) +import Common.Model.CreatePayment (CreatePayment(..)) +import Common.Model.Currency (Currency(..)) +import Common.Model.EditCategory (EditCategory(..)) +import Common.Model.EditIncome (EditIncome(..)) +import Common.Model.EditPayment (EditPayment(..)) +import Common.Model.Frequency (Frequency(..)) +import Common.Model.Income (Income(..), IncomeId) +import Common.Model.Init (Init(..)) +import Common.Model.InitResult (InitResult(..)) +import Common.Model.Payment (Payment(..), PaymentId) +import Common.Model.PaymentCategory (PaymentCategory(..), PaymentCategoryId) +import Common.Model.SignIn (SignIn(..)) +import Common.Model.User (User(..), UserId) diff --git a/src/common/Model/Category.hs b/src/common/Model/Category.hs new file mode 100644 index 0000000..53a6bdb --- /dev/null +++ b/src/common/Model/Category.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Category + ( CategoryId + , Category(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type CategoryId = Int64 + +data Category = Category + { _category_id :: CategoryId + , _category_name :: Text + , _category_color :: Text + , _category_createdAt :: UTCTime + , _category_editedAt :: Maybe UTCTime + , _category_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Category +instance ToJSON Category diff --git a/src/server/Model/Json/CreateCategory.hs b/src/common/Model/CreateCategory.hs index fffc882..bfe24c5 100644 --- a/src/server/Model/Json/CreateCategory.hs +++ b/src/common/Model/CreateCategory.hs @@ -1,17 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} -module Model.Json.CreateCategory +module Common.Model.CreateCategory ( CreateCategory(..) ) where -import GHC.Generics - -import Data.Aeson +import Data.Aeson (FromJSON) import Data.Text (Text) +import GHC.Generics (Generic) data CreateCategory = CreateCategory - { name :: Text - , color :: Text + { _createCategory_name :: Text + , _createCategory_color :: Text } deriving (Show, Generic) instance FromJSON CreateCategory diff --git a/src/server/Model/Json/CreateIncome.hs b/src/common/Model/CreateIncome.hs index cf9b1c3..4ee3a50 100644 --- a/src/server/Model/Json/CreateIncome.hs +++ b/src/common/Model/CreateIncome.hs @@ -1,17 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} -module Model.Json.CreateIncome +module Common.Model.CreateIncome ( CreateIncome(..) ) where -import GHC.Generics - -import Data.Aeson +import Data.Aeson (FromJSON) import Data.Time.Calendar (Day) +import GHC.Generics (Generic) data CreateIncome = CreateIncome - { date :: Day - , amount :: Int + { _createIncome_date :: Day + , _createIncome_amount :: Int } deriving (Show, Generic) instance FromJSON CreateIncome diff --git a/src/common/Model/CreatePayment.hs b/src/common/Model/CreatePayment.hs new file mode 100644 index 0000000..b5b6256 --- /dev/null +++ b/src/common/Model/CreatePayment.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON CreatePayment diff --git a/src/common/Model/Currency.hs b/src/common/Model/Currency.hs new file mode 100644 index 0000000..7c12545 --- /dev/null +++ b/src/common/Model/Currency.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Currency + ( Currency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Currency = Currency Text deriving (Show, Generic) + +instance FromJSON Currency +instance ToJSON Currency diff --git a/src/common/Model/EditCategory.hs b/src/common/Model/EditCategory.hs new file mode 100644 index 0000000..2a3a697 --- /dev/null +++ b/src/common/Model/EditCategory.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategory diff --git a/src/common/Model/EditIncome.hs b/src/common/Model/EditIncome.hs new file mode 100644 index 0000000..a55c39e --- /dev/null +++ b/src/common/Model/EditIncome.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_date :: Day + , _editIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON EditIncome diff --git a/src/common/Model/EditPayment.hs b/src/common/Model/EditPayment.hs new file mode 100644 index 0000000..172c0c1 --- /dev/null +++ b/src/common/Model/EditPayment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON EditPayment diff --git a/src/common/Model/Frequency.hs b/src/common/Model/Frequency.hs new file mode 100644 index 0000000..7c46605 --- /dev/null +++ b/src/common/Model/Frequency.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Frequency + ( Frequency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Frequency = + Punctual + | Monthly + deriving (Eq, Read, Show, Generic) + +instance FromJSON Frequency +instance ToJSON Frequency diff --git a/src/common/Model/Income.hs b/src/common/Model/Income.hs new file mode 100644 index 0000000..280812f --- /dev/null +++ b/src/common/Model/Income.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Income + ( IncomeId + , Income(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +type IncomeId = Int64 + +data Income = Income + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int + , _income_createdAt :: UTCTime + , _income_editedAt :: Maybe UTCTime + , _income_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Income +instance ToJSON Income diff --git a/src/common/Model/Init.hs b/src/common/Model/Init.hs new file mode 100644 index 0000000..68fcfb8 --- /dev/null +++ b/src/common/Model/Init.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Init + ( Init(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category) +import Common.Model.Currency (Currency) +import Common.Model.Income (Income) +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.User (UserId, User) + +data Init = Init + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] + , _init_paymentCategories :: [PaymentCategory] + , _init_currency :: Currency + } deriving (Show, Generic) + +instance FromJSON Init +instance ToJSON Init diff --git a/src/common/Model/InitResult.hs b/src/common/Model/InitResult.hs new file mode 100644 index 0000000..43c16f9 --- /dev/null +++ b/src/common/Model/InitResult.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.InitResult + ( InitResult(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Init (Init) + +data InitResult = + InitSuccess Init + | InitEmpty (Either Text (Maybe Text)) + deriving (Show, Generic) + +instance FromJSON InitResult +instance ToJSON InitResult diff --git a/src/common/Model/Payment.hs b/src/common/Model/Payment.hs new file mode 100644 index 0000000..804b501 --- /dev/null +++ b/src/common/Model/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Payment + ( PaymentId + , Payment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Frequency +import Common.Model.User (UserId) + +type PaymentId = Int64 + +data Payment = Payment + { _payment_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day + , _payment_frequency :: Frequency + , _payment_createdAt :: UTCTime + , _payment_editedAt :: Maybe UTCTime + , _payment_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Payment +instance ToJSON Payment diff --git a/src/common/Model/PaymentCategory.hs b/src/common/Model/PaymentCategory.hs new file mode 100644 index 0000000..a0e94f9 --- /dev/null +++ b/src/common/Model/PaymentCategory.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.PaymentCategory + ( PaymentCategoryId + , PaymentCategory(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +type PaymentCategoryId = Int64 + +data PaymentCategory = PaymentCategory + { _paymentCategory_id :: PaymentCategoryId + , _paymentCategory_name :: Text + , _paymentCategory_category :: CategoryId + , _paymentCategory_createdAt :: UTCTime + , _paymentCategory_editedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON PaymentCategory +instance ToJSON PaymentCategory diff --git a/src/common/Model/SignIn.hs b/src/common/Model/SignIn.hs new file mode 100644 index 0000000..f4da97f --- /dev/null +++ b/src/common/Model/SignIn.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.SignIn + ( SignIn(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data SignIn = SignIn + { _signIn_email :: Text + } deriving (Show, Generic) + +instance FromJSON SignIn +instance ToJSON SignIn diff --git a/src/common/Model/User.hs b/src/common/Model/User.hs new file mode 100644 index 0000000..8c64bc2 --- /dev/null +++ b/src/common/Model/User.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.User + ( UserId + , User(..) + , find + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.List as L +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type UserId = Int64 + +data User = User + { _user_id :: UserId + , _user_creation :: UTCTime + , _user_email :: Text + , _user_name :: Text + } deriving (Show, Generic) + +instance FromJSON User +instance ToJSON User + +find :: UserId -> [User] -> Maybe User +find userId users = L.find ((== userId) . _user_id) users diff --git a/src/server/Utils/Text.hs b/src/common/Util/Text.hs index 5ed77e4..4af7a4c 100644 --- a/src/server/Utils/Text.hs +++ b/src/common/Util/Text.hs @@ -1,4 +1,4 @@ -module Utils.Text +module Common.Util.Text ( unaccent ) where diff --git a/src/common/View/Format.hs b/src/common/View/Format.hs new file mode 100644 index 0000000..a7fa4e3 --- /dev/null +++ b/src/common/View/Format.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.View.Format + ( shortDay + , longDay + , price + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, toGregorian) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.Currency (Currency(..)) + +shortDay :: Day -> Text +shortDay date = + Message.get $ Key.Date_Short + day + month + (fromIntegral year) + where (year, month, day) = toGregorian date + +longDay :: Day -> Text +longDay date = + Message.get $ Key.Date_Long + day + (fromMaybe "−" . fmap Message.get . monthToKey $ month) + (fromIntegral year) + where (year, month, day) = toGregorian date + + monthToKey 1 = Just Key.Month_January + monthToKey 2 = Just Key.Month_February + monthToKey 3 = Just Key.Month_March + monthToKey 4 = Just Key.Month_April + monthToKey 5 = Just Key.Month_May + monthToKey 6 = Just Key.Month_June + monthToKey 7 = Just Key.Month_July + monthToKey 8 = Just Key.Month_August + monthToKey 9 = Just Key.Month_September + monthToKey 10 = Just Key.Month_October + monthToKey 11 = Just Key.Month_November + monthToKey 12 = Just Key.Month_December + monthToKey _ = Nothing + +price :: Currency -> Int -> Text +price (Currency currency) amount = T.concat [ number amount, " ", currency ] + +number :: Int -> Text +number n = + T.pack + . (++) (if n < 0 then "-" else "") + . reverse + . concat + . intersperse " " + . group 3 + . reverse + . show + . abs $ n + +group :: Int -> [a] -> [[a]] +group n xs = + if length xs <= n + then [xs] + else (take n xs) : (group n (drop n xs)) diff --git a/src/migrations/2.sql b/src/migrations/2.sql new file mode 100644 index 0000000..ec0d1b0 --- /dev/null +++ b/src/migrations/2.sql @@ -0,0 +1,23 @@ +BEGIN TRANSACTION; + +ALTER TABLE payment RENAME TO tmp_payment; + +CREATE TABLE IF NOT EXISTS "payment"( + "id" INTEGER PRIMARY KEY, + "user" INTEGER NOT NULL REFERENCES "user", + "name" VARCHAR NOT NULL, + "cost" INTEGER NOT NULL, + "date" DATE NOT NULL, + "frequency" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +INSERT INTO payment(id, user, name, cost, date, frequency, created_at, edited_at, deleted_at) +SELECT id, user_id, name, cost, date, frequency, created_at, edited_at, deleted_at +FROM tmp_payment; + +DROP TABLE tmp_payment; + +COMMIT; diff --git a/src/server/Common b/src/server/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/server/Common @@ -0,0 +1 @@ +../common
\ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs index a05349d..92df4e9 100644 --- a/src/server/Conf.hs +++ b/src/server/Conf.hs @@ -10,11 +10,13 @@ import qualified Data.Text as T import qualified Data.ConfigManager as Conf import Data.Time.Clock (NominalDiffTime) +import Common.Model.Currency (Currency(..)) + data Conf = Conf { hostname :: Text , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Text + , currency :: Currency , noReplyMail :: Text , https :: Bool } deriving Show @@ -28,7 +30,7 @@ get path = do Conf.lookup "hostname" conf <*> Conf.lookup "port" conf <*> Conf.lookup "signInExpiration" conf <*> - Conf.lookup "currency" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> Conf.lookup "https" conf ) diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 3f800da..1a44083 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -11,12 +11,14 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty hiding (delete) +import Common.Model.Category (CategoryId) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.CreateCategory as Json +import qualified Common.Model.EditCategory as Json + import Json (jsonId) -import Model.Category (CategoryId) import qualified Model.Category as Category -import qualified Model.Json.CreateCategory as Json -import qualified Model.Json.EditCategory as Json -import qualified Model.Message.Key as Key import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query import qualified Secure @@ -49,5 +51,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.CategoryNotDeleted + text . TL.fromStrict $ Message.get Key.Category_NotDeleted ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 18394d0..148b713 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -11,26 +11,25 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + import Json (jsonId) -import Model.Income (IncomeId) import qualified Model.Income as Income -import qualified Model.Json.CreateIncome as Json -import qualified Model.Json.EditIncome as Json -import qualified Model.Message.Key as Key import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure -create :: Json.CreateIncome -> ActionM () -create (Json.CreateIncome date amount) = +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId ) -editOwn :: Json.EditIncome -> ActionM () -editOwn (Json.EditIncome incomeId date amount) = +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -45,5 +44,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.IncomeNotDeleted + text . TL.fromStrict $ Message.get Key.Income_NotDeleted ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 9fb2aa0..8473c5c 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -7,15 +7,17 @@ import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) import Web.Scotty hiding (get) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + import Conf (Conf(..)) import Model.Init (getInit) -import Model.Json.Init (InitResult(..)) -import Model.Message.Key -import Model.User (User) import qualified LoginSession -import qualified Model.Json.Conf as M import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -29,17 +31,17 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitError $ errorKey + return . InitEmpty . Left . Message.get $ errorKey Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return InitEmpty + return . InitEmpty . Right $ Nothing Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) initResult + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -52,23 +54,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ SignInInvalid + return . Left $ Key.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ SignInUsed + return . Left $ Key.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ SignInExpired + return . Left $ Key.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn + User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left UnauthorizedSignIn + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d71b451..6a9ede7 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -11,37 +11,36 @@ import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status (ok200, badRequest400) import Web.Scotty +import qualified Common.Model.CreatePayment as M +import qualified Common.Model.EditPayment as M +import Common.Model (PaymentId, User(..)) + import Json (jsonId) -import Model.Payment (PaymentId) -import qualified Model.Json.CreatePayment as Json -import qualified Model.Json.EditPayment as Json -import qualified Model.Json.Payment as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json + (liftIO . Query.run $ Payment.list) >>= json ) -create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date category frequency) = +create :: M.CreatePayment -> ActionM () +create (M.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> (liftIO . Query.run $ do PaymentCategory.save name category - Payment.create (User.id user) name cost date frequency + Payment.create (_user_id user) name cost date frequency ) >>= jsonId ) -editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date category frequency) = +editOwn :: M.EditPayment -> ActionM () +editOwn (M.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (User.id user) paymentId name cost date frequency + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -54,7 +53,7 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId if deleted then status ok200 else status badRequest400 diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 152168c..932ce53 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -5,15 +5,17 @@ module Controller.SignIn ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.SignIn as M + import Conf (Conf) -import Model.Message.Key import qualified Conf import qualified Model.Query as Query import qualified Model.SignIn as SignIn @@ -22,30 +24,24 @@ import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn -signIn :: Conf -> Text -> ActionM () -signIn conf login = - if Email.isValid (TE.encodeUtf8 login) +signIn :: Conf -> M.SignIn -> ActionM () +signIn conf (M.SignIn email) = + if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.getUser login + maybeUser <- liftIO . Query.run $ User.get email case maybeUser of Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login + token <- liftIO . Query.run $ SignIn.createSignInToken email let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, "?signInToken=", token ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> - status ok200 - Left _ -> do - status badRequest400 - text . TL.pack . show $ SendEmailFail - Nothing -> do - status badRequest400 - text . TL.pack . show $ UnauthorizedSignIn - else do - status badRequest400 - text . TL.pack . show $ EnterValidEmail + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs deleted file mode 100644 index d8604ac..0000000 --- a/src/server/Controller/User.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.User - ( getUsers - ) where - -import Web.Scotty - -import Control.Monad.IO.Class (liftIO) - -import qualified Secure - -import Model.Database -import qualified Model.User as User - -getUsers :: ActionM () -getUsers = - Secure.loggedAction (\_ -> - (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json - ) diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index afc601f..06c468e 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -7,6 +7,9 @@ import qualified Clay.Color as C white :: C.Color white = C.white +black :: C.Color +black = C.black + chestnutRose :: C.Color chestnutRose = C.rgb 207 92 86 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index e742978..47ea4a9 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -8,9 +8,7 @@ import Clay import Data.Text.Lazy (Text) -import qualified Design.Header as Header -import qualified Design.SignIn as SignIn -import qualified Design.LoggedIn as LoggedIn +import qualified Design.Views as Views import qualified Design.Form as Form import qualified Design.Errors as Errors import qualified Design.Dialog as Dialog @@ -26,13 +24,10 @@ globalDesign = renderWith compact [] global global :: Css global = do - - header ? Header.design - ".signIn" ? SignIn.design - ".loggedIn" ? LoggedIn.design ".errors" ? Errors.design ".dialog" ? Dialog.design ".tooltip" ? Tooltip.design + Views.design Form.design body ? do @@ -49,6 +44,8 @@ global = do a ? cursor pointer + input ? fontSize inherit + h1 ? do color Color.chestnutRose marginBottom (em 1) diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index 869616d..41528ed 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -3,8 +3,8 @@ module Design.Helper ( clearFix , button + , waitable , input - , iconButton , centeredWithMargin , verticalCentering ) where @@ -13,8 +13,6 @@ import Prelude hiding (span) import Clay hiding (button, input) -import Data.Monoid ((<>)) - import Design.Constants import Design.Color as Color @@ -27,6 +25,9 @@ clearFix = button :: Color -> Color -> Size a -> (Color -> Color) -> Css button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center backgroundColor backgroundCol padding (px 0) (px 10) (px 0) (px 10) color textCol @@ -38,19 +39,20 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) + waitable -iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css -iconButton backgroundCol textCol h focusOp = do - button backgroundCol textCol h focusOp - i <> span ? do - height h - lineHeight h - span ? do - display inlineBlock - marginLeft (px 20) - i ? do - marginLeft (px 15) - marginRight (px 20) +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation input :: Double -> Css input h = do @@ -72,3 +74,17 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/src/server/Design/LoggedIn/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/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/Header.hs b/src/server/Design/View/Header.hs index 8feac64..20627e6 100644 --- a/src/server/Design/Header.hs +++ b/src/server/Design/View/Header.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.Header +module Design.View.Header ( design ) where @@ -9,6 +9,7 @@ import Data.Monoid ((<>)) import Clay import Design.Color as Color +import qualified Design.Helper as Helper import qualified Design.Media as Media design :: Css @@ -57,9 +58,12 @@ design = do Media.tabletDesktop $ headerPadding ".signOut" ? do + Helper.waitable heightMedia svg ? do + Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") lineHeightMedia :: Css lineHeightMedia = do diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/src/server/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/src/server/Design/LoggedIn/Home/Header.hs b/src/server/Design/View/Payment/Header.hs index 5fd2d79..f02da8a 100644 --- a/src/server/Design/LoggedIn/Home/Header.hs +++ b/src/server/Design/View/Payment/Header.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Home.Header +module Design.View.Payment.Header ( design ) where diff --git a/src/server/Design/LoggedIn/Home/Pages.hs b/src/server/Design/View/Payment/Pages.hs index 71f3254..ade81a8 100644 --- a/src/server/Design/LoggedIn/Home/Pages.hs +++ b/src/server/Design/View/Payment/Pages.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Home.Pages +module Design.View.Payment.Pages ( design ) where diff --git a/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/View/Payment/Table.hs index cb46ac9..a866b40 100644 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ b/src/server/Design/View/Payment/Table.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Home.Table +module Design.View.Payment.Table ( design ) where import Clay +import qualified Design.Color as Color import qualified Design.Media as Media design :: Css @@ -35,3 +36,7 @@ design = do ".shortDate" ? display none ".longDate" ? display inline marginBottom (em 0.5) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/src/server/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/src/server/Design/LoggedIn/Stat.hs b/src/server/Design/View/Stat.hs index 62028cb..0a5b258 100644 --- a/src/server/Design/LoggedIn/Stat.hs +++ b/src/server/Design/View/Stat.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Stat +module Design.View.Stat ( design ) where diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/View/Table.hs index 44b001a..95abf90 100644 --- a/src/server/Design/LoggedIn/Table.hs +++ b/src/server/Design/View/Table.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn.Table +module Design.View.Table ( design ) where diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/Views.hs index 4a21832..bc6ac83 100644 --- a/src/server/Design/LoggedIn.hs +++ b/src/server/Design/Views.hs @@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -module Design.LoggedIn +module Design.Views ( 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.View.Header as Header +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table import qualified Design.Helper as Helper import qualified Design.Constants as Constants @@ -17,7 +19,9 @@ import qualified Design.Media as Media design :: Css design = do - ".home" ? Home.design + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design ".stat" ? Stat.design Table.design diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index 8c11ccf..ba24cca 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -4,7 +4,8 @@ module Job.MonthlyPayment import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Frequency +import Common.Model (Frequency(..), Payment(..)) + import qualified Model.Payment as Payment import Utils.Time (timeToDay) import qualified Model.Query as Query @@ -14,6 +15,12 @@ monthlyPayment _ = do monthlyPayments <- Query.run Payment.listMonthly now <- getCurrentTime actualDay <- timeToDay now - let punctualPayments = map (\p -> p { Payment.frequency = Punctual, Payment.date = actualDay, Payment.createdAt = now }) monthlyPayments + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments _ <- Query.run (Payment.createMany punctualPayments) return now diff --git a/src/server/Main.hs b/src/server/Main.hs index 17c2594..db73474 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -1,16 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + import Network.Wai.Middleware.Static import qualified Data.Text.Lazy as LT import Web.Scotty -import Job.Daemon (runDaemons) import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment import qualified Controller.SignIn as SignIn +import Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query main :: IO () main = do @@ -19,13 +28,19 @@ main = do scotty (Conf.port conf) $ do middleware . staticPolicy $ noDots >-> addBase "public" + get "/exceedingPayer" $ do + time <- liftIO Time.getCurrentTime + (users, incomes, payments) <- liftIO . Query.run $ + liftA3 (,,) UserM.list IncomeM.list PaymentM.list + let exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + get "/" $ do signInToken <- mbParam "signInToken" Index.get conf signInToken post "/signIn" $ do - email <- param "email" - SignIn.signIn conf email + jsonData >>= SignIn.signIn conf post "/signOut" $ Index.signOut conf diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs index 9597bd9..6b7a488 100644 --- a/src/server/Model/Category.hs +++ b/src/server/Model/Category.hs @@ -1,34 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category - ( CategoryId - , Category(..) - , list + ( list , create , edit , delete ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Model.Query (Query(Query)) - -type CategoryId = Int64 +import Common.Model (Category(..), CategoryId) -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow Category where fromRow = Category <$> diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs index f9958e1..4f7b83d 100644 --- a/src/server/Model/Frequency.hs +++ b/src/server/Model/Frequency.hs @@ -1,28 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Model.Frequency - ( Frequency(..) - ) where +module Model.Frequency () where -import Data.Aeson import Database.SQLite.Simple (SQLData(SQLText)) import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) import Database.SQLite.Simple.ToField (ToField(toField)) -import GHC.Generics import qualified Data.Text as T -import Web.Scotty (parseParam, Parsable, readEither) -data Frequency = - Punctual - | Monthly - deriving (Eq, Show, Read, Generic) - -instance Parsable Frequency where parseParam = readEither -instance FromJSON Frequency -instance ToJSON Frequency +import Common.Model.Frequency (Frequency) instance FromField Frequency where fromField field = case fieldData field of diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index c6cdb55..bbe7657 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income - ( IncomeId - , Income(..) - , list + ( list , create , editOwn , deleteOwn , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime, getCurrentTime) @@ -18,27 +16,15 @@ import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite +import Common.Model (Income(..), IncomeId, User(..), UserId) + import Model.Query (Query(Query)) -import Model.User (User, UserId) -import qualified Model.User as User import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type IncomeId = Int64 - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Income where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt instance FromRow Income where fromRow = Income <$> @@ -70,7 +56,7 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == incomeUserId + if _income_userId income == incomeUserId then do now <- getCurrentTime SQLite.execute @@ -90,7 +76,7 @@ deleteOwn user incomeId = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == User.id user + if _income_userId income == _user_id user then do now <- getCurrentTime SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 7a9ccea..8c6a961 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -4,27 +4,24 @@ module Model.Init ( getInit ) where -import Model.Json.Init (Init) +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf import Model.Query (Query) -import Model.User (User) import qualified Model.Category as Category import qualified Model.Income as Income -import qualified Model.Json.Category as Json -import qualified Model.Json.Income as Json -import qualified Model.Json.Init as Init -import qualified Model.Json.Payment as Json -import qualified Model.Json.PaymentCategory as Json -import qualified Model.Json.User as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.User as User -getInit :: User -> Query Init -getInit user = - Init.Init <$> - (map Json.fromUser <$> User.list) <*> - (return . User.id $ user) <*> - (map Json.fromPayment <$> Payment.list) <*> - (map Json.fromIncome <$> Income.list) <*> - (map Json.fromCategory <$> Category.list) <*> - (map Json.fromPaymentCategory <$> PaymentCategory.list) +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs deleted file mode 100644 index 8b5e527..0000000 --- a/src/server/Model/Json/Category.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Category - ( Category(..) - , fromCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.Category as M - -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance ToJSON Category - -fromCategory :: M.Category -> Category -fromCategory category = Category (M.id category) (M.name category) (M.color category) diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs deleted file mode 100644 index a66fb55..0000000 --- a/src/server/Model/Json/Conf.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Conf - ( Conf(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -data Conf = Conf - { currency :: Text - } deriving (Show, Generic) - -instance FromJSON Conf -instance ToJSON Conf diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs deleted file mode 100644 index 6ab3a5b..0000000 --- a/src/server/Model/Json/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs deleted file mode 100644 index a10ce39..0000000 --- a/src/server/Model/Json/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) - -data EditCategory = EditCategory - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs deleted file mode 100644 index 9b29379..0000000 --- a/src/server/Model/Json/EditIncome.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditIncome - ( EditIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -import Model.Income (IncomeId) - -data EditIncome = EditIncome - { id :: IncomeId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs deleted file mode 100644 index b7d4d7d..0000000 --- a/src/server/Model/Json/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) -import Model.Payment (PaymentId) - -data EditPayment = EditPayment - { id :: PaymentId - , name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs deleted file mode 100644 index 7e23a84..0000000 --- a/src/server/Model/Json/Income.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Income - ( Income(..) - , fromIncome - ) where - -import Data.Aeson -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Income (IncomeId) -import Model.User (UserId) -import qualified Model.Income as M - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance ToJSON Income - -fromIncome :: M.Income -> Income -fromIncome income = Income (M.id income) (M.userId income) (M.date income) (M.amount income) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs deleted file mode 100644 index 530c3b7..0000000 --- a/src/server/Model/Json/Init.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Init - ( Init(..) - , InitResult(..) - ) where - -import Data.Aeson -import GHC.Generics - -import Model.Json.Category (Category) -import Model.Json.Income (Income) -import Model.Json.Payment (Payment) -import Model.Json.PaymentCategory (PaymentCategory) -import Model.Json.User (User) -import Model.Message.Key (Key) -import Model.User (UserId) - -data Init = Init - { users :: [User] - , me :: UserId - , payments :: [Payment] - , incomes :: [Income] - , categories :: [Category] - , paymentCategories :: [PaymentCategory] - } deriving (Show, Generic) - -instance ToJSON Init - -data InitResult = - InitEmpty - | InitSuccess Init - | InitError Key - deriving (Show, Generic) - -instance ToJSON InitResult diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs deleted file mode 100644 index 0753d7c..0000000 --- a/src/server/Model/Json/MessagePart.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.MessagePart - ( MessagePart(..) - ) where - -import Data.Text (Text) - -import Data.Aeson -import GHC.Generics - -data MessagePart = - Order Int - | Str Text - deriving (Eq, Show, Generic) - -instance FromJSON MessagePart -instance ToJSON MessagePart diff --git a/src/server/Model/Json/Number.hs b/src/server/Model/Json/Number.hs deleted file mode 100644 index 52c9da8..0000000 --- a/src/server/Model/Json/Number.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Number - ( Number(..) - ) where - -import Data.Aeson -import GHC.Generics - -data Number = Number - { number :: Int - } deriving (Show, Generic) - -instance FromJSON Number -instance ToJSON Number diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs deleted file mode 100644 index e406c0f..0000000 --- a/src/server/Model/Json/Payment.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Payment - ( Payment(..) - , fromPayment - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics -import Prelude hiding (id) - -import Model.Frequency -import Model.Payment (PaymentId) -import Model.User (UserId) -import qualified Model.Payment as M - -data Payment = Payment - { id :: PaymentId - , date :: Day - , name :: Text - , cost :: Int - , userId :: UserId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment - -fromPayment :: M.Payment -> Payment -fromPayment payment = - Payment - { id = M.id payment - , date = M.date payment - , name = M.name payment - , cost = M.cost payment - , userId = M.userId payment - , frequency = M.frequency payment - } diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs deleted file mode 100644 index fd97674..0000000 --- a/src/server/Model/Json/PaymentCategory.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.PaymentCategory - ( PaymentCategory(..) - , fromPaymentCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.PaymentCategory as M - -data PaymentCategory = PaymentCategory - { name :: Text - , category :: CategoryId - } deriving (Show, Generic) - -instance ToJSON PaymentCategory - -fromPaymentCategory :: M.PaymentCategory -> PaymentCategory -fromPaymentCategory pc = PaymentCategory (M.name pc) (M.category pc) diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs deleted file mode 100644 index 9dcfe80..0000000 --- a/src/server/Model/Json/Translation.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Translation - ( Translation(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -import Model.Json.MessagePart - -data Translation = Translation - { key :: Text - , message :: [MessagePart] - } deriving (Show, Generic) - -instance FromJSON Translation -instance ToJSON Translation diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs deleted file mode 100644 index c289fe0..0000000 --- a/src/server/Model/Json/User.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.User - ( User(..) - , fromUser - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.User (UserId) -import qualified Model.User as M - -data User = User - { id :: UserId - , name :: Text - , email :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -fromUser :: M.User -> User -fromUser user = User (M.id user) (M.name user) (M.email user) diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs deleted file mode 100644 index 026967f..0000000 --- a/src/server/Model/Message.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Message - ( getMessage - , getParamMessage - , getTranslations - , plural - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key (Key) -import Model.Message.Lang -import Model.Message.Translations (getNonFormattedMessage) -import Model.Message.Parts - -import Model.Json.Translation - -getMessage :: Key -> Text -getMessage = getParamMessage [] - -getParamMessage :: [Text] -> Key -> Text -getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey) - -getTranslations :: [Translation] -getTranslations = (map getTranslation [minBound..]) - -getTranslation :: Key -> Translation -getTranslation translationKey = - Translation - (T.pack . show $ translationKey) - (getParts $ getNonFormattedMessage lang translationKey) - -plural :: Int -> Key -> Key -> Text -plural count singularKey pluralKey = - getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs deleted file mode 100644 index 18f16f0..0000000 --- a/src/server/Model/Message/Key.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Message.Key - ( Key(..) - ) where - -import qualified Data.Aeson as Json -import qualified Data.Text as T - -data Key = - - -- Title - - SharedCost - - -- Sign - - | Email - | SignIn - | SendEmailFail - | InvalidEmail - | UnauthorizedSignIn - | Forbidden - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid - | SignInMailTitle - | SignInMail - | SignInEmailSent - - -- Dates - - | January - | February - | March - | April - | May - | June - | July - | August - | September - | October - | November - | December - - | ShortDate - | ShortMonthAndYear - | LongDate - - -- Search - - | SearchName - | SearchPunctual - | SearchMonthly - - -- Payments - - | PaymentsAreBalanced - | Name - | Cost - | Payer - | Date - | Frequency - | InvalidFrequency - | AddPayment - | ClonePayment - | EditPayment - | PaymentNotDeleted - | Punctual - | Monthly - - | PaymentsTitle - | Payment - | Payments - | Worth - | NoPayment - - | PaymentName - | PaymentCost - | PaymentDate - | PaymentCategory - | PaymentPunctual - | PaymentMonthly - - | Clone - | Edit - | Delete - | ConfirmPaymentDelete - - -- Categories - - | Categories - | NoCategories - | CategoryNotDeleted - | AddCategory - | CloneCategory - | EditCategory - | ConfirmCategoryDelete - | CategoryName - | CategoryColor - | Color - | UsedCategory - - -- Statistics - - | Statistics - | ByMonthsAndMean - | By - | Total - - -- Income - - | CumulativeIncomesSince - | NoIncome - | Income - | MonthlyNetIncomes - | AddIncome - | CloneIncome - | EditIncome - | IncomeNotDeleted - | IncomeAmount - | IncomeDate - | ConfirmIncomeDelete - | Add - - -- Form - - | Empty - | InvalidString - | InvalidDate - | CostMustNotBeNull - | InvalidInt - | InvalidCategory - | InvalidColor - | AlreadyExists - | SmallerIntThan - | GreaterIntThan - - -- Errors - - | CreatePaymentError - | EditPaymentError - | DeletePaymentError - | CreateIncomeError - | EditIncomeError - | DeleteIncomeError - | CreateCategoryError - | EditCategoryError - | DeleteCategoryError - | SignOutError - - -- Dialog - - | Confirm - | Undo - - -- Page not found - - | PageNotFound - - -- Weekly report - - | WeeklyReport - | WeeklyReportEmpty - | PaymentCreated - | PaymentsCreated - | PaymentEdited - | PaymentsEdited - | PaymentDeleted - | PaymentsDeleted - | IncomeCreated - | IncomesCreated - | IncomeEdited - | IncomesEdited - | IncomeDeleted - | IncomesDeleted - | PayedFor - | DidNotPayFor - | IsPayedFrom - | IsNotPayedFrom - - -- Http error - - | BadUrl - | Timeout - | NetworkError - | BadPayload - - deriving (Enum, Bounded, Show) - -instance Json.ToJSON Key where - toJSON = Json.String . T.pack . show diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs deleted file mode 100644 index f515c96..0000000 --- a/src/server/Model/Message/Lang.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Model.Message.Lang - ( Lang(..) - , lang - ) where - -data Lang = - English - | French - -lang :: Lang -lang = French diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs deleted file mode 100644 index d065cf2..0000000 --- a/src/server/Model/Message/Parts.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Parts - ( replaceParts - , getParts - ) where - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T - -import Text.ParserCombinators.Parsec - -import Model.Json.MessagePart - -replaceParts :: [Text] -> Text -> Text -replaceParts values message = - T.concat . map (replacePart values) $ getParts message - -replacePart :: [Text] -> MessagePart -> Text -replacePart _ (Str str) = str -replacePart values (Order n) = - fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values - -getParts :: Text -> [MessagePart] -getParts str = - case parse partsParser "" (T.unpack str) of - Right parts -> parts - Left _ -> [] - -partsParser :: Parser [MessagePart] -partsParser = many partParser - -partParser :: Parser MessagePart -partParser = - (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n)) - <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str)) diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/src/server/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5414d18..5b576c5 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment - ( PaymentId - , Payment(..) + ( Payment(..) , find , list , listMonthly @@ -13,7 +13,6 @@ module Model.Payment , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time (UTCTime) @@ -24,29 +23,19 @@ import Database.SQLite.Simple.ToField (ToField(toField)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Frequency +import Common.Model.Frequency +import Common.Model.Payment (Payment(..)) +import Common.Model.User (UserId) +import Common.Model.Payment (PaymentId) + +import Model.Frequency () import Model.Query (Query(Query)) -import Model.User (UserId) import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type PaymentId = Int64 - -data Payment = Payment - { id :: PaymentId - , userId :: UserId - , name :: Text - , cost :: Int - , date :: Day - , frequency :: Frequency - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Payment where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt instance FromRow Payment where fromRow = Payment <$> @@ -62,12 +51,12 @@ instance FromRow Payment where instance ToRow Payment where toRow p = - [ toField (userId p) - , toField (name p) - , toField (cost p) - , toField (date p) - , toField (frequency p) - , toField (createdAt p) + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_frequency p) + , toField (_payment_createdAt p) ] find :: PaymentId -> Query (Maybe Payment) @@ -92,13 +81,13 @@ listMonthly = ) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create paymentUserId paymentName paymentCost paymentDate paymentFrequency = +create userId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do now <- getCurrentTime SQLite.execute conn "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" - (paymentUserId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -112,13 +101,13 @@ createMany payments = ) editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequency = +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute @@ -133,13 +122,13 @@ editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequ ) deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn paymentUserId paymentId = +deleteOwn userId paymentId = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs index 7c504dc..6e1d304 100644 --- a/src/server/Model/PaymentCategory.hs +++ b/src/server/Model/PaymentCategory.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - , list + ( list , listByCategory , save ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Data.Text as T import qualified Database.SQLite.Simple as SQLite -import Model.Category (CategoryId) -import Model.Query (Query(Query)) -import qualified Utils.Text as T - -type PaymentCategoryId = Int64 +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T -data PaymentCategory = PaymentCategory - { id :: PaymentCategoryId - , name :: Text - , category :: CategoryId - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index c8a0d53..eb78a69 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User - ( UserId - , User(..) - , list - , getUser - , findUser + ( list + , get , createUser , deleteUser ) where -import Data.Int (Int64) -import Data.List (find) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) - -type UserId = Int64 +import Common.Model (UserId, User(..)) -data User = User - { id :: UserId - , creation :: UTCTime - , email :: Text - , name :: Text - } deriving Show +import Model.Query (Query(Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field @@ -37,15 +25,12 @@ instance FromRow User where list :: Query [User] list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") -getUser :: Text -> Query (Maybe User) -getUser userEmail = +get :: Text -> Query (Maybe User) +get userEmail = Query (\conn -> listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -findUser :: UserId -> [User] -> Maybe User -findUser userId = find ((==) userId . id) - createUser :: Text -> Text -> Query UserId createUser userEmail userName = Query (\conn -> do diff --git a/src/server/Secure.hs b/src/server/Secure.hs index da48878..f427304 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -11,11 +11,12 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import Model.Message (getMessage) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + import Model.Query (Query) -import Model.User (User) import qualified LoginSession -import qualified Model.Message.Key as Key import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -31,16 +32,16 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.UnauthorizedSignIn + html . fromStrict . Message.get $ Key.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.Forbidden + html . fromStrict . Message.get $ Key.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do mbSignIn <- SignIn.getSignIn token case mbSignIn of Just signIn -> - User.getUser (SignIn.email signIn) + User.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs index 4a247e9..97457c7 100644 --- a/src/server/Utils/Time.hs +++ b/src/server/Utils/Time.hs @@ -2,7 +2,6 @@ module Utils.Time ( belongToCurrentMonth , belongToCurrentWeek , timeToDay - , monthToKey ) where import Data.Time.Clock (UTCTime, getCurrentTime) @@ -10,9 +9,6 @@ import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate (toWeekDate) -import Model.Message.Key (Key) -import qualified Model.Message.Key as K - belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time @@ -27,18 +23,3 @@ belongToCurrentWeek time = do timeToDay :: UTCTime -> IO Day timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time - -monthToKey :: Int -> Maybe Key -monthToKey 1 = Just K.January -monthToKey 2 = Just K.February -monthToKey 3 = Just K.March -monthToKey 4 = Just K.April -monthToKey 5 = Just K.May -monthToKey 6 = Just K.June -monthToKey 7 = Just K.July -monthToKey 8 = Just K.August -monthToKey 9 = Just K.September -monthToKey 10 = Just K.October -monthToKey 11 = Just K.November -monthToKey 12 = Just K.December -monthToKey _ = Nothing diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs deleted file mode 100644 index 354d46a..0000000 --- a/src/server/View/Format.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Format - ( price - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) - -import Conf (Conf) -import qualified Conf - -price :: Conf -> Int -> Text -price conf amount = T.concat [number amount, " ", Conf.currency conf] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index c7d40d8..12c4f34 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -6,10 +6,11 @@ module View.Mail.SignIn import Data.Text (Text) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.User (User(..)) + import Conf (Conf) -import Model.Message -import Model.Message.Key -import Model.User (User(..)) import qualified Conf as Conf import qualified Model.Mail as M @@ -18,6 +19,6 @@ mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = (getMessage SignInMailTitle) - , M.plainBody = getParamMessage [name user, url] SignInMail + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index 1a80b95..0bafb70 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -9,38 +9,34 @@ import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime) import qualified Data.Map as M import qualified Data.Text as T -import Resource (Status(..), groupByStatus, statuses) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model.User as User +import qualified Common.View.Format as Format -import Model.Income (Income) import Model.Mail (Mail(Mail)) -import Model.Message (getMessage, getParamMessage, plural) -import Model.Payment (Payment) -import Model.User (findUser) -import Model.User (User, UserId) -import qualified Model.Income as Income +import Model.Payment () +import qualified Model.Income () import qualified Model.Mail as M -import qualified Model.Message.Key as K -import qualified Model.Payment as Payment -import qualified Model.User as User - +import Resource (Status(..), groupByStatus, statuses) import Conf (Conf) import qualified Conf as Conf -import qualified View.Format as Format - -import Utils.Time (monthToKey) - mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = Mail { M.from = Conf.noReplyMail conf - , M.to = map User.email users - , M.subject = T.concat [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport] + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -48,7 +44,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - getMessage K.WeeklyReportEmpty + Message.get Key.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -57,65 +53,45 @@ body conf users paymentsByStatus incomesByStatus = paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = - section - (plural (length payments) singleKey pluralKey) - (map (payedFor status conf users) . sortOn Payment.date $ payments) - where (singleKey, pluralKey) = - case status of - Created -> (K.PaymentCreated, K.PaymentsCreated) - Edited -> (K.PaymentEdited, K.PaymentsEdited) - Deleted -> (K.PaymentDeleted, K.PaymentsDeleted) + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = - getParamMessage - [ formatUserName (Payment.userId payment) users - , Format.price conf . Payment.cost $ payment - , Payment.name payment - , formatDay $ Payment.date payment - ] - ( case status of - Created -> K.PayedFor - Edited -> K.PayedFor - Deleted -> K.DidNotPayFor - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = - section - (plural (length incomes) singleKey pluralKey) - (map (isPayedFrom status conf users) . sortOn Income.date $ incomes) - where (singleKey, pluralKey) = - case status of - Created -> (K.IncomeCreated, K.IncomesCreated) - Edited -> (K.IncomeEdited, K.IncomesEdited) - Deleted -> (K.IncomeDeleted, K.IncomesDeleted) + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = - getParamMessage - [ formatUserName (Income.userId income) users - , Format.price conf . Income.amount $ income - , formatDay $ Income.date income - ] - ( case status of - Created -> K.IsPayedFrom - Edited -> K.IsPayedFrom - Deleted -> K.IsNotPayedFrom - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income formatUserName :: UserId -> [User] -> Text -formatUserName userId = fromMaybe "−" . fmap User.name . findUser userId - -formatDay :: Day -> Text -formatDay d = - let (year, month, day) = toGregorian d - in getParamMessage - [ T.pack . show $ day - , fromMaybe "−" . fmap getMessage . monthToKey $ month - , T.pack . show $ year - ] - K.LongDate +formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId section :: Text -> [Text] -> Text section title items = diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 5a2e4f8..1c072a4 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -16,29 +16,24 @@ import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text (renderHtml) -import Design.Global (globalDesign) +import qualified Common.Message as Message +import Common.Model.InitResult (InitResult) +import qualified Common.Message.Key as Key -import Model.Message -import Model.Json.Conf -import Model.Json.Init (InitResult) -import Model.Message.Key (Key(SharedCost)) +import Design.Global (globalDesign) -page :: Conf -> InitResult -> Text -page conf initResult = +page :: InitResult -> Text +page initResult = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ getMessage SharedCost) - script ! src "javascripts/client.js" $ "" - jsonScript "translations" getTranslations - jsonScript "conf" conf - jsonScript "result" initResult + H.title (toHtml $ Message.get Key.App_Title) + script ! src "javascript/main.js" $ "" + jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign - body $ do - script ! src "javascripts/main.js" $ "" jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = |