diff options
106 files changed, 2025 insertions, 749 deletions
@@ -1,8 +1,8 @@ -dist/ database database-shm database-wal elm-stuff/ -public/javascripts/*.js +.stack-work +public/javascripts sessionKey local.conf diff --git a/.tmuxinator.yml b/.tmuxinator.yml index e714e72..1f3a804 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -6,3 +6,5 @@ windows: panes: - # Empty - make install build watch + - db: + - sqlite3 database @@ -1,10 +1,11 @@ all: build clean: - @cabal clean > /dev/null + @stack clean > /dev/null @rm -r elm-stuff >/dev/null 2>&1 || true install: + @stack setup @elm package install --yes # Watch @@ -27,10 +28,11 @@ watch-js: build-and-launch-server: build-server kill-server launch-server launch-server: - @./dist/build/sharedCost/sharedCost & + @stack exec sharedCost & kill-server: - @pkill sharedCost || true + @killall sharedCost || : + # Build # ----- @@ -39,7 +41,7 @@ kill-server: build: build-server build-elm build-js build-server: - @cabal build || true + @stack build || true build-elm: @elm make src/client/elm/Main.elm --output public/javascripts/client.js || true @@ -46,5 +46,11 @@ See [application.conf](application.conf). TODO ---- +- Modelize current page for both punctual and monthly payments +- search by payment category +- Use `sqlite-simple` instead of `persistent` +- Move up element ids security (editOwn is actually at db level) +- Prevent a daemon to freeze when it got “SQLite3 returned ErrorBusy while + attempting to perform step.” +- Minify javascript from elm for production build - CRUD animations (loading, created-updated-deleted element) -- Payment categories ? @@ -1,2 +1,2 @@ #!/bin/sh -nix-shell --command "tmuxinator local" +nix-shell --command "mux local" diff --git a/elm-package.json b/elm-package.json index f37c33b..19674fe 100644 --- a/elm-package.json +++ b/elm-package.json @@ -5,17 +5,19 @@ "license": "GPL-3", "source-directories": [ "src/client/elm" ], "exposed-modules": [], - "elm-version": "0.17.0 <= v < 0.18.0", + "elm-version": "0.18.0 <= v < 0.19.0", "dependencies": { - "elm-lang/core": "4.0.1 <= v < 5.0.0", - "elm-lang/html": "1.0.0 <= v < 2.0.0", - "elm-lang/navigation": "1.0.0 <= v < 2.0.0", - "elm-lang/mouse": "1.0.0 <= v < 2.0.0", - "elm-lang/window": "1.0.0 <= v < 2.0.0", - "etaque/elm-simple-form": "3.0.1 <= v < 4.0.0", - "evancz/elm-http": "3.0.1 <= v < 4.0.0", - "evancz/url-parser": "1.0.0 <= v < 2.0.0", - "jystic/elm-font-awesome": "2.0.0 <= v < 3.0.0", - "rluiten/elm-date-extra": "6.0.1 <= v < 7.0.0" + "elm-community/json-extra": "2.1.0 <= v < 3.0.0", + "elm-lang/core": "5.1.1 <= v < 6.0.0", + "elm-lang/dom": "1.1.1 <= v < 2.0.0", + "elm-lang/html": "2.0.0 <= v < 3.0.0", + "elm-lang/http": "1.0.0 <= v < 2.0.0", + "elm-lang/mouse": "1.0.1 <= v < 2.0.0", + "elm-lang/navigation": "2.0.1 <= v < 3.0.0", + "elm-lang/window": "1.0.1 <= v < 2.0.0", + "etaque/elm-form": "2.0.0 <= v < 3.0.0", + "evancz/url-parser": "2.0.1 <= v < 3.0.0", + "jystic/elm-font-awesome": "2.0.1 <= v < 3.0.0", + "rluiten/elm-date-extra": "8.3.0 <= v < 9.0.0" } } diff --git a/public/css/reset.css b/public/css/reset.css index 2eecc94..42f3b8c 100644 --- a/public/css/reset.css +++ b/public/css/reset.css @@ -56,5 +56,17 @@ button:hover { cursor: pointer; } button::-moz-focus-inner { border: 0; } :focus { outline: none; } +select:-moz-focusring { + color: transparent; + text-shadow: 0 0 0 #000; +} +select { + -webkit-appearance: none; + -moz-appearance: none; + text-indent: 1px; + text-overflow: ''; + cursor: pointer; +} + html { box-sizing: border-box; } *, *:before, *:after { box-sizing: inherit; } diff --git a/sharedCost.cabal b/sharedCost.cabal index 0cf5152..31aed97 100644 --- a/sharedCost.cabal +++ b/sharedCost.cabal @@ -43,3 +43,76 @@ executable sharedCost , containers , email-validate , config-manager + other-modules: Conf + , Controller.Category + , Controller.Income + , Controller.Index + , Controller.Payment + , Controller.SignIn + , Cookie + , Design.LoggedIn.Home.Table + , Design.LoggedIn.Stat + , Design.LoggedIn.Table + , Design.Media + , Design.SignIn + , Design.Tooltip + , Design.Color + , Design.Constants + , Design.Dialog + , Design.Errors + , Design.Form + , Design.Global + , Design.Header + , Design.Helper + , Design.LoggedIn + , Design.LoggedIn.Home + , Design.LoggedIn.Home.Header + , Design.LoggedIn.Home.Pages + , Job.Daemon + , Job.Frequency + , Job.Kind + , Job.Model + , Job.MonthlyPayment + , Job.WeeklyReport + , Json + , LoginSession + , Model.Category + , Model.Database + , Model.Frequency + , Model.Income + , Model.Init + , Model.Json.Category + , Model.Json.Conf + , Model.Json.CreateCategory + , Model.Json.CreateIncome + , Model.Json.CreatePayment + , Model.Json.EditCategory + , Model.Json.EditIncome + , Model.Json.EditPayment + , Model.Json.Income + , Model.Json.Init + , Model.Json.MessagePart + , Model.Json.Payment + , Model.Json.PaymentCategory + , Model.Json.Translation + , Model.Json.User + , Model.Mail + , Model.Message + , Model.Message.Key + , Model.Message.Lang + , Model.Message.Parts + , Model.Message.Translations + , Model.Payment + , Model.PaymentCategory + , Model.SignIn + , Model.UUID + , Model.User + , Resource + , Secure + , SendMail + , Utils.Text + , Utils.Time + , View.Format + , View.Mail.SignIn + , View.Mail.WeeklyReport + , View.Page @@ -3,44 +3,11 @@ with import <nixpkgs> {}; { name = "env"; buildInputs = with pkgs; [ elmPackages.elm - cabal-install - cabal2nix - nodejs + nodePackages.nodemon sqlite + stack tmux tmuxinator - nodePackages.nodemon - (haskellPackages.ghcWithPackages (p: with p; [ - scotty - wai - wai-middleware-static - http-types - http-conduit - time - text - blaze-builder - cookie - bytestring - persistent - persistent-sqlite - persistent-template - monad-logger - resourcet - transformers - blaze-html - clay - aeson - clientsession - uuid - mime-mail - mtl - lens - parsec - unordered-containers - containers - email-validate - config-manager - ])) ]; }; } diff --git a/src/client/elm/Dialog.elm b/src/client/elm/Dialog.elm index 3b9e93b..a7e059a 100644 --- a/src/client/elm/Dialog.elm +++ b/src/client/elm/Dialog.elm @@ -65,8 +65,7 @@ update updateModel msg baseModel model = UpdateAndClose msg -> ( { model | config = Nothing } - , Task.succeed () - |> Task.perform (always msg) (always msg) + , Task.perform (always msg) (Task.succeed msg) ) OpenWithUpdate config modelMsg -> diff --git a/src/client/elm/Dialog/AddCategory/Model.elm b/src/client/elm/Dialog/AddCategory/Model.elm new file mode 100644 index 0000000..8aeec1a --- /dev/null +++ b/src/client/elm/Dialog/AddCategory/Model.elm @@ -0,0 +1,53 @@ +module Dialog.AddCategory.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.Category exposing (Category, CategoryId) + +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" (Validate.string |> Validate.andThen Validate.nonEmpty)) diff --git a/src/client/elm/Dialog/AddCategory/View.elm b/src/client/elm/Dialog/AddCategory/View.elm new file mode 100644 index 0000000..6c02351 --- /dev/null +++ b/src/client/elm/Dialog/AddCategory/View.elm @@ -0,0 +1,72 @@ +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 data.name data.color + Nothing -> + Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateCategory data.name data.color + Nothing -> + Msg.Dialog <| Dialog.Update <| DialogMsg.AddCategoryMsg <| Form.Submit diff --git a/src/client/elm/Dialog/AddIncome/Model.elm b/src/client/elm/Dialog/AddIncome/Model.elm index 0d52b22..ad7b25a 100644 --- a/src/client/elm/Dialog/AddIncome/Model.elm +++ b/src/client/elm/Dialog/AddIncome/Model.elm @@ -4,6 +4,7 @@ module Dialog.AddIncome.Model exposing , initialAdd , initialClone , initialEdit + , validation ) import Date exposing (Date) @@ -24,29 +25,29 @@ type alias Model = } init : Form String Model -init = Form.initial [] validate +init = Form.initial [] validation initialAdd : Translations -> Date -> List (String, Field) initialAdd translations date = - [ ("date", Field.Text (Date.shortView date translations)) + [ ("date", Field.string (Date.shortView date translations)) ] initialClone : Translations -> Date -> Income -> List (String, Field) initialClone translations date income = - [ ("amount", Field.Text (toString income.amount)) - , ("date", Field.Text (Date.shortView date translations)) + [ ("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.Text (toString incomeId)) - , ("amount", Field.Text (toString income.amount)) - , ("date", Field.Text (Date.shortView (Date.fromTime income.time) translations)) + [ ("id", Field.string (toString incomeId)) + , ("amount", Field.string (toString income.amount)) + , ("date", Field.string (Date.shortView (Date.fromTime income.time) translations)) ] -validate : Validation String Model -validate = - Validate.form3 Model - (Validate.get "id" (Validate.maybe Validate.int)) - (Validate.get "amount" (Validate.int `Validate.andThen` (Validate.minInt 1))) - (Validate.get "date" Validation.date) +validation : Validation String Model +validation = + Validate.map3 Model + (Validate.field "id" (Validate.maybe Validate.int)) + (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 1))) + (Validate.field "date" Validation.date) diff --git a/src/client/elm/Dialog/AddIncome/View.elm b/src/client/elm/Dialog/AddIncome/View.elm index c628d37..b413308 100644 --- a/src/client/elm/Dialog/AddIncome/View.elm +++ b/src/client/elm/Dialog/AddIncome/View.elm @@ -5,7 +5,6 @@ module Dialog.AddIncome.View exposing import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import Html.App as Html import Task import Form exposing (Form) @@ -31,8 +30,8 @@ import Model.View exposing (View(LoggedInView)) import LoggedData exposing (LoggedData) import LoggedIn.Home.Model as HomeModel -button : String -> LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button className loggedData initialForm title buttonContent tooltip = +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 @@ -46,9 +45,7 @@ button className loggedData initialForm title buttonContent tooltip = Just message -> Tooltip.show Msg.Tooltip message Nothing -> [] ) - ++ [ class className - , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.AddIncomeMsg <| Form.Reset initialForm)) - ] + ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "incomeamount" (DialogMsg.AddIncomeMsg <| Form.Reset initialForm))) ] ) [ buttonContent ] diff --git a/src/client/elm/Dialog/AddPayment/Model.elm b/src/client/elm/Dialog/AddPayment/Model.elm index 19326f0..a287d37 100644 --- a/src/client/elm/Dialog/AddPayment/Model.elm +++ b/src/client/elm/Dialog/AddPayment/Model.elm @@ -4,6 +4,7 @@ module Dialog.AddPayment.Model exposing , initialAdd , initialClone , initialEdit + , validation ) import Date exposing (Date) @@ -16,46 +17,54 @@ import Validation import Model.Payment as Payment exposing (Payment, Frequency, PaymentId) import Model.Translations exposing (Translations) +import Model.Category as Category exposing (Categories, CategoryId) + +import Utils.Maybe as Maybe type alias Model = { id : Maybe PaymentId , name : String , cost : Int , date : Date + , category : CategoryId , frequency : Frequency } init : Form String Model -init = Form.initial [] validation +init = Form.initial [] (validation Category.empty) initialAdd : Translations -> Date -> Frequency -> List (String, Field) initialAdd translations date frequency = - [ ("date", Field.Text (Date.shortView date translations)) - , ("frequency", Field.Radio (toString frequency)) + [ ("date", Field.string (Date.shortView date translations)) + , ("frequency", Field.string (toString frequency)) + , ("category", Field.string "") ] -initialClone : Translations -> Date -> Payment -> List (String, Field) -initialClone translations date payment = - [ ("name", Field.Text payment.name) - , ("cost", Field.Text (toString payment.cost)) - , ("date", Field.Text (Date.shortView date translations)) - , ("frequency", Field.Radio (toString payment.frequency)) +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 -> Payment -> List (String, Field) -initialEdit translations payment = - [ ("id", Field.Text (toString payment.id)) - , ("name", Field.Text payment.name) - , ("cost", Field.Text (toString payment.cost)) - , ("date", Field.Text (Date.shortView payment.date translations)) - , ("frequency", Field.Radio (toString payment.frequency)) +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 : Validation String Model -validation = - Validate.form5 Model - (Validate.get "id" (Validate.maybe Validate.int)) - (Validate.get "name" (Validate.string `Validate.andThen` (Validate.nonEmpty))) - (Validate.get "cost" (Validate.int `Validate.andThen` (Validate.minInt 1))) - (Validate.get "date" Validation.date) - (Validate.get "frequency" Payment.validateFrequency) +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" (Validate.int |> Validate.andThen (Validate.minInt 1))) + (Validate.field "date" Validation.date) + (Validate.field "category" (Validation.category categories)) + (Validate.field "frequency" Payment.validateFrequency) diff --git a/src/client/elm/Dialog/AddPayment/View.elm b/src/client/elm/Dialog/AddPayment/View.elm index df1ad3b..078d5b7 100644 --- a/src/client/elm/Dialog/AddPayment/View.elm +++ b/src/client/elm/Dialog/AddPayment/View.elm @@ -2,10 +2,10 @@ module Dialog.AddPayment.View exposing ( button ) +import Dict import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import Html.App as Html import Task import Form exposing (Form) @@ -18,15 +18,17 @@ import Dialog.Msg as DialogMsg import Tooltip -import View.Form as Form import View.Events exposing (onSubmitPrevDefault) +import View.Form as Form -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg import LoggedIn.Home.Msg as HomeMsg +import LoggedIn.Msg as LoggedInMsg +import Msg exposing (Msg) -import Model.Translations exposing (getMessage) +import Model.Category exposing (Categories) import Model.Payment as Payment exposing (Frequency(..)) +import Model.PaymentCategory exposing (PaymentCategories) +import Model.Translations exposing (getMessage) import Model.View exposing (View(LoggedInView)) import LoggedData exposing (LoggedData) @@ -39,7 +41,7 @@ button loggedData initialForm title buttonContent tooltip = , title = getMessage loggedData.translations title , body = \model -> addPaymentForm loggedData model.addPayment , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addPayment + , confirmMsg = submitForm loggedData.categories loggedData.paymentCategories << .addPayment , undo = getMessage loggedData.translations "Undo" } in Html.button @@ -48,14 +50,19 @@ button loggedData initialForm title buttonContent tooltip = Nothing -> [] ) ++ [ class "addPayment" - , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.AddPaymentMsg <| Form.Reset initialForm)) + , 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) + 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 @@ -65,18 +72,24 @@ addPaymentForm loggedData addPayment = , 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 addPayment) + , Form.hiddenSubmit (submitForm loggedData.categories loggedData.paymentCategories addPayment) ] -submitForm : Form String AddPayment.Model -> Msg -submitForm 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 data.name data.cost data.date data.frequency + Msg.Dialog + <| Dialog.UpdateAndClose + <| Msg.EditPayment paymentId data.name data.cost data.date data.category data.frequency Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreatePayment data.name data.cost data.date data.frequency + Msg.Dialog + <| Dialog.UpdateAndClose + <| Msg.CreatePayment data.name data.cost data.date data.category data.frequency Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg <| Form.Submit + Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg categories paymentCategories <| Form.Submit diff --git a/src/client/elm/Dialog/Model.elm b/src/client/elm/Dialog/Model.elm index a3901f9..d4fd484 100644 --- a/src/client/elm/Dialog/Model.elm +++ b/src/client/elm/Dialog/Model.elm @@ -16,14 +16,17 @@ import Model.Translations exposing (Translations) 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/elm/Dialog/Msg.elm b/src/client/elm/Dialog/Msg.elm index d504281..68ed146 100644 --- a/src/client/elm/Dialog/Msg.elm +++ b/src/client/elm/Dialog/Msg.elm @@ -4,7 +4,12 @@ module Dialog.Msg exposing import Form exposing (Form) +import Model.Category exposing (Categories) +import Model.PaymentCategory exposing (PaymentCategories) + type Msg = NoOp - | AddPaymentMsg Form.Msg + | Init String Msg + | AddPaymentMsg Categories PaymentCategories Form.Msg | AddIncomeMsg Form.Msg + | AddCategoryMsg Form.Msg diff --git a/src/client/elm/Dialog/Update.elm b/src/client/elm/Dialog/Update.elm index d69082d..3915548 100644 --- a/src/client/elm/Dialog/Update.elm +++ b/src/client/elm/Dialog/Update.elm @@ -2,10 +2,19 @@ module Dialog.Update exposing ( update ) +import Dom exposing (Id) import Form exposing (Form) +import Form.Field as Field +import Task -import Dialog.Msg as Dialog +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 = @@ -16,16 +25,50 @@ update msg model = , Cmd.none ) - Dialog.AddPaymentMsg formMsg -> + Dialog.Init inputId dialogMsg -> + update dialogMsg model + |> Tuple.mapSecond (\cmd -> Cmd.batch [cmd, inputFocus inputId]) + + Dialog.AddPaymentMsg categories paymentCategories formMsg -> ( { model - | addPayment = Form.update formMsg model.addPayment + | addPayment = + Form.update (AddPayment.validation categories) formMsg model.addPayment + |> updateCategory categories paymentCategories formMsg } , Cmd.none ) Dialog.AddIncomeMsg formMsg -> ( { model - | addIncome = Form.update formMsg model.addIncome + | 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/elm/Init.elm b/src/client/elm/Init.elm index 9c6fc3b..d87e870 100644 --- a/src/client/elm/Init.elm +++ b/src/client/elm/Init.elm @@ -5,7 +5,7 @@ module Init exposing import Time exposing (..) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) import Model.Translations exposing (..) import Model.Conf exposing (..) @@ -20,11 +20,11 @@ type alias Init = , windowSize : Size } -decoder : Json.Decoder Init +decoder : Decoder Init decoder = - Json.object5 Init - ("time" := Json.float) - ("translations" := translationsDecoder) - ("conf" := confDecoder) - ("result" := initResultDecoder) - ("windowSize" := sizeDecoder) + 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/elm/LoggedData.elm b/src/client/elm/LoggedData.elm index d4c31f1..9bb0a7f 100644 --- a/src/client/elm/LoggedData.elm +++ b/src/client/elm/LoggedData.elm @@ -13,6 +13,8 @@ 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 @@ -24,6 +26,8 @@ type alias LoggedData = , me : UserId , payments : Payments , incomes : Incomes + , categories : Categories + , paymentCategories : PaymentCategories } build : Model -> LoggedInModel.Model -> LoggedData @@ -35,4 +39,6 @@ build model loggedIn = , me = loggedIn.me , payments = loggedIn.payments , incomes = loggedIn.incomes + , categories = loggedIn.categories + , paymentCategories = loggedIn.paymentCategories } diff --git a/src/client/elm/LoggedIn/Category/Model.elm b/src/client/elm/LoggedIn/Category/Model.elm new file mode 100644 index 0000000..7092fc4 --- /dev/null +++ b/src/client/elm/LoggedIn/Category/Model.elm @@ -0,0 +1,36 @@ +module LoggedIn.Category.Model exposing + ( Model + , AddCategory + , init + , initForm + , validation + ) + +import Date exposing (Date) + +import Form exposing (Form) +import Form.Validate as Validate exposing (Validation) +import Validation + +type alias Model = + { addCategory : Form String AddCategory + } + +type alias AddCategory = + { amount : Int + , date : Date + } + +init : Model +init = + { addCategory = initForm + } + +initForm : Form String AddCategory +initForm = Form.initial [] validation + +validation : Validation String AddCategory +validation = + Validate.map2 AddCategory + (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 1))) + (Validate.field "date" Validation.date) diff --git a/src/client/elm/LoggedIn/Category/Msg.elm b/src/client/elm/LoggedIn/Category/Msg.elm new file mode 100644 index 0000000..3184297 --- /dev/null +++ b/src/client/elm/LoggedIn/Category/Msg.elm @@ -0,0 +1,9 @@ +module LoggedIn.Category.Msg exposing + ( Msg(..) + ) + +import Form exposing (Form) + +type Msg = + NoOp + | AddCategoryMsg Form.Msg diff --git a/src/client/elm/LoggedIn/Category/Table/View.elm b/src/client/elm/LoggedIn/Category/Table/View.elm new file mode 100644 index 0000000..fa7a7b1 --- /dev/null +++ b/src/client/elm/LoggedIn/Category/Table/View.elm @@ -0,0 +1,124 @@ +module LoggedIn.Category.Table.View 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 LoggedIn.Category.Model as Category +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 -> Category.Model -> Html Msg +view loggedData categoryModel = + let categories = + loggedData.categories + |> Dict.toList + |> List.sortBy (.name << Tuple.second) + in div + [ class "table" ] + [ div + [ class "lines" ] + ( headerLine loggedData :: List.map (paymentLine loggedData categoryModel) 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 -> Category.Model -> (CategoryId, Category) -> Html Msg +paymentLine loggedData categoryModel (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/elm/LoggedIn/Category/Update.elm b/src/client/elm/LoggedIn/Category/Update.elm new file mode 100644 index 0000000..1072ef0 --- /dev/null +++ b/src/client/elm/LoggedIn/Category/Update.elm @@ -0,0 +1,24 @@ +module LoggedIn.Category.Update exposing + ( update + ) + +import Form exposing (Form) + +import LoggedData exposing (LoggedData) + +import LoggedIn.Category.Model as Category +import LoggedIn.Category.Msg as Category + +update : LoggedData -> Category.Msg -> Category.Model -> (Category.Model, Cmd Category.Msg) +update loggedData msg model = + case msg of + + Category.NoOp -> + ( model + , Cmd.none + ) + + Category.AddCategoryMsg formMsg -> + ( { model | addCategory = Form.update Category.validation formMsg model.addCategory } + , Cmd.none + ) diff --git a/src/client/elm/LoggedIn/Category/View.elm b/src/client/elm/LoggedIn/Category/View.elm new file mode 100644 index 0000000..4e04fa2 --- /dev/null +++ b/src/client/elm/LoggedIn/Category/View.elm @@ -0,0 +1,35 @@ +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.Model as Category +import LoggedIn.Category.Table.View as Table + +import Model.Translations exposing (getMessage, getParamMessage) + +view : LoggedData -> Category.Model -> Html Msg +view loggedData categoryModel = + 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 categoryModel + ] diff --git a/src/client/elm/LoggedIn/Home/Header/View.elm b/src/client/elm/LoggedIn/Home/Header/View.elm index b67fb3b..3f8a320 100644 --- a/src/client/elm/LoggedIn/Home/Header/View.elm +++ b/src/client/elm/LoggedIn/Home/Header/View.elm @@ -5,7 +5,6 @@ module LoggedIn.Home.Header.View exposing import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import Html.App as Html import String import Dict import Date @@ -32,8 +31,6 @@ import LoggedIn.Home.View.ExceedingPayers as ExceedingPayers import LoggedIn.View.Format as Format import View.Plural exposing (plural) -import Utils.Tuple as Tuple - view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg view loggedData { search } payments frequency = let currentDate = Date.fromTime loggedData.currentTime @@ -90,9 +87,9 @@ paymentsPartition loggedData payments = ", " ( loggedData.users |> Dict.toList - |> List.map (Tuple.mapFst (\userId -> Payment.totalPayments (always True) userId payments)) + |> List.map (Tuple.mapFirst (\userId -> Payment.totalPayments (always True) userId payments)) |> List.filter (\(sum, _) -> sum > 0) - |> List.sortBy fst + |> List.sortBy Tuple.first |> List.reverse |> List.map (\(sum, user) -> getParamMessage [ user.name, Format.price loggedData.conf sum ] loggedData.translations "By" diff --git a/src/client/elm/LoggedIn/Home/Model.elm b/src/client/elm/LoggedIn/Home/Model.elm index caedc29..ace1593 100644 --- a/src/client/elm/LoggedIn/Home/Model.elm +++ b/src/client/elm/LoggedIn/Home/Model.elm @@ -3,6 +3,7 @@ module LoggedIn.Home.Model exposing , Search , init , searchInitial + , validation ) import Form exposing (Form) @@ -26,14 +27,14 @@ type alias Search = init : Model init = { currentPage = 1 - , search = Form.initial (searchInitial Punctual) searchValidation + , search = Form.initial (searchInitial Punctual) validation } searchInitial : Frequency -> List (String, Field) -searchInitial frequency = [ ("frequency", Field.Radio (toString frequency)) ] +searchInitial frequency = [ ("frequency", Field.string (toString frequency)) ] -searchValidation : Validation String Search -searchValidation = - Validate.form2 Search - (Validate.get "name" (Validate.maybe Validate.string)) - (Validate.get "frequency" Payment.validateFrequency) +validation : Validation String Search +validation = + Validate.map2 Search + (Validate.field "name" (Validate.maybe Validate.string)) + (Validate.field "frequency" Payment.validateFrequency) diff --git a/src/client/elm/LoggedIn/Home/Update.elm b/src/client/elm/LoggedIn/Home/Update.elm index d1a3239..b0ce256 100644 --- a/src/client/elm/LoggedIn/Home/Update.elm +++ b/src/client/elm/LoggedIn/Home/Update.elm @@ -25,10 +25,10 @@ update loggedData msg model = Home.SearchMsg formMsg -> ( { model - | search = Form.update formMsg model.search + | search = Form.update Home.validation formMsg model.search , currentPage = case formMsg of - Form.Input "name" _ -> 1 + Form.Input "name" _ _ -> 1 _ -> model.currentPage } , Cmd.none diff --git a/src/client/elm/LoggedIn/Home/View.elm b/src/client/elm/LoggedIn/Home/View.elm index 0def64e..0b90e67 100644 --- a/src/client/elm/LoggedIn/Home/View.elm +++ b/src/client/elm/LoggedIn/Home/View.elm @@ -2,23 +2,22 @@ module LoggedIn.Home.View exposing ( view ) +import Date import Html exposing (..) import Html.Attributes exposing (..) -import Date import Form import Utils.Form as Form -import Msg exposing (Msg) - import LoggedData exposing (LoggedData) -import Model.Payment as Payment exposing (Frequency(..)) - -import LoggedIn.Home.Model as Home import LoggedIn.Home.Header.View as Header - -import LoggedIn.Home.View.Table as Table +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 exposing (Frequency(..)) +import Msg exposing (Msg) view : LoggedData -> Home.Model -> Html Msg view loggedData home = @@ -31,5 +30,9 @@ view loggedData home = [ class "home" ] [ Header.view loggedData home payments frequency , Table.view loggedData home payments frequency - , Paging.view home payments + , Paging.view + home.currentPage + (List.length payments) + Msg.NoOp + (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage) ] diff --git a/src/client/elm/LoggedIn/Home/View/Paging.elm b/src/client/elm/LoggedIn/Home/View/Paging.elm index 5bcb827..dffe061 100644 --- a/src/client/elm/LoggedIn/Home/View/Paging.elm +++ b/src/client/elm/LoggedIn/Home/View/Paging.elm @@ -10,31 +10,29 @@ import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import LoggedIn.Msg as LoggedInMsg - -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Home.Model as HomeModel - -import Msg exposing (Msg) import LoggedData exposing (LoggedData) import Model.Payment as Payment exposing (Payments, perPage) showedPages : Int showedPages = 5 -view : HomeModel.Model -> Payments -> Html Msg -view homeModel payments = - let maxPage = ceiling (toFloat (List.length payments) / toFloat perPage) - pages = truncatePages homeModel.currentPage [1..maxPage] +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 homeModel, previousPage homeModel ] - ++ ( List.map (paymentsPage homeModel) pages) - ++ [ nextPage homeModel maxPage, lastPage homeModel maxPage ] + ( [ 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 @@ -44,57 +42,57 @@ truncatePages currentPage pages = showedRightPages = floor ((toFloat showedPages - 1) / 2) truncatedPages = if currentPage <= showedLeftPages then - [1..showedPages] + (List.range 1 showedPages) else if currentPage > totalPages - showedRightPages then - [(totalPages - showedPages + 1)..totalPages] + (List.range (totalPages - showedPages + 1) totalPages) else - [(currentPage - showedLeftPages)..(currentPage + showedRightPages)] + (List.range (currentPage - showedLeftPages) (currentPage + showedRightPages)) in List.filter (flip List.member pages) truncatedPages -firstPage : HomeModel.Model -> Html Msg -firstPage homeModel = +firstPage : Int -> (Int -> msg) -> Html msg +firstPage currentPage pageMsg = button [ classList [ ("page", True) - , ("disable", homeModel.currentPage <= 1) + , ("disable", currentPage <= 1) ] - , onClick (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage <| 1) + , onClick (pageMsg 1) ] [ FontAwesome.fast_backward grey 13 ] -previousPage : HomeModel.Model -> Html Msg -previousPage homeModel = +previousPage : Int -> msg -> (Int -> msg) -> Html msg +previousPage currentPage noOp pageMsg = button [ class "page" , onClick <| - if homeModel.currentPage > 1 - then (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage <| homeModel.currentPage - 1) - else Msg.NoOp + if currentPage > 1 + then (pageMsg <| currentPage - 1) + else noOp ] [ FontAwesome.backward grey 13 ] -nextPage : HomeModel.Model -> Int -> Html Msg -nextPage homeModel maxPage = +nextPage : Int -> Int -> msg -> (Int -> msg) -> Html msg +nextPage currentPage maxPage noOp pageMsg = button [ class "page" , onClick <| - if homeModel.currentPage < maxPage - then (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage <| homeModel.currentPage + 1) - else Msg.NoOp + if currentPage < maxPage + then (pageMsg <| currentPage + 1) + else noOp ] [ FontAwesome.forward grey 13 ] -lastPage : HomeModel.Model -> Int -> Html Msg -lastPage homeModel maxPage = +lastPage : Int -> Int -> (Int -> msg) -> Html msg +lastPage currentPage maxPage pageMsg = button [ class "page" - , onClick (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage <| maxPage) + , onClick (pageMsg maxPage) ] [ FontAwesome.fast_forward grey 13 ] -paymentsPage : HomeModel.Model -> Int -> Html Msg -paymentsPage homeModel page = - let onCurrentPage = page == homeModel.currentPage +paymentsPage : Int -> msg -> (Int -> msg) -> Int -> Html msg +paymentsPage currentPage noOp pageMsg page = + let onCurrentPage = page == currentPage in button [ classList [ ("page", True) @@ -102,8 +100,8 @@ paymentsPage homeModel page = ] , onClick <| if onCurrentPage - then Msg.NoOp - else Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage <| page + then noOp + else pageMsg page ] [ text (toString page) ] diff --git a/src/client/elm/LoggedIn/Home/View/Table.elm b/src/client/elm/LoggedIn/Home/View/Table.elm index 6423bf9..8828488 100644 --- a/src/client/elm/LoggedIn/Home/View/Table.elm +++ b/src/client/elm/LoggedIn/Home/View/Table.elm @@ -2,8 +2,8 @@ module LoggedIn.Home.View.Table exposing ( view ) -import Dict exposing (..) import Date exposing (Date) +import Dict exposing (..) import String exposing (append) import FontAwesome @@ -26,12 +26,13 @@ import LoggedData exposing (LoggedData) import LoggedIn.Msg as LoggedInMsg import LoggedIn.Home.Model as Home -import View.Date as Date import LoggedIn.View.Format as Format +import View.Date as Date -import Model.User exposing (getUserName) import Model.Payment as Payment exposing (..) +import Model.PaymentCategory as PaymentCategory import Model.Translations exposing (getMessage) +import Model.User exposing (getUserName) view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg view loggedData homeModel payments frequency = @@ -60,6 +61,7 @@ headerLine loggedData frequency = [ 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 "" @@ -72,7 +74,7 @@ paymentLine : LoggedData -> Home.Model -> Frequency -> Payment -> Html Msg paymentLine loggedData homeModel frequency payment = div [ class "row" ] - [ div [ class "cell category" ] [ text payment.name ] + [ div [ class "cell name" ] [ text payment.name ] , div [ classList [ ("cell cost", True) @@ -87,6 +89,22 @@ paymentLine loggedData homeModel frequency payment = |> 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 @@ -103,9 +121,10 @@ paymentLine loggedData homeModel frequency payment = , 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 payment) + (AddPayment.initialClone loggedData.translations currentDate category payment) "ClonePayment" (FontAwesome.clone Color.chestnutRose 18) (Just (getMessage loggedData.translations "Clone")) @@ -116,12 +135,13 @@ paymentLine loggedData homeModel frequency payment = then text "" else - AddPayment.button - loggedData - (AddPayment.initialEdit loggedData.translations payment) - "EditPayment" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) + 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" ] diff --git a/src/client/elm/LoggedIn/Income/Model.elm b/src/client/elm/LoggedIn/Income/Model.elm index cf1bf57..7d852b9 100644 --- a/src/client/elm/LoggedIn/Income/Model.elm +++ b/src/client/elm/LoggedIn/Income/Model.elm @@ -3,12 +3,13 @@ module LoggedIn.Income.Model exposing , AddIncome , init , initForm + , validation ) import Date exposing (Date) import Form exposing (Form) -import Form.Validate as Validate exposing (..) +import Form.Validate as Validate exposing (Validation) import Validation type alias Model = @@ -26,10 +27,10 @@ init = } initForm : Form String AddIncome -initForm = Form.initial [] validate +initForm = Form.initial [] validation -validate : Validation String AddIncome -validate = - form2 AddIncome - (get "amount" (int `andThen` (minInt 1))) - (get "date" Validation.date) +validation : Validation String AddIncome +validation = + Validate.map2 AddIncome + (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 1))) + (Validate.field "date" Validation.date) diff --git a/src/client/elm/LoggedIn/Income/Update.elm b/src/client/elm/LoggedIn/Income/Update.elm index ec6a0c1..0023c76 100644 --- a/src/client/elm/LoggedIn/Income/Update.elm +++ b/src/client/elm/LoggedIn/Income/Update.elm @@ -6,19 +6,19 @@ import Form exposing (Form) import LoggedData exposing (LoggedData) -import LoggedIn.Income.Model as IncomeModel -import LoggedIn.Income.Msg as IncomeMsg +import LoggedIn.Income.Model as Income +import LoggedIn.Income.Msg as Income -update : LoggedData -> IncomeMsg.Msg -> IncomeModel.Model -> (IncomeModel.Model, Cmd IncomeMsg.Msg) +update : LoggedData -> Income.Msg -> Income.Model -> (Income.Model, Cmd Income.Msg) update loggedData msg model = case msg of - IncomeMsg.NoOp -> + Income.NoOp -> ( model , Cmd.none ) - IncomeMsg.AddIncomeMsg formMsg -> - ( { model | addIncome = Form.update formMsg model.addIncome } + Income.AddIncomeMsg formMsg -> + ( { model | addIncome = Form.update Income.validation formMsg model.addIncome } , Cmd.none ) diff --git a/src/client/elm/LoggedIn/Income/View.elm b/src/client/elm/LoggedIn/Income/View.elm index 2c5bcaf..00a1646 100644 --- a/src/client/elm/LoggedIn/Income/View.elm +++ b/src/client/elm/LoggedIn/Income/View.elm @@ -12,7 +12,6 @@ import FontAwesome import Html exposing (..) import Html.Events exposing (..) import Html.Attributes exposing (..) -import Html.App as Html import Form exposing (Form) import View.Form as Form @@ -45,19 +44,21 @@ view : LoggedData -> Income.Model -> Html Msg view loggedData incomeModel = div [ class "income" ] - [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of - Just since -> cumulativeIncomesView loggedData since - Nothing -> text "" - , div - [ class "textual monthlyNetIncomes" ] - [ h1 [] [ text <| getMessage loggedData.translations "MonthlyNetIncomes" ] - , AddIncome.button - "addIncome" - loggedData - (AddIncome.initialAdd loggedData.translations (Date.fromTime loggedData.currentTime)) - "AddIncome" - (text (getMessage loggedData.translations "AddIncome")) - Nothing + [ 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 incomeModel ] @@ -66,7 +67,7 @@ cumulativeIncomesView : LoggedData -> Time -> Html Msg cumulativeIncomesView loggedData since = let longDate = Date.longView (Date.fromTime since) loggedData.translations in div - [ class "textual" ] + [] [ h1 [] [ text <| getParamMessage [longDate] loggedData.translations "CumulativeIncomesSince" ] , ul [] @@ -74,7 +75,7 @@ cumulativeIncomesView loggedData since = |> List.map (\(userId, user) -> (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId) ) - |> List.sortBy snd + |> List.sortBy Tuple.second |> List.map (\(userName, cumulativeIncome) -> li [] diff --git a/src/client/elm/LoggedIn/Income/View/Table.elm b/src/client/elm/LoggedIn/Income/View/Table.elm index dcf6d78..aa5e392 100644 --- a/src/client/elm/LoggedIn/Income/View/Table.elm +++ b/src/client/elm/LoggedIn/Income/View/Table.elm @@ -38,7 +38,7 @@ view loggedData incomeModel = let incomes = loggedData.incomes |> Dict.toList - |> List.sortBy (.time << snd) + |> List.sortBy (.time << Tuple.second) |> List.reverse in div [ class "table" ] @@ -49,7 +49,7 @@ view loggedData incomeModel = then div [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoPayment" ] + [ text <| getMessage loggedData.translations "NoIncome" ] else text "" ] @@ -87,7 +87,6 @@ paymentLine loggedData incomeModel (incomeId, income) = [ class "cell button" ] [ let currentDate = Date.fromTime loggedData.currentTime in AddIncome.button - "" loggedData (AddIncome.initialClone loggedData.translations currentDate income) "CloneIncome" @@ -101,7 +100,6 @@ paymentLine loggedData incomeModel (incomeId, income) = text "" else AddIncome.button - "" loggedData (AddIncome.initialEdit loggedData.translations incomeId income) "EditIncome" diff --git a/src/client/elm/LoggedIn/Model.elm b/src/client/elm/LoggedIn/Model.elm index 11386d5..6bcb0b2 100644 --- a/src/client/elm/LoggedIn/Model.elm +++ b/src/client/elm/LoggedIn/Model.elm @@ -9,25 +9,34 @@ import Model.Init 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.Home.Model as HomeModel -import LoggedIn.Income.Model as IncomeModel +import LoggedIn.Home.Model as Home +import LoggedIn.Income.Model as Income +import LoggedIn.Category.Model as Categories type alias Model = - { home : HomeModel.Model - , income : IncomeModel.Model + { home : Home.Model + , income : Income.Model + , category : Categories.Model , users : Users , me : UserId , payments : Payments , incomes : Incomes + , categories : Categories + , paymentCategories : PaymentCategories } init : Init -> Model init initData = - { home = HomeModel.init - , income = IncomeModel.init + { home = Home.init + , income = Income.init + , category = Categories.init , users = initData.users , me = initData.me , payments = initData.payments , incomes = initData.incomes + , categories = initData.categories + , paymentCategories = initData.paymentCategories } diff --git a/src/client/elm/LoggedIn/Msg.elm b/src/client/elm/LoggedIn/Msg.elm index ff275e2..a1379a6 100644 --- a/src/client/elm/LoggedIn/Msg.elm +++ b/src/client/elm/LoggedIn/Msg.elm @@ -6,17 +6,23 @@ import Date exposing (Date) import Model.Payment exposing (PaymentId, Frequency) import Model.Income exposing (IncomeId) +import Model.Category exposing (CategoryId) -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Income.Msg as IncomeMsg +import LoggedIn.Home.Msg as Home +import LoggedIn.Income.Msg as Income +import LoggedIn.Category.Msg as Categories type Msg = NoOp - | HomeMsg HomeMsg.Msg - | IncomeMsg IncomeMsg.Msg - | ValidateCreatePayment PaymentId String Int Date Frequency - | ValidateEditPayment PaymentId String Int Date Frequency + | HomeMsg Home.Msg + | IncomeMsg Income.Msg + | CategoriesMsg Categories.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/elm/LoggedIn/Stat/View.elm b/src/client/elm/LoggedIn/Stat/View.elm index 946005a..f57316a 100644 --- a/src/client/elm/LoggedIn/Stat/View.elm +++ b/src/client/elm/LoggedIn/Stat/View.elm @@ -26,7 +26,7 @@ view loggedData = let paymentsByMonth = Payment.groupAndSortByMonth (Payment.punctual loggedData.payments) monthPaymentMean = getMonthPaymentMean loggedData paymentsByMonth in div - [ class "stat textual" ] + [ class "stat withMargin" ] [ h1 [] [ text (getParamMessage [ Format.price loggedData.conf monthPaymentMean ] loggedData.translations "ByMonthsAndMean") ] , ul [] @@ -40,7 +40,7 @@ getMonthPaymentMean loggedData paymentsByMonth = let currentDate = Date.fromTime loggedData.currentTime in not (Date.month currentDate == month && Date.year currentDate == year) ) - |> List.map (List.sum << List.map .cost << snd) + |> List.map (List.sum << List.map .cost << Tuple.second) |> List.mean monthDetail : LoggedData -> ((Month, Int), Payments) -> Html Msg diff --git a/src/client/elm/LoggedIn/Update.elm b/src/client/elm/LoggedIn/Update.elm index 06cd623..9e6d6ee 100644 --- a/src/client/elm/LoggedIn/Update.elm +++ b/src/client/elm/LoggedIn/Update.elm @@ -15,6 +15,8 @@ import Form import Model exposing (Model) import Model.Payment as Payment exposing (Payment, Frequency(..)) import Model.Income as Income exposing (Income) +import Model.Category exposing (Category) +import Model.PaymentCategory as PaymentCategory import Server import LoggedData @@ -22,16 +24,16 @@ import LoggedData import LoggedIn.Msg as LoggedInMsg import LoggedIn.Model as LoggedInModel -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Home.Update as HomeUpdate -import LoggedIn.Home.Model as HomeModel +import LoggedIn.Home.Msg as Home +import LoggedIn.Home.Update as Home +import LoggedIn.Home.Model as Home -import LoggedIn.Income.Msg as IncomeMsg -import LoggedIn.Income.Update as IncomeUpdate +import LoggedIn.Income.Update as Income +import LoggedIn.Income.Model as Income -import LoggedIn.Income.Model as IncomeModel +import LoggedIn.Category.Update as Categories +import LoggedIn.Category.Model as Categories -import Utils.Tuple as Tuple import Utils.Cmd exposing ((:>)) update : Model -> LoggedInMsg.Msg -> LoggedInModel.Model -> (LoggedInModel.Model, Cmd LoggedInMsg.Msg) @@ -45,32 +47,51 @@ update model msg loggedIn = ) LoggedInMsg.HomeMsg homeMsg -> - case HomeUpdate.update loggedData homeMsg loggedIn.home of + case Home.update loggedData homeMsg loggedIn.home of (home, effects) -> ( { loggedIn | home = home } , Cmd.map LoggedInMsg.HomeMsg effects ) LoggedInMsg.IncomeMsg incomeMsg -> - case IncomeUpdate.update loggedData incomeMsg loggedIn.income of + case Income.update loggedData incomeMsg loggedIn.income of (income, cmd) -> ( { loggedIn | income = income } , Cmd.map LoggedInMsg.IncomeMsg cmd ) - LoggedInMsg.ValidateCreatePayment paymentId name cost date frequency -> - update model (LoggedInMsg.HomeMsg <| HomeMsg.SearchMsg (Form.Reset (HomeModel.searchInitial frequency))) loggedIn - :> update model (LoggedInMsg.HomeMsg <| HomeMsg.UpdatePage 1) + LoggedInMsg.CategoriesMsg categoriesMsg -> + case Categories.update loggedData categoriesMsg loggedIn.category of + (category, cmd) -> + ( { loggedIn | category = category } + , Cmd.map LoggedInMsg.CategoriesMsg cmd + ) + + LoggedInMsg.ValidateCreatePayment paymentId name cost date category frequency -> + update model (LoggedInMsg.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial frequency))) loggedIn + :> update model (LoggedInMsg.HomeMsg <| Home.UpdatePage 1) :> (\loggedIn -> let newPayment = Payment paymentId name cost date loggedIn.me frequency - in ( { loggedIn | payments = newPayment :: loggedIn.payments } + in ( { loggedIn + | payments = newPayment :: loggedIn.payments + , paymentCategories = PaymentCategory.set name category loggedIn.paymentCategories + } , Cmd.none ) ) - LoggedInMsg.ValidateEditPayment paymentId name cost date frequency -> + LoggedInMsg.ValidateEditPayment paymentId name cost date category frequency -> let updatedPayment = Payment paymentId name cost date loggedIn.me frequency - in ( { loggedIn | payments = Payment.edit updatedPayment loggedIn.payments } + mbOldPayment = Payment.find paymentId loggedIn.payments + in ( { loggedIn + | payments = Payment.edit updatedPayment loggedIn.payments + , paymentCategories = + case mbOldPayment of + Just oldPayment -> + PaymentCategory.update oldPayment.name name category loggedIn.paymentCategories + Nothing -> + loggedData.paymentCategories + } , Cmd.none ) @@ -86,7 +107,7 @@ update model msg loggedIn = ) in if switchToPunctual then - update model (LoggedInMsg.HomeMsg <| HomeMsg.SearchMsg (Form.Reset (HomeModel.searchInitial Punctual))) loggedIn + update model (LoggedInMsg.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial Punctual))) loggedIn :> (\loggedIn -> ( { loggedIn | payments = payments } , Cmd.none @@ -99,20 +120,12 @@ update model msg loggedIn = LoggedInMsg.ValidateCreateIncome incomeId amount date -> let newIncome = { userId = loggedIn.me, amount = amount, time = Date.toTime date } - loggedInIncome = loggedIn.income - in ( { loggedIn - | incomes = Dict.insert incomeId newIncome loggedIn.incomes - , income = { loggedInIncome | addIncome = IncomeModel.initForm } - } + in ( { loggedIn | incomes = Dict.insert incomeId newIncome loggedIn.incomes } , Cmd.none ) LoggedInMsg.ValidateEditIncome incomeId amount date -> - let updatedIncome = Income loggedIn.me (Date.toTime date) amount - updateIncome mbIncome = - case mbIncome of - Just _ -> Just updatedIncome - Nothing -> Just updatedIncome + let updateIncome _ = Just <| Income loggedIn.me (Date.toTime date) amount in ( { loggedIn | incomes = Dict.update incomeId updateIncome loggedIn.incomes } , Cmd.none ) @@ -121,3 +134,18 @@ update model msg loggedIn = ( { loggedIn | incomes = Dict.remove incomeId loggedIn.incomes } , Cmd.none ) + + LoggedInMsg.ValidateCreateCategory categoryId name color -> + let newCategory = { name = name, color = color } + in ( { loggedIn | categories = Dict.insert categoryId newCategory loggedIn.categories } + , Cmd.none + ) + + LoggedInMsg.ValidateEditCategory categoryId name color -> + let updateCategory _ = Just <| Category name color + in ( { loggedIn | categories = Dict.update categoryId updateCategory loggedIn.categories } , Cmd.none) + + LoggedInMsg.ValidateDeleteCategory categoryId -> + ( { loggedIn | categories = Dict.remove categoryId loggedIn.categories } + , Cmd.none + ) diff --git a/src/client/elm/LoggedIn/View.elm b/src/client/elm/LoggedIn/View.elm index a1fa3f0..2e42a73 100644 --- a/src/client/elm/LoggedIn/View.elm +++ b/src/client/elm/LoggedIn/View.elm @@ -9,13 +9,15 @@ 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 HomeView -import LoggedIn.Income.View as UserView -import LoggedIn.Stat.View as StatView +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 = @@ -23,7 +25,9 @@ view model loggedIn = [ class "loggedIn" ] [ let loggedData = LoggedData.build model loggedIn in case model.page of - Page.Home -> HomeView.view loggedData loggedIn.home - Page.Income -> UserView.view loggedData loggedIn.income - Page.Statistics -> StatView.view loggedData + Page.Home -> Home.view loggedData loggedIn.home + Page.Income -> Income.view loggedData loggedIn.income + Page.Categories -> Categories.view loggedData loggedIn.category + Page.Statistics -> Stat.view loggedData + Page.NotFound -> div [] [ text (getMessage model.translations "PageNotFound") ] ] diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm index fa1415d..9674b66 100644 --- a/src/client/elm/Main.elm +++ b/src/client/elm/Main.elm @@ -4,20 +4,19 @@ module Main exposing import Navigation import Time -import Msg +import Msg exposing (Msg(UpdatePage)) import Model exposing (init) -import Update exposing (update, urlUpdate) +import Update exposing (update) import View exposing (view) import Page import Tooltip main = - Navigation.programWithFlags (Navigation.makeParser Page.fromHash) + Navigation.programWithFlags (UpdatePage << Page.fromLocation) { init = init , view = view , update = update - , urlUpdate = urlUpdate , subscriptions = (\model -> Sub.batch [ Time.every 1000 Msg.UpdateTime diff --git a/src/client/elm/Model.elm b/src/client/elm/Model.elm index a1d2bff..5167e42 100644 --- a/src/client/elm/Model.elm +++ b/src/client/elm/Model.elm @@ -4,9 +4,11 @@ module Model exposing ) import Time exposing (Time) -import Json.Decode as Json +import Json.Decode as Decode -import Html.App as Html +import Navigation exposing (Location) + +import Html as Html import Page exposing (Page) import Init as Init exposing (Init) @@ -38,14 +40,10 @@ type alias Model = , tooltip : Tooltip.Model } -init : Json.Value -> Result String Page -> (Model, Cmd Msg) -init payload result = - let page = - case result of - Err _ -> Page.Home - Ok page -> page - model = - case Json.decodeValue Init.decoder payload of +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 @@ -58,7 +56,7 @@ init payload result = , currentTime = time , translations = translations , conf = conf - , page = page + , page = Page.fromLocation location , errors = [] , dialog = Dialog.init DialogModel.init Msg.Dialog , tooltip = Tooltip.init windowSize.width windowSize.height @@ -68,7 +66,7 @@ init payload result = , currentTime = 0 , translations = [] , conf = { currency = "" } - , page = page + , page = Page.fromLocation location , errors = [ error ] , dialog = Dialog.init DialogModel.init Msg.Dialog , tooltip = Tooltip.init 0 0 diff --git a/src/client/elm/Model/Category.elm b/src/client/elm/Model/Category.elm new file mode 100644 index 0000000..8b653a7 --- /dev/null +++ b/src/client/elm/Model/Category.elm @@ -0,0 +1,35 @@ +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/elm/Model/Conf.elm b/src/client/elm/Model/Conf.elm index ec04622..308fa04 100644 --- a/src/client/elm/Model/Conf.elm +++ b/src/client/elm/Model/Conf.elm @@ -3,11 +3,11 @@ module Model.Conf exposing , confDecoder ) -import Json.Decode exposing (..) +import Json.Decode as Decode exposing (Decoder) type alias Conf = { currency : String } confDecoder : Decoder Conf -confDecoder = object1 Conf ("currency" := string) +confDecoder = Decode.map Conf (Decode.field "currency" Decode.string) diff --git a/src/client/elm/Model/Date.elm b/src/client/elm/Model/Date.elm index f3c9b91..bfba02f 100644 --- a/src/client/elm/Model/Date.elm +++ b/src/client/elm/Model/Date.elm @@ -4,12 +4,12 @@ module Model.Date exposing ) import Date as Date exposing (Date) +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Extra as Decode import Time exposing (Time) -import Json.Decode as Json exposing (..) - timeDecoder : Decoder Time -timeDecoder = Json.map Date.toTime dateDecoder +timeDecoder = Decode.map Date.toTime dateDecoder dateDecoder : Decoder Date -dateDecoder = customDecoder string Date.fromString +dateDecoder = Decode.string |> Decode.andThen (Date.fromString >> Decode.fromResult) diff --git a/src/client/elm/Model/Income.elm b/src/client/elm/Model/Income.elm index a5ca34b..34578c6 100644 --- a/src/client/elm/Model/Income.elm +++ b/src/client/elm/Model/Income.elm @@ -9,7 +9,8 @@ module Model.Income exposing , cumulativeIncomesSince ) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) +import Utils.Json as Json import Time exposing (Time, hour) import List exposing (..) import Dict exposing (Dict) @@ -17,7 +18,7 @@ import Dict exposing (Dict) import Model.Date exposing (timeDecoder) import Model.User exposing (UserId, userIdDecoder) -import Utils.Maybe exposing (isJust, catMaybes, maybeToList) +import Utils.Maybe as Maybe type alias Incomes = Dict IncomeId Income @@ -29,31 +30,23 @@ type alias Income = , amount : Int } -incomesDecoder : Json.Decoder Incomes -incomesDecoder = Json.map Dict.fromList (Json.list incomeWithIdDecoder) +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) -incomeWithIdDecoder : Json.Decoder (IncomeId, Income) -incomeWithIdDecoder = - Json.object2 (,) - ("id" := incomeIdDecoder) - incomeDecoder - -incomeIdDecoder : Json.Decoder IncomeId -incomeIdDecoder = Json.int - -incomeDecoder : Json.Decoder Income -incomeDecoder = - Json.object3 Income - ("userId" := userIdDecoder) - ("date" := timeDecoder) - ("amount" := Json.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 isJust firstIncomes - then head << reverse << List.sort << map .time << catMaybes <| firstIncomes + in if all Maybe.isJust firstIncomes + then head << reverse << List.sort << map .time << Maybe.cat <| firstIncomes else Nothing userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int @@ -71,7 +64,7 @@ getOrderedIncomesSince : Time -> List Income -> List Income getOrderedIncomesSince time incomes = let mbStarterIncome = getIncomeAt time incomes orderedIncomesSince = filter (\income -> income.time >= time) incomes - in (maybeToList mbStarterIncome) ++ orderedIncomesSince + in (Maybe.toList mbStarterIncome) ++ orderedIncomesSince getIncomeAt : Time -> List Income -> Maybe Income getIncomeAt time incomes = diff --git a/src/client/elm/Model/Init.elm b/src/client/elm/Model/Init.elm index 3a86dba..db7069f 100644 --- a/src/client/elm/Model/Init.elm +++ b/src/client/elm/Model/Init.elm @@ -3,23 +3,29 @@ module Model.Init exposing , initDecoder ) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) import Model.Payment exposing (Payments, paymentsDecoder) -import Model.Income exposing (Incomes, incomesDecoder) 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 : Json.Decoder Init +initDecoder : Decoder Init initDecoder = - Json.object4 Init - ("users" := usersDecoder) - ("me" := userIdDecoder) - ("payments" := paymentsDecoder) - ("incomes" := incomesDecoder) + 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/elm/Model/InitResult.elm b/src/client/elm/Model/InitResult.elm index c8da533..7ce0be2 100644 --- a/src/client/elm/Model/InitResult.elm +++ b/src/client/elm/Model/InitResult.elm @@ -3,7 +3,7 @@ module Model.InitResult exposing , initResultDecoder ) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) import Model.Init exposing (Init, initDecoder) @@ -12,17 +12,17 @@ type InitResult = | InitSuccess Init | InitError String -initResultDecoder : Json.Decoder InitResult -initResultDecoder = ("tag" := Json.string) `Json.andThen` initResultDecoderWithTag +initResultDecoder : Decoder InitResult +initResultDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen initResultDecoderWithTag -initResultDecoderWithTag : String -> Json.Decoder InitResult +initResultDecoderWithTag : String -> Decoder InitResult initResultDecoderWithTag tag = case tag of "InitEmpty" -> - Json.succeed InitEmpty + Decode.succeed InitEmpty "InitSuccess" -> - Json.map InitSuccess ("contents" := initDecoder) + Decode.map InitSuccess (Decode.field "contents" initDecoder) "InitError" -> - Json.map InitError ("contents" := Json.string) + Decode.map InitError (Decode.field "contents" Decode.string) _ -> - Json.fail <| "got " ++ tag ++ " for InitResult" + Decode.fail <| "got " ++ tag ++ " for InitResult" diff --git a/src/client/elm/Model/Payer.elm b/src/client/elm/Model/Payer.elm index e5a4b65..1663273 100644 --- a/src/client/elm/Model/Payer.elm +++ b/src/client/elm/Model/Payer.elm @@ -6,7 +6,6 @@ module Model.Payer exposing , useIncomesFrom ) -import Json.Decode as Json exposing (..) import Dict exposing (..) import List import Maybe @@ -54,7 +53,7 @@ getOrderedExceedingPayers currentTime users incomes payments = mbMaxRatio = postPaymentPayers |> Dict.toList - |> List.map (.ratio << snd) + |> List.map (.ratio << Tuple.second) |> List.maximum in case mbMaxRatio of Just maxRatio -> @@ -110,15 +109,15 @@ getPayers currentTime users incomes payments = exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer exceedingPayersFromAmounts userAmounts = - let mbMinAmount = List.minimum << List.map snd <| userAmounts + let mbMinAmount = List.minimum << List.map Tuple.second <| userAmounts in case mbMinAmount of Nothing -> [] Just minAmount -> userAmounts |> List.map (\userAmount -> - { userId = fst userAmount - , amount = snd userAmount - minAmount + { userId = Tuple.first userAmount + , amount = Tuple.second userAmount - minAmount } ) |> List.filter (\payer -> payer.amount > 0) diff --git a/src/client/elm/Model/Payment.elm b/src/client/elm/Model/Payment.elm index 5109b2f..f61ded8 100644 --- a/src/client/elm/Model/Payment.elm +++ b/src/client/elm/Model/Payment.elm @@ -6,6 +6,7 @@ module Model.Payment exposing , Frequency(..) , paymentsDecoder , paymentIdDecoder + , find , edit , delete , totalPayments @@ -18,15 +19,16 @@ module Model.Payment exposing import Date exposing (..) import Date.Extra.Core exposing (monthToInt, intToMonth) -import Json.Decode as Json exposing ((:=)) -import String +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Extra as Decode import List import Form.Validate as Validate exposing (Validation) -import Model.User exposing (UserId, userIdDecoder) import Model.Date exposing (dateDecoder) +import Model.User exposing (UserId, userIdDecoder) import Utils.List as List +import Utils.Search as Search perPage : Int perPage = 7 @@ -46,31 +48,36 @@ type alias PaymentId = Int type Frequency = Punctual | Monthly -paymentsDecoder : Json.Decoder Payments -paymentsDecoder = Json.list paymentDecoder +paymentsDecoder : Decoder Payments +paymentsDecoder = Decode.list paymentDecoder -paymentDecoder : Json.Decoder Payment +paymentDecoder : Decoder Payment paymentDecoder = - Json.object6 Payment - ("id" := paymentIdDecoder) - ("name" := Json.string) - ("cost" := Json.int) - ("date" := dateDecoder) - ("userId" := userIdDecoder) - ("frequency" := frequencyDecoder) - -paymentIdDecoder : Json.Decoder PaymentId -paymentIdDecoder = Json.int - -frequencyDecoder : Json.Decoder Frequency + 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" frequencyDecoder) + +paymentIdDecoder : Decoder PaymentId +paymentIdDecoder = Decode.int + +frequencyDecoder : Decoder Frequency frequencyDecoder = - Json.customDecoder - Json.string - (\input -> case input of - "Punctual" -> Ok Punctual - "Monthly" -> Ok Monthly - _ -> Err ("Could not deduce Punctual nor Monthly from " ++ input) - ) + let frequencyResult input = + case input of + "Punctual" -> Ok Punctual + "Monthly" -> Ok Monthly + _ -> Err ("Could not deduce Punctual nor Monthly from " ++ input) + in Decode.string |> Decode.andThen (Decode.fromResult << frequencyResult) + +find : PaymentId -> Payments -> Maybe Payment +find paymentId payments = + payments + |> List.filter (\p -> p.id == paymentId) + |> List.head edit : Payment -> Payments -> Payments edit payment payments = payment :: delete payment.id payments @@ -98,7 +105,7 @@ groupAndSortByMonth : Payments -> List ((Month, Int), Payments) groupAndSortByMonth payments = payments |> List.groupBy (\payment -> (Date.year payment.date, monthToInt << Date.month <| payment.date)) - |> List.sortBy fst + |> List.sortBy Tuple.first |> List.map (\((year, month), payments) -> ((intToMonth month, year), payments)) |> List.reverse @@ -118,7 +125,7 @@ paymentSort frequency = searchSuccess : String -> Payment -> Bool searchSuccess search { name, cost } = let searchSuccessWord word = - ( String.contains (String.toLower word) (String.toLower name) + ( 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/elm/Model/PaymentCategory.elm b/src/client/elm/Model/PaymentCategory.elm new file mode 100644 index 0000000..87678fe --- /dev/null +++ b/src/client/elm/Model/PaymentCategory.elm @@ -0,0 +1,48 @@ +module Model.PaymentCategory exposing + ( PaymentCategories + , paymentCategoriesDecoder + , search + , isCategoryUnused + , set + , update + ) + +import Dict exposing (Dict) +import Json.Decode as Decode exposing (Decoder) + +import Model.Category exposing (CategoryId, categoryIdDecoder) +import Utils.Json as Json +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) + +search : String -> PaymentCategories -> Maybe CategoryId +search paymentName paymentCategories = + paymentCategories + |> List.filter (\pc -> Search.format pc.name == Search.format paymentName) + |> List.head + |> Maybe.map .category + +isCategoryUnused : CategoryId -> PaymentCategories -> Bool +isCategoryUnused category paymentCategories = + paymentCategories + |> List.filter ((==) category << .category) + |> List.isEmpty + +set : String -> CategoryId -> PaymentCategories -> PaymentCategories +set name category paymentCategories = update name name category paymentCategories + +update : String -> String -> CategoryId -> PaymentCategories -> PaymentCategories +update oldName newName category paymentCategories = + { name = newName, category = category } :: List.filter (\pc -> not <| Search.format pc.name == Search.format oldName) paymentCategories diff --git a/src/client/elm/Model/Size.elm b/src/client/elm/Model/Size.elm index b29e90b..f40fb01 100644 --- a/src/client/elm/Model/Size.elm +++ b/src/client/elm/Model/Size.elm @@ -3,15 +3,15 @@ module Model.Size exposing , sizeDecoder ) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) type alias Size = { width: Int , height: Int } -sizeDecoder : Json.Decoder Size +sizeDecoder : Decoder Size sizeDecoder = - Json.object2 Size - ("width" := Json.int) - ("height" := Json.int) + Decode.map2 Size + (Decode.field "width" Decode.int) + (Decode.field "height" Decode.int) diff --git a/src/client/elm/Model/Translations.elm b/src/client/elm/Model/Translations.elm index 57409b0..9b314e1 100644 --- a/src/client/elm/Model/Translations.elm +++ b/src/client/elm/Model/Translations.elm @@ -7,13 +7,13 @@ module Model.Translations exposing ) import Maybe exposing (withDefault) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) import String type alias Translations = List Translation -translationsDecoder : Json.Decoder Translations -translationsDecoder = Json.list translationDecoder +translationsDecoder : Decoder Translations +translationsDecoder = Decode.list translationDecoder type alias Translation = { key : String @@ -27,25 +27,24 @@ getTranslation key translations = |> List.head |> Maybe.map .message -translationDecoder : Json.Decoder Translation +translationDecoder : Decoder Translation translationDecoder = - Json.object2 Translation - ("key" := Json.string) - ("message" := Json.list partDecoder) + Decode.map2 Translation + (Decode.field "key" Decode.string) + (Decode.field "message" (Decode.list partDecoder)) type MessagePart = Order Int | Str String -partDecoder : Json.Decoder MessagePart -partDecoder = - ("tag" := Json.string) `Json.andThen` partDecoderWithTag +partDecoder : Decoder MessagePart +partDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen partDecoderWithTag -partDecoderWithTag : String -> Json.Decoder MessagePart +partDecoderWithTag : String -> Decoder MessagePart partDecoderWithTag tag = case tag of - "Order" -> Json.object1 Order ("contents" := Json.int) - _ -> Json.object1 Str ("contents" := Json.string) + "Order" -> Decode.map Order (Decode.field "contents" Decode.int) + _ -> Decode.map Str (Decode.field "contents" Decode.string) ----- diff --git a/src/client/elm/Model/User.elm b/src/client/elm/Model/User.elm index 02f2cea..f6e8147 100644 --- a/src/client/elm/Model/User.elm +++ b/src/client/elm/Model/User.elm @@ -8,7 +8,7 @@ module Model.User exposing , getUserName ) -import Json.Decode as Json exposing ((:=)) +import Json.Decode as Decode exposing (Decoder) import Dict exposing (Dict) type alias Users = Dict UserId User @@ -20,23 +20,23 @@ type alias User = , email : String } -usersDecoder : Json.Decoder Users -usersDecoder = Json.map Dict.fromList (Json.list userWithIdDecoder) +usersDecoder : Decoder Users +usersDecoder = Decode.map Dict.fromList (Decode.list userWithIdDecoder) -userWithIdDecoder : Json.Decoder (UserId, User) +userWithIdDecoder : Decode.Decoder (UserId, User) userWithIdDecoder = - Json.object2 (,) - ("id" := userIdDecoder) + Decode.map2 (,) + (Decode.field "id" userIdDecoder) userDecoder -userIdDecoder : Json.Decoder UserId -userIdDecoder = Json.int +userIdDecoder : Decoder UserId +userIdDecoder = Decode.int -userDecoder : Json.Decoder User +userDecoder : Decoder User userDecoder = - Json.object2 User - ("name" := Json.string) - ("email" := Json.string) + Decode.map2 User + (Decode.field "name" Decode.string) + (Decode.field "email" Decode.string) getUserName : Users -> UserId -> Maybe String getUserName users userId = diff --git a/src/client/elm/Msg.elm b/src/client/elm/Msg.elm index 49d13ca..cf592aa 100644 --- a/src/client/elm/Msg.elm +++ b/src/client/elm/Msg.elm @@ -10,6 +10,7 @@ import Page exposing (Page) import Model.Init exposing (Init) import Model.Payment exposing (PaymentId, Frequency) import Model.Income exposing (IncomeId) +import Model.Category exposing (CategoryId) import Dialog import Dialog.Model as DialogModel @@ -22,19 +23,26 @@ import LoggedIn.Msg as LoggedInMsg type Msg = NoOp + | UpdatePage Page | SignIn String | UpdateTime Time | GoLoggedInView Init | UpdateSignIn SignInMsg.Msg | UpdateLoggedIn LoggedInMsg.Msg - | CreatePayment String Int Date Frequency - | EditPayment PaymentId String Int Date Frequency - | DeletePayment PaymentId - | CreateIncome Int Date - | EditIncome IncomeId Int Date - | DeleteIncome IncomeId | 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/elm/Page.elm b/src/client/elm/Page.elm index 7cfbbc7..39232e0 100644 --- a/src/client/elm/Page.elm +++ b/src/client/elm/Page.elm @@ -1,32 +1,43 @@ module Page exposing ( Page(..) , toHash - , fromHash + , fromLocation ) -import Navigation -import UrlParser exposing (..) +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" -fromHash : Navigation.Location -> Result String Page -fromHash location = UrlParser.parse identity pageParser (String.dropLeft 1 location.hash) +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 = - oneOf - [ format Home (s "") - , format Income (s "income") - , format Statistics (s "statistics") + UrlParser.oneOf + [ UrlParser.map Income (s "income") + , UrlParser.map Categories (s "categories") + , UrlParser.map Statistics (s "statistics") ] diff --git a/src/client/elm/Server.elm b/src/client/elm/Server.elm index c017548..7f25876 100644 --- a/src/client/elm/Server.elm +++ b/src/client/elm/Server.elm @@ -6,14 +6,17 @@ module Server exposing , createIncome , editIncome , deleteIncome + , createCategory + , editCategory + , deleteCategory , signOut ) import Task as Task exposing (Task) -import Http +import Http exposing (Error) import Date -import Json.Decode exposing ((:=)) -import Json.Encode as Json +import Json.Decode as Decode +import Json.Encode as Encode import Date exposing (Date) import Date.Extra.Format as DateFormat @@ -21,68 +24,91 @@ import Date.Extra.Format as DateFormat import Utils.Http as HttpUtils import Model.Payment exposing (..) -import Model.Income exposing (incomesDecoder, incomeIdDecoder, IncomeId) +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 -> Task Http.Error () -signIn email = - HttpUtils.request "POST" ("/signIn?email=" ++ email) - |> Task.map (always ()) +signIn : String -> (Result Error String -> msg) -> Cmd msg +signIn email = HttpUtils.request "POST" ("/signIn?email=" ++ email) Http.expectString -createPayment : String -> Int -> Date -> Frequency -> Task Http.Error PaymentId -createPayment name cost date frequency = - Json.object - [ ("name", Json.string name) - , ("cost", Json.int cost) - , ("date", Json.string (DateFormat.isoDateString date)) - , ("frequency", Json.string (toString frequency)) - ] - |> HttpUtils.jsonRequest "POST" "/payment" - |> flip Task.andThen (HttpUtils.decodeHttpValue <| "id" := paymentIdDecoder) +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 -> Frequency -> Task Http.Error () -editPayment paymentId name cost date frequency = - Json.object - [ ("id", Json.int paymentId) - , ("name", Json.string name) - , ("cost", Json.int cost) - , ("date", Json.string (DateFormat.isoDateString date)) - , ("frequency", Json.string (toString frequency)) - ] - |> HttpUtils.jsonRequest "PUT" "/payment" - |> Task.map (always ()) +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 -> Task Http.Error () +deletePayment : PaymentId -> (Result Error String -> msg) -> Cmd msg deletePayment paymentId = - HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) - |> Task.map (always ()) + HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) Http.expectString -createIncome : Int -> Date -> Task Http.Error IncomeId -createIncome amount date = - Json.object - [ ("amount", Json.int amount) - , ("date", Json.string (DateFormat.isoDateString date)) - ] - |> HttpUtils.jsonRequest "POST" "/income" - |> flip Task.andThen (HttpUtils.decodeHttpValue <| "id" := incomeIdDecoder) +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 -> Task Http.Error () -editIncome incomeId amount date = - Json.object - [ ("id", Json.int incomeId) - , ("amount", Json.int amount) - , ("date", Json.string (DateFormat.isoDateString date)) - ] - |> HttpUtils.jsonRequest "PUT" "/income" - |> Task.map (always ()) +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 -> Task Http.Error () +deleteIncome : IncomeId -> (Result Error String -> msg) -> Cmd msg deleteIncome incomeId = - HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) - |> Task.map (always ()) + HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) Http.expectString -signOut : Task Http.Error () -signOut = - HttpUtils.request "POST" "/signOut" - |> Task.map (always ()) +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/elm/SignIn/View.elm b/src/client/elm/SignIn/View.elm index f23ca09..88f74b0 100644 --- a/src/client/elm/SignIn/View.elm +++ b/src/client/elm/SignIn/View.elm @@ -2,7 +2,7 @@ module SignIn.View exposing ( view ) -import Json.Decode as Json +import Json.Decode as Decode import FontAwesome import View.Color as Color @@ -30,7 +30,7 @@ view model signInModel = [ onSubmitPrevDefault (SignIn signInModel.login) ] [ input [ value signInModel.login - , on "input" (targetValue |> (Json.map <| (UpdateSignIn << SignInMsg.UpdateLogin))) + , on "input" (targetValue |> (Decode.map <| (UpdateSignIn << SignInMsg.UpdateLogin))) , name "email" ] [] diff --git a/src/client/elm/Update.elm b/src/client/elm/Update.elm index e66414e..7006d5a 100644 --- a/src/client/elm/Update.elm +++ b/src/client/elm/Update.elm @@ -1,11 +1,10 @@ module Update exposing ( update - , urlUpdate ) import Task import Platform.Cmd exposing (Cmd) -import Navigation +import Navigation exposing (Location) import Page exposing (Page) @@ -32,7 +31,6 @@ import Tooltip import Utils.Http exposing (errorKey) import Utils.Cmd exposing ((:>)) -import Utils.Tuple as Tuple update : Msg -> Model -> (Model, Cmd Msg) update msg model = @@ -41,12 +39,15 @@ update msg model = NoOp -> (model, Cmd.none) + UpdatePage page -> + ({ model | page = page }, Cmd.none) + SignIn email -> ( applySignIn model (SignInMsg.WaitingServer) - , Server.signIn email - |> Task.perform - (\error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error))) - (\() -> UpdateSignIn SignInMsg.ValidLogin) + , Server.signIn email (\result -> case result of + Ok _ -> UpdateSignIn SignInMsg.ValidLogin + Err error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error)) + ) ) GoLoggedInView init -> @@ -66,73 +67,100 @@ update msg model = UpdateLoggedIn loggedInMsg -> applyLoggedIn model loggedInMsg - CreatePayment name cost date frequency -> + 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 frequency - |> Task.perform - (always <| Error "CreatePaymentError") - (\paymentId -> UpdateLoggedIn <| LoggedInMsg.ValidateCreatePayment paymentId name cost date frequency) + , Server.createPayment name cost date category frequency (\result -> case result of + Ok paymentId -> UpdateLoggedIn <| LoggedInMsg.ValidateCreatePayment paymentId name cost date category frequency + Err _ -> Error "CreatePaymentError" + ) ) - EditPayment paymentId name cost date frequency -> + EditPayment paymentId name cost date category frequency -> ( model - , Server.editPayment paymentId name cost date frequency - |> Task.perform - (always <| Error "EditPaymentError") - (always <| UpdateLoggedIn <| LoggedInMsg.ValidateEditPayment paymentId name cost date frequency) + , Server.editPayment paymentId name cost date category frequency (\result -> case result of + Ok _ -> UpdateLoggedIn <| LoggedInMsg.ValidateEditPayment paymentId name cost date category frequency + Err _ -> Error "EditPaymentError" + ) ) DeletePayment paymentId -> ( model - , Server.deletePayment paymentId - |> Task.perform - (always <| Error "DeletePaymentError") - (always <| UpdateLoggedIn <| LoggedInMsg.ValidateDeletePayment paymentId) + , Server.deletePayment paymentId (\result -> case result of + Ok _ -> UpdateLoggedIn <| LoggedInMsg.ValidateDeletePayment paymentId + Err _ -> Error "DeletePaymentError" + ) ) CreateIncome amount date -> ( model - , Server.createIncome amount date - |> Task.perform - (always <| Error "CreateIncomeError") - (\incomeId -> UpdateLoggedIn <| LoggedInMsg.ValidateCreateIncome incomeId amount date) + , Server.createIncome amount date (\result -> case result of + Ok incomeId -> UpdateLoggedIn <| LoggedInMsg.ValidateCreateIncome incomeId amount date + Err _ -> Error "CreateIncomeError" + ) ) EditIncome incomeId amount date -> ( model - , Server.editIncome incomeId amount date - |> Task.perform - (always <| Error "EditIncomeError") - (always <| UpdateLoggedIn <| LoggedInMsg.ValidateEditIncome incomeId amount date) + , Server.editIncome incomeId amount date (\result -> case result of + Ok _ -> UpdateLoggedIn <| LoggedInMsg.ValidateEditIncome incomeId amount date + Err _ -> Error "EditIncomeError" + ) ) DeleteIncome incomeId -> ( model - , Server.deleteIncome incomeId - |> Task.perform - (always <| Error "DeleteIncomeError") - (always <| UpdateLoggedIn <| LoggedInMsg.ValidateDeleteIncome incomeId) + , Server.deleteIncome incomeId (\result -> case result of + Ok _ -> UpdateLoggedIn <| LoggedInMsg.ValidateDeleteIncome incomeId + Err _ -> Error "DeleteIncomeError" + ) ) - SignOut -> + CreateCategory name color -> ( model - , Server.signOut - |> Task.perform (always <| Error "SignOutError") (always GoSignInView) + , Server.createCategory name color (\result -> case result of + Ok categoryId -> UpdateLoggedIn <| LoggedInMsg.ValidateCreateCategory categoryId name color + Err _ -> Error "CreateCategoryError" + ) ) - Error error -> - ({ model | errors = model.errors ++ [ error ] }, Cmd.none) + EditCategory categoryId name color -> + ( model + , Server.editCategory categoryId name color (\result -> case result of + Ok _ -> UpdateLoggedIn <| LoggedInMsg.ValidateEditCategory categoryId name color + Err _ -> Error "EditCategoryError" + ) + ) - Dialog dialogMsg -> - Dialog.update DialogUpdate.update dialogMsg model.dialog.model model.dialog - |> Tuple.mapFst (\dialog -> { model | dialog = dialog }) - :> update (Tooltip Tooltip.HideMessage) + DeleteCategory categoryId -> + ( model + , Server.deleteCategory categoryId (\result -> case result of + Ok _ -> UpdateLoggedIn <| LoggedInMsg.ValidateDeleteCategory categoryId + Err _ -> Error "DeleteCategoryError" + ) + ) - Tooltip tooltipMsg -> - let (newTooltip, command) = Tooltip.update tooltipMsg model.tooltip - in ( { model | tooltip = newTooltip } - , Cmd.map Tooltip command - ) applySignIn : Model -> SignInMsg.Msg -> Model applySignIn model signInMsg = @@ -146,17 +174,9 @@ applyLoggedIn : Model -> LoggedInMsg.Msg -> (Model, Cmd Msg) applyLoggedIn model loggedInMsg = case model.view of V.LoggedInView loggedInView -> - let (loggedInView, cmd) = LoggedInUpdate.update model loggedInMsg loggedInView - in ( { model | view = V.LoggedInView loggedInView } + let (view, cmd) = LoggedInUpdate.update model loggedInMsg loggedInView + in ( { model | view = V.LoggedInView view } , Cmd.map UpdateLoggedIn cmd ) _ -> (model, Cmd.none) - -urlUpdate : Result String Page -> Model -> (Model, Cmd Msg) -urlUpdate result model = - case result of - Err _ -> - (model, Navigation.modifyUrl (Page.toHash model.page)) - Ok page -> - ({ model | page = page }, Cmd.none) diff --git a/src/client/elm/Utils/Cmd.elm b/src/client/elm/Utils/Cmd.elm index 8b79446..5f41cbe 100644 --- a/src/client/elm/Utils/Cmd.elm +++ b/src/client/elm/Utils/Cmd.elm @@ -7,8 +7,8 @@ import Platform.Cmd as Cmd pipeUpdate : (model, Cmd msg) -> (model -> (model, Cmd msg)) -> (model, Cmd msg) pipeUpdate (model, cmd) f = - let (model', cmd') = f model - in (model', Cmd.batch [ cmd, cmd' ]) + let (newModel, newCmd) = f model + in (newModel, Cmd.batch [ cmd, newCmd ]) (:>) : (m, Cmd a) -> (m -> (m, Cmd a)) -> (m, Cmd a) (:>) = pipeUpdate diff --git a/src/client/elm/Utils/Http.elm b/src/client/elm/Utils/Http.elm index 4edc233..dd3870a 100644 --- a/src/client/elm/Utils/Http.elm +++ b/src/client/elm/Utils/Http.elm @@ -1,69 +1,39 @@ module Utils.Http exposing ( jsonRequest , request - , requestWithBody - , decodeHttpValue , errorKey ) import Http exposing (..) import Task exposing (..) -import Json.Decode as JsonDecode exposing (Decoder) -import Json.Encode as JsonEncode - -jsonRequest : String -> String -> JsonEncode.Value -> Task Error Value -jsonRequest method url json = - json - |> JsonEncode.encode 0 - |> Http.string - |> requestWithBody method url - -request : String -> String -> Task Error Value -request method url = requestWithBody method url empty - -requestWithBody : String -> String -> Body -> Task Error Value -requestWithBody method url body = - { verb = method - , headers = [] - , url = url - , body = body - } - |> Http.send defaultSettings - |> mapError promoteError - |> flip Task.andThen handleResponse - -promoteError : RawError -> Error -promoteError rawError = - case rawError of - RawTimeout -> Timeout - RawNetworkError -> NetworkError - -handleResponse : Response -> Task Error Value -handleResponse response = - if 200 <= response.status && response.status < 300 - then Task.succeed response.value - else fail (BadResponse response.status (responseString response.value)) - -responseString : Value -> String -responseString value = - case value of - Text str -> str - _ -> "" - -decodeHttpValue : Decoder a -> Value -> Task Error a -decodeHttpValue decoder value = - case value of - Text str -> - case JsonDecode.decodeString decoder str of - Ok v -> succeed v - Err msg -> fail (UnexpectedPayload msg) - _ -> - fail (UnexpectedPayload "Response body is a blob, expecting a string.") +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" - UnexpectedPayload _ -> "UnexpectedPayload" - BadResponse _ key -> key + BadPayload _ _ -> "BadPayload" + BadStatus response -> response.body diff --git a/src/client/elm/Utils/Json.elm b/src/client/elm/Utils/Json.elm new file mode 100644 index 0000000..29e815b --- /dev/null +++ b/src/client/elm/Utils/Json.elm @@ -0,0 +1,12 @@ +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/elm/Utils/Maybe.elm b/src/client/elm/Utils/Maybe.elm index 4a94aa5..46456e1 100644 --- a/src/client/elm/Utils/Maybe.elm +++ b/src/client/elm/Utils/Maybe.elm @@ -1,7 +1,8 @@ module Utils.Maybe exposing ( isJust - , catMaybes - , maybeToList + , cat + , toList + , orElse ) isJust : Maybe a -> Bool @@ -10,8 +11,8 @@ isJust maybe = Just _ -> True Nothing -> False -catMaybes : List (Maybe a) -> List a -catMaybes = +cat : List (Maybe a) -> List a +cat = List.foldr (\mb xs -> case mb of @@ -20,8 +21,14 @@ catMaybes = ) [] -maybeToList : Maybe a -> List a -maybeToList mb = +toList : Maybe a -> List a +toList mb = case mb of Just a -> [a] Nothing -> [] + +orElse : Maybe a -> Maybe a -> Maybe a +orElse mb1 mb2 = + case mb1 of + Just x -> Just x + Nothing -> mb2 diff --git a/src/client/elm/Utils/Search.elm b/src/client/elm/Utils/Search.elm new file mode 100644 index 0000000..1b70387 --- /dev/null +++ b/src/client/elm/Utils/Search.elm @@ -0,0 +1,10 @@ +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/elm/Utils/String.elm b/src/client/elm/Utils/String.elm new file mode 100644 index 0000000..90fe68e --- /dev/null +++ b/src/client/elm/Utils/String.elm @@ -0,0 +1,38 @@ +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/elm/Utils/Tuple.elm b/src/client/elm/Utils/Tuple.elm deleted file mode 100644 index f9391a0..0000000 --- a/src/client/elm/Utils/Tuple.elm +++ /dev/null @@ -1,14 +0,0 @@ -module Utils.Tuple exposing - ( mapFst - , mapSnd - , mapBoth - ) - -mapFst : (a -> x) -> (a, b) -> (x, b) -mapFst f (a, b) = (f a, b) - -mapSnd : (b -> x) -> (a, b) -> (a, x) -mapSnd f (a, b) = (a, f b) - -mapBoth : (a -> x) -> (b -> y) -> (a, b) -> (x, y) -mapBoth f g (a, b) = (f a, g b) diff --git a/src/client/elm/Validation.elm b/src/client/elm/Validation.elm index 1729daa..18b3934 100644 --- a/src/client/elm/Validation.elm +++ b/src/client/elm/Validation.elm @@ -1,14 +1,18 @@ module Validation exposing ( date + , category ) -import String exposing (toInt, split) import Date exposing (Date) -import Date.Extra.Create exposing (dateFromFields) import Date.Extra.Core exposing (intToMonth) +import Date.Extra.Create exposing (dateFromFields) +import Dict +import String exposing (toInt, split) import Form.Validate as Validate exposing (..) +import Model.Category exposing (Categories, CategoryId) + date : Validation String Date date = customValidation string (\str -> @@ -20,3 +24,15 @@ date = _ -> Err (customError "InvalidDate") _ -> Err (customError "InvalidDate") ) + +category : Categories -> Validation String CategoryId +category categories = + customValidation string (\str -> + case toInt str of + Ok category -> + if List.member category (Dict.keys categories) + then Ok category + else Err (customError "InvalidCategory") + Err _ -> + Err (customError "InvalidCategory") + ) diff --git a/src/client/elm/View.elm b/src/client/elm/View.elm index 4a0822f..66c498a 100644 --- a/src/client/elm/View.elm +++ b/src/client/elm/View.elm @@ -3,7 +3,6 @@ module View exposing ) import Html exposing (..) -import Html.App as Html import Html.Attributes exposing (..) import Model exposing (Model) diff --git a/src/client/elm/View/Events.elm b/src/client/elm/View/Events.elm index c50fe98..d71d67d 100644 --- a/src/client/elm/View/Events.elm +++ b/src/client/elm/View/Events.elm @@ -2,7 +2,7 @@ module View.Events exposing ( onSubmitPrevDefault ) -import Json.Decode as Json +import Json.Decode as Decode import Html exposing (..) import Html.Events exposing (..) import Html.Attributes exposing (..) @@ -12,4 +12,4 @@ onSubmitPrevDefault value = onWithOptions "submit" { defaultOptions | preventDefault = True } - (Json.succeed value) + (Decode.succeed value) diff --git a/src/client/elm/View/Form.elm b/src/client/elm/View/Form.elm index dcde47d..7a4965d 100644 --- a/src/client/elm/View/Form.elm +++ b/src/client/elm/View/Form.elm @@ -1,5 +1,7 @@ module View.Form exposing ( textInput + , colorInput + , selectInput , radioInputs , hiddenSubmit ) @@ -13,7 +15,7 @@ import View.Color as Color import Form exposing (Form, FieldState) import Form.Input as Input -import Form.Error as FormError exposing (Error(..)) +import Form.Error as FormError exposing (ErrorValue(..)) import Form.Field as Field import Msg exposing (Msg) @@ -27,6 +29,7 @@ import Utils.Maybe exposing (isJust) 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) @@ -35,21 +38,39 @@ textInput translations form formName fieldName = ] [ Input.textInput field - [ id (formName ++ fieldName) + [ id fieldId , classList [ ("filled", isJust field.value) ] + , value (Maybe.withDefault "" field.value) ] , label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) ] + [ for fieldId ] + [ text (Translations.getMessage translations fieldId) ] , button - [ type' "button" - , onClick (Form.Input fieldName Field.EmptyField) + [ type_ "button" + , onClick (Form.Input fieldName Form.Text Field.EmptyField) , tabindex -1 ] [ FontAwesome.times Color.silver 15 ] - , case field.liveError of - Just error -> formError translations error - Nothing -> text "" + , 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", 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 @@ -67,9 +88,7 @@ radioInputs translations form formName radioName fieldNames = , div [ class "radioInputs" ] (List.map (radioInput translations field formName) fieldNames) - , case field.liveError of - Just error -> formError translations error - Nothing -> text "" + , formError translations field ] radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg @@ -89,17 +108,41 @@ radioInput translations field formName fieldName = ] ] -formError : Translations -> FormError.Error String -> Html msg -formError translations 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) [] +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", 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 = diff --git a/src/client/elm/View/Header.elm b/src/client/elm/View/Header.elm index 08a429f..12fb87c 100644 --- a/src/client/elm/View/Header.elm +++ b/src/client/elm/View/Header.elm @@ -37,6 +37,7 @@ view model = LoggedInView { me, users } -> [ item Home "PaymentsTitle" , item Income "Income" + , item Categories "Categories" , item Statistics "Statistics" , div [ class "nameSignOut" ] diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs new file mode 100644 index 0000000..19109a3 --- /dev/null +++ b/src/server/Controller/Category.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Category + ( create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty hiding (delete) + +import Json (jsonId) +import Model.Database +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 Secure + +create :: Json.CreateCategory -> ActionM () +create (Json.CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . runDb $ Category.create name color) >>= jsonId + ) + +edit :: Json.EditCategory -> ActionM () +edit (Json.EditCategory categoryId name color) = + Secure.loggedAction (\_ -> do + updated <- liftIO . runDb $ Category.edit categoryId name color + if updated + then status ok200 + else status badRequest400 + ) + +delete :: Text -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . runDb $ do + paymentCategories <- PaymentCategory.listByCategory (textToKey categoryId) + if null paymentCategories + then Category.delete (textToKey categoryId) + else return False + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.pack . show $ Key.CategoryNotDeleted + ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index abb3b17..96d0a49 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -1,18 +1,18 @@ module Controller.Index - ( getIndex + ( get , signOut ) where import Control.Monad.IO.Class (liftIO) -import Web.Scotty +import Web.Scotty hiding (get) import Network.HTTP.Types.Status (ok200) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Database.Persist hiding (Key) +import Database.Persist hiding (Key, get) import Conf (Conf(..)) import qualified LoginSession @@ -28,8 +28,8 @@ import Model.Init (getInit) import View.Page (page) -getIndex :: Conf -> Maybe Text -> ActionM () -getIndex conf mbToken = do +get :: Conf -> Maybe Text -> ActionM () +get conf mbToken = do initResult <- case mbToken of Just token -> do userOrError <- validateSignIn conf token diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index 9155a78..e3f1082 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -23,6 +23,7 @@ import Json (jsonId) import Model.Database import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Json.CreatePayment as Json import qualified Model.Json.EditPayment as Json @@ -33,15 +34,27 @@ list = ) create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date frequency) = +create (Json.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . runDb $ Payment.create (entityKey user) name cost date frequency) >>= jsonId + (liftIO . runDb $ do + PaymentCategory.set name category + Payment.create (entityKey user) name cost date frequency + ) >>= jsonId ) editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date frequency) = +editOwn (Json.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do - updated <- liftIO . runDb $ Payment.editOwn (entityKey user) paymentId name cost date frequency + updated <- liftIO . runDb $ do + mbPayment <- fmap entityVal <$> Payment.find paymentId + case mbPayment of + Just payment -> do + edited <- Payment.editOwn (entityKey user) paymentId name cost date frequency + if edited + then PaymentCategory.edit (paymentName payment) name category >> return True + else return edited + _ -> + return False if updated then status ok200 else status badRequest400 diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs index 1baab18..d8604ac 100644 --- a/src/server/Controller/User.hs +++ b/src/server/Controller/User.hs @@ -2,7 +2,6 @@ module Controller.User ( getUsers - , whoAmI ) where import Web.Scotty @@ -12,16 +11,10 @@ import Control.Monad.IO.Class (liftIO) import qualified Secure import Model.Database -import qualified Model.User as U +import qualified Model.User as User getUsers :: ActionM () getUsers = Secure.loggedAction (\_ -> - (liftIO $ map U.getJsonUser <$> runDb U.getUsers) >>= json - ) - -whoAmI :: ActionM () -whoAmI = - Secure.loggedAction (\user -> - json (U.getJsonUser user) + (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json ) diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs index a532ac8..4e2b8cc 100644 --- a/src/server/Design/Constants.hs +++ b/src/server/Design/Constants.hs @@ -2,13 +2,13 @@ module Design.Constants where import Clay -iconFontSize :: Size Abs +iconFontSize :: Size LengthUnit iconFontSize = px 32 -radius :: Size Abs +radius :: Size LengthUnit radius = px 3 -blockPadding :: Size Abs +blockPadding :: Size LengthUnit blockPadding = px 15 blockPercentWidth :: Double diff --git a/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs index 2320c45..4678633 100644 --- a/src/server/Design/Dialog.hs +++ b/src/server/Design/Dialog.hs @@ -14,8 +14,11 @@ design = do ".content" ? do minWidth (px 270) - ".paymentDialog" ? do - ".radioGroup" ? ".title" ? display none + ".paymentDialog" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do h1 ? marginBottom (em 1.5) diff --git a/src/server/Design/Form.hs b/src/server/Design/Form.hs index 3043125..ebb8ac8 100644 --- a/src/server/Design/Form.hs +++ b/src/server/Design/Form.hs @@ -18,6 +18,10 @@ design = do let inputPaddingBottom = 3 let inputZIndex = 1 + label ? do + cursor pointer + color Color.silver + ".textInput" ? do position relative marginBottom (em 1.5) @@ -44,7 +48,6 @@ design = do position absolute top (px inputTop) left (px 0) - color Color.silver transition "all" (sec 0.2) easeIn (sec 0) button ? do @@ -68,6 +71,15 @@ design = do color Color.chestnutRose fontSize (pct 80) + ".colorInput" ? do + display flex + alignItems center + marginBottom (em 1.5) + + input ? do + borderColor transparent + backgroundColor transparent + ".radioGroup" ? do position relative marginBottom (em 2) @@ -90,11 +102,29 @@ design = do width (px 30) margin (px 0) (px (-15)) (px 0) (px (-15)) - label ? cursor pointer - "input:focus + label" ? do textDecoration underline "input:checked + label" ? do color Color.chestnutRose fontWeight bold + + ".selectInput" ? do + label ? do + display block + marginBottom (px 10) + fontSize (pct 80) + select ? do + backgroundColor Color.white + border solid (px 1) Color.silver + sym borderRadius (px 3) + sym2 padding (px 5) (px 8) + option ? do + firstChild & display none + sym2 padding (px 5) (px 8) + ".error" & do + select ? borderColor Color.chestnutRose + ".errorMessage" ? do + color Color.chestnutRose + fontSize (pct 80) + marginTop (em 0.5) diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index f25cf05..869616d 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -17,13 +17,12 @@ import Data.Monoid ((<>)) import Design.Constants import Design.Color as Color -import qualified Clay.Display as D clearFix :: Css clearFix = after & do content (stringContent "") - display D.table + display displayTable clear both button :: Color -> Color -> Size a -> (Color -> Color) -> Css @@ -40,7 +39,7 @@ button backgroundCol textCol h focusOp = do hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) -iconButton :: Color -> Color -> Size Abs -> (Color -> Color) -> Css +iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css iconButton backgroundCol textCol h focusOp = do button backgroundCol textCol h focusOp i <> span ? do diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/LoggedIn.hs index 2899fa4..4a21832 100644 --- a/src/server/Design/LoggedIn.hs +++ b/src/server/Design/LoggedIn.hs @@ -7,16 +7,39 @@ module Design.LoggedIn import Clay import qualified Design.LoggedIn.Home as Home -import qualified Design.LoggedIn.Income as Income import qualified Design.LoggedIn.Stat as Stat import qualified Design.LoggedIn.Table as Table +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + design :: Css design = do ".home" ? Home.design - ".income" ? Income.design ".stat" ? Stat.design Table.design - ".textual" ? do + ".withMargin" ? do "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/LoggedIn/Home/Table.hs index 73ced3a..cb46ac9 100644 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ b/src/server/Design/LoggedIn/Home/Table.hs @@ -11,17 +11,20 @@ import qualified Design.Media as Media design :: Css design = do ".cell" ? do - ".category" & do - Media.tabletDesktop $ width (pct 36) + ".name" & do + Media.tabletDesktop $ width (pct 30) ".cost" & do - Media.tabletDesktop $ width (pct 15) + Media.tabletDesktop $ width (pct 10) ".user" & do - Media.tabletDesktop $ width (pct 20) + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) ".date" & do - Media.tabletDesktop $ width (pct 20) + Media.tabletDesktop $ width (pct 15) Media.desktop $ do ".shortDate" ? display none ".longDate" ? display inline diff --git a/src/server/Design/LoggedIn/Income.hs b/src/server/Design/LoggedIn/Income.hs deleted file mode 100644 index c44c67b..0000000 --- a/src/server/Design/LoggedIn/Income.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Income - ( design - ) where - -import Clay - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = - ".monthlyNetIncomes" ? do - - h1 ? do - Media.tabletDesktop $ float floatLeft - - ".addIncome" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs index 1af5e2b..44b001a 100644 --- a/src/server/Design/LoggedIn/Table.hs +++ b/src/server/Design/LoggedIn/Table.hs @@ -7,7 +7,6 @@ module Design.LoggedIn.Table import Data.Monoid ((<>)) import Clay -import qualified Clay.Display as D import Design.Color as Color import qualified Design.Media as Media @@ -19,7 +18,7 @@ design = do textAlign (alignSide sideCenter) ".lines" ? do - Media.tabletDesktop $ display D.table + Media.tabletDesktop $ display displayTable width (pct 100) textAlign (alignSide (sideCenter)) diff --git a/src/server/Design/Media.hs b/src/server/Design/Media.hs index d61a8e1..77220ee 100644 --- a/src/server/Design/Media.hs +++ b/src/server/Design/Media.hs @@ -29,8 +29,8 @@ desktop = query [Media.minWidth tabletDesktopLimit] query :: [Feature] -> Css -> Css query = Clay.query Media.screen -mobileTabletLimit :: Size Abs +mobileTabletLimit :: Size LengthUnit mobileTabletLimit = (px 520) -tabletDesktopLimit :: Size Abs +tabletDesktopLimit :: Size LengthUnit tabletDesktopLimit = (px 950) diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs index 0d1eb35..5cde3e9 100644 --- a/src/server/Job/WeeklyReport.hs +++ b/src/server/Job/WeeklyReport.hs @@ -7,7 +7,7 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Model.Database (runDb) import qualified Model.Payment as Payment import qualified Model.Income as Income -import Model.User (getUsers) +import qualified Model.User as User import SendMail @@ -25,7 +25,7 @@ weeklyReport conf mbLastExecution = do (,,) <$> Payment.modifiedDuring lastExecution now <*> Income.modifiedDuring lastExecution now <*> - getUsers + User.list _ <- sendMail (mail conf users payments incomes lastExecution now) return () return now diff --git a/src/server/Main.hs b/src/server/Main.hs index 2ce8115..b7764c9 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -8,10 +8,11 @@ import Job.Daemon (runDaemons) import qualified Data.Text.Lazy as LT -import Controller.Index -import Controller.SignIn -import Controller.Payment as Payment -import Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.SignIn as SignIn +import qualified Controller.Payment as Payment +import qualified Controller.Income as Income +import qualified Controller.Category as Category import Model.Database (runMigrations) @@ -27,14 +28,14 @@ main = do get "/" $ do signInToken <- mbParam "signInToken" - getIndex conf signInToken + Index.get conf signInToken post "/signIn" $ do email <- param "email" - signIn conf email + SignIn.signIn conf email post "/signOut" $ - signOut conf + Index.signOut conf post "/payment" $ jsonData >>= Payment.create @@ -56,5 +57,15 @@ main = do incomeId <- param "id" Income.deleteOwn incomeId + post "/category" $ + jsonData >>= Category.create + + put "/category" $ + jsonData >>= Category.edit + + delete "/category" $ do + categoryId <- param "id" + Category.delete categoryId + mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs new file mode 100644 index 0000000..50c3622 --- /dev/null +++ b/src/server/Model/Category.hs @@ -0,0 +1,56 @@ +module Model.Category + ( list + , create + , edit + , delete + ) where + +import Data.Text (Text) +import Data.Maybe (isJust) +import Data.Time.Clock (getCurrentTime) + +import Control.Monad.IO.Class (liftIO) + +import Database.Persist hiding (delete) + +import Model.Database +import qualified Model.Json.Category as Json + +list :: Persist [Json.Category] +list = map getJsonCategory <$> selectList [ CategoryDeletedAt ==. Nothing ] [] + +getJsonCategory :: Entity Category -> Json.Category +getJsonCategory categoryEntity = + Json.Category (entityKey categoryEntity) (categoryName category) (categoryColor category) + where category = entityVal categoryEntity + +create :: Text -> Text -> Persist CategoryId +create name color = do + now <- liftIO getCurrentTime + insert (Category name color now Nothing Nothing) + +edit :: CategoryId -> Text -> Text -> Persist Bool +edit categoryId name color = do + mbCategory <- get categoryId + if isJust mbCategory + then do + now <- liftIO getCurrentTime + update categoryId + [ CategoryEditedAt =. Just now + , CategoryName =. name + , CategoryColor =. color + ] + return True + else + return False + +delete :: CategoryId -> Persist Bool +delete categoryId = do + mbCategory <- get categoryId + if isJust mbCategory + then do + now <- liftIO getCurrentTime + update categoryId [CategoryDeletedAt =. Just now] + return True + else + return False diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 7f8326e..ba302de 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -46,6 +46,20 @@ Payment editedAt UTCTime Maybe deletedAt UTCTime Maybe deriving Show +Category + name Text + color Text + createdAt UTCTime + editedAt UTCTime Maybe + deletedAt UTCTime Maybe + deriving Show +PaymentCategory + name Text + category CategoryId + createdAt UTCTime + editedAt UTCTime Maybe + UniqPaymentCategoryName name + deriving Show SignIn token Text creation UTCTime diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index b7dd11c..ff6accd 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,6 +1,5 @@ module Model.Income - ( getJsonIncome - , getIncomes + ( list , create , editOwn , deleteOwn @@ -17,14 +16,14 @@ import Database.Persist import Model.Database import qualified Model.Json.Income as Json +list :: Persist [Json.Income] +list = map getJsonIncome <$> selectList [IncomeDeletedAt ==. Nothing] [] + getJsonIncome :: Entity Income -> Json.Income getJsonIncome incomeEntity = Json.Income (entityKey incomeEntity) (incomeUserId income) (incomeDate income) (incomeAmount income) where income = entityVal incomeEntity -getIncomes :: Persist [Entity Income] -getIncomes = selectList [IncomeDeletedAt ==. Nothing] [] - create :: UserId -> Day -> Int -> Persist IncomeId create userId date amount = do now <- liftIO getCurrentTime diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 09ac627..7610b25 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -10,22 +10,21 @@ import Database.Persist import Model.Database -import Model.Json.Init (Init, Init(Init)) +import Model.Json.Init (Init) import qualified Model.Payment as Payment -import Model.User (getUsers, getJsonUser) -import Model.Income (getIncomes, getJsonIncome) +import qualified Model.User as User +import qualified Model.Income as Income +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Json.Init as Init getInit :: Entity User -> Persist Init getInit user = - liftIO . runDb $ do - users <- getUsers - payments <- Payment.list - incomes <- getIncomes - return $ Init - { Init.users = map getJsonUser users - , Init.me = entityKey user - , Init.payments = payments - , Init.incomes = map getJsonIncome incomes - } + liftIO . runDb $ Init.Init <$> + (map User.getJson <$> User.list) <*> + (return . entityKey $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs new file mode 100644 index 0000000..daad4c2 --- /dev/null +++ b/src/server/Model/Json/Category.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.Category + ( Category(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +import Model.Database (CategoryId) + +data Category = Category + { id :: CategoryId + , name :: Text + , color :: Text + } deriving (Show, Generic) + +instance ToJSON Category diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs new file mode 100644 index 0000000..fffc882 --- /dev/null +++ b/src/server/Model/Json/CreateCategory.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.CreateCategory + ( CreateCategory(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +data CreateCategory = CreateCategory + { name :: Text + , color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategory diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs index 4ba9e1a..5bc6b47 100644 --- a/src/server/Model/Json/CreatePayment.hs +++ b/src/server/Model/Json/CreatePayment.hs @@ -10,12 +10,14 @@ import Data.Aeson import Data.Time.Calendar (Day) import Data.Text (Text) +import Model.Database (CategoryId) import Model.Frequency (Frequency) data CreatePayment = CreatePayment { name :: Text , cost :: Int , date :: Day + , category :: CategoryId , frequency :: Frequency } deriving (Show, Generic) diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs new file mode 100644 index 0000000..bda3418 --- /dev/null +++ b/src/server/Model/Json/EditCategory.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.EditCategory + ( EditCategory(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +import Model.Database (CategoryId) + +data EditCategory = EditCategory + { id :: CategoryId + , name :: Text + , color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs index 4e91000..35f44e5 100644 --- a/src/server/Model/Json/EditPayment.hs +++ b/src/server/Model/Json/EditPayment.hs @@ -11,13 +11,14 @@ import Data.Time.Calendar (Day) import Data.Text (Text) import Model.Frequency (Frequency) -import Model.Database (PaymentId) +import Model.Database (PaymentId, CategoryId) data EditPayment = EditPayment { id :: PaymentId , name :: Text , cost :: Int , date :: Day + , category :: CategoryId , frequency :: Frequency } deriving (Show, Generic) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs index 5e6d2a2..b9f7f40 100644 --- a/src/server/Model/Json/Init.hs +++ b/src/server/Model/Json/Init.hs @@ -13,6 +13,8 @@ import Model.Database (UserId) import Model.Json.User (User) import Model.Json.Payment (Payment) import Model.Json.Income (Income) +import Model.Json.Category (Category) +import Model.Json.PaymentCategory (PaymentCategory) import Model.Message.Key (Key) data Init = Init @@ -20,6 +22,8 @@ data Init = Init , me :: UserId , payments :: [Payment] , incomes :: [Income] + , categories :: [Category] + , paymentCategories :: [PaymentCategory] } deriving (Show, Generic) instance ToJSON Init diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs new file mode 100644 index 0000000..edd4388 --- /dev/null +++ b/src/server/Model/Json/PaymentCategory.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Model.Json.PaymentCategory + ( PaymentCategory(..) + ) where + +import GHC.Generics + +import Data.Aeson +import Data.Text (Text) + +import Model.Database (CategoryId) + +data PaymentCategory = PaymentCategory + { name :: Text + , category :: CategoryId + } deriving (Show, Generic) + +instance ToJSON PaymentCategory diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index d00d8b8..36b3ba0 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -77,6 +77,8 @@ data Key = | PaymentName | PaymentCost + | PaymentDate + | PaymentCategory | PaymentPunctual | PaymentMonthly @@ -85,6 +87,20 @@ data Key = | Delete | ConfirmPaymentDelete + -- Categories + + | Categories + | NoCategories + | CategoryNotDeleted + | AddCategory + | CloneCategory + | EditCategory + | ConfirmCategoryDelete + | CategoryName + | CategoryColor + | Color + | UsedCategory + -- Statistics | Statistics @@ -94,6 +110,7 @@ data Key = -- Income | CumulativeIncomesSince + | NoIncome | Income | MonthlyNetIncomes | AddIncome @@ -101,6 +118,7 @@ data Key = | EditIncome | IncomeNotDeleted | IncomeAmount + | IncomeDate | ConfirmIncomeDelete | Add @@ -110,6 +128,7 @@ data Key = | InvalidString | InvalidDate | InvalidInt + | InvalidCategory | SmallerIntThan | GreaterIntThan @@ -121,6 +140,9 @@ data Key = | CreateIncomeError | EditIncomeError | DeleteIncomeError + | CreateCategoryError + | EditCategoryError + | DeleteCategoryError | SignOutError -- Dialog @@ -128,6 +150,10 @@ data Key = | Confirm | Undo + -- Page not found + + | PageNotFound + -- Weekly report | WeeklyReport @@ -151,9 +177,10 @@ data Key = -- Http error + | BadUrl | Timeout | NetworkError - | UnexpectedPayload + | BadPayload deriving (Enum, Bounded, Show) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index 23e3a6c..6565344 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -295,6 +295,63 @@ m l NoPayment = English -> "No payment found from your search criteria." French -> "Aucun paiement ne correspond à vos critères de recherches." +-- Categories + +m l Categories = + case l of + English -> "Categories" + French -> "Catégories" + +m l NoCategories = + case l of + English -> "No category." + French -> "Aucune catégorie." + +m l CategoryNotDeleted = + case l of + English -> "The category could not have been deleted." + French -> "La catégorie n'a pas pu être supprimé." + +m l AddCategory = + case l of + English -> "Add an category" + French -> "Ajouter une catégorie" + +m l CloneCategory = + case l of + English -> "Clone an category" + French -> "Cloner une catégorie" + +m l EditCategory = + case l of + English -> "Edit an category" + French -> "Modifier une catégorie" + +m l ConfirmCategoryDelete = + case l of + English -> "Are you sure to delete this category ?" + French -> "Voulez-vous vraiment supprimer cette catégorie ?" + +m l CategoryName = + case l of + English -> "Name" + French -> "Nom" + +m l CategoryColor = + case l of + English -> "Color" + French -> "Couleur" + +m l Color = + case l of + English -> "Color" + French -> "Couleur" + +m l UsedCategory = + case l of + English -> "This category is currently being used" + French -> "Cette catégorie est utilisée actuellement" + -- Statistics m l Statistics = @@ -322,6 +379,16 @@ m l PaymentCost = English -> "Cost" French -> "Coût" +m l PaymentDate = + case l of + English -> "Date" + French -> "Date" + +m l PaymentCategory = + case l of + English -> "Category" + French -> "Catégorie" + m l PaymentPunctual = case l of English -> "Punctual" @@ -359,6 +426,11 @@ m l CumulativeIncomesSince = English -> "Cumulative incomes since {1}" French -> "Revenus nets cumulés depuis le {1}" +m l NoIncome = + case l of + English -> "No income." + French -> "Aucun revenu." + m l Income = case l of English -> "Income" @@ -394,6 +466,11 @@ m l IncomeAmount = English -> "Amount" French -> "Montant" +m l IncomeDate = + case l of + English -> "Date" + French -> "Date" + m l ConfirmIncomeDelete = case l of English -> "Are you sure to delete this income ?" @@ -426,6 +503,11 @@ m l InvalidInt = English -> "Integer required" French -> "Entier requis" +m l InvalidCategory = + case l of + English -> "Invalid category" + French -> "Catégorie invalide" + m l SmallerIntThan = case l of English -> "Integer bigger than {1} or equal required" @@ -468,6 +550,21 @@ m l DeleteIncomeError = English -> "Error at income deletion" French -> "Erreur lors de la suppression du revenu" +m l CreateCategoryError = + case l of + English -> "Error at category creation" + French -> "Erreur lors de la création de la catégorie" + +m l EditCategoryError = + case l of + English -> "Error at category edition" + French -> "Erreur lors de la modification de la catégorie" + +m l DeleteCategoryError = + case l of + English -> "Error at category deletion" + French -> "Erreur lors de la suppression de la catégorie" + m l SignOutError = case l of English -> "Error at sign out" @@ -485,6 +582,13 @@ m l Undo = English -> "Undo" French -> "Annuler" +-- Page not found + +m l PageNotFound = + case l of + English -> "Page not found" + French -> "Page introuvable" + -- Weekly report m l WeeklyReport = @@ -579,6 +683,11 @@ m l IsNotPayedFrom = -- Http error +m l BadUrl = + case l of + English -> "URL not valid" + French -> "l'URL n'est pas valide" + m l Timeout = case l of English -> "Timeout server error" @@ -589,7 +698,7 @@ m l NetworkError = English -> "Network can not be reached" French -> "Le serveur n'est pas accessible" -m l UnexpectedPayload = +m l BadPayload = case l of - English -> "Unexpected payload server error" - French -> "Contenu inattendu du en provenance du serveur" + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index ac6cf0a..d8caaa8 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Model.Payment - ( list + ( find + , list , listMonthly , create , editOwn @@ -22,11 +23,11 @@ import Model.Database import Model.Frequency import qualified Model.Json.Payment as P +find :: PaymentId -> Persist (Maybe (Entity Payment)) +find paymentId = selectFirst [ PaymentId ==. paymentId ] [] + list :: Persist [P.Payment] -list = - map getJsonPayment <$> selectList - [ PaymentDeletedAt ==. Nothing ] - [] +list = map getJsonPayment <$> selectList [ PaymentDeletedAt ==. Nothing ] [] listMonthly :: Persist [Entity Payment] listMonthly = diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs new file mode 100644 index 0000000..6df77e2 --- /dev/null +++ b/src/server/Model/PaymentCategory.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.PaymentCategory + ( list + , listByCategory + , set + , edit + , delete + ) where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import qualified Data.Text as T + +import Control.Monad.IO.Class (liftIO) + +import Database.Persist + +import Model.Database +import qualified Model.Json.PaymentCategory as Json +import qualified Utils.Text as T + +list :: Persist [Json.PaymentCategory] +list = map getJsonPaymentCategory <$> selectList [] [] + +listByCategory :: CategoryId -> Persist [Entity PaymentCategory] +listByCategory category = selectList [ PaymentCategoryCategory ==. category ] [] + +getJsonPaymentCategory :: Entity PaymentCategory -> Json.PaymentCategory +getJsonPaymentCategory entity = + Json.PaymentCategory (paymentCategoryName pc) (paymentCategoryCategory pc) + where pc = entityVal entity + +set :: Text -> CategoryId -> Persist () +set name category = edit name name category + +edit :: Text -> Text -> CategoryId -> Persist () +edit oldName newName category = do + now <- liftIO getCurrentTime + mbPaymentCategory <- selectFirst [PaymentCategoryName ==. (formatPaymentName oldName)] [] + if isJust mbPaymentCategory + then + updateWhere + [ PaymentCategoryName ==. (formatPaymentName oldName) ] + [ PaymentCategoryName =. (formatPaymentName newName) + , PaymentCategoryCategory =. category + , PaymentCategoryEditedAt =. Just now + ] + else do + _ <- insert $ PaymentCategory (formatPaymentName newName) category now Nothing + return () + +formatPaymentName :: Text -> Text +formatPaymentName = T.unaccent . T.toLower diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index 696ef4f..ab39822 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,8 +1,8 @@ module Model.User - ( getUsers + ( list , getUser + , getJson , findUser - , getJsonUser , createUser , deleteUser ) where @@ -18,8 +18,8 @@ import Database.Persist import Model.Database import qualified Model.Json.User as Json -getUsers :: Persist [Entity User] -getUsers = selectList [] [Desc UserCreation] +list :: Persist [Entity User] +list = selectList [] [Desc UserCreation] getUser :: Text -> Persist (Maybe (Entity User)) getUser email = selectFirst [UserEmail ==. email] [] @@ -27,8 +27,8 @@ getUser email = selectFirst [UserEmail ==. email] [] findUser :: UserId -> [Entity User] -> Maybe User findUser i = fmap entityVal . find ((==) i . entityKey) -getJsonUser :: Entity User -> Json.User -getJsonUser userEntity = +getJson :: Entity User -> Json.User +getJson userEntity = let user = entityVal userEntity in Json.User (entityKey userEntity) (userName user) (userEmail user) diff --git a/src/server/Utils/Text.hs b/src/server/Utils/Text.hs new file mode 100644 index 0000000..5ed77e4 --- /dev/null +++ b/src/server/Utils/Text.hs @@ -0,0 +1,41 @@ +module Utils.Text + ( unaccent + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +unaccent :: Text -> Text +unaccent = T.map unaccentChar + +unaccentChar :: Char -> Char +unaccentChar c = case c of + 'à' -> 'a' + 'á' -> 'a' + 'â' -> 'a' + 'ã' -> 'a' + 'ä' -> 'a' + 'ç' -> 'c' + 'è' -> 'e' + 'é' -> 'e' + 'ê' -> 'e' + 'ë' -> 'e' + 'ì' -> 'i' + 'í' -> 'i' + 'î' -> 'i' + 'ï' -> 'i' + 'ñ' -> 'n' + 'ò' -> 'o' + 'ó' -> 'o' + 'ô' -> 'o' + 'õ' -> 'o' + 'ö' -> 'o' + 'š' -> 's' + 'ù' -> 'u' + 'ú' -> 'u' + 'û' -> 'u' + 'ü' -> 'u' + 'ý' -> 'y' + 'ÿ' -> 'y' + 'ž' -> 'z' + _ -> c diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index f76fb0e..e33459c 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -48,7 +48,7 @@ body conf users paymentsByStatus incomesByStatus = then getMessage K.WeeklyReportEmpty else - T.intercalate "\n\n" . catMaybes . concat $ + T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses ] @@ -119,6 +119,6 @@ section :: Text -> [Text] -> Text section title items = T.concat [ title - , "\n" + , "\n\n" , T.unlines . map (" - " <>) $ items ] diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..b72f9a0 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-8.3 +extra-deps: +- config-manager-0.3.0.1 |