From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Sep 2017 22:14:48 +0200 Subject: Bootstrap with GHCJS and reflex: - setup login and logout, - first draft of payment view. --- .gitignore | 12 +- Makefile | 25 +- README.md | 25 +- elm-package.json | 26 - public/javascript/.gitkeep | 0 public/javascripts/.gitkeep | 0 public/javascripts/main.js | 17 - sharedCost.cabal | 44 +- shell.nix | 6 +- src/client/Chart/Api.elm | 41 -- src/client/Chart/Model.elm | 73 --- src/client/Chart/View.elm | 182 ------ src/client/Common | 1 + src/client/Component/Button.hs | 53 ++ src/client/Component/Input.hs | 34 + src/client/Debug.hs | 17 + src/client/Dialog.elm | 165 ----- src/client/Dialog/AddCategory/Model.elm | 54 -- src/client/Dialog/AddCategory/View.elm | 72 --- src/client/Dialog/AddIncome/Model.elm | 53 -- src/client/Dialog/AddIncome/View.elm | 72 --- src/client/Dialog/AddPayment/Model.elm | 70 --- src/client/Dialog/AddPayment/View.elm | 95 --- src/client/Dialog/Model.elm | 23 - src/client/Dialog/Msg.elm | 15 - src/client/Dialog/Update.elm | 74 --- src/client/Icon.hs | 44 ++ src/client/Init.elm | 30 - src/client/LoggedData.elm | 44 -- src/client/LoggedIn/Category/Table.elm | 123 ---- src/client/LoggedIn/Category/View.elm | 34 - src/client/LoggedIn/Home/Header/View.elm | 105 ---- src/client/LoggedIn/Home/Model.elm | 44 -- src/client/LoggedIn/Home/Msg.elm | 13 - src/client/LoggedIn/Home/Update.elm | 44 -- src/client/LoggedIn/Home/View.elm | 43 -- src/client/LoggedIn/Home/View/ExceedingPayers.elm | 45 -- src/client/LoggedIn/Home/View/Paging.elm | 109 ---- src/client/LoggedIn/Home/View/Table.elm | 167 ----- src/client/LoggedIn/Income/Table.elm | 128 ---- src/client/LoggedIn/Income/View.elm | 104 --- src/client/LoggedIn/Model.elm | 38 -- src/client/LoggedIn/Msg.elm | 26 - src/client/LoggedIn/Stat/Model.elm | 34 - src/client/LoggedIn/Stat/Msg.elm | 7 - src/client/LoggedIn/Stat/Update.elm | 24 - src/client/LoggedIn/Stat/View.elm | 77 --- src/client/LoggedIn/Update.elm | 137 ---- src/client/LoggedIn/View.elm | 33 - src/client/LoggedIn/View/Format.elm | 37 -- src/client/Main.elm | 26 - src/client/Main.hs | 41 ++ src/client/Model.elm | 72 --- src/client/Model/Category.elm | 35 -- src/client/Model/Conf.elm | 13 - src/client/Model/Date.elm | 15 - src/client/Model/Frequency.elm | 36 -- src/client/Model/Income.elm | 101 --- src/client/Model/Init.elm | 31 - src/client/Model/InitResult.elm | 28 - src/client/Model/Payer.elm | 137 ---- src/client/Model/Payment.elm | 117 ---- src/client/Model/PaymentCategory.elm | 61 -- src/client/Model/Size.elm | 17 - src/client/Model/Translations.elm | 68 -- src/client/Model/User.elm | 44 -- src/client/Model/View.elm | 12 - src/client/Msg.elm | 49 -- src/client/Page.elm | 43 -- src/client/Server.elm | 115 ---- src/client/SignIn/Model.elm | 17 - src/client/SignIn/Msg.elm | 9 - src/client/SignIn/Update.elm | 31 - src/client/SignIn/View.elm | 63 -- src/client/Tooltip.elm | 113 ---- src/client/Update.elm | 182 ------ src/client/Utils/Cmd.elm | 16 - src/client/Utils/Dict.elm | 11 - src/client/Utils/Either.elm | 9 - src/client/Utils/Form.elm | 11 - src/client/Utils/Http.elm | 39 -- src/client/Utils/Json.elm | 12 - src/client/Utils/List.elm | 36 -- src/client/Utils/Search.elm | 10 - src/client/Utils/String.elm | 38 -- src/client/Validation.elm | 65 -- src/client/View.elm | 34 - src/client/View/App.hs | 44 ++ src/client/View/Color.elm | 12 - src/client/View/Date.elm | 57 -- src/client/View/Errors.elm | 21 - src/client/View/Events.elm | 15 - src/client/View/Form.elm | 152 ----- src/client/View/Header.elm | 60 -- src/client/View/Header.hs | 86 +++ src/client/View/Payment.hs | 33 + src/client/View/Payment/Table.hs | 90 +++ src/client/View/Plural.elm | 11 - src/client/View/SignIn.hs | 86 +++ src/common/Message.hs | 12 + src/common/Message/Key.hs | 152 +++++ src/common/Message/Lang.hs | 7 + src/common/Message/Translation.hs | 697 +++++++++++++++++++++ src/common/Model.hs | 40 ++ src/common/Model/Category.hs | 26 + src/common/Model/CreateCategory.hs | 16 + src/common/Model/CreateIncome.hs | 16 + src/common/Model/CreatePayment.hs | 23 + src/common/Model/Currency.hs | 14 + src/common/Model/EditCategory.hs | 19 + src/common/Model/EditIncome.hs | 19 + src/common/Model/EditPayment.hs | 25 + src/common/Model/Frequency.hs | 16 + src/common/Model/Income.hs | 29 + src/common/Model/Init.hs | 28 + src/common/Model/InitResult.hs | 19 + src/common/Model/Payment.hs | 33 + src/common/Model/PaymentCategory.hs | 27 + src/common/Model/SignIn.hs | 16 + src/common/Model/User.hs | 29 + src/common/Util/Text.hs | 41 ++ src/common/View/Format.hs | 69 ++ src/migrations/2.sql | 23 + src/server/Common | 1 + src/server/Conf.hs | 6 +- src/server/Controller/Category.hs | 12 +- src/server/Controller/Income.hs | 23 +- src/server/Controller/Index.hs | 30 +- src/server/Controller/Payment.hs | 25 +- src/server/Controller/SignIn.hs | 34 +- src/server/Controller/User.hs | 20 - src/server/Design/Color.hs | 3 + src/server/Design/Global.hs | 11 +- src/server/Design/Header.hs | 74 --- src/server/Design/Helper.hs | 46 +- src/server/Design/LoggedIn.hs | 45 -- src/server/Design/LoggedIn/Home.hs | 17 - src/server/Design/LoggedIn/Home/Header.hs | 84 --- src/server/Design/LoggedIn/Home/Pages.hs | 54 -- src/server/Design/LoggedIn/Home/Table.hs | 37 -- src/server/Design/LoggedIn/Stat.hs | 15 - src/server/Design/LoggedIn/Table.hs | 84 --- src/server/Design/SignIn.hs | 40 -- src/server/Design/View/Header.hs | 78 +++ src/server/Design/View/Payment.hs | 17 + src/server/Design/View/Payment/Header.hs | 84 +++ src/server/Design/View/Payment/Pages.hs | 54 ++ src/server/Design/View/Payment/Table.hs | 42 ++ src/server/Design/View/SignIn.hs | 42 ++ src/server/Design/View/Stat.hs | 15 + src/server/Design/View/Table.hs | 84 +++ src/server/Design/Views.hs | 49 ++ src/server/Job/MonthlyPayment.hs | 11 +- src/server/Main.hs | 21 +- src/server/Model/Category.hs | 23 +- src/server/Model/Frequency.hs | 23 +- src/server/Model/Income.hs | 32 +- src/server/Model/Init.hs | 31 +- src/server/Model/Json/Category.hs | 24 - src/server/Model/Json/Conf.hs | 17 - src/server/Model/Json/CreateCategory.hs | 17 - src/server/Model/Json/CreateIncome.hs | 17 - src/server/Model/Json/CreatePayment.hs | 23 - src/server/Model/Json/EditCategory.hs | 19 - src/server/Model/Json/EditIncome.hs | 20 - src/server/Model/Json/EditPayment.hs | 25 - src/server/Model/Json/Income.hs | 26 - src/server/Model/Json/Init.hs | 36 -- src/server/Model/Json/MessagePart.hs | 18 - src/server/Model/Json/Number.hs | 15 - src/server/Model/Json/Payment.hs | 40 -- src/server/Model/Json/PaymentCategory.hs | 23 - src/server/Model/Json/Translation.hs | 20 - src/server/Model/Json/User.hs | 25 - src/server/Model/Message.hs | 35 -- src/server/Model/Message/Key.hs | 193 ------ src/server/Model/Message/Lang.hs | 11 - src/server/Model/Message/Parts.hs | 37 -- src/server/Model/Message/Translations.hs | 729 ---------------------- src/server/Model/Payer.hs | 216 +++++++ src/server/Model/Payment.hs | 59 +- src/server/Model/PaymentCategory.hs | 24 +- src/server/Model/User.hs | 31 +- src/server/Secure.hs | 13 +- src/server/Utils/Text.hs | 41 -- src/server/Utils/Time.hs | 19 - src/server/View/Format.hs | 33 - src/server/View/Mail/SignIn.hs | 11 +- src/server/View/Mail/WeeklyReport.hs | 110 ++-- src/server/View/Page.hs | 23 +- stack.yaml | 3 - 191 files changed, 2928 insertions(+), 6851 deletions(-) delete mode 100644 elm-package.json create mode 100644 public/javascript/.gitkeep delete mode 100644 public/javascripts/.gitkeep delete mode 100644 public/javascripts/main.js delete mode 100644 src/client/Chart/Api.elm delete mode 100644 src/client/Chart/Model.elm delete mode 100644 src/client/Chart/View.elm create mode 120000 src/client/Common create mode 100644 src/client/Component/Button.hs create mode 100644 src/client/Component/Input.hs create mode 100644 src/client/Debug.hs delete mode 100644 src/client/Dialog.elm delete mode 100644 src/client/Dialog/AddCategory/Model.elm delete mode 100644 src/client/Dialog/AddCategory/View.elm delete mode 100644 src/client/Dialog/AddIncome/Model.elm delete mode 100644 src/client/Dialog/AddIncome/View.elm delete mode 100644 src/client/Dialog/AddPayment/Model.elm delete mode 100644 src/client/Dialog/AddPayment/View.elm delete mode 100644 src/client/Dialog/Model.elm delete mode 100644 src/client/Dialog/Msg.elm delete mode 100644 src/client/Dialog/Update.elm create mode 100644 src/client/Icon.hs delete mode 100644 src/client/Init.elm delete mode 100644 src/client/LoggedData.elm delete mode 100644 src/client/LoggedIn/Category/Table.elm delete mode 100644 src/client/LoggedIn/Category/View.elm delete mode 100644 src/client/LoggedIn/Home/Header/View.elm delete mode 100644 src/client/LoggedIn/Home/Model.elm delete mode 100644 src/client/LoggedIn/Home/Msg.elm delete mode 100644 src/client/LoggedIn/Home/Update.elm delete mode 100644 src/client/LoggedIn/Home/View.elm delete mode 100644 src/client/LoggedIn/Home/View/ExceedingPayers.elm delete mode 100644 src/client/LoggedIn/Home/View/Paging.elm delete mode 100644 src/client/LoggedIn/Home/View/Table.elm delete mode 100644 src/client/LoggedIn/Income/Table.elm delete mode 100644 src/client/LoggedIn/Income/View.elm delete mode 100644 src/client/LoggedIn/Model.elm delete mode 100644 src/client/LoggedIn/Msg.elm delete mode 100644 src/client/LoggedIn/Stat/Model.elm delete mode 100644 src/client/LoggedIn/Stat/Msg.elm delete mode 100644 src/client/LoggedIn/Stat/Update.elm delete mode 100644 src/client/LoggedIn/Stat/View.elm delete mode 100644 src/client/LoggedIn/Update.elm delete mode 100644 src/client/LoggedIn/View.elm delete mode 100644 src/client/LoggedIn/View/Format.elm delete mode 100644 src/client/Main.elm create mode 100644 src/client/Main.hs delete mode 100644 src/client/Model.elm delete mode 100644 src/client/Model/Category.elm delete mode 100644 src/client/Model/Conf.elm delete mode 100644 src/client/Model/Date.elm delete mode 100644 src/client/Model/Frequency.elm delete mode 100644 src/client/Model/Income.elm delete mode 100644 src/client/Model/Init.elm delete mode 100644 src/client/Model/InitResult.elm delete mode 100644 src/client/Model/Payer.elm delete mode 100644 src/client/Model/Payment.elm delete mode 100644 src/client/Model/PaymentCategory.elm delete mode 100644 src/client/Model/Size.elm delete mode 100644 src/client/Model/Translations.elm delete mode 100644 src/client/Model/User.elm delete mode 100644 src/client/Model/View.elm delete mode 100644 src/client/Msg.elm delete mode 100644 src/client/Page.elm delete mode 100644 src/client/Server.elm delete mode 100644 src/client/SignIn/Model.elm delete mode 100644 src/client/SignIn/Msg.elm delete mode 100644 src/client/SignIn/Update.elm delete mode 100644 src/client/SignIn/View.elm delete mode 100644 src/client/Tooltip.elm delete mode 100644 src/client/Update.elm delete mode 100644 src/client/Utils/Cmd.elm delete mode 100644 src/client/Utils/Dict.elm delete mode 100644 src/client/Utils/Either.elm delete mode 100644 src/client/Utils/Form.elm delete mode 100644 src/client/Utils/Http.elm delete mode 100644 src/client/Utils/Json.elm delete mode 100644 src/client/Utils/List.elm delete mode 100644 src/client/Utils/Search.elm delete mode 100644 src/client/Utils/String.elm delete mode 100644 src/client/Validation.elm delete mode 100644 src/client/View.elm create mode 100644 src/client/View/App.hs delete mode 100644 src/client/View/Color.elm delete mode 100644 src/client/View/Date.elm delete mode 100644 src/client/View/Errors.elm delete mode 100644 src/client/View/Events.elm delete mode 100644 src/client/View/Form.elm delete mode 100644 src/client/View/Header.elm create mode 100644 src/client/View/Header.hs create mode 100644 src/client/View/Payment.hs create mode 100644 src/client/View/Payment/Table.hs delete mode 100644 src/client/View/Plural.elm create mode 100644 src/client/View/SignIn.hs create mode 100644 src/common/Message.hs create mode 100644 src/common/Message/Key.hs create mode 100644 src/common/Message/Lang.hs create mode 100644 src/common/Message/Translation.hs create mode 100644 src/common/Model.hs create mode 100644 src/common/Model/Category.hs create mode 100644 src/common/Model/CreateCategory.hs create mode 100644 src/common/Model/CreateIncome.hs create mode 100644 src/common/Model/CreatePayment.hs create mode 100644 src/common/Model/Currency.hs create mode 100644 src/common/Model/EditCategory.hs create mode 100644 src/common/Model/EditIncome.hs create mode 100644 src/common/Model/EditPayment.hs create mode 100644 src/common/Model/Frequency.hs create mode 100644 src/common/Model/Income.hs create mode 100644 src/common/Model/Init.hs create mode 100644 src/common/Model/InitResult.hs create mode 100644 src/common/Model/Payment.hs create mode 100644 src/common/Model/PaymentCategory.hs create mode 100644 src/common/Model/SignIn.hs create mode 100644 src/common/Model/User.hs create mode 100644 src/common/Util/Text.hs create mode 100644 src/common/View/Format.hs create mode 100644 src/migrations/2.sql create mode 120000 src/server/Common delete mode 100644 src/server/Controller/User.hs delete mode 100644 src/server/Design/Header.hs delete mode 100644 src/server/Design/LoggedIn.hs delete mode 100644 src/server/Design/LoggedIn/Home.hs delete mode 100644 src/server/Design/LoggedIn/Home/Header.hs delete mode 100644 src/server/Design/LoggedIn/Home/Pages.hs delete mode 100644 src/server/Design/LoggedIn/Home/Table.hs delete mode 100644 src/server/Design/LoggedIn/Stat.hs delete mode 100644 src/server/Design/LoggedIn/Table.hs delete mode 100644 src/server/Design/SignIn.hs create mode 100644 src/server/Design/View/Header.hs create mode 100644 src/server/Design/View/Payment.hs create mode 100644 src/server/Design/View/Payment/Header.hs create mode 100644 src/server/Design/View/Payment/Pages.hs create mode 100644 src/server/Design/View/Payment/Table.hs create mode 100644 src/server/Design/View/SignIn.hs create mode 100644 src/server/Design/View/Stat.hs create mode 100644 src/server/Design/View/Table.hs create mode 100644 src/server/Design/Views.hs delete mode 100644 src/server/Model/Json/Category.hs delete mode 100644 src/server/Model/Json/Conf.hs delete mode 100644 src/server/Model/Json/CreateCategory.hs delete mode 100644 src/server/Model/Json/CreateIncome.hs delete mode 100644 src/server/Model/Json/CreatePayment.hs delete mode 100644 src/server/Model/Json/EditCategory.hs delete mode 100644 src/server/Model/Json/EditIncome.hs delete mode 100644 src/server/Model/Json/EditPayment.hs delete mode 100644 src/server/Model/Json/Income.hs delete mode 100644 src/server/Model/Json/Init.hs delete mode 100644 src/server/Model/Json/MessagePart.hs delete mode 100644 src/server/Model/Json/Number.hs delete mode 100644 src/server/Model/Json/Payment.hs delete mode 100644 src/server/Model/Json/PaymentCategory.hs delete mode 100644 src/server/Model/Json/Translation.hs delete mode 100644 src/server/Model/Json/User.hs delete mode 100644 src/server/Model/Message.hs delete mode 100644 src/server/Model/Message/Key.hs delete mode 100644 src/server/Model/Message/Lang.hs delete mode 100644 src/server/Model/Message/Parts.hs delete mode 100644 src/server/Model/Message/Translations.hs create mode 100644 src/server/Model/Payer.hs delete mode 100644 src/server/Utils/Text.hs delete mode 100644 src/server/View/Format.hs delete mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index 4765b25..0650382 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,14 @@ database database-shm database-wal -elm-stuff/ -.stack-work -public/javascripts/client.js +dist +sharedCost.nix +public/javascript/main.js sessionKey local.conf +reflex-platform/ +*.js_hi +*.js_dyn_hi +*.js_o +*.js_dyn_o +Main.jsexe diff --git a/Makefile b/Makefile index a0458f1..5d695f2 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ start: - @nix-shell --command "mux local" + @nix-shell --command "tmuxinator local" stop: @tmux kill-session -t sharedCost @@ -15,31 +15,36 @@ build: build-server build-client # ------ clean-server: - @stack clean > /dev/null + @cabal clean install-server: - @stack setup + @cabal2nix --shell . > sharedCost.nix build-server: - @stack build || : + @nix-shell sharedCost.nix --command "cabal build" launch-server: - @(killall sharedCost || :) && stack exec sharedCost + @killall sharedCost || : + @cabal run sharedCost watch-server: - @nodemon -e hs,conf --exec 'clear && make build-server --silent && make launch-server' + @nodemon --watch src/server -e hs,conf --exec '(clear && make build-server && make launch-server) || :' # Client # ------ clean-client: - @rm -r elm-stuff >/dev/null 2>&1 || true + @rm -rf reflex-platform install-client: - @elm package install --yes + @git clone https://github.com/reflex-frp/reflex-platform 2>/dev/null || : + @cd reflex-platform && ./try-reflex --command exit >/dev/null + +build-client-inside: + @cd src/client && ghcjs -Wall -Werror --make Main && mv Main.jsexe/all.js ../../public/javascript/main.js build-client: - @elm make src/client/Main.elm --output public/javascripts/client.js || true + @./reflex-platform/try-reflex --command "make build-client-inside" watch-client: - @nodemon -e elm --exec 'clear && make build-client --silent' + @./reflex-platform/try-reflex --command "nodemon --watch src/client -e hs --exec '(clear && make build-client-inside) || true'" diff --git a/README.md b/README.md index e746560..1dc589e 100644 --- a/README.md +++ b/README.md @@ -19,10 +19,16 @@ curl https://nixos.org/nix/install | sh Start the environment with: -``` sh +```bash ./make start ``` +Init the database with migration scripts: + +```bash +sqlite3 database < src/migrations/x.sql +``` + Inside the tmux session, add some users with sqlite after the migration is done: ``` @@ -33,7 +39,7 @@ insert into user(creation, email, name) values (datetime('now'), 'lisa@mail.com' Later, stop the environment with: -```sh +```bash ./make stop ``` @@ -52,18 +58,11 @@ See [application.conf](application.conf). TODO ---- -### Chart - -- Tooltip with values -- Show / Hide serie by clicking on caption -- Adapt to screen width -- Show only the last entries and allow to move in time ? - -### Other +- remove duplicates server models / common models +- use another route to check the token and redirect to / - Add payment balance in weekly report - search by payment category and payment date - 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) +- Minify javascript +- Extract persistence from model files diff --git a/elm-package.json b/elm-package.json deleted file mode 100644 index 9f7fcbf..0000000 --- a/elm-package.json +++ /dev/null @@ -1,26 +0,0 @@ -{ - "version": "0.0.1", - "summary": "SharedCost", - "repository": "https://github.com/guyonvarch/sharedcost.git", - "license": "GPL-3", - "source-directories": [ "src/client" ], - "exposed-modules": [], - "elm-version": "0.18.0 <= v < 0.19.0", - "dependencies": { - "elm-community/json-extra": "2.1.0 <= v < 3.0.0", - "elm-community/list-extra": "6.0.0 <= v < 7.0.0", - "elm-community/maybe-extra": "4.0.0 <= v < 5.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/svg": "2.0.0 <= 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/javascript/.gitkeep b/public/javascript/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/public/javascripts/.gitkeep b/public/javascripts/.gitkeep deleted file mode 100644 index e69de29..0000000 diff --git a/public/javascripts/main.js b/public/javascripts/main.js deleted file mode 100644 index 3c3d797..0000000 --- a/public/javascripts/main.js +++ /dev/null @@ -1,17 +0,0 @@ -// Remove search query -window.history.pushState( - { - html: document.documentElement.innerHTML, - pageTitle: document.title - }, - '', - document.location.pathname + document.location.hash -); - -var app = Elm.Main.fullscreen({ - time: new Date().getTime(), - translations: JSON.parse(document.getElementById('translations').innerHTML), - conf: JSON.parse(document.getElementById('conf').innerHTML), - result: JSON.parse(document.getElementById('result').innerHTML), - windowSize: { width: window.innerWidth, height: window.innerHeight } -}); diff --git a/sharedCost.cabal b/sharedCost.cabal index befd71b..275c849 100644 --- a/sharedCost.cabal +++ b/sharedCost.cabal @@ -48,18 +48,18 @@ executable sharedCost , base64-bytestring -- , mime-mail - other-modules: Conf + other-modules: Common.Model.SignIn + , Conf , Controller.Category , Controller.Income , Controller.Index , Controller.Payment , Controller.SignIn , Cookie - , Design.LoggedIn.Home.Table - , Design.LoggedIn.Stat - , Design.LoggedIn.Table + , Design.View.Payment.Table + , Design.View.Stat + , Design.View.Table , Design.Media - , Design.SignIn , Design.Tooltip , Design.Color , Design.Constants @@ -67,12 +67,13 @@ executable sharedCost , Design.Errors , Design.Form , Design.Global - , Design.Header , Design.Helper - , Design.LoggedIn - , Design.LoggedIn.Home - , Design.LoggedIn.Home.Header - , Design.LoggedIn.Home.Pages + , Design.Views + , Design.View.Header + , Design.View.Payment + , Design.View.Payment.Header + , Design.View.Payment.Pages + , Design.View.SignIn , Job.Daemon , Job.Frequency , Job.Kind @@ -86,27 +87,8 @@ executable sharedCost , 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.Payer , Model.Payment , Model.PaymentCategory , Model.Query @@ -116,9 +98,7 @@ executable sharedCost , Resource , Secure , SendMail - , Utils.Text , Utils.Time - , View.Format , View.Mail.SignIn , View.Mail.WeeklyReport , View.Page diff --git a/shell.nix b/shell.nix index 83935d8..23a7255 100644 --- a/shell.nix +++ b/shell.nix @@ -5,9 +5,13 @@ with import {}; { elmPackages.elm nodePackages.nodemon sqlite - stack + cabal-install + cabal2nix tmux tmuxinator ]; + shellHook = '' + export PATH=node_modules/.bin:$PATH; + ''; }; } diff --git a/src/client/Chart/Api.elm b/src/client/Chart/Api.elm deleted file mode 100644 index 693f362..0000000 --- a/src/client/Chart/Api.elm +++ /dev/null @@ -1,41 +0,0 @@ -module Chart.Api exposing - ( from - , withSize - , withTitle - , withOrdinate - , toHtml - ) - -import Html exposing (Html) -import Svg exposing (..) -import Svg.Attributes exposing (..) - -import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) -import Chart.View as Chart - -from : List String -> List Serie -> Chart -from keys series = - { keys = keys - , series = series - , size = { x = 600, y = 400 } - , title = "" - , scaleColor = "#DDDDDD" - , formatOrdinate = toString - , ordinateLines = 5 - } - -withSize : Vec2 -> Chart -> Chart -withSize size chart = { chart | size = size } - -withTitle : String -> Chart -> Chart -withTitle title chart = { chart | title = title } - -withOrdinate : Int -> (Float -> String) -> Chart -> Chart -withOrdinate lines format chart = - { chart - | formatOrdinate = format - , ordinateLines = lines - } - -toHtml : Chart -> Html msg -toHtml chart = Chart.view chart diff --git a/src/client/Chart/Model.elm b/src/client/Chart/Model.elm deleted file mode 100644 index b5c176f..0000000 --- a/src/client/Chart/Model.elm +++ /dev/null @@ -1,73 +0,0 @@ -module Chart.Model exposing - ( Chart - , Serie - , maxScale - , Vec2 - , View - , mkView - , bounds - ) - -import List.Extra as List - -type alias Chart = - { keys : List String - , series : List Serie - , size : Vec2 - , title : String - , scaleColor : String - , formatOrdinate : Float -> String - , ordinateLines : Int - } - -type alias Serie = - { values : List Float - , color : String - , label : String - } - -maxScale : Chart -> Float -maxScale { keys, series } = - List.range 0 (List.length keys - 1) - |> List.map (\i -> - series - |> List.map (truncate << Maybe.withDefault 0 << List.getAt i << .values) - |> List.maximum - |> Maybe.withDefault 0 - ) - |> List.maximum - |> Maybe.withDefault 0 - |> upperBound - -upperBound : Int -> Float -upperBound n = toFloat (upperBoundInt 0 n) - -upperBoundInt : Int -> Int -> Int -upperBoundInt count n = - if n < 10 - then - (n + 1) * (10 ^ count) - else - upperBoundInt (count + 1) (n // 10) - -type alias Vec2 = - { x : Float - , y : Float - } - -type alias View = - { fx : Float -> Float - , fy : Float -> Float - } - -mkView : Vec2 -> Vec2 -> View -mkView p1 p2 = - { fx = \x -> p1.x + x * (p2.x - p1.x) - , fy = \y -> p1.y + y * (p2.y - p1.y) - } - -bounds : View -> (Vec2, Vec2) -bounds { fx, fy } = - ( { x = fx 0, y = fy 0 } - , { x = fx 1, y = fy 1 } - ) diff --git a/src/client/Chart/View.elm b/src/client/Chart/View.elm deleted file mode 100644 index af8b4b7..0000000 --- a/src/client/Chart/View.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Chart.View exposing - ( view - ) - -import Html exposing (Html) -import List.Extra as List -import Svg exposing (..) -import Svg.Attributes exposing (..) - -import Chart.Model as Chart exposing (Chart, Serie, Vec2, View) -import Utils.List as List - -view : Chart -> Html msg -view chart = - let { size, title, series } = chart - titleHeight = 100 - captionHeight = 50 - in svg - [ width << toString <| size.x - , height << toString <| size.y - , viewBox ("0 0 " ++ (toString size.x) ++ " " ++ (toString size.y)) - ] - ( [ renderTitle (Chart.mkView { x = 0, y = 0 } { x = size.x, y = titleHeight }) title ] - ++ renderSeriesAndScales (Chart.mkView { x = 50, y = titleHeight } { x = size.x, y = size.y - captionHeight }) chart - ++ renderCaptions (Chart.mkView { x = 0, y = size.y - captionHeight } { x = size.x, y = size.y }) series - ) - -renderTitle : View -> String -> Svg msg -renderTitle view title = - text_ - [ x << toString <| view.fx 0.5 - , y << toString <| view.fy 0.5 - , textAnchor "middle" - , dominantBaseline "middle" - , fontSize "20" - ] - [ text title ] - -renderSeriesAndScales : View -> Chart -> List (Svg msg) -renderSeriesAndScales view chart = - let { keys, series, scaleColor, formatOrdinate } = chart - (p1, p2) = Chart.bounds view - ordinateWidth = 100 - abscissaHeight = 60 - maxScale = Chart.maxScale chart - in ( renderOrdinates (Chart.mkView { x = p1.x, y = p1.y } { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight }) formatOrdinate maxScale - ++ renderAbscissas (Chart.mkView { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight } { x = p2.x, y = p2.y }) keys scaleColor - ++ renderSeries (Chart.mkView { x = p1.x + ordinateWidth, y = p1.y } { x = p2.x, y = p2.y - abscissaHeight }) series maxScale scaleColor - ) - -renderOrdinates : View -> (Float -> String) -> Float -> List (Svg msg) -renderOrdinates view formatOrdinate maxScale = - ordinates - |> List.map (\l -> - text_ - [ x << toString <| view.fx 0.5 - , y << toString <| view.fy l - , textAnchor "middle" - , dominantBaseline "middle" - ] - [ text << formatOrdinate <| (1 - l) * maxScale ] - ) - - -renderAbscissas : View -> List String -> String -> List (Svg msg) -renderAbscissas view keys scaleColor = - let count = List.length keys - in ( abscissasXPositions keys - |> List.map (\(xPos, key) -> - [ text_ - [ x << toString <| view.fx xPos - , y << toString <| view.fy 0.5 - , textAnchor "middle" - , dominantBaseline "middle" - ] - [ text key ] - , line - [ x1 << toString <| view.fx xPos - , y1 << toString <| view.fy 0 - , x2 << toString <| view.fx xPos - , y2 << toString <| view.fy 0.2 - , stroke scaleColor - ] - [] - ] - ) - |> List.concat - ) - -renderSeries : View -> List Serie -> Float -> String -> List (Svg msg) -renderSeries view series maxScale scaleColor = - ( renderHorizontalLines view series scaleColor - ++ renderPoints view series maxScale - ) - -renderHorizontalLines : View -> List Serie -> String -> List (Svg msg) -renderHorizontalLines view series scaleColor = - ordinates - |> List.map (\l -> - line - [ x1 << toString <| view.fx 0 - , y1 << toString <| view.fy l - , x2 << toString <| view.fx 1 - , y2 << toString <| view.fy l - , stroke scaleColor - ] - [] - ) - -renderPoints : View -> List Serie -> Float -> List (Svg msg) -renderPoints view series maxScale = - series - |> List.map (\serie -> - let points = - abscissasXPositions serie.values - |> List.map (\(xPos, value) -> { x = xPos, y = 1 - value / maxScale }) - in [ renderLines view serie.color points - , List.map (renderPoint view serie.color) points - ] - |> List.concat - ) - |> List.concat - -renderLines : View -> String -> List Vec2 -> List (Svg msg) -renderLines view color points = - List.links points - |> List.map (\(p1, p2) -> - line - [ x1 << toString <| view.fx p1.x - , y1 << toString <| view.fy p1.y - , x2 << toString <| view.fx p2.x - , y2 << toString <| view.fy p2.y - , stroke color - ] - [] - ) - -renderPoint : View -> String -> Vec2 -> Svg msg -renderPoint view color pos = - circle - [ cx << toString <| view.fx pos.x - , cy << toString <| view.fy pos.y - , r "4" - , fill color - ] - [] - -abscissasXPositions : List a -> List (Float, a) -abscissasXPositions xs = - let count = List.length xs - in xs - |> List.zip (List.range 1 (count + 1)) - |> List.map (\(i, x) -> (toFloat i / (toFloat count + 1), x)) - -ordinates : List Float -ordinates = - let count = 10 - in List.range 0 (count - 1) - |> List.map (\l -> toFloat l / (toFloat count - 1)) - -renderCaptions : View -> List Serie -> List (Svg msg) -renderCaptions view series = - let count = List.length series - in series - |> List.zip (List.range 1 (List.length series)) - |> List.map (\(i, serie) -> - renderCaption { x = view.fx (toFloat i / (toFloat count + 1)), y = view.fy 0.5 } serie - ) - |> List.concat - -renderCaption : Vec2 -> Serie -> List (Svg msg) -renderCaption point { label, color } = - [ text_ - [ x << toString <| point.x - , y << toString <| point.y - , textAnchor "middle" - , dominantBaseline "middle" - , fill color - , fontSize "18" - ] - [ text label ] - ] diff --git a/src/client/Common b/src/client/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/client/Common @@ -0,0 +1 @@ +../common \ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs new file mode 100644 index 0000000..f21798c --- /dev/null +++ b/src/client/Component/Button.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Button + ( ButtonIn(..) + , buttonInDefault + , ButtonOut(..) + , button + ) where + +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Icon + +data ButtonIn t m = ButtonIn + { _buttonIn_class :: Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + } + +buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault = ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.blank + , _buttonIn_waiting = R.never + } + +data ButtonOut t = ButtonOut + { _buttonOut_clic :: Event t () + } + +button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) +button buttonIn = do + attr <- R.holdDyn + (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) + (fmap + (\w -> M.fromList $ + [ ("type", "button") ] + <> if w + then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] + else [("class", _buttonIn_class buttonIn)]) + (_buttonIn_waiting buttonIn)) + (e, _) <- R.elDynAttr' "button" attr $ do + Icon.loading + R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut + { _buttonOut_clic = R.domEvent R.Click e + } diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs new file mode 100644 index 0000000..7111630 --- /dev/null +++ b/src/client/Component/Input.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Input + ( InputIn(..) + , InputOut(..) + , input + ) where + +import Data.Text (Text) +import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import qualified Reflex.Dom as R + +data InputIn t a b = InputIn + { _inputIn_reset :: Event t a + , _inputIn_placeHolder :: Text + } + +data InputOut t = InputOut + { _inputOut_value :: Dynamic t Text + , _inputOut_enter :: Event t () + } + +input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) +input inputIn = do + let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) + let value = fmap (const "") (_inputIn_reset inputIn) + textInput <- R.textInput $ R.def & R.attributes .~ placeHolder + & R.setValue .~ value + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + return $ InputOut + { _inputOut_value = R._textInput_value textInput + , _inputOut_enter = enter + } diff --git a/src/client/Debug.hs b/src/client/Debug.hs new file mode 100644 index 0000000..0c5c979 --- /dev/null +++ b/src/client/Debug.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Debug + ( event + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event, Dynamic) +import qualified Reflex.Dom as R + +event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () +event name e = do + count <- R.count e :: m (Dynamic t Int) + let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count + R.el "div" $ R.dynText text diff --git a/src/client/Dialog.elm b/src/client/Dialog.elm deleted file mode 100644 index a7e059a..0000000 --- a/src/client/Dialog.elm +++ /dev/null @@ -1,165 +0,0 @@ -module Dialog exposing - ( Msg(..) - , Model - , Config - , init - , update - , view - ) - -import Platform.Cmd exposing (Cmd) -import Task exposing (Task) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - --- Model - -type alias Model model modelMsg msg = - { config : Maybe (Config model msg) - , mapMsg : Msg model modelMsg msg -> msg - , model : model - } - -type alias Config model msg = - { className : String - , title : String - , body : model -> Html msg - , confirm : String - , confirmMsg : model -> msg - , undo : String - } - -init : model -> (Msg model modelMsg msg -> msg) -> Model model modelMsg msg -init model mapMsg = - { config = Nothing - , mapMsg = mapMsg - , model = model - } - --- Update - -type Msg model modelMsg msg = - NoOp - | Update modelMsg - | UpdateAndClose msg - | OpenWithUpdate (Config model msg) modelMsg - | Open (Config model msg) - | Close - -update : (modelMsg -> model -> (model, Cmd modelMsg)) -> Msg model modelMsg msg -> model -> Model model modelMsg msg -> (Model model modelMsg msg, Cmd msg) -update updateModel msg baseModel model = - case msg of - NoOp -> - ( model - , Cmd.none - ) - - Update modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model | model = newModel } - , Cmd.map (model.mapMsg << Update) effects - ) - - UpdateAndClose msg -> - ( { model | config = Nothing } - , Task.perform (always msg) (Task.succeed msg) - ) - - OpenWithUpdate config modelMsg -> - case updateModel modelMsg baseModel of - (newModel, effects) -> - ( { model - | model = newModel - , config = Just config - } - , Cmd.map (model.mapMsg << Update) effects - ) - - Open config -> - ( { model | config = Just config } - , Cmd.none - ) - - Close -> - ( { model | config = Nothing } - , Cmd.none - ) - --- View - -view : Model model modelMsg msg -> Html msg -view { mapMsg, config, model } = - let isVisible = - case config of - Just _ -> True - Nothing -> False - in div - [ class "dialog" ] - [ curtain mapMsg isVisible - , case config of - Nothing -> - text "" - Just c -> - dialog model mapMsg c - ] - -curtain : (Msg model modelMsg msg -> msg) -> Bool -> Html msg -curtain mapMsg isVisible = - div - [ class "curtain" - , style - [ ("position", "fixed") - , ("top", "0") - , ("left", "0") - , ("width", "100%") - , ("height", "100%") - , ("background-color", "rgba(0, 0, 0, 0.5)") - , ("z-index", if isVisible then "1000" else "-1") - , ("opacity", if isVisible then "1" else "0") - , ("transition", "all 0.2s ease") - ] - , onClick (mapMsg Close) - ] - [] - -dialog : model -> (Msg model modelMsg msg -> msg) -> Config model msg -> Html msg -dialog model mapMsg { className, title, body, confirm, confirmMsg, undo } = - div - [ class ("content " ++ className) - , style - [ ("position", "fixed") - , ("top", "25%") - , ("left", "50%") - , ("transform", "translate(-50%, -25%)") - , ("z-index", "1000") - , ("background-color", "white") - , ("padding", "20px") - , ("border-radius", "5px") - , ("box-shadow", "0px 0px 15px rgba(0, 0, 0, 0.5)") - ] - ] - [ h1 [] [ text title ] - , body model - , div - [ style - [ ("float", "right") - ] - ] - [ button - [ class "confirm" - , onClick (confirmMsg model) - , style - [ ("margin-right", "15px") - ] - ] - [ text confirm ] - , button - [ class "undo" - , onClick (mapMsg Close) - ] - [ text undo ] - ] - ] diff --git a/src/client/Dialog/AddCategory/Model.elm b/src/client/Dialog/AddCategory/Model.elm deleted file mode 100644 index 3b70482..0000000 --- a/src/client/Dialog/AddCategory/Model.elm +++ /dev/null @@ -1,54 +0,0 @@ -module Dialog.AddCategory.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import Dict - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Category exposing (Categories, Category, CategoryId) -import Model.Translations exposing (Translations) -import Validation -import View.Date as Date - -type alias Model = - { id : Maybe CategoryId - , name : String - , color : String - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> List (String, Field) -initialAdd translations = - [ ("color", Field.string "#000000") - ] - -initialClone : Translations -> Category -> List (String, Field) -initialClone translations category = - [ ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -initialEdit : Translations -> CategoryId -> Category -> List (String, Field) -initialEdit translations categoryId category = - [ ("id", Field.string (toString categoryId)) - , ("name", Field.string category.name) - , ("color", Field.string category.color) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "color" Validation.color) diff --git a/src/client/Dialog/AddCategory/View.elm b/src/client/Dialog/AddCategory/View.elm deleted file mode 100644 index dc55b60..0000000 --- a/src/client/Dialog/AddCategory/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddCategory.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "categoryDialog" - , title = getMessage loggedData.translations title - , body = \model -> addCategoryForm loggedData model.addCategory - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addCategory - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "categoryname" (DialogMsg.AddCategoryMsg (Form.Reset initialForm)))) ] - ) - [ buttonContent ] - -addCategoryForm : LoggedData -> Form String AddCategory.Model -> Html Msg -addCategoryForm loggedData addCategory = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddCategoryMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addCategory "category" "name" - , htmlMap <| Form.colorInput loggedData.translations addCategory "category" "color" - , Form.hiddenSubmit (submitForm addCategory) - ] - -submitForm : Form String AddCategory.Model -> Msg -submitForm addCategory = - case Form.getOutput addCategory of - Just data -> - case data.id of - Just categoryId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditCategory categoryId (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateCategory (String.trim data.name) data.color - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddCategoryMsg <| Form.Submit diff --git a/src/client/Dialog/AddIncome/Model.elm b/src/client/Dialog/AddIncome/Model.elm deleted file mode 100644 index 5e2ccf1..0000000 --- a/src/client/Dialog/AddIncome/Model.elm +++ /dev/null @@ -1,53 +0,0 @@ -module Dialog.AddIncome.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Translations exposing (Translations) -import Model.Income exposing (Income, IncomeId) - -type alias Model = - { id : Maybe IncomeId - , amount : Int - , date : Date - } - -init : Form String Model -init = Form.initial [] validation - -initialAdd : Translations -> Date -> List (String, Field) -initialAdd translations date = - [ ("date", Field.string (Date.shortView date translations)) - ] - -initialClone : Translations -> Date -> Income -> List (String, Field) -initialClone translations date income = - [ ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView date translations)) - ] - -initialEdit : Translations -> IncomeId -> Income -> List (String, Field) -initialEdit translations incomeId income = - [ ("id", Field.string (toString incomeId)) - , ("amount", Field.string (toString income.amount)) - , ("date", Field.string (Date.shortView (Date.fromTime income.time) translations)) - ] - -validation : Validation String Model -validation = - Validate.map3 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 0))) - (Validate.field "date" Validation.date) diff --git a/src/client/Dialog/AddIncome/View.elm b/src/client/Dialog/AddIncome/View.elm deleted file mode 100644 index b413308..0000000 --- a/src/client/Dialog/AddIncome/View.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Dialog.AddIncome.View exposing - ( button - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "incomeDialog" - , title = getMessage loggedData.translations title - , body = \model -> addIncomeForm loggedData model.addIncome - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm << .addIncome - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "incomeamount" (DialogMsg.AddIncomeMsg <| Form.Reset initialForm))) ] - ) - [ buttonContent ] - -addIncomeForm : LoggedData -> Form String AddIncome.Model -> Html Msg -addIncomeForm loggedData addIncome = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddIncomeMsg) - in Html.form - [ onSubmitPrevDefault Msg.NoOp ] - [ htmlMap <| Form.textInput loggedData.translations addIncome "income" "amount" - , htmlMap <| Form.textInput loggedData.translations addIncome "income" "date" - , Form.hiddenSubmit (submitForm addIncome) - ] - -submitForm : Form String AddIncome.Model -> Msg -submitForm addIncome = - case Form.getOutput addIncome of - Just data -> - case data.id of - Just incomeId -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditIncome incomeId data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateIncome data.amount data.date - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddIncomeMsg <| Form.Submit diff --git a/src/client/Dialog/AddPayment/Model.elm b/src/client/Dialog/AddPayment/Model.elm deleted file mode 100644 index 07e7cbb..0000000 --- a/src/client/Dialog/AddPayment/Model.elm +++ /dev/null @@ -1,70 +0,0 @@ -module Dialog.AddPayment.Model exposing - ( Model - , init - , initialAdd - , initialClone - , initialEdit - , validation - ) - -import Date exposing (Date) -import View.Date as Date - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) -import Validation - -import Model.Category as Category exposing (Categories, CategoryId) -import Model.Frequency as Frequency -import Model.Payment as Payment exposing (Payment, PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Translations exposing (Translations) - -type alias Model = - { id : Maybe PaymentId - , name : String - , cost : Int - , date : Date - , category : CategoryId - , frequency : Frequency - } - -init : Form String Model -init = Form.initial [] (validation Category.empty) - -initialAdd : Translations -> Date -> Frequency -> List (String, Field) -initialAdd translations date frequency = - [ ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString frequency)) - , ("category", Field.string "") - ] - -initialClone : Translations -> Date -> Maybe CategoryId -> Payment -> List (String, Field) -initialClone translations date category payment = - [ ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -initialEdit : Translations -> Maybe CategoryId -> Payment -> List (String, Field) -initialEdit translations category payment = - [ ("id", Field.string (toString payment.id)) - , ("name", Field.string payment.name) - , ("cost", Field.string (toString payment.cost)) - , ("date", Field.string (Date.shortView payment.date translations)) - , ("frequency", Field.string (toString payment.frequency)) - , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault "")) - ] - -validation : Categories -> Validation String Model -validation categories = - Validate.map6 Model - (Validate.field "id" (Validate.maybe Validate.int)) - (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty)) - (Validate.field "cost" Validation.cost) - (Validate.field "date" Validation.date) - (Validate.field "category" (Validation.category categories)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/Dialog/AddPayment/View.elm b/src/client/Dialog/AddPayment/View.elm deleted file mode 100644 index 584adcd..0000000 --- a/src/client/Dialog/AddPayment/View.elm +++ /dev/null @@ -1,95 +0,0 @@ -module Dialog.AddPayment.View exposing - ( button - ) - -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Task - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Utils.Form as Form - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.Msg as DialogMsg - -import Tooltip - -import View.Events exposing (onSubmitPrevDefault) -import View.Form as Form - -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Msg as LoggedInMsg -import Msg exposing (Msg) - -import Model.Category exposing (Categories) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (getMessage) -import Model.View exposing (View(LoggedInView)) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as HomeModel - -button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg -button loggedData initialForm title buttonContent tooltip = - let dialogConfig = - { className = "paymentDialog" - , title = getMessage loggedData.translations title - , body = \model -> addPaymentForm loggedData model.addPayment - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = submitForm loggedData.categories loggedData.paymentCategories << .addPayment - , undo = getMessage loggedData.translations "Undo" - } - in Html.button - ( ( case tooltip of - Just message -> Tooltip.show Msg.Tooltip message - Nothing -> [] - ) - ++ [ class "addPayment" - , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "paymentname" (DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories <| Form.Reset initialForm))) - ] - ) - [ buttonContent ] - -addPaymentForm : LoggedData -> Form String AddPayment.Model -> Html Msg -addPaymentForm loggedData addPayment = - let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories) - categoryOptions = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - |> List.map (\(id, category) -> (toString id, category.name)) - in Html.form - [ class "addPayment" - , onSubmitPrevDefault Msg.NoOp - ] - [ htmlMap <| Form.textInput loggedData.translations addPayment "payment" "name" - , htmlMap <| Form.textInput loggedData.translations addPayment "payment" "cost" - , if (Form.getFieldAsString "frequency" addPayment).value == Just (toString Punctual) - then htmlMap <| Form.textInput loggedData.translations addPayment "payment" "date" - else text "" - , htmlMap <| Form.selectInput loggedData.translations addPayment "payment" "category" categoryOptions - - , htmlMap <| Form.radioInputs loggedData.translations addPayment "payment" "frequency" [ toString Punctual, toString Monthly ] - , Form.hiddenSubmit (submitForm loggedData.categories loggedData.paymentCategories addPayment) - ] - -submitForm : Categories -> PaymentCategories -> Form String AddPayment.Model -> Msg -submitForm categories paymentCategories addPayment = - case Form.getOutput addPayment of - Just data -> - case data.id of - Just paymentId -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.EditPayment paymentId (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog - <| Dialog.UpdateAndClose - <| Msg.CreatePayment (String.trim data.name) data.cost data.date data.category data.frequency - Nothing -> - Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg categories paymentCategories <| Form.Submit diff --git a/src/client/Dialog/Model.elm b/src/client/Dialog/Model.elm deleted file mode 100644 index ff8bc57..0000000 --- a/src/client/Dialog/Model.elm +++ /dev/null @@ -1,23 +0,0 @@ -module Dialog.Model exposing - ( Model - , init - ) - -import Form exposing (Form) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddCategory.Model as AddCategory - -type alias Model = - { addPayment : Form String AddPayment.Model - , addIncome : Form String AddIncome.Model - , addCategory : Form String AddCategory.Model - } - -init : Model -init = - { addPayment = AddPayment.init - , addIncome = AddIncome.init - , addCategory = AddCategory.init - } diff --git a/src/client/Dialog/Msg.elm b/src/client/Dialog/Msg.elm deleted file mode 100644 index 68ed146..0000000 --- a/src/client/Dialog/Msg.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Dialog.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -type Msg = - NoOp - | Init String Msg - | AddPaymentMsg Categories PaymentCategories Form.Msg - | AddIncomeMsg Form.Msg - | AddCategoryMsg Form.Msg diff --git a/src/client/Dialog/Update.elm b/src/client/Dialog/Update.elm deleted file mode 100644 index 3915548..0000000 --- a/src/client/Dialog/Update.elm +++ /dev/null @@ -1,74 +0,0 @@ -module Dialog.Update exposing - ( update - ) - -import Dom exposing (Id) -import Form exposing (Form) -import Form.Field as Field -import Task - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddPayment.Model as AddPayment -import Dialog.Model as Dialog -import Dialog.Msg as Dialog - -import Model.Category exposing (Categories) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -update : Dialog.Msg -> Dialog.Model -> (Dialog.Model, Cmd Dialog.Msg) -update msg model = - case msg of - - Dialog.NoOp -> - ( model - , Cmd.none - ) - - Dialog.Init inputId dialogMsg -> - update dialogMsg model - |> Tuple.mapSecond (\cmd -> Cmd.batch [cmd, inputFocus inputId]) - - Dialog.AddPaymentMsg categories paymentCategories formMsg -> - ( { model - | addPayment = - Form.update (AddPayment.validation categories) formMsg model.addPayment - |> updateCategory categories paymentCategories formMsg - } - , Cmd.none - ) - - Dialog.AddIncomeMsg formMsg -> - ( { model - | addIncome = Form.update AddIncome.validation formMsg model.addIncome - } - , Cmd.none - ) - - Dialog.AddCategoryMsg formMsg -> - ( { model - | addCategory = Form.update AddCategory.validation formMsg model.addCategory - } - , Cmd.none - ) - -inputFocus : Id -> Cmd Dialog.Msg -inputFocus id = - Dom.focus id - |> Task.map (always Dialog.NoOp) - |> Task.onError (\_ -> Task.succeed Dialog.NoOp) - |> Task.perform (always Dialog.NoOp) - -updateCategory : Categories -> PaymentCategories -> Form.Msg -> (Form String AddPayment.Model -> Form String AddPayment.Model) -updateCategory categories paymentCategories formMsg = - case formMsg of - Form.Input "name" Form.Text (Field.String paymentName) -> - case PaymentCategory.search paymentName paymentCategories of - Just category -> - Form.update - (AddPayment.validation categories) - (Form.Input "category" Form.Text (Field.String <| toString category)) - Nothing -> - identity - _ -> - identity diff --git a/src/client/Icon.hs b/src/client/Icon.hs new file mode 100644 index 0000000..7223def --- /dev/null +++ b/src/client/Icon.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Icon + ( loading + , signOut + , clone + , edit + , delete + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/src/client/Init.elm b/src/client/Init.elm deleted file mode 100644 index d87e870..0000000 --- a/src/client/Init.elm +++ /dev/null @@ -1,30 +0,0 @@ -module Init exposing - ( Init - , decoder - ) - -import Time exposing (..) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import Model.Size exposing (..) - -type alias Init = - { time : Time - , translations : Translations - , conf : Conf - , result : InitResult - , windowSize : Size - } - -decoder : Decoder Init -decoder = - Decode.map5 Init - (Decode.field "time" Decode.float) - (Decode.field "translations" translationsDecoder) - (Decode.field "conf" confDecoder) - (Decode.field "result" initResultDecoder) - (Decode.field "windowSize" sizeDecoder) diff --git a/src/client/LoggedData.elm b/src/client/LoggedData.elm deleted file mode 100644 index e048247..0000000 --- a/src/client/LoggedData.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedData exposing - ( LoggedData - , build - ) - -import Time exposing (Time) - -import Msg exposing (Msg) - -import Model exposing (Model) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.Payment exposing (Payments) -import Model.User exposing (Users, UserId) -import Model.Income exposing (Incomes) -import Model.Category exposing (Categories) -import Model.PaymentCategory exposing (PaymentCategories) - -import LoggedIn.Model as LoggedInModel - -type alias LoggedData = - { currentTime : Time - , translations : Translations - , conf : Conf - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -build : Time -> Translations -> Conf -> LoggedInModel.Model -> LoggedData -build currentTime translations conf loggedIn = - { currentTime = currentTime - , translations = translations - , conf = conf - , users = loggedIn.users - , me = loggedIn.me - , payments = loggedIn.payments - , incomes = loggedIn.incomes - , categories = loggedIn.categories - , paymentCategories = loggedIn.paymentCategories - } diff --git a/src/client/LoggedIn/Category/Table.elm b/src/client/LoggedIn/Category/Table.elm deleted file mode 100644 index 9405e57..0000000 --- a/src/client/LoggedIn/Category/Table.elm +++ /dev/null @@ -1,123 +0,0 @@ -module LoggedIn.Category.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Category as Category exposing (CategoryId, Category) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let categories = - loggedData.categories - |> Dict.toList - |> List.sortBy (.name << Tuple.second) - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) categories) - , if List.isEmpty (Dict.toList loggedData.categories) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoCategories" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell category" ] [ text <| getMessage loggedData.translations "Color" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (CategoryId, Category) -> Html Msg -paymentLine loggedData (categoryId, category) = - div - [ class "row" ] - [ div - [ class "cell category" ] - [ text category.name ] - , div - [ class "cell category" ] - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.color ] - ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddCategory.button - loggedData - (AddCategory.initialClone loggedData.translations category) - "CloneCategory" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ AddCategory.button - loggedData - (AddCategory.initialEdit loggedData.translations categoryId category) - "EditCategory" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if PaymentCategory.isCategoryUnused categoryId loggedData.paymentCategories - then - let dialogConfig = - { className = "deleteCategoryDialog" - , title = getMessage loggedData.translations "ConfirmCategoryDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteCategory categoryId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - else - span - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "UsedCategory") ) - [ FontAwesome.trash Color.silver 18 ] - ] - ] diff --git a/src/client/LoggedIn/Category/View.elm b/src/client/LoggedIn/Category/View.elm deleted file mode 100644 index bba51b7..0000000 --- a/src/client/LoggedIn/Category/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Category.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import LoggedData exposing (LoggedData) - -import Msg exposing (Msg) - -import Dialog.AddCategory.Model as AddCategory -import Dialog.AddCategory.View as AddCategory - -import LoggedIn.Category.Table as Table - -import Model.Translations exposing (getMessage, getParamMessage) - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "categories" ] - [ div - [ class "titleButton withMargin" ] - [ h1 [] [ text <| getMessage loggedData.translations "Categories" ] - , AddCategory.button - loggedData - (AddCategory.initialAdd loggedData.translations) - "AddCategory" - (text (getMessage loggedData.translations "AddCategory")) - Nothing - ] - , Table.view loggedData - ] diff --git a/src/client/LoggedIn/Home/Header/View.elm b/src/client/LoggedIn/Home/Header/View.elm deleted file mode 100644 index 14d90d7..0000000 --- a/src/client/LoggedIn/Home/Header/View.elm +++ /dev/null @@ -1,105 +0,0 @@ -module LoggedIn.Home.Header.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import String -import Dict -import Date - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Msg exposing (Msg) -import LoggedIn.Msg as LoggedInMsg -import LoggedIn.Home.Msg as HomeMsg - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import Model.Translations exposing (getParamMessage) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.Translations exposing (getMessage) - -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import LoggedIn.Home.View.ExceedingPayers as ExceedingPayers -import LoggedIn.View.Format as Format -import View.Plural exposing (plural) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg -view loggedData { search } payments frequency = - let currentDate = Date.fromTime loggedData.currentTime - in Html.div - [ class "header" ] - [ div - [ class "payerAndAdd" ] - [ ExceedingPayers.view loggedData - , AddPayment.button - loggedData - (AddPayment.initialAdd loggedData.translations currentDate frequency) - "AddPayment" - (text (getMessage loggedData.translations "AddPayment")) - Nothing - ] - , Html.div - [ class "searchLine" ] - [ searchForm loggedData search ] - , infos loggedData payments - ] - -searchForm : LoggedData -> Form String Home.Search -> Html Msg -searchForm loggedData search = - Html.map (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.SearchMsg) <| - Html.form - [ onSubmitPrevDefault Form.NoOp ] - [ Form.textInput loggedData.translations search "search" "name" - , if List.isEmpty (Payment.monthly loggedData.payments) - then text "" - else Form.radioInputs loggedData.translations search "search" "frequency" [ toString Punctual, toString Monthly ] - ] - -infos : LoggedData -> Payments -> Html Msg -infos loggedData payments = - let paymentsCount = List.length payments - in if paymentsCount == 0 - then text "" - else - let count = plural loggedData.translations (List.length payments) "Payment" "Payments" - sum = paymentsSum loggedData.conf payments - in div - [ class "infos" ] - [ span - [ class "total" ] - [ text <| getParamMessage [ count, sum ] loggedData.translations "Worth" ] - , span - [ class "partition" ] - [ text <| paymentsPartition loggedData payments ] - ] - -paymentsPartition : LoggedData -> Payments -> String -paymentsPartition loggedData payments = - String.join - ", " - ( loggedData.users - |> Dict.toList - |> List.map (Tuple.mapFirst (\userId -> Payment.totalPayments (always True) userId payments)) - |> List.filter (\(sum, _) -> sum > 0) - |> List.sortBy Tuple.first - |> List.reverse - |> List.map (\(sum, user) -> - getParamMessage [ user.name, Format.price loggedData.conf sum ] loggedData.translations "By" - ) - ) - -paymentsSum : Conf -> Payments -> String -paymentsSum conf payments = - payments - |> List.map .cost - |> List.sum - |> Format.price conf diff --git a/src/client/LoggedIn/Home/Model.elm b/src/client/LoggedIn/Home/Model.elm deleted file mode 100644 index e5381f6..0000000 --- a/src/client/LoggedIn/Home/Model.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Model exposing - ( Model - , Search - , init - , searchInitial - , validation - ) - -import Form exposing (Form) -import Form.Field as Field exposing (Field) -import Form.Validate as Validate exposing (Validation) - -import Model.Frequency as Frequency -import Model.Payer exposing (Payers) -import Model.Payment as Payment exposing (PaymentId, Payments) -import Model.Frequency exposing (Frequency(..)) -import Model.User exposing (Users, UserId) - -type alias Model = - { punctualPage : Int - , monthlyPage : Int - , search : Form String Search - } - -type alias Search = - { name : Maybe String - , frequency : Frequency - } - -init : Model -init = - { punctualPage = 1 - , monthlyPage = 1 - , search = Form.initial (searchInitial Punctual) validation - } - -searchInitial : Frequency -> List (String, Field) -searchInitial frequency = [ ("frequency", Field.string (toString frequency)) ] - -validation : Validation String Search -validation = - Validate.map2 Search - (Validate.field "name" (Validate.maybe Validate.string)) - (Validate.field "frequency" Frequency.validate) diff --git a/src/client/LoggedIn/Home/Msg.elm b/src/client/LoggedIn/Home/Msg.elm deleted file mode 100644 index 69f15ad..0000000 --- a/src/client/LoggedIn/Home/Msg.elm +++ /dev/null @@ -1,13 +0,0 @@ -module LoggedIn.Home.Msg exposing - ( Msg(..) - ) - -import Form exposing (Form) - -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) - -type Msg = - NoOp - | UpdatePage Int - | SearchMsg Form.Msg diff --git a/src/client/LoggedIn/Home/Update.elm b/src/client/LoggedIn/Home/Update.elm deleted file mode 100644 index 06c2c7e..0000000 --- a/src/client/LoggedIn/Home/Update.elm +++ /dev/null @@ -1,44 +0,0 @@ -module LoggedIn.Home.Update exposing - ( update - ) - -import Form exposing (Form) - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import Model.Frequency as Frequency exposing (Frequency(..)) - -update : LoggedData -> Home.Msg -> Home.Model -> (Home.Model, Cmd Home.Msg) -update loggedData msg model = - case msg of - - Home.NoOp -> - ( model - , Cmd.none - ) - - Home.UpdatePage page -> - ( updatePage page model - , Cmd.none - ) - - Home.SearchMsg formMsg -> - let newModel = - case formMsg of - Form.Input "name" _ _ -> updatePage 1 model - _ -> model - in ( { model | search = Form.update Home.validation formMsg model.search } - , Cmd.none - ) - -updatePage : Int -> Home.Model -> Home.Model -updatePage page model = - let frequency = - Form.getFieldAsString "frequency" model.search - |> .value - |> Maybe.andThen Frequency.fromString - in case frequency of - Just Punctual -> { model | punctualPage = page } - Just Monthly -> { model | monthlyPage = page } - Nothing -> model diff --git a/src/client/LoggedIn/Home/View.elm b/src/client/LoggedIn/Home/View.elm deleted file mode 100644 index fba3f7c..0000000 --- a/src/client/LoggedIn/Home/View.elm +++ /dev/null @@ -1,43 +0,0 @@ -module LoggedIn.Home.View exposing - ( view - ) - -import Date -import Html exposing (..) -import Html.Attributes exposing (..) - -import Form -import Utils.Form as Form - -import LoggedData exposing (LoggedData) -import LoggedIn.Home.Header.View as Header -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as HomeMsg -import LoggedIn.Home.View.Paging as Paging -import LoggedIn.Home.View.Table as Table -import LoggedIn.Msg as LoggedInMsg -import Model.Payment as Payment -import Model.Frequency exposing (Frequency(..)) -import Msg exposing (Msg) - -view : LoggedData -> Home.Model -> Html Msg -view loggedData home = - let (name, frequency) = - case Form.getOutput home.search of - Just data -> (Maybe.withDefault "" data.name, data.frequency) - Nothing -> ("", Punctual) - payments = Payment.search name frequency loggedData.payments - page = - case frequency of - Punctual -> home.punctualPage - Monthly -> home.monthlyPage - in div - [ class "home" ] - [ Header.view loggedData home payments frequency - , Table.view loggedData home payments frequency page - , Paging.view - page - (List.length payments) - Msg.NoOp - (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage) - ] diff --git a/src/client/LoggedIn/Home/View/ExceedingPayers.elm b/src/client/LoggedIn/Home/View/ExceedingPayers.elm deleted file mode 100644 index 6f2439c..0000000 --- a/src/client/LoggedIn/Home/View/ExceedingPayers.elm +++ /dev/null @@ -1,45 +0,0 @@ -module LoggedIn.Home.View.ExceedingPayers exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.View.Format as Format - -import Model exposing (Model) -import Model.User exposing (getUserName) -import Model.Payment as Payment -import Model.Payer exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let payments = Payment.punctual loggedData.payments - exceedingPayers = getOrderedExceedingPayers loggedData.currentTime loggedData.users loggedData.incomes payments - in div - [ class "exceedingPayers" ] - ( if List.isEmpty exceedingPayers - then [ text <| getMessage loggedData.translations "PaymentsAreBalanced" ] - else (List.map (exceedingPayer loggedData) exceedingPayers) - ) - -exceedingPayer : LoggedData -> ExceedingPayer -> Html Msg -exceedingPayer loggedData payer = - span - [ class "exceedingPayer" ] - [ span - [ class "userName" ] - [ payer.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , span - [ class "amount" ] - [ text ("+ " ++ (Format.price loggedData.conf payer.amount)) ] - ] diff --git a/src/client/LoggedIn/Home/View/Paging.elm b/src/client/LoggedIn/Home/View/Paging.elm deleted file mode 100644 index dffe061..0000000 --- a/src/client/LoggedIn/Home/View/Paging.elm +++ /dev/null @@ -1,109 +0,0 @@ -module LoggedIn.Home.View.Paging exposing - ( view - ) - -import Color exposing (Color) - -import FontAwesome - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import LoggedData exposing (LoggedData) -import Model.Payment as Payment exposing (Payments, perPage) - -showedPages : Int -showedPages = 5 - -view : Int -> Int -> msg -> (Int -> msg) -> Html msg -view currentPage payments noOp pageMsg = - let maxPage = ceiling (toFloat payments / toFloat perPage) - pages = truncatePages currentPage (List.range 1 maxPage) - in if maxPage <= 1 - then - text "" - else - div - [ class "pages" ] - ( [ firstPage currentPage pageMsg - , previousPage currentPage noOp pageMsg - ] - ++ ( List.map (paymentsPage currentPage noOp pageMsg) pages) - ++ [ nextPage currentPage maxPage noOp pageMsg - , lastPage currentPage maxPage pageMsg - ] - ) - -truncatePages : Int -> List Int -> List Int -truncatePages currentPage pages = - let totalPages = List.length pages - showedLeftPages = ceiling ((toFloat showedPages - 1) / 2) - showedRightPages = floor ((toFloat showedPages - 1) / 2) - truncatedPages = - if currentPage <= showedLeftPages then - (List.range 1 showedPages) - else if currentPage > totalPages - showedRightPages then - (List.range (totalPages - showedPages + 1) totalPages) - else - (List.range (currentPage - showedLeftPages) (currentPage + showedRightPages)) - in List.filter (flip List.member pages) truncatedPages - -firstPage : Int -> (Int -> msg) -> Html msg -firstPage currentPage pageMsg = - button - [ classList - [ ("page", True) - , ("disable", currentPage <= 1) - ] - , onClick (pageMsg 1) - ] - [ FontAwesome.fast_backward grey 13 ] - -previousPage : Int -> msg -> (Int -> msg) -> Html msg -previousPage currentPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage > 1 - then (pageMsg <| currentPage - 1) - else noOp - ] - [ FontAwesome.backward grey 13 ] - -nextPage : Int -> Int -> msg -> (Int -> msg) -> Html msg -nextPage currentPage maxPage noOp pageMsg = - button - [ class "page" - , onClick <| - if currentPage < maxPage - then (pageMsg <| currentPage + 1) - else noOp - ] - [ FontAwesome.forward grey 13 ] - -lastPage : Int -> Int -> (Int -> msg) -> Html msg -lastPage currentPage maxPage pageMsg = - button - [ class "page" - , onClick (pageMsg maxPage) - ] - [ FontAwesome.fast_forward grey 13 ] - -paymentsPage : Int -> msg -> (Int -> msg) -> Int -> Html msg -paymentsPage currentPage noOp pageMsg page = - let onCurrentPage = page == currentPage - in button - [ classList - [ ("page", True) - , ("current", onCurrentPage) - ] - , onClick <| - if onCurrentPage - then noOp - else pageMsg page - ] - [ text (toString page) ] - -grey : Color -grey = Color.greyscale 0.35 diff --git a/src/client/LoggedIn/Home/View/Table.elm b/src/client/LoggedIn/Home/View/Table.elm deleted file mode 100644 index f94bb19..0000000 --- a/src/client/LoggedIn/Home/View/Table.elm +++ /dev/null @@ -1,167 +0,0 @@ -module LoggedIn.Home.View.Table exposing - ( view - ) - -import Date exposing (Date) -import Dict exposing (..) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddPayment.Model as AddPayment -import Dialog.AddPayment.View as AddPayment - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import LoggedIn.Home.Model as Home -import LoggedIn.View.Format as Format -import View.Date as Date - -import Model.Payment as Payment exposing (..) -import Model.Frequency exposing (Frequency(..)) -import Model.PaymentCategory as PaymentCategory -import Model.Translations exposing (getMessage) -import Model.User exposing (getUserName) - -view : LoggedData -> Home.Model -> Payments -> Frequency -> Int -> Html Msg -view loggedData homeModel payments frequency page = - let visiblePayments = - payments - |> List.drop ((page - 1) * perPage) - |> List.take perPage - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData frequency :: List.map (paymentLine loggedData homeModel frequency) visiblePayments ) - , if List.isEmpty visiblePayments - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoPayment" ] - else - text "" - ] - -headerLine : LoggedData -> Frequency -> Html Msg -headerLine loggedData frequency = - div - [ class "header" ] - [ div [ class "cell category" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell cost" ] [ text <| getMessage loggedData.translations "Cost" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "Payer" ] - , div [ class "cell user" ] [ text <| getMessage loggedData.translations "PaymentCategory" ] - , case frequency of - Punctual -> div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - Monthly -> text "" - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> Home.Model -> Frequency -> Payment -> Html Msg -paymentLine loggedData homeModel frequency payment = - div - [ class "row" ] - [ div [ class "cell name" ] [ text payment.name ] - , div - [ classList - [ ("cell cost", True) - , ("refund", payment.cost < 0) - ] - ] - [ text (Format.price loggedData.conf payment.cost) ] - , div - [ class "cell user" ] - [ payment.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell category" ] - ( let mbCategory = - PaymentCategory.search payment.name loggedData.paymentCategories - |> Maybe.andThen (\category -> Dict.get category loggedData.categories) - in case mbCategory of - Just category -> - [ span - [ class "tag" - , style [("background-color", category.color)] - ] - [ text category.name ] - ] - Nothing -> - [] - ) - , case frequency of - Punctual -> - div - [ class "cell date" ] - [ span - [ class "shortDate" ] - [ text (Date.shortView payment.date loggedData.translations) ] - , span - [ class "longDate" ] - [ text (Date.longView payment.date loggedData.translations) ] - ] - Monthly -> - text "" - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialClone loggedData.translations currentDate category payment) - "ClonePayment" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let category = PaymentCategory.search payment.name loggedData.paymentCategories - in AddPayment.button - loggedData - (AddPayment.initialEdit loggedData.translations category payment) - "EditPayment" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= payment.userId - then - text "" - else - let dialogConfig = - { className = "deletePaymentDialog" - , title = getMessage loggedData.translations "ConfirmPaymentDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeletePayment payment.id - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/Table.elm b/src/client/LoggedIn/Income/Table.elm deleted file mode 100644 index f10a552..0000000 --- a/src/client/LoggedIn/Income/Table.elm +++ /dev/null @@ -1,128 +0,0 @@ -module LoggedIn.Income.Table exposing - ( view - ) - -import Dict exposing (..) -import Date exposing (Date) -import String exposing (append) - -import FontAwesome -import View.Color as Color - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Tooltip - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import LoggedIn.Msg as LoggedInMsg - -import View.Date as Date -import LoggedIn.View.Format as Format - -import Model.User exposing (getUserName) -import Model.Income as Income exposing (..) -import Model.Translations exposing (getMessage) - -view : LoggedData -> Html Msg -view loggedData = - let incomes = - loggedData.incomes - |> Dict.toList - |> List.sortBy (.time << Tuple.second) - |> List.reverse - in div - [ class "table" ] - [ div - [ class "lines" ] - ( headerLine loggedData :: List.map (paymentLine loggedData) incomes) - , if List.isEmpty (Dict.toList loggedData.incomes) - then - div - [ class "emptyTableMsg" ] - [ text <| getMessage loggedData.translations "NoIncome" ] - else - text "" - ] - -headerLine : LoggedData -> Html Msg -headerLine loggedData = - div - [ class "header" ] - [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ] - , div [ class "cell income" ] [ text <| getMessage loggedData.translations "Income" ] - , div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - , div [ class "cell" ] [] - ] - -paymentLine : LoggedData -> (IncomeId, Income) -> Html Msg -paymentLine loggedData (incomeId, income) = - div - [ class "row" ] - [ div - [ class "cell name" ] - [ income.userId - |> getUserName loggedData.users - |> Maybe.withDefault "−" - |> text - ] - , div - [ class "cell income" ] - [ text (Format.price loggedData.conf income.amount) ] - , div - [ class "cell date" ] - [ text (Date.longView (Date.fromTime income.time) loggedData.translations) ] - , div - [ class "cell button" ] - [ let currentDate = Date.fromTime loggedData.currentTime - in AddIncome.button - loggedData - (AddIncome.initialClone loggedData.translations currentDate income) - "CloneIncome" - (FontAwesome.clone Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Clone")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - AddIncome.button - loggedData - (AddIncome.initialEdit loggedData.translations incomeId income) - "EditIncome" - (FontAwesome.pencil Color.chestnutRose 18) - (Just (getMessage loggedData.translations "Edit")) - ] - , div - [ class "cell button" ] - [ if loggedData.me /= income.userId - then - text "" - else - let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete") - ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - ) - [ FontAwesome.trash Color.chestnutRose 18 ] - ] - ] diff --git a/src/client/LoggedIn/Income/View.elm b/src/client/LoggedIn/Income/View.elm deleted file mode 100644 index 85b0dc3..0000000 --- a/src/client/LoggedIn/Income/View.elm +++ /dev/null @@ -1,104 +0,0 @@ -module LoggedIn.Income.View exposing - ( view - ) - -import Dict -import Date -import Time exposing (Time) -import Task - -import FontAwesome - -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -import Form exposing (Form) -import View.Form as Form -import View.Events exposing (onSubmitPrevDefault) - -import Dialog -import Dialog.AddIncome.Model as AddIncome -import Dialog.AddIncome.View as AddIncome - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Income exposing (IncomeId, Income, userCumulativeIncomeSince) -import Model.Translations exposing (getMessage, getParamMessage) -import Model.Payer exposing (useIncomesFrom) -import Model.User exposing (UserId, User) -import Model.View as View - -import View.Date as Date -import LoggedIn.View.Format as Format -import View.Color as Color -import LoggedIn.Income.Table as Table - -view : LoggedData -> Html Msg -view loggedData = - div - [ class "income" ] - [ div - [ class "withMargin" ] - [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of - Just since -> cumulativeIncomesView loggedData since - Nothing -> text "" - , div - [ class "titleButton" ] - [ h1 [] [ text <| getMessage loggedData.translations "MonthlyNetIncomes" ] - , AddIncome.button - loggedData - (AddIncome.initialAdd loggedData.translations (Date.fromTime loggedData.currentTime)) - "AddIncome" - (text (getMessage loggedData.translations "AddIncome")) - Nothing - ] - ] - , Table.view loggedData - ] - -cumulativeIncomesView : LoggedData -> Time -> Html Msg -cumulativeIncomesView loggedData since = - let longDate = Date.longView (Date.fromTime since) loggedData.translations - in div - [] - [ h1 [] [ text <| getParamMessage [longDate] loggedData.translations "CumulativeIncomesSince" ] - , ul - [] - ( Dict.toList loggedData.users - |> List.map (\(userId, user) -> - (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId) - ) - |> List.sortBy Tuple.second - |> List.map (\(userName, cumulativeIncome) -> - li - [] - [ text userName - , text " − " - , text <| Format.price loggedData.conf cumulativeIncome - ] - ) - ) - ] - -incomeView : LoggedData -> (IncomeId, Income) -> Html Msg -incomeView loggedData (incomeId, income) = - li - [] - [ text <| Date.shortView (Date.fromTime income.time) loggedData.translations - , text " − " - , text <| Format.price loggedData.conf income.amount - , let dialogConfig = - { className = "deleteIncomeDialog" - , title = getMessage loggedData.translations "ConfirmIncomeDelete" - , body = always <| text "" - , confirm = getMessage loggedData.translations "Confirm" - , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId - , undo = getMessage loggedData.translations "Undo" - } - in button - [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ] - [ FontAwesome.trash Color.chestnutRose 14 ] - ] diff --git a/src/client/LoggedIn/Model.elm b/src/client/LoggedIn/Model.elm deleted file mode 100644 index f4fad94..0000000 --- a/src/client/LoggedIn/Model.elm +++ /dev/null @@ -1,38 +0,0 @@ -module LoggedIn.Model exposing - ( Model - , init - ) - -import Time exposing (Time) - -import LoggedIn.Home.Model as Home -import LoggedIn.Stat.Model as Stat -import Model.Category exposing (Categories) -import Model.Income exposing (Incomes) -import Model.Init exposing (..) -import Model.Payment exposing (Payments) -import Model.PaymentCategory exposing (PaymentCategories) -import Model.User exposing (Users, UserId) - -type alias Model = - { home : Home.Model - , stat : Stat.Model - , users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -init : Time -> Init -> Model -init time { users, me, payments, incomes, categories, paymentCategories } = - { home = Home.init - , stat = Stat.init time paymentCategories payments - , users = users - , me = me - , payments = payments - , incomes = incomes - , categories = categories - , paymentCategories = paymentCategories - } diff --git a/src/client/LoggedIn/Msg.elm b/src/client/LoggedIn/Msg.elm deleted file mode 100644 index d9b3bce..0000000 --- a/src/client/LoggedIn/Msg.elm +++ /dev/null @@ -1,26 +0,0 @@ -module LoggedIn.Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) - -import LoggedIn.Home.Msg as Home -import LoggedIn.Stat.Msg as Stat -import Model.Category exposing (CategoryId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Payment exposing (PaymentId) - -type Msg = - NoOp - | HomeMsg Home.Msg - | StatMsg Stat.Msg - | ValidateCreatePayment PaymentId String Int Date CategoryId Frequency - | ValidateEditPayment PaymentId String Int Date CategoryId Frequency - | ValidateDeletePayment PaymentId - | ValidateCreateIncome IncomeId Int Date - | ValidateEditIncome IncomeId Int Date - | ValidateDeleteIncome IncomeId - | ValidateCreateCategory CategoryId String String - | ValidateEditCategory CategoryId String String - | ValidateDeleteCategory CategoryId diff --git a/src/client/LoggedIn/Stat/Model.elm b/src/client/LoggedIn/Stat/Model.elm deleted file mode 100644 index bfc66f2..0000000 --- a/src/client/LoggedIn/Stat/Model.elm +++ /dev/null @@ -1,34 +0,0 @@ -module LoggedIn.Stat.Model exposing - ( Model - , init - , getPaymentsByMonthByCategory - ) - -import Date exposing (Month) -import List.Extra as List -import Time exposing (Time) - -import Model.Category exposing (CategoryId) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) - -type alias Model = - { paymentsByMonthByCategory : List ((Month, Int), List (CategoryId, Int)) - } - -init : Time -> PaymentCategories -> Payments -> Model -init currentTime paymentCategories payments = - { paymentsByMonthByCategory = getPaymentsByMonthByCategory currentTime paymentCategories payments - } - -getPaymentsByMonthByCategory : Time -> PaymentCategories -> Payments -> List ((Month, Int), List (CategoryId, Int)) -getPaymentsByMonthByCategory currentTime paymentCategories payments = - Payment.punctual payments - |> Payment.groupAndSortByMonth - |> List.map (\(m, payments) -> - ( m - , PaymentCategory.groupPaymentsByCategory paymentCategories payments - |> List.map (Tuple.mapSecond (List.sum << List.map .cost)) - ) - ) diff --git a/src/client/LoggedIn/Stat/Msg.elm b/src/client/LoggedIn/Stat/Msg.elm deleted file mode 100644 index d517544..0000000 --- a/src/client/LoggedIn/Stat/Msg.elm +++ /dev/null @@ -1,7 +0,0 @@ -module LoggedIn.Stat.Msg exposing - ( Msg(..) - ) - -type Msg = - NoOp - | UpdateChart diff --git a/src/client/LoggedIn/Stat/Update.elm b/src/client/LoggedIn/Stat/Update.elm deleted file mode 100644 index 2415733..0000000 --- a/src/client/LoggedIn/Stat/Update.elm +++ /dev/null @@ -1,24 +0,0 @@ -module LoggedIn.Stat.Update exposing - ( update - ) - -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat - -update : LoggedData -> Stat.Msg -> Stat.Model -> (Stat.Model, Cmd Stat.Msg) -update loggedData msg model = - case msg of - - Stat.NoOp -> - ( model - , Cmd.none - ) - - Stat.UpdateChart -> - let { currentTime, paymentCategories, payments } = loggedData - in ( { model - | paymentsByMonthByCategory = Stat.getPaymentsByMonthByCategory currentTime paymentCategories payments - } - , Cmd.none - ) diff --git a/src/client/LoggedIn/Stat/View.elm b/src/client/LoggedIn/Stat/View.elm deleted file mode 100644 index e389c67..0000000 --- a/src/client/LoggedIn/Stat/View.elm +++ /dev/null @@ -1,77 +0,0 @@ -module LoggedIn.Stat.View exposing - ( view - ) - -import Date exposing (Month) -import Dict -import Html exposing (..) -import Html.Attributes exposing (..) -import List.Extra as List -import Time exposing (Time) - -import Chart.Api as Chart -import LoggedData exposing (LoggedData) -import LoggedIn.Stat.Model as Stat -import LoggedIn.View.Format as Format -import Model.Category exposing (CategoryId, Categories) -import Model.Conf exposing (Conf) -import Model.Payment as Payment exposing (Payments) -import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories) -import Model.Translations exposing (Translations, getMessage, getParamMessage) -import Msg exposing (Msg) -import Utils.List as List -import View.Date as Date -import View.Plural exposing (plural) - -view : LoggedData -> Stat.Model -> Html Msg -view loggedData { paymentsByMonthByCategory } = - div - [ class "stat withMargin" ] - [ renderChart loggedData paymentsByMonthByCategory ] - -renderChart : LoggedData -> List ((Month, Int), List (CategoryId, Int)) -> Html msg -renderChart { currentTime, paymentCategories, categories, conf, translations } paymentsByMonthByCategory = - let monthPaymentMean = getMonthPaymentMean currentTime paymentsByMonthByCategory - title = getParamMessage [ Format.price conf monthPaymentMean ] translations "ByMonthsAndMean" - keys = - paymentsByMonthByCategory - |> List.map (\((month, year), _) -> Date.shortMonthAndYear month year translations) - series = - categories - |> Dict.toList - |> List.map (\(categoryId, category) -> - { values = - List.map - (\(_, paymentsByCategory) -> - paymentsByCategory - |> List.find (\(c, _) -> c == categoryId) - |> Maybe.map (toFloat << Tuple.second) - |> Maybe.withDefault 0 - ) - paymentsByMonthByCategory - , color = category.color - , label = category.name - } - ) - totalSerie = - { values = - List.transpose (List.map .values series) - |> List.map List.sum - , color = "black" - , label = getMessage translations "Total" - } - in Chart.from keys (series ++ [totalSerie]) - |> Chart.withSize { x = 2000, y = 900 } - |> Chart.withTitle title - |> Chart.withOrdinate 10 (Format.price conf << truncate) - |> Chart.toHtml - -getMonthPaymentMean : Time -> List ((Month, Int), List (CategoryId, Int)) -> Int -getMonthPaymentMean currentTime paymentsByMonthByCategory = - paymentsByMonthByCategory - |> List.filter (\((month, year), _) -> - let currentDate = Date.fromTime currentTime - in not (Date.month currentDate == month && Date.year currentDate == year) - ) - |> List.map (List.sum << List.map Tuple.second << Tuple.second) - |> List.mean diff --git a/src/client/LoggedIn/Update.elm b/src/client/LoggedIn/Update.elm deleted file mode 100644 index a1d5f7d..0000000 --- a/src/client/LoggedIn/Update.elm +++ /dev/null @@ -1,137 +0,0 @@ -module LoggedIn.Update exposing - ( update - ) - -import Date exposing (Date) -import Dict -import Form -import Http exposing (Error(..)) -import Platform.Cmd exposing (Cmd) -import String -import Task - -import LoggedData -import LoggedIn.Home.Model as Home -import LoggedIn.Home.Msg as Home -import LoggedIn.Home.Update as Home -import LoggedIn.Model as LoggedInModel -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Model as Stat -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Stat.Update as Stat -import Model exposing (Model) -import Model.Category exposing (Category) -import Model.Frequency exposing (Frequency(..)) -import Model.Income as Income exposing (Income) -import Model.Payment as Payment exposing (Payment) -import Model.PaymentCategory as PaymentCategory -import Server - -import Utils.Cmd exposing ((:>)) - -update : Model -> LoggedIn.Msg -> LoggedInModel.Model -> (LoggedInModel.Model, Cmd LoggedIn.Msg) -update model msg loggedIn = - let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case msg of - - LoggedIn.NoOp -> - ( loggedIn - , Cmd.none - ) - - LoggedIn.HomeMsg homeMsg -> - case Home.update loggedData homeMsg loggedIn.home of - (home, effects) -> - ( { loggedIn | home = home } - , Cmd.map LoggedIn.HomeMsg effects - ) - - LoggedIn.StatMsg statMsg -> - case Stat.update loggedData statMsg loggedIn.stat of - (stat, effects) -> - ( { loggedIn | stat = stat } - , Cmd.map LoggedIn.StatMsg effects - ) - - LoggedIn.ValidateCreatePayment paymentId name cost date category frequency -> - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial frequency))) loggedIn - :> update model (LoggedIn.HomeMsg <| Home.UpdatePage 1) - :> (\loggedIn -> - let newPayment = Payment paymentId name cost date loggedIn.me frequency - in ( { loggedIn - | payments = newPayment :: loggedIn.payments - , paymentCategories = PaymentCategory.save name category loggedIn.paymentCategories - } - , Cmd.none - ) - ) - - LoggedIn.ValidateEditPayment paymentId name cost date category frequency -> - let updatedPayment = Payment paymentId name cost date loggedIn.me frequency - mbOldPayment = Payment.find paymentId loggedIn.payments - in ( { loggedIn - | payments = Payment.edit updatedPayment loggedIn.payments - , paymentCategories = - case mbOldPayment of - Just oldPayment -> - PaymentCategory.save name category loggedIn.paymentCategories - Nothing -> - loggedData.paymentCategories - } - , Cmd.none - ) - - LoggedIn.ValidateDeletePayment paymentId -> - let payments = Payment.delete paymentId loggedIn.payments - frequency = - case Form.getOutput loggedIn.home.search of - Just data -> data.frequency - Nothing -> Punctual - switchToPunctual = - ( frequency == Monthly - && List.isEmpty (Payment.monthly payments) - ) - in if switchToPunctual - then - update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial Punctual))) loggedIn - :> (\loggedIn -> - ( { loggedIn | payments = payments } - , Cmd.none - ) - ) - else - ( { loggedIn | payments = payments } - , Cmd.none - ) - - LoggedIn.ValidateCreateIncome incomeId amount date -> - let newIncome = { userId = loggedIn.me, amount = amount, time = Date.toTime date } - in ( { loggedIn | incomes = Dict.insert incomeId newIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateEditIncome incomeId amount date -> - let updateIncome _ = Just <| Income loggedIn.me (Date.toTime date) amount - in ( { loggedIn | incomes = Dict.update incomeId updateIncome loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateDeleteIncome incomeId -> - ( { loggedIn | incomes = Dict.remove incomeId loggedIn.incomes } - , Cmd.none - ) - - LoggedIn.ValidateCreateCategory categoryId name color -> - let newCategory = { name = name, color = color } - in ( { loggedIn | categories = Dict.insert categoryId newCategory loggedIn.categories } - , Cmd.none - ) - - LoggedIn.ValidateEditCategory categoryId name color -> - let updateCategory _ = Just <| Category name color - in ( { loggedIn | categories = Dict.update categoryId updateCategory loggedIn.categories } , Cmd.none) - - LoggedIn.ValidateDeleteCategory categoryId -> - ( { loggedIn | categories = Dict.remove categoryId loggedIn.categories } - , Cmd.none - ) diff --git a/src/client/LoggedIn/View.elm b/src/client/LoggedIn/View.elm deleted file mode 100644 index 4936c6e..0000000 --- a/src/client/LoggedIn/View.elm +++ /dev/null @@ -1,33 +0,0 @@ -module LoggedIn.View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Page - -import Msg exposing (Msg) -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import LoggedData - -import LoggedIn.Model as LoggedInModel - -import LoggedIn.Home.View as Home -import LoggedIn.Income.View as Income -import LoggedIn.Category.View as Categories -import LoggedIn.Stat.View as Stat - -view : Model -> LoggedInModel.Model -> Html Msg -view model loggedIn = - div - [ class "loggedIn" ] - [ let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn - in case model.page of - Page.Home -> Home.view loggedData loggedIn.home - Page.Income -> Income.view loggedData - Page.Categories -> Categories.view loggedData - Page.Statistics -> Stat.view loggedData loggedIn.stat - Page.NotFound -> div [] [ text (getMessage model.translations "PageNotFound") ] - ] diff --git a/src/client/LoggedIn/View/Format.elm b/src/client/LoggedIn/View/Format.elm deleted file mode 100644 index f41e2cd..0000000 --- a/src/client/LoggedIn/View/Format.elm +++ /dev/null @@ -1,37 +0,0 @@ -module LoggedIn.View.Format exposing - ( price - ) - -import String exposing (..) - -import Model.Conf exposing (Conf) - -price : Conf -> Int -> String -price conf amount = - ( number amount - ++ " " - ++ conf.currency - ) - -number : Int -> String -number n = - abs n - |> toString - |> toList - |> List.reverse - |> group 3 - |> List.intersperse [' '] - |> List.concat - |> List.reverse - |> fromList - |> append (if n < 0 then "-" else "") - -group : Int -> List a -> List (List a) -group n xs = - if List.length xs <= n - then - [xs] - else - let take = List.take n xs - drop = List.drop n xs - in take :: (group n drop) diff --git a/src/client/Main.elm b/src/client/Main.elm deleted file mode 100644 index 7981a1c..0000000 --- a/src/client/Main.elm +++ /dev/null @@ -1,26 +0,0 @@ -module Main exposing - ( main - ) - -import Navigation -import Time -import Msg exposing (Msg(UpdatePage)) - -import Model exposing (init) -import Update exposing (update) -import View exposing (view) -import Page -import Tooltip - -main = - Navigation.programWithFlags (UpdatePage << Page.fromLocation) - { init = init - , view = view - , update = update - , subscriptions = (\model -> - Sub.batch - [ Time.every 60000 Msg.UpdateTime - , Sub.map Msg.Tooltip Tooltip.subscription - ] - ) - } diff --git a/src/client/Main.hs b/src/client/Main.hs new file mode 100644 index 0000000..c5f2c50 --- /dev/null +++ b/src/client/Main.hs @@ -0,0 +1,41 @@ +module Main + ( main + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import Data.JSString.Text (textFromJSString) +import qualified Data.Text.Encoding as T +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.NonElementParentNode as Dom +import GHCJS.DOM.Types (JSM, Element, JSString) +import Prelude hiding (init, error) + +import Common.Model (InitResult(InitEmpty)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import qualified View.App as App + +main :: JSM () +main = do + initResult <- readInit + putStrLn . show $ initResult + App.widget initResult + +readInit :: JSM InitResult +readInit = do + document <- Dom.currentDocumentUnchecked + initNode <- Dom.getElementById document "init" + case initNode of + Just node -> do + text <- textFromJSString <$> js_getInnerText node + return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of + Just init -> init + Nothing -> initParseError + _ -> + return initParseError + where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + +foreign import javascript unsafe "$1[\"innerText\"]" + js_getInnerText :: Element -> IO JSString diff --git a/src/client/Model.elm b/src/client/Model.elm deleted file mode 100644 index 7f62416..0000000 --- a/src/client/Model.elm +++ /dev/null @@ -1,72 +0,0 @@ -module Model exposing - ( Model - , init - ) - -import Time exposing (Time) -import Json.Decode as Decode - -import Navigation exposing (Location) - -import Html as Html - -import Page exposing (Page) -import Init as Init exposing (Init) -import Msg exposing (Msg) - -import Model.View exposing (..) -import Model.Translations exposing (..) -import Model.Conf exposing (..) -import Model.InitResult exposing (..) -import LoggedIn.Model as LoggedInModel -import SignIn.Model as SignInModel - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -type alias Model = - { view : View - , currentTime : Time - , translations : Translations - , conf : Conf - , page : Page - , errors : List String - , dialog : Dialog.Model DialogModel.Model DialogMsg.Msg Msg - , tooltip : Tooltip.Model - } - -init : Decode.Value -> Location -> (Model, Cmd Msg) -init payload location = - let model = - case Decode.decodeValue Init.decoder payload of - Ok { time, translations, conf, result, windowSize } -> - { view = - case result of - InitEmpty -> - SignInView (SignInModel.init Nothing) - InitSuccess init -> - LoggedInView (LoggedInModel.init time init) - InitError error -> - SignInView (SignInModel.init (Just error)) - , currentTime = time - , translations = translations - , conf = conf - , page = Page.fromLocation location - , errors = [] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init windowSize.width windowSize.height - } - Err error -> - { view = SignInView (SignInModel.init (Just error)) - , currentTime = 0 - , translations = [] - , conf = { currency = "" } - , page = Page.fromLocation location - , errors = [ error ] - , dialog = Dialog.init DialogModel.init Msg.Dialog - , tooltip = Tooltip.init 0 0 - } - in (model, Cmd.none) diff --git a/src/client/Model/Category.elm b/src/client/Model/Category.elm deleted file mode 100644 index 8b653a7..0000000 --- a/src/client/Model/Category.elm +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Category exposing - ( Categories - , Category - , CategoryId - , categoriesDecoder - , categoryIdDecoder - , empty - ) - -import Json.Decode as Decode exposing (Decoder) -import Utils.Json as Json -import Dict exposing (Dict) - -type alias Categories = Dict CategoryId Category - -type alias CategoryId = Int - -type alias Category = - { name : String - , color : String - } - -categoriesDecoder : Decoder Categories -categoriesDecoder = - Json.dictDecoder (Decode.field "id" categoryIdDecoder) <| - Decode.map2 - Category - (Decode.field "name" Decode.string) - (Decode.field "color" Decode.string) - -categoryIdDecoder : Decoder CategoryId -categoryIdDecoder = Decode.int - -empty : Categories -empty = Dict.empty diff --git a/src/client/Model/Conf.elm b/src/client/Model/Conf.elm deleted file mode 100644 index 308fa04..0000000 --- a/src/client/Model/Conf.elm +++ /dev/null @@ -1,13 +0,0 @@ -module Model.Conf exposing - ( Conf - , confDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Conf = - { currency : String - } - -confDecoder : Decoder Conf -confDecoder = Decode.map Conf (Decode.field "currency" Decode.string) diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm deleted file mode 100644 index bfba02f..0000000 --- a/src/client/Model/Date.elm +++ /dev/null @@ -1,15 +0,0 @@ -module Model.Date exposing - ( timeDecoder - , dateDecoder - ) - -import Date as Date exposing (Date) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import Time exposing (Time) - -timeDecoder : Decoder Time -timeDecoder = Decode.map Date.toTime dateDecoder - -dateDecoder : Decoder Date -dateDecoder = Decode.string |> Decode.andThen (Date.fromString >> Decode.fromResult) diff --git a/src/client/Model/Frequency.elm b/src/client/Model/Frequency.elm deleted file mode 100644 index 40f9893..0000000 --- a/src/client/Model/Frequency.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Model.Frequency exposing - ( Frequency(..) - , decoder - , validate - , fromString - ) - -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode - -import Form.Validate as Validate exposing (Validation) - -type Frequency = Punctual | Monthly - -decoder : Decoder Frequency -decoder = - let frequencyResult input = - fromString input - |> Result.fromMaybe ("Could not deduce Punctual nor Monthly from " ++ input) - in Decode.string |> Decode.andThen (Decode.fromResult << frequencyResult) - -validate : Validation String Frequency -validate = - Validate.customValidation Validate.string (\str -> - fromString str - |> Result.fromMaybe (Validate.customError "InvalidFrequency") - ) - -fromString : String -> Maybe Frequency -fromString str = - if str == toString Punctual then - Just Punctual - else if str == toString Monthly then - Just Monthly - else - Nothing diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm deleted file mode 100644 index aa5f05f..0000000 --- a/src/client/Model/Income.elm +++ /dev/null @@ -1,101 +0,0 @@ -module Model.Income exposing - ( Incomes - , Income - , IncomeId - , incomesDecoder - , incomeIdDecoder - , incomeDefinedForAll - , userCumulativeIncomeSince - , cumulativeIncomesSince - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List exposing (..) -import Maybe.Extra as Maybe -import Time exposing (Time, hour) -import Utils.Json as Json - -import Model.Date exposing (timeDecoder) -import Model.User exposing (UserId, userIdDecoder) - -type alias Incomes = Dict IncomeId Income - -type alias IncomeId = Int - -type alias Income = - { userId : UserId - , time : Float - , amount : Int - } - -incomesDecoder : Decoder Incomes -incomesDecoder = - Json.dictDecoder (Decode.field "id" incomeIdDecoder) <| - Decode.map3 Income - (Decode.field "userId" userIdDecoder) - (Decode.field "date" timeDecoder) - (Decode.field "amount" Decode.int) - -incomeIdDecoder : Decoder IncomeId -incomeIdDecoder = Decode.int - -incomeDefinedForAll : List UserId -> Incomes -> Maybe Time -incomeDefinedForAll userIds incomes = - let userIncomes = List.map (\userId -> List.filter ((==) userId << .userId) << Dict.values <| incomes) userIds - firstIncomes = map (head << sortBy .time) userIncomes - in if all Maybe.isJust firstIncomes - then head << reverse << List.sort << map .time << Maybe.values <| firstIncomes - else Nothing - -userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int -userCumulativeIncomeSince currentTime since incomes userId = - incomes - |> Dict.values - |> List.filter (\income -> income.userId == userId) - |> cumulativeIncomesSince currentTime since - -cumulativeIncomesSince : Time -> Time -> (List Income) -> Int -cumulativeIncomesSince currentTime since incomes = - cumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince : Time -> List Income -> List Income -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> income.time >= time) incomes - in (Maybe.toList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt : Time -> List Income -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if x.time < time - then Just { userId = x.userId, time = time, amount = x.amount } - else Nothing - x1 :: x2 :: xs -> - if x1.time < time && x2.time >= time - then Just { userId = x1.userId, time = time, amount = x1.amount } - else getIncomeAt time (x2 :: xs) - [] -> - Nothing - -cumulativeIncome : Time -> List Income -> Int -cumulativeIncome currentTime incomes = - getIncomesWithDuration currentTime (List.sortBy .time incomes) - |> map durationIncome - |> sum - -getIncomesWithDuration : Time -> List Income -> List (Float, Int) -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(currentTime - income.time, income.amount)] - (income1 :: income2 :: xs) -> - (income2.time - income1.time, income1.amount) :: (getIncomesWithDuration currentTime (income2 :: xs)) - -durationIncome : (Float, Int) -> Int -durationIncome (duration, income) = - duration * toFloat income / (hour * 24 * 365 / 12) - |> truncate diff --git a/src/client/Model/Init.elm b/src/client/Model/Init.elm deleted file mode 100644 index db7069f..0000000 --- a/src/client/Model/Init.elm +++ /dev/null @@ -1,31 +0,0 @@ -module Model.Init exposing - ( Init - , initDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Payment exposing (Payments, paymentsDecoder) -import Model.User exposing (Users, UserId, usersDecoder, userIdDecoder) -import Model.Income exposing (Incomes, incomesDecoder) -import Model.Category exposing (Categories, categoriesDecoder) -import Model.PaymentCategory exposing (PaymentCategories, paymentCategoriesDecoder) - -type alias Init = - { users : Users - , me : UserId - , payments : Payments - , incomes : Incomes - , categories : Categories - , paymentCategories : PaymentCategories - } - -initDecoder : Decoder Init -initDecoder = - Decode.map6 Init - (Decode.field "users" usersDecoder) - (Decode.field "me" userIdDecoder) - (Decode.field "payments" paymentsDecoder) - (Decode.field "incomes" incomesDecoder) - (Decode.field "categories" categoriesDecoder) - (Decode.field "paymentCategories" paymentCategoriesDecoder) diff --git a/src/client/Model/InitResult.elm b/src/client/Model/InitResult.elm deleted file mode 100644 index 7ce0be2..0000000 --- a/src/client/Model/InitResult.elm +++ /dev/null @@ -1,28 +0,0 @@ -module Model.InitResult exposing - ( InitResult(..) - , initResultDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -import Model.Init exposing (Init, initDecoder) - -type InitResult = - InitEmpty - | InitSuccess Init - | InitError String - -initResultDecoder : Decoder InitResult -initResultDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen initResultDecoderWithTag - -initResultDecoderWithTag : String -> Decoder InitResult -initResultDecoderWithTag tag = - case tag of - "InitEmpty" -> - Decode.succeed InitEmpty - "InitSuccess" -> - Decode.map InitSuccess (Decode.field "contents" initDecoder) - "InitError" -> - Decode.map InitError (Decode.field "contents" Decode.string) - _ -> - Decode.fail <| "got " ++ tag ++ " for InitResult" diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm deleted file mode 100644 index 4d9190e..0000000 --- a/src/client/Model/Payer.elm +++ /dev/null @@ -1,137 +0,0 @@ -module Model.Payer exposing - ( Payers - , Payer - , ExceedingPayer - , getOrderedExceedingPayers - , useIncomesFrom - ) - -import Dict exposing (..) -import List -import Maybe -import Time exposing (Time) -import Date - -import Model.Payment exposing (Payments, totalPayments) -import Model.User exposing (Users, UserId, userIdDecoder) -import Model.Income exposing (..) - -import Utils.Dict exposing (mapValues) - -type alias Payers = Dict UserId Payer - -type alias Payer = - { preIncomePaymentSum : Int - , postIncomePaymentSum : Int - , incomes : List Income - } - -type alias PostPaymentPayer = - { preIncomePaymentSum : Int - , cumulativeIncome : Int - , ratio : Float - } - -type alias ExceedingPayer = - { userId : UserId - , amount : Int - } - -getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer -getOrderedExceedingPayers currentTime users incomes payments = - let payers = getPayers currentTime users incomes payments - exceedingPayersOnPreIncome = - payers - |> mapValues .preIncomePaymentSum - |> Dict.toList - |> exceedingPayersFromAmounts - mbSince = useIncomesFrom users incomes payments - in case mbSince of - Just since -> - let postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - postPaymentPayers - |> Dict.toList - |> List.map (.ratio << Tuple.second) - |> List.maximum - in case mbMaxRatio of - Just maxRatio -> - postPaymentPayers - |> mapValues (getFinalDiff maxRatio) - |> Dict.toList - |> exceedingPayersFromAmounts - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom : Users -> Incomes -> Payments -> Maybe Time -useIncomesFrom users incomes payments = - let firstPaymentTime = - payments - |> List.map (Date.toTime << .date) - |> List.sort - |> List.head - mbIncomeTime = incomeDefinedForAll (Dict.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just paymentTime, Just incomeTime) -> - Just (max paymentTime incomeTime) - _ -> - Nothing - -getPayers : Time -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Dict.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in userIds - |> List.map (\userId -> - ( userId - , { preIncomePaymentSum = - totalPayments - (\p -> (Date.toTime p.date) < (Maybe.withDefault currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> (Date.toTime p.date) >= t - ) - userId - payments - , incomes = List.filter ((==) userId << .userId) (Dict.values incomes) - } - ) - ) - |> Dict.fromList - -exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer -exceedingPayersFromAmounts userAmounts = - let mbMinAmount = List.minimum << List.map Tuple.second <| userAmounts - in case mbMinAmount of - Nothing -> - [] - Just minAmount -> - userAmounts - |> List.map (\userAmount -> - { userId = Tuple.first userAmount - , amount = Tuple.second userAmount - minAmount - } - ) - |> List.filter (\payer -> payer.amount > 0) - -getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes - in { preIncomePaymentSum = payer.preIncomePaymentSum - , cumulativeIncome = cumulativeIncome - , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome - } - -getFinalDiff : Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome - |> truncate - in postIncomeDiff + payer.preIncomePaymentSum diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm deleted file mode 100644 index 204f9f5..0000000 --- a/src/client/Model/Payment.elm +++ /dev/null @@ -1,117 +0,0 @@ -module Model.Payment exposing - ( perPage - , Payments - , Payment - , PaymentId - , paymentsDecoder - , paymentIdDecoder - , find - , edit - , delete - , totalPayments - , punctual - , monthly - , groupAndSortByMonth - , search - ) - -import Date exposing (..) -import Date.Extra.Core exposing (monthToInt, intToMonth) -import Json.Decode as Decode exposing (Decoder) -import Json.Decode.Extra as Decode -import List -import List.Extra as List - -import Form.Validate as Validate exposing (Validation) -import Model.Date exposing (dateDecoder) -import Model.Frequency as Frequency exposing (Frequency(..)) -import Model.User exposing (UserId, userIdDecoder) -import Utils.List as List -import Utils.Search as Search - -perPage : Int -perPage = 7 - -type alias Payments = List Payment - -type alias Payment = - { id : PaymentId - , name : String - , cost : Int - , date : Date - , userId : UserId - , frequency : Frequency - } - -type alias PaymentId = Int - -paymentsDecoder : Decoder Payments -paymentsDecoder = Decode.list paymentDecoder - -paymentDecoder : Decoder Payment -paymentDecoder = - Decode.map6 Payment - (Decode.field "id" paymentIdDecoder) - (Decode.field "name" Decode.string) - (Decode.field "cost" Decode.int) - (Decode.field "date" dateDecoder) - (Decode.field "userId" userIdDecoder) - (Decode.field "frequency" Frequency.decoder) - -paymentIdDecoder : Decoder PaymentId -paymentIdDecoder = Decode.int - -find : PaymentId -> Payments -> Maybe Payment -find paymentId payments = - payments - |> List.find (\p -> p.id == paymentId) - -edit : Payment -> Payments -> Payments -edit payment payments = payment :: delete payment.id payments - -delete : PaymentId -> Payments -> Payments -delete paymentId = List.filter (((/=) paymentId) << .id) - -totalPayments : (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - payments - |> List.filter (\payment -> - paymentFilter payment - && payment.userId == userId - ) - |> List.map .cost - |> List.sum - -punctual : Payments -> Payments -punctual = List.filter ((==) Punctual << .frequency) - -monthly : Payments -> Payments -monthly = List.filter ((==) Monthly << .frequency) - -groupAndSortByMonth : Payments -> List ((Month, Int), Payments) -groupAndSortByMonth payments = - payments - |> List.groupBy (\payment -> (Date.year payment.date, monthToInt << Date.month <| payment.date)) - |> List.sortBy Tuple.first - |> List.map (\((year, month), payments) -> ((intToMonth month, year), payments)) - -search : String -> Frequency -> Payments -> Payments -search name frequency payments = - payments - |> List.filter ((==) frequency << .frequency) - |> paymentSort frequency - |> List.filter (searchSuccess name) - -paymentSort : Frequency -> Payments -> Payments -paymentSort frequency = - case frequency of - Punctual -> List.reverse << List.sortBy (Date.toTime << .date) - Monthly -> List.sortBy (String.toLower << .name) - -searchSuccess : String -> Payment -> Bool -searchSuccess search { name, cost } = - let searchSuccessWord word = - ( String.contains (Search.format word) (Search.format name) - || String.contains word (toString cost) - ) - in List.all searchSuccessWord (String.words search) diff --git a/src/client/Model/PaymentCategory.elm b/src/client/Model/PaymentCategory.elm deleted file mode 100644 index a4fceb1..0000000 --- a/src/client/Model/PaymentCategory.elm +++ /dev/null @@ -1,61 +0,0 @@ -module Model.PaymentCategory exposing - ( PaymentCategories - , paymentCategoriesDecoder - , search - , groupPaymentsByCategory - , isCategoryUnused - , save - ) - -import Dict exposing (Dict) -import Json.Decode as Decode exposing (Decoder) -import List.Extra as List -import Maybe.Extra as Maybe - -import Model.Category exposing (CategoryId, categoryIdDecoder) -import Model.Payment exposing (Payments) -import Utils.Json as Json -import Utils.List as List -import Utils.Search as Search - -type alias PaymentCategories = List PaymentCategory - -type alias PaymentCategory = - { name : String - , category : CategoryId - } - -paymentCategoriesDecoder : Decoder PaymentCategories -paymentCategoriesDecoder = - Decode.list <| Decode.map2 PaymentCategory - (Decode.field "name" Decode.string) - (Decode.field "category" categoryIdDecoder) - -groupPaymentsByCategory : PaymentCategories -> Payments -> List (CategoryId, Payments) -groupPaymentsByCategory paymentCategories payments = - payments - |> List.groupBy (\payment -> - search payment.name paymentCategories - |> Maybe.withDefault -1 - ) - |> List.filterMap (\(category, payments) -> - case category of - -1 -> Nothing - _ -> Just (category, payments) - ) - -search : String -> PaymentCategories -> Maybe CategoryId -search paymentName paymentCategories = - paymentCategories - |> List.find (\pc -> Search.format pc.name == Search.format paymentName) - |> Maybe.map .category - -isCategoryUnused : CategoryId -> PaymentCategories -> Bool -isCategoryUnused category paymentCategories = - paymentCategories - |> List.find ((==) category << .category) - |> Maybe.isNothing - -save : String -> CategoryId -> PaymentCategories -> PaymentCategories -save name category paymentCategories = - { name = name, category = category } :: List.filter (\pc -> not <| Search.format pc.name == Search.format name) paymentCategories diff --git a/src/client/Model/Size.elm b/src/client/Model/Size.elm deleted file mode 100644 index f40fb01..0000000 --- a/src/client/Model/Size.elm +++ /dev/null @@ -1,17 +0,0 @@ -module Model.Size exposing - ( Size - , sizeDecoder - ) - -import Json.Decode as Decode exposing (Decoder) - -type alias Size = - { width: Int - , height: Int - } - -sizeDecoder : Decoder Size -sizeDecoder = - Decode.map2 Size - (Decode.field "width" Decode.int) - (Decode.field "height" Decode.int) diff --git a/src/client/Model/Translations.elm b/src/client/Model/Translations.elm deleted file mode 100644 index 9b314e1..0000000 --- a/src/client/Model/Translations.elm +++ /dev/null @@ -1,68 +0,0 @@ -module Model.Translations exposing - ( translationsDecoder - , Translations - , Translation - , getMessage - , getParamMessage - ) - -import Maybe exposing (withDefault) -import Json.Decode as Decode exposing (Decoder) -import String - -type alias Translations = List Translation - -translationsDecoder : Decoder Translations -translationsDecoder = Decode.list translationDecoder - -type alias Translation = - { key : String - , message : List MessagePart - } - -getTranslation : String -> Translations -> Maybe (List MessagePart) -getTranslation key translations = - translations - |> List.filter (\translation -> String.toLower translation.key == String.toLower key) - |> List.head - |> Maybe.map .message - -translationDecoder : Decoder Translation -translationDecoder = - Decode.map2 Translation - (Decode.field "key" Decode.string) - (Decode.field "message" (Decode.list partDecoder)) - -type MessagePart = - Order Int - | Str String - -partDecoder : Decoder MessagePart -partDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen partDecoderWithTag - -partDecoderWithTag : String -> Decoder MessagePart -partDecoderWithTag tag = - case tag of - "Order" -> Decode.map Order (Decode.field "contents" Decode.int) - _ -> Decode.map Str (Decode.field "contents" Decode.string) - ------ - -getMessage : Translations -> String -> String -getMessage = getParamMessage [] - -getParamMessage : List String -> Translations -> String -> String -getParamMessage values translations key = - getTranslation key translations - |> Maybe.map (\parts -> String.concat (List.map (replacePart values) parts)) - |> withDefault key - -replacePart : List String -> MessagePart -> String -replacePart values part = - case part of - Str str -> str - Order n -> - values - |> List.drop (n - 1) - |> List.head - |> withDefault ("{" ++ (toString n) ++ "}") diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm deleted file mode 100644 index f6e8147..0000000 --- a/src/client/Model/User.elm +++ /dev/null @@ -1,44 +0,0 @@ -module Model.User exposing - ( Users - , usersDecoder - , User - , userDecoder - , UserId - , userIdDecoder - , getUserName - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -type alias Users = Dict UserId User - -type alias UserId = Int - -type alias User = - { name : String - , email : String - } - -usersDecoder : Decoder Users -usersDecoder = Decode.map Dict.fromList (Decode.list userWithIdDecoder) - -userWithIdDecoder : Decode.Decoder (UserId, User) -userWithIdDecoder = - Decode.map2 (,) - (Decode.field "id" userIdDecoder) - userDecoder - -userIdDecoder : Decoder UserId -userIdDecoder = Decode.int - -userDecoder : Decoder User -userDecoder = - Decode.map2 User - (Decode.field "name" Decode.string) - (Decode.field "email" Decode.string) - -getUserName : Users -> UserId -> Maybe String -getUserName users userId = - Dict.get userId users - |> Maybe.map .name diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm deleted file mode 100644 index 61d42a7..0000000 --- a/src/client/Model/View.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Model.View exposing - ( View(..) - ) - -import Model.Payment exposing (Payments) - -import SignIn.Model as SignInModel -import LoggedIn.Model as LoggedInModel - -type View = - SignInView SignInModel.Model - | LoggedInView LoggedInModel.Model diff --git a/src/client/Msg.elm b/src/client/Msg.elm deleted file mode 100644 index 5970747..0000000 --- a/src/client/Msg.elm +++ /dev/null @@ -1,49 +0,0 @@ -module Msg exposing - ( Msg(..) - ) - -import Date exposing (Date) -import Time exposing (Time) - -import Page exposing (Page) - -import Model.Init exposing (Init) -import Model.Payment exposing (PaymentId) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (IncomeId) -import Model.Category exposing (CategoryId) - -import Dialog -import Dialog.Model as DialogModel -import Dialog.Msg as DialogMsg - -import Tooltip - -import SignIn.Msg as SignInMsg -import LoggedIn.Msg as LoggedInMsg - -type Msg = - NoOp - | UpdatePage Page - | SignIn String - | UpdateTime Time - | GoLoggedInView Init - | UpdateSignIn SignInMsg.Msg - | UpdateLoggedIn LoggedInMsg.Msg - | GoSignInView - | SignOut - | Error String - | Dialog (Dialog.Msg DialogModel.Model DialogMsg.Msg Msg) - | Tooltip Tooltip.Msg - - | CreatePayment String Int Date CategoryId Frequency - | EditPayment PaymentId String Int Date CategoryId Frequency - | DeletePayment PaymentId - - | CreateIncome Int Date - | EditIncome IncomeId Int Date - | DeleteIncome IncomeId - - | CreateCategory String String - | EditCategory CategoryId String String - | DeleteCategory CategoryId diff --git a/src/client/Page.elm b/src/client/Page.elm deleted file mode 100644 index 39232e0..0000000 --- a/src/client/Page.elm +++ /dev/null @@ -1,43 +0,0 @@ -module Page exposing - ( Page(..) - , toHash - , fromLocation - ) - -import Navigation exposing (Location) -import UrlParser exposing (Parser, (), s) -import String - -type Page = - Home - | Income - | Categories - | Statistics - | NotFound - -toHash : Page -> String -toHash page = - case page of - Home -> "#" - Income -> "#income" - Categories -> "#categories" - Statistics -> "#statistics" - NotFound -> "#notFound" - -fromLocation : Location -> Page -fromLocation location = - if location.hash == "" - then - Home - else - case UrlParser.parseHash pageParser location of - Just page -> page - Nothing -> NotFound - -pageParser : Parser (Page -> a) a -pageParser = - UrlParser.oneOf - [ UrlParser.map Income (s "income") - , UrlParser.map Categories (s "categories") - , UrlParser.map Statistics (s "statistics") - ] diff --git a/src/client/Server.elm b/src/client/Server.elm deleted file mode 100644 index c44b777..0000000 --- a/src/client/Server.elm +++ /dev/null @@ -1,115 +0,0 @@ -module Server exposing - ( signIn - , createPayment - , editPayment - , deletePayment - , createIncome - , editIncome - , deleteIncome - , createCategory - , editCategory - , deleteCategory - , signOut - ) - -import Task as Task exposing (Task) -import Http exposing (Error) -import Date -import Json.Decode as Decode -import Json.Encode as Encode -import Date exposing (Date) - -import Date.Extra.Format as DateFormat - -import Utils.Http as HttpUtils - -import Model.Payment exposing (..) -import Model.Frequency exposing (Frequency) -import Model.Income exposing (incomeIdDecoder, IncomeId) -import Model.Category exposing (categoryIdDecoder, CategoryId) -import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder) -import Model.Init exposing (Init) - -signIn : String -> (Result Error String -> msg) -> Cmd msg -signIn email = HttpUtils.request "POST" ("/signIn?email=" ++ email) Http.expectString - -createPayment : String -> Int -> Date -> CategoryId -> Frequency -> (Result Error PaymentId -> msg) -> Cmd msg -createPayment name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - expect = Http.expectJson (Decode.field "id" paymentIdDecoder) - in HttpUtils.jsonRequest "POST" "/payment" expect handleResult json - -editPayment : PaymentId -> String -> Int -> Date -> CategoryId -> Frequency -> (Result Error String -> msg) -> Cmd msg -editPayment paymentId name cost date categoryId frequency handleResult = - let json = - Encode.object - [ ("id", Encode.int paymentId) - , ("name", Encode.string name) - , ("cost", Encode.int cost) - , ("date", Encode.string (DateFormat.isoDateString date)) - , ("category", Encode.int categoryId) - , ("frequency", Encode.string (toString frequency)) - ] - in HttpUtils.jsonRequest "PUT" "/payment" Http.expectString handleResult json - -deletePayment : PaymentId -> (Result Error String -> msg) -> Cmd msg -deletePayment paymentId = - HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) Http.expectString - -createIncome : Int -> Date -> (Result Error IncomeId -> msg) -> Cmd msg -createIncome amount date handleResult = - let json = - Encode.object - [ ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - expect = Http.expectJson (Decode.field "id" incomeIdDecoder) - in HttpUtils.jsonRequest "POST" "/income" expect handleResult json - -editIncome : IncomeId -> Int -> Date -> (Result Error String -> msg) -> Cmd msg -editIncome incomeId amount date handleResult = - let json = - Encode.object - [ ("id", Encode.int incomeId) - , ("amount", Encode.int amount) - , ("date", Encode.string (DateFormat.isoDateString date)) - ] - in HttpUtils.jsonRequest "PUT" "/income" Http.expectString handleResult json - -deleteIncome : IncomeId -> (Result Error String -> msg) -> Cmd msg -deleteIncome incomeId = - HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) Http.expectString - -createCategory : String -> String -> (Result Error CategoryId -> msg) -> Cmd msg -createCategory name color handleResult = - let json = - Encode.object - [ ("name", Encode.string name) - , ("color", Encode.string color) - ] - expect = Http.expectJson (Decode.field "id" categoryIdDecoder) - in HttpUtils.jsonRequest "POST" "/category" expect handleResult json - -editCategory : CategoryId -> String -> String -> (Result Error String -> msg) -> Cmd msg -editCategory categoryId name color handleResult = - let json = - Encode.object - [ ("id", Encode.int categoryId) - , ("name", Encode.string name) - , ("color", Encode.string color) - ] - in HttpUtils.jsonRequest "PUT" "/category" Http.expectString handleResult json - -deleteCategory : CategoryId -> (Result Error String -> msg) -> Cmd msg -deleteCategory categoryId = - HttpUtils.request "DELETE" ("/category?id=" ++ (toString categoryId)) Http.expectString - -signOut : (Result Error String -> msg) -> Cmd msg -signOut = HttpUtils.request "POST" "/signOut" Http.expectString diff --git a/src/client/SignIn/Model.elm b/src/client/SignIn/Model.elm deleted file mode 100644 index 19d4305..0000000 --- a/src/client/SignIn/Model.elm +++ /dev/null @@ -1,17 +0,0 @@ -module SignIn.Model exposing - ( Model - , init - ) - -type alias Model = - { login : String - , waitingServer : Bool - , result : Maybe (Result String String) - } - -init : Maybe String -> Model -init mbSignInError = - { login = "" - , waitingServer = False - , result = Maybe.map Err mbSignInError - } diff --git a/src/client/SignIn/Msg.elm b/src/client/SignIn/Msg.elm deleted file mode 100644 index f753ebd..0000000 --- a/src/client/SignIn/Msg.elm +++ /dev/null @@ -1,9 +0,0 @@ -module SignIn.Msg exposing - ( Msg(..) - ) - -type Msg = - UpdateLogin String - | WaitingServer - | ValidLogin - | ErrorLogin String diff --git a/src/client/SignIn/Update.elm b/src/client/SignIn/Update.elm deleted file mode 100644 index 98de777..0000000 --- a/src/client/SignIn/Update.elm +++ /dev/null @@ -1,31 +0,0 @@ -module SignIn.Update exposing - ( update - ) - -import SignIn.Model exposing (..) -import SignIn.Msg exposing (..) - -import Model.Translations exposing (getMessage, Translations) - -update : Translations -> Msg -> Model -> Model -update translations msg signInView = - case msg of - UpdateLogin login -> - { signInView | - login = login - } - WaitingServer -> - { signInView - | waitingServer = True - } - ValidLogin -> - { signInView - | login = "" - , result = Just (Ok (getMessage translations "SignInEmailSent")) - , waitingServer = False - } - ErrorLogin message -> - { signInView - | result = Just (Err message) - , waitingServer = False - } diff --git a/src/client/SignIn/View.elm b/src/client/SignIn/View.elm deleted file mode 100644 index 88f74b0..0000000 --- a/src/client/SignIn/View.elm +++ /dev/null @@ -1,63 +0,0 @@ -module SignIn.View exposing - ( view - ) - -import Json.Decode as Decode - -import FontAwesome -import View.Color as Color - -import Html as H exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import SignIn.Msg as SignInMsg -import SignIn.Model as SignInModel - -import Update exposing (..) - -import Model exposing (Model) -import Msg exposing (..) -import Model.Translations exposing (getMessage) - -import View.Events exposing (onSubmitPrevDefault) - -view : Model -> SignInModel.Model -> Html Msg -view model signInModel = - div - [ class "signIn" ] - [ H.form - [ onSubmitPrevDefault (SignIn signInModel.login) ] - [ input - [ value signInModel.login - , on "input" (targetValue |> (Decode.map <| (UpdateSignIn << SignInMsg.UpdateLogin))) - , name "email" - ] - [] - , button - [] - [ if signInModel.waitingServer - then FontAwesome.spinner Color.white 20 - else text (getMessage model.translations "SignIn") - ] - ] - , div - [ class "result" ] - [ signInResult model signInModel ] - ] - -signInResult : Model -> SignInModel.Model -> Html Msg -signInResult model signInModel = - case signInModel.result of - Just result -> - case result of - Ok login -> - div - [ class "success" ] - [ text (getMessage model.translations "SignInEmailSent") ] - Err error -> - div - [ class "error" ] - [ text (getMessage model.translations error) ] - Nothing -> - text "" diff --git a/src/client/Tooltip.elm b/src/client/Tooltip.elm deleted file mode 100644 index 4f70cda..0000000 --- a/src/client/Tooltip.elm +++ /dev/null @@ -1,113 +0,0 @@ -module Tooltip exposing - ( Msg(..) - , Model - , init - , subscription - , update - , view - , show - ) - -import Platform.Cmd - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Mouse exposing (Position) -import Window exposing (Size) - -type Msg = - UpdateMousePosition Position - | UpdateWindowSize Size - | ShowMessage String - | HideMessage - -type alias Model = - { mousePosition : Maybe Position - , windowSize : Size - , message : Maybe String - } - -init : Int -> Int -> Model -init width height = - { mousePosition = Nothing - , windowSize = - { width = width - , height = height - } - , message = Nothing - } - -subscription : Sub Msg -subscription = - Sub.batch - [ Mouse.moves UpdateMousePosition - , Window.resizes UpdateWindowSize - ] - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - UpdateMousePosition position -> - ( { model | mousePosition = Just position } - , Cmd.none - ) - - UpdateWindowSize size -> - ( { model | windowSize = size } - , Cmd.none - ) - - ShowMessage message -> - ( { model | message = Just message } - , Cmd.none - ) - - HideMessage -> - ( { model | message = Nothing } - , Cmd.none - ) - -view : Model -> Html Msg -view { mousePosition, windowSize, message } = - case (mousePosition, message) of - (Just pos, Just msg) -> - div - [ class "tooltip" - , style - [ ("position", "absolute") - , horizontalPosition windowSize pos - , ("top", px <| pos.y + 15) - ] - ] - [ text msg ] - _ -> - text "" - -horizontalPosition : Size -> Position -> (String, String) -horizontalPosition size position = - if isLeft size position - then ("left", px <| position.x + 5) - else ("right", px <| size.width - position.x) - -verticalPosition : Size -> Position -> (String, String) -verticalPosition size position = - if isTop size position - then ("top", px <| position.y + 20) - else ("bottom", px <| size.height - position.y + 15) - -px : Int -> String -px n = (toString n) ++ "px" - -isLeft : Size -> Position -> Bool -isLeft { width } { x } = x < width // 2 - -isTop : Size -> Position -> Bool -isTop { height } { y } = y < height // 2 - -show : (Msg -> msg) -> String -> List (Attribute msg) -show mapMsg message = - [ onMouseEnter <| mapMsg <| ShowMessage message - , onMouseLeave <| mapMsg <| HideMessage - ] diff --git a/src/client/Update.elm b/src/client/Update.elm deleted file mode 100644 index 4284b65..0000000 --- a/src/client/Update.elm +++ /dev/null @@ -1,182 +0,0 @@ -module Update exposing - ( update - ) - -import Navigation exposing (Location) -import Platform.Cmd exposing (Cmd) -import Task - -import Dialog -import Dialog.Update as DialogUpdate -import LoggedIn.Model as LoggedIn -import LoggedIn.Msg as LoggedIn -import LoggedIn.Stat.Msg as Stat -import LoggedIn.Update as LoggedIn -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Model.View as V -import Msg exposing (..) -import Page exposing (Page(..)) -import Server -import SignIn.Model as SignInModel -import SignIn.Msg as SignInMsg -import SignIn.Update as SignInUpdate -import Tooltip -import Utils.Cmd exposing ((:>)) -import Utils.Http exposing (errorKey) - -update : Msg -> Model -> (Model, Cmd Msg) -update msg model = - case msg of - - NoOp -> - (model, Cmd.none) - - UpdatePage page -> - ( { model | page = page } - , if page == Statistics - then - let msg = UpdateLoggedIn <| LoggedIn.StatMsg <| Stat.UpdateChart - in Task.perform (\_ -> msg) (Task.succeed ()) - else - Cmd.none - ) - - SignIn email -> - ( applySignIn model (SignInMsg.WaitingServer) - , Server.signIn email (\result -> case result of - Ok _ -> UpdateSignIn SignInMsg.ValidLogin - Err error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error)) - ) - ) - - GoLoggedInView init -> - ( { model | view = V.LoggedInView (LoggedIn.init model.currentTime init) } - , Cmd.none - ) - - UpdateTime time -> - ({ model | currentTime = time }, Cmd.none) - - GoSignInView -> - ({ model | view = V.SignInView (SignInModel.init Nothing) }, Cmd.none) - - UpdateSignIn signInMsg -> - (applySignIn model signInMsg, Cmd.none) - - UpdateLoggedIn loggedInMsg -> - applyLoggedIn model loggedInMsg - - SignOut -> - ( model - , Server.signOut (\result -> case result of - Ok _ -> GoSignInView - Err _ -> Error "SignOutError" - ) - ) - - Error error -> - ({ model | errors = model.errors ++ [ error ] }, Cmd.none) - - Dialog dialogMsg -> - Dialog.update DialogUpdate.update dialogMsg model.dialog.model model.dialog - |> Tuple.mapFirst (\dialog -> { model | dialog = dialog }) - :> update (Tooltip Tooltip.HideMessage) - - Tooltip tooltipMsg -> - let (newTooltip, command) = Tooltip.update tooltipMsg model.tooltip - in ( { model | tooltip = newTooltip } - , Cmd.map Tooltip command - ) - - CreatePayment name cost date category frequency -> - ( model - , Server.createPayment name cost date category frequency (\result -> case result of - Ok paymentId -> UpdateLoggedIn <| LoggedIn.ValidateCreatePayment paymentId name cost date category frequency - Err _ -> Error "CreatePaymentError" - ) - ) - - EditPayment paymentId name cost date category frequency -> - ( model - , Server.editPayment paymentId name cost date category frequency (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditPayment paymentId name cost date category frequency - Err _ -> Error "EditPaymentError" - ) - ) - - DeletePayment paymentId -> - ( model - , Server.deletePayment paymentId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeletePayment paymentId - Err _ -> Error "DeletePaymentError" - ) - ) - - CreateIncome amount date -> - ( model - , Server.createIncome amount date (\result -> case result of - Ok incomeId -> UpdateLoggedIn <| LoggedIn.ValidateCreateIncome incomeId amount date - Err _ -> Error "CreateIncomeError" - ) - ) - - EditIncome incomeId amount date -> - ( model - , Server.editIncome incomeId amount date (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditIncome incomeId amount date - Err _ -> Error "EditIncomeError" - ) - ) - - DeleteIncome incomeId -> - ( model - , Server.deleteIncome incomeId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteIncome incomeId - Err _ -> Error "DeleteIncomeError" - ) - ) - - CreateCategory name color -> - ( model - , Server.createCategory name color (\result -> case result of - Ok categoryId -> UpdateLoggedIn <| LoggedIn.ValidateCreateCategory categoryId name color - Err _ -> Error "CreateCategoryError" - ) - ) - - EditCategory categoryId name color -> - ( model - , Server.editCategory categoryId name color (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditCategory categoryId name color - Err _ -> Error "EditCategoryError" - ) - ) - - DeleteCategory categoryId -> - ( model - , Server.deleteCategory categoryId (\result -> case result of - Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteCategory categoryId - Err _ -> Error "DeleteCategoryError" - ) - ) - - -applySignIn : Model -> SignInMsg.Msg -> Model -applySignIn model signInMsg = - case model.view of - V.SignInView signInView -> - { model | view = V.SignInView (SignInUpdate.update model.translations signInMsg signInView) } - _ -> - model - -applyLoggedIn : Model -> LoggedIn.Msg -> (Model, Cmd Msg) -applyLoggedIn model loggedInMsg = - case model.view of - V.LoggedInView loggedInView -> - let (view, cmd) = LoggedIn.update model loggedInMsg loggedInView - in ( { model | view = V.LoggedInView view } - , Cmd.map UpdateLoggedIn cmd - ) - _ -> - (model, Cmd.none) diff --git a/src/client/Utils/Cmd.elm b/src/client/Utils/Cmd.elm deleted file mode 100644 index 5f41cbe..0000000 --- a/src/client/Utils/Cmd.elm +++ /dev/null @@ -1,16 +0,0 @@ -module Utils.Cmd exposing - ( pipeUpdate - , (:>) - ) - -import Platform.Cmd as Cmd - -pipeUpdate : (model, Cmd msg) -> (model -> (model, Cmd msg)) -> (model, Cmd msg) -pipeUpdate (model, cmd) f = - let (newModel, newCmd) = f model - in (newModel, Cmd.batch [ cmd, newCmd ]) - -(:>) : (m, Cmd a) -> (m -> (m, Cmd a)) -> (m, Cmd a) -(:>) = pipeUpdate - -infixl 0 :> diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm deleted file mode 100644 index 7d708e2..0000000 --- a/src/client/Utils/Dict.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Dict exposing - ( mapValues - ) - -import Dict as Dict exposing (..) - -mapValues : (a -> b) -> Dict comparable a -> Dict comparable b -mapValues f = Dict.fromList << List.map (onSecond f) << Dict.toList - -onSecond : (a -> b) -> (comparable, a) -> (comparable, b) -onSecond f tuple = case tuple of (x, y) -> (x, f y) diff --git a/src/client/Utils/Either.elm b/src/client/Utils/Either.elm deleted file mode 100644 index 275fc8c..0000000 --- a/src/client/Utils/Either.elm +++ /dev/null @@ -1,9 +0,0 @@ -module Utils.Either exposing - ( toMaybeError - ) - -toMaybeError : Result a b -> Maybe a -toMaybeError result = - case result of - Ok _ -> Nothing - Err x -> Just x diff --git a/src/client/Utils/Form.elm b/src/client/Utils/Form.elm deleted file mode 100644 index 6793222..0000000 --- a/src/client/Utils/Form.elm +++ /dev/null @@ -1,11 +0,0 @@ -module Utils.Form exposing - ( fieldAsText - ) - -import Form exposing (Form) - -fieldAsText : Form a b -> String -> String -fieldAsText form field = - Form.getFieldAsString field form - |> .value - |> Maybe.withDefault "" diff --git a/src/client/Utils/Http.elm b/src/client/Utils/Http.elm deleted file mode 100644 index dd3870a..0000000 --- a/src/client/Utils/Http.elm +++ /dev/null @@ -1,39 +0,0 @@ -module Utils.Http exposing - ( jsonRequest - , request - , errorKey - ) - -import Http exposing (..) -import Task exposing (..) -import Json.Decode as Decode exposing (Decoder, Value) -import Json.Encode as Encode - -jsonRequest : String -> String -> Expect a -> (Result Error a -> msg) -> Encode.Value -> Cmd msg -jsonRequest method url expect handleResult value = - requestWithBody method url (jsonBody value) expect handleResult - -request : String -> String -> Expect a -> (Result Error a -> msg) -> Cmd msg -request method url = requestWithBody method url emptyBody - -requestWithBody : String -> String -> Body -> Expect a -> (Result Error a -> msg) -> Cmd msg -requestWithBody method url body expect handleResult = - let req = Http.request - { method = method - , headers = [] - , url = url - , body = body - , expect = expect - , timeout = Nothing - , withCredentials = False - } - in send handleResult req - -errorKey : Error -> String -errorKey error = - case error of - BadUrl _ -> "BadUrl" - Timeout -> "Timeout" - NetworkError -> "NetworkError" - BadPayload _ _ -> "BadPayload" - BadStatus response -> response.body diff --git a/src/client/Utils/Json.elm b/src/client/Utils/Json.elm deleted file mode 100644 index 29e815b..0000000 --- a/src/client/Utils/Json.elm +++ /dev/null @@ -1,12 +0,0 @@ -module Utils.Json exposing - ( dictDecoder - ) - -import Json.Decode as Decode exposing (Decoder) -import Dict exposing (Dict) - -dictDecoder : Decoder comparable -> Decoder a -> Decoder (Dict comparable a) -dictDecoder keyDecoder valueDecoder = - Decode.map2 (,) keyDecoder valueDecoder - |> Decode.list - |> Decode.map Dict.fromList diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm deleted file mode 100644 index 8e26e85..0000000 --- a/src/client/Utils/List.elm +++ /dev/null @@ -1,36 +0,0 @@ -module Utils.List exposing - ( groupBy - , mean - , links - ) - -import Dict -import Maybe.Extra as Maybe - -groupBy : (a -> comparable) -> List a -> List (comparable, List a) -groupBy f xs = - let addItem item dict = - let groupItems = Dict.get (f item) dict |> Maybe.withDefault [] - in Dict.insert (f item) (item :: groupItems) dict - in List.foldr addItem Dict.empty xs - |> Dict.toList - -mean : List Int -> Int -mean xs = (List.sum xs) // (List.length xs) - -links : List a -> List (a, a) -links xs = - let reversed = List.reverse xs - in List.foldr - (\x acc -> - case Maybe.map Tuple.first (List.head acc) of - Just y -> - (x, y) :: acc - _ -> - acc - ) - (case reversed of - x :: y :: _ -> [(y, x)] - _ -> [] - ) - (List.reverse << List.drop 2 <| reversed) diff --git a/src/client/Utils/Search.elm b/src/client/Utils/Search.elm deleted file mode 100644 index 1b70387..0000000 --- a/src/client/Utils/Search.elm +++ /dev/null @@ -1,10 +0,0 @@ -module Utils.Search exposing - ( format - ) - -import String - -import Utils.String as String - -format : String -> String -format = String.unaccent << String.toLower diff --git a/src/client/Utils/String.elm b/src/client/Utils/String.elm deleted file mode 100644 index 90fe68e..0000000 --- a/src/client/Utils/String.elm +++ /dev/null @@ -1,38 +0,0 @@ -module Utils.String exposing - ( unaccent - ) - -unaccent : String -> String -unaccent = String.map unaccentChar - -unaccentChar : Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/client/Validation.elm b/src/client/Validation.elm deleted file mode 100644 index de27963..0000000 --- a/src/client/Validation.elm +++ /dev/null @@ -1,65 +0,0 @@ -module Validation exposing - ( cost - , date - , category - , color - , new - ) - -import Date exposing (Date) -import Date.Extra.Core exposing (intToMonth) -import Date.Extra.Create exposing (dateFromFields) -import Dict -import Regex -import String exposing (toInt, split) - -import Form.Validate as Validate exposing (Validation) -import Form.Error as Error exposing (ErrorValue(CustomError)) - -import Model.Category exposing (Categories, CategoryId) - -cost : Validation String Int -cost = - Validate.customValidation Validate.int (\n -> - if n == 0 - then Err (Validate.customError "CostMustNotBeNull") - else Ok n - ) - -date : Validation String Date -date = - Validate.customValidation Validate.string (\str -> - case split "/" str of - [day, month, year] -> - case (toInt day, toInt month, toInt year) of - (Ok dayNum, Ok monthNum, Ok yearNum) -> - Ok (dateFromFields yearNum (intToMonth monthNum) dayNum 0 0 0 0) - _ -> Err (Validate.customError "InvalidDate") - _ -> Err (Validate.customError "InvalidDate") - ) - -category : Categories -> Validation String CategoryId -category categories = - Validate.customValidation Validate.string (\str -> - case toInt str of - Ok category -> - if List.member category (Dict.keys categories) - then Ok category - else Err (Validate.customError "InvalidCategory") - Err _ -> - Err (Validate.customError "InvalidCategory") - ) - -color : Validation String String -color = - Validate.customValidation Validate.string (\str -> - if Regex.contains (Regex.regex "^#[0-9a-fA-F]{6}$") str - then Ok str - else Err (Validate.customError "InvalidColor") - ) - -new : List x -> x -> Validation String x -new xs x field = - if List.member x xs - then Err (Error.value <| CustomError "AlreadyExists") - else Ok x diff --git a/src/client/View.elm b/src/client/View.elm deleted file mode 100644 index deee272..0000000 --- a/src/client/View.elm +++ /dev/null @@ -1,34 +0,0 @@ -module View exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) - -import Model exposing (Model) -import Msg exposing (Msg) -import Model.View exposing (..) -import LoggedData -import Dialog -import Tooltip - -import View.Header as Header -import View.Errors as Errors - -import SignIn.View as SignInView -import LoggedIn.View as LoggedInView - -view : Model -> Html Msg -view model = - div - [] - [ Header.view model - , case model.view of - SignInView signIn -> - SignInView.view model signIn - LoggedInView loggedIn -> - LoggedInView.view model loggedIn - , Errors.view model.translations model.errors - , Dialog.view model.dialog - , Html.map Msg.Tooltip <| Tooltip.view model.tooltip - ] diff --git a/src/client/View/App.hs b/src/client/View/App.hs new file mode 100644 index 0000000..1466811 --- /dev/null +++ b/src/client/View/App.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.App + ( widget + ) where + +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import Common.Model (InitResult(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import View.Header (HeaderIn(..)) +import View.Payment (PaymentIn(..)) +import qualified View.Header as Header +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn + +widget :: InitResult -> IO () +widget initResult = + R.mainWidget $ do + headerOut <- Header.view $ HeaderIn + { _headerIn_initResult = initResult + } + + let signOut = Header._headerOut_signOut headerOut + + initialContent = case initResult of + InitSuccess initSuccess -> do + _ <- Payment.widget $ PaymentIn + { _paymentIn_init = initSuccess + } + return () + InitEmpty result -> + SignIn.view result + + signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + + _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + + R.blank diff --git a/src/client/View/Color.elm b/src/client/View/Color.elm deleted file mode 100644 index a2a20c7..0000000 --- a/src/client/View/Color.elm +++ /dev/null @@ -1,12 +0,0 @@ -module View.Color exposing (..) - -import Color exposing (Color) - -chestnutRose : Color -chestnutRose = Color.rgb 207 92 86 - -white : Color -white = Color.white - -silver : Color -silver = Color.rgb 200 200 200 diff --git a/src/client/View/Date.elm b/src/client/View/Date.elm deleted file mode 100644 index 6df971b..0000000 --- a/src/client/View/Date.elm +++ /dev/null @@ -1,57 +0,0 @@ -module View.Date exposing - ( shortMonthAndYear - , shortView - , longView - , monthView - ) - -import Date exposing (..) -import Date.Extra.Core as Date -import String - -import Model.Translations exposing (..) - -shortMonthAndYear : Month -> Int -> Translations -> String -shortMonthAndYear month year translations = - let params = - [ String.pad 2 '0' (toString (Date.monthToInt month)) - , toString year - ] - in getParamMessage params translations "ShortMonthAndYear" - -shortView : Date -> Translations -> String -shortView date translations = - let params = - [ String.pad 2 '0' (toString (Date.day date)) - , String.pad 2 '0' (toString (Date.monthToInt (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "ShortDate" - -longView : Date -> Translations -> String -longView date translations = - let params = - [ toString (Date.day date) - , (getMessage translations (getMonthKey (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "LongDate" - -monthView : Translations -> Month -> String -monthView translations month = getMessage translations (getMonthKey month) - -getMonthKey : Month -> String -getMonthKey month = - case month of - Jan -> "January" - Feb -> "February" - Mar -> "March" - Apr -> "April" - May -> "May" - Jun -> "June" - Jul -> "July" - Aug -> "August" - Sep -> "September" - Oct -> "October" - Nov -> "November" - Dec -> "December" diff --git a/src/client/View/Errors.elm b/src/client/View/Errors.elm deleted file mode 100644 index 3e25c99..0000000 --- a/src/client/View/Errors.elm +++ /dev/null @@ -1,21 +0,0 @@ -module View.Errors exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model.Translations exposing (Translations, getMessage) - -view : Translations -> List String -> Html msg -view translations errors = - ul - [ class "errors" ] - ( List.map (errorView translations) errors) - -errorView : Translations -> String -> Html msg -errorView translations error = - li - [ class "error" ] - [ text <| getMessage translations error ] diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm deleted file mode 100644 index d71d67d..0000000 --- a/src/client/View/Events.elm +++ /dev/null @@ -1,15 +0,0 @@ -module View.Events exposing - ( onSubmitPrevDefault - ) - -import Json.Decode as Decode -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -onSubmitPrevDefault : msg -> Attribute msg -onSubmitPrevDefault value = - onWithOptions - "submit" - { defaultOptions | preventDefault = True } - (Decode.succeed value) diff --git a/src/client/View/Form.elm b/src/client/View/Form.elm deleted file mode 100644 index 977ca0a..0000000 --- a/src/client/View/Form.elm +++ /dev/null @@ -1,152 +0,0 @@ -module View.Form exposing - ( textInput - , colorInput - , selectInput - , radioInputs - , hiddenSubmit - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Maybe.Extra as Maybe - -import FontAwesome -import View.Color as Color - -import Form exposing (Form, FieldState) -import Form.Input as Input -import Form.Error as FormError exposing (ErrorValue(..)) -import Form.Field as Field - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Translations as Translations exposing (Translations) - -textInput : Translations -> Form String a -> String -> String -> Html Form.Msg -textInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - fieldId = formName ++ fieldName - in div - [ classList - [ ("textInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ Input.textInput - field - [ id fieldId - , classList [ ("filled", Maybe.isJust field.value) ] - , value (Maybe.withDefault "" field.value) - ] - , label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , button - [ type_ "button" - , onClick (Form.Input fieldName Form.Text Field.EmptyField) - , tabindex -1 - ] - [ FontAwesome.times Color.silver 15 ] - , formError translations field - ] - -colorInput : Translations -> Form String a -> String -> String -> Html Form.Msg -colorInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - in div - [ classList - [ ("colorInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) ] - , Input.textInput - field - [ id (formName ++ fieldName) - , type_ "color" - ] - ] - -radioInputs : Translations -> Form String a -> String -> String -> List String -> Html Form.Msg -radioInputs translations form formName radioName fieldNames = - let field = Form.getFieldAsString radioName form - in div - [ classList - [ ("radioGroup", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ div - [ class "title" ] - [ text (Translations.getMessage translations (formName ++ radioName) ) ] - , div - [ class "radioInputs" ] - (List.map (radioInput translations field formName) fieldNames) - , formError translations field - ] - -radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg -radioInput translations field formName fieldName = - div - [ class "radioInput" ] - [ Input.radioInput - field.path - field - [ id (formName ++ fieldName) - , value fieldName - , checked (field.value == Just fieldName) - ] - , label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) - ] - ] - -selectInput : Translations -> Form String a -> String -> String -> List (String, String) -> Html Form.Msg -selectInput translations form formName selectName options = - let field = Form.getFieldAsString selectName form - fieldId = formName ++ selectName - in div - [ classList - [ ("selectInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , Input.selectInput - (("", "") :: options) - field - [ id fieldId ] - , formError translations field - ] - -formError : Translations -> FieldState String a -> Html msg -formError translations field = - case field.liveError of - Just error -> - let errorElement error params = - div - [ class "errorMessage" ] - [ text (Translations.getParamMessage params translations error) ] - in case error of - CustomError key -> errorElement key [] - SmallerIntThan n -> errorElement "SmallerIntThan" [toString n] - GreaterIntThan n -> errorElement "GreaterIntThan" [toString n] - error -> errorElement (toString error) [] - Nothing -> - text "" - -hiddenSubmit : msg -> Html msg -hiddenSubmit msg = - button - [ style [ ("display", "none") ] - , onClick msg - ] - [] diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm deleted file mode 100644 index 12fb87c..0000000 --- a/src/client/View/Header.elm +++ /dev/null @@ -1,60 +0,0 @@ -module View.Header exposing - ( view - ) - -import Dict - -import FontAwesome -import View.Color as Color - -import Page exposing (..) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Msg exposing (..) -import Model.View exposing (..) - -view : Model -> Html Msg -view model = - header - [] - ( [ div [ class "title" ] [ text (getMessage model.translations "SharedCost") ] ] - ++ let item page name = - a - [ href (Page.toHash page) - , classList - [ ("item", True) - , ("current", model.page == page) - ] - ] - [ text (getMessage model.translations name) - ] - in case model.view of - LoggedInView { me, users } -> - [ item Home "PaymentsTitle" - , item Income "Income" - , item Categories "Categories" - , item Statistics "Statistics" - , div - [ class "nameSignOut" ] - [ div - [ class "name" ] - [ Dict.get me users - |> Maybe.map .name - |> Maybe.withDefault "" - |> text - ] - , button - [ class "signOut item" - , onClick SignOut - ] - [ FontAwesome.power_off Color.white 30 ] - ] - ] - _ -> - [] - ) diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs new file mode 100644 index 0000000..32738f1 --- /dev/null +++ b/src/client/View/Header.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Header + ( view + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), Init(..), User(..)) +import qualified Common.Model.User as User + +import Component.Button (ButtonIn(..)) +import qualified Component.Button as Component +import qualified Icon + +data HeaderIn = HeaderIn + { _headerIn_initResult :: InitResult + } + +data HeaderOut t = HeaderOut + { _headerOut_signOut :: Event t () + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view headerIn = + R.el "header" $ do + + R.divClass "title" $ + R.text $ Message.get Key.App_Title + + signOut <- nameSignOut $ _headerIn_initResult headerIn + + return $ HeaderOut + { _headerOut_signOut = signOut + } + +nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) +nameSignOut initResult = case initResult of + (InitSuccess init) -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case User.find (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never + +signOutButton :: forall t m. MonadWidget t m => m (Event t ()) +signOutButton = do + rec + signOut <- Component.button $ ButtonIn + { Component._buttonIn_class = "signOut item" + , Component._buttonIn_content = Icon.signOut + , Component._buttonIn_waiting = waiting + } + let signOutClic = Component._buttonOut_clic signOut + waiting = R.leftmost + [ fmap (const True) signOutClic + , fmap (const False) signOutSuccess + ] + signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) + + return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess + + where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) + askSignOut signOut = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + getResult = (== 200) . R._xhrResponse_status diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs new file mode 100644 index 0000000..e80790b --- /dev/null +++ b/src/client/View/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment + ( widget + , PaymentIn(..) + , PaymentOut(..) + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init) + +import View.Payment.Table (TableIn(..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +data PaymentOut = PaymentOut + { + } + +widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget paymentIn = do + R.divClass "payment" $ do + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + } + return $ PaymentOut {} diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs new file mode 100644 index 0000000..878e7da --- /dev/null +++ b/src/client/View/Payment/Table.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Table + ( widget + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List as L +import qualified Data.Map as M +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) +import qualified Common.Model.User as User +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format + +import qualified Icon + +data TableIn = TableIn + { _tableIn_init :: Init + } + +data TableOut = TableOut + { + } + +widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +widget tableIn = do + R.divClass "table" $ + R.divClass "lines" $ do + R.divClass "header" $ do + R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name + R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost + R.divClass "cell user" $ R.text $ Message.get Key.Payment_User + R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category + R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + let init = _tableIn_init tableIn + payments = _init_payments init + mapM_ + (paymentRow init) + (take 8 . reverse . L.sortOn _payment_date $ payments) + return $ TableOut {} + +paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow init payment = + R.divClass "row" $ do + R.divClass "cell name" . R.text $ _payment_name payment + R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell user" $ + case User.find (_payment_user payment) (_init_users init) of + Just user -> R.text (_user_name user) + _ -> R.blank + R.divClass "cell category" $ + case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of + Just category -> + R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ + R.text $ _category_name category + _ -> + R.blank + R.divClass "cell date" $ do + R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) + R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.divClass "cell button" . R.el "button" $ Icon.clone + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.edit + else R.blank + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.delete + else R.blank + +findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category +findCategory categories paymentCategories paymentName = do + paymentCategory <- L.find + ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + paymentCategories + L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/src/client/View/Plural.elm b/src/client/View/Plural.elm deleted file mode 100644 index c36eaca..0000000 --- a/src/client/View/Plural.elm +++ /dev/null @@ -1,11 +0,0 @@ -module View.Plural exposing - ( plural - ) - -import Model.Translations exposing (Translations, getMessage) - -plural : Translations -> Int -> String -> String -> String -plural translations n single multiple = - let singleMessage = getMessage translations single - multipleMessage = getMessage translations multiple - in (toString n) ++ " " ++ if n <= 1 then singleMessage else multipleMessage diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs new file mode 100644 index 0000000..e164ee7 --- /dev/null +++ b/src/client/View/SignIn.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.SignIn + ( view + ) where + +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(SignIn)) + +import Component.Input (InputIn(..), InputOut(..)) +import Component.Button (ButtonIn(..), ButtonOut(..)) +import qualified Component.Button as Component +import qualified Component.Input as Component + +view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () +view result = + R.divClass "signIn" $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + } + + let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button + + dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ + [ fmap (const True) userWantsEmailValidation + , fmap (const False) signInResult + ] + + uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail + + let validatedEmail = R.tagPromptlyDyn + (_inputOut_value input) + (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) + + let waiting = R.leftmost + [ fmap (const True) validatedEmail + , fmap (const False) signInResult + ] + + button <- Component.button $ ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_waiting = waiting + } + + signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) + + showSignInResult result signInResult + +askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) +askSignIn email = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + getResult response = + case R._xhrResponse_responseText response of + Just key -> + if R._xhrResponse_status response == 200 then Right key else Left key + _ -> Left "NoKey" + +showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () +showSignInResult result signInResult = do + _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult + R.blank + + where showInitResult (Left error) = showError error + showInitResult (Right (Just success)) = showSuccess success + showInitResult (Right Nothing) = R.blank + + showResult (Left error) = showError error + showResult (Right success) = showSuccess success + + showError = R.divClass "error" . R.text + showSuccess = R.divClass "success" . R.text diff --git a/src/common/Message.hs b/src/common/Message.hs new file mode 100644 index 0000000..9ae735d --- /dev/null +++ b/src/common/Message.hs @@ -0,0 +1,12 @@ +module Common.Message + ( get + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key) +import Common.Message.Lang (Lang(..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/src/common/Message/Key.hs b/src/common/Message/Key.hs new file mode 100644 index 0000000..4127808 --- /dev/null +++ b/src/common/Message/Key.hs @@ -0,0 +1,152 @@ +module Common.Message.Key + ( Key(..) + ) where + +import Data.Text + +data Key = + + App_Title + + | Category_Add + | Category_Clone + | Category_Color + | Category_DeleteConfirm + | Category_Edit + | Category_Empty + | Category_Name + | Category_NotDeleted + | Category_Title + | Category_Used + + | Date_Long Int Text Int + | Date_Short Int Int Int + | Date_ShortMonthAndYear Int Int + + | Dialog_Confirm + | Dialog_Undo + + | Error_CategoryCreate + | Error_CategoryDelete + | Error_CategoryEdit + | Error_IncomeCreate + | Error_IncomeDelete + | Error_IncomeEdit + | Error_PaymentCreate + | Error_PaymentDelete + | Error_PaymentEdit + | Error_SignOut + + | Form_AlreadyExists + | Form_CostMustNotBeNull + | Form_Empty + | Form_GreaterIntThan Int + | Form_InvalidCategory + | Form_InvalidColor + | Form_InvalidDate + | Form_InvalidInt + | Form_InvalidString + | Form_SmallerIntThan Int + + | HttpError_BadPayload + | HttpError_BadUrl + | HttpError_NetworkError + | HttpError_Timeout + + | Income_AddLong + | Income_AddShort + | Income_Amount + | Income_Clone + | Income_CumulativeSince Text + | Income_Date + | Income_DeleteConfirm + | Income_Edit + | Income_Empty + | Income_MonthlyNet + | Income_NotDeleted + | Income_Title + + | Month_January + | Month_February + | Month_March + | Month_April + | Month_May + | Month_June + | Month_July + | Month_August + | Month_September + | Month_October + | Month_November + | Month_December + + | PageNotFound_Title + + | Payment_Add + | Payment_Balanced + | Payment_Category + | Payment_CloneLong + | Payment_CloneShort + | Payment_Cost + | Payment_Date + | Payment_Delete + | Payment_DeleteConfirm + | Payment_EditLong + | Payment_EditShort + | Payment_Empty + | Payment_Frequency + | Payment_InvalidFrequency + | Payment_Many + | Payment_MonthlyFemale + | Payment_MonthlyMale + | Payment_Name + | Payment_NotDeleted + | Payment_One + | Payment_PunctualFemale + | Payment_PunctualMale + | Payment_Title + | Payment_User + | Payment_Worth Text Text + + | Search_Monthly + | Search_Name + | Search_Punctual + + | Secure_Forbidden + | Secure_Unauthorized + + | SignIn_Button + | SignIn_DisconnectSuccess + | SignIn_EmailInvalid + | SignIn_EmailPlaceholder + | SignIn_EmailSendFail + | SignIn_EmailSent + | SignIn_LinkExpired + | SignIn_LinkInvalid + | SignIn_LinkUsed + | SignIn_MailTitle + | SignIn_MailBody Text Text + | SignIn_ParseError + + | Statistic_Title + | Statistic_ByMonthsAndMean Text + | Statistic_By Text Text + | Statistic_Total + + | WeeklyReport_Empty + | WeeklyReport_IncomesCreated Int + | WeeklyReport_IncomesDeleted Int + | WeeklyReport_IncomesEdited Int + | WeeklyReport_IncomeCreated Int + | WeeklyReport_IncomeDeleted Int + | WeeklyReport_IncomeEdited Int + | WeeklyReport_PayedFor Text Text Text Text + | WeeklyReport_PayedForNot Text Text Text Text + | WeeklyReport_PayedFrom Text Text Text + | WeeklyReport_PayedFromNot Text Text Text + | WeeklyReport_PaymentsCreated Int + | WeeklyReport_PaymentsDeleted Int + | WeeklyReport_PaymentsEdited Int + | WeeklyReport_PaymentCreated Int + | WeeklyReport_PaymentDeleted Int + | WeeklyReport_PaymentEdited Int + | WeeklyReport_Title diff --git a/src/common/Message/Lang.hs b/src/common/Message/Lang.hs new file mode 100644 index 0000000..0a32ede --- /dev/null +++ b/src/common/Message/Lang.hs @@ -0,0 +1,7 @@ +module Common.Message.Lang + ( Lang(..) + ) where + +data Lang = + English + | French diff --git a/src/common/Message/Translation.hs b/src/common/Message/Translation.hs new file mode 100644 index 0000000..900a9e9 --- /dev/null +++ b/src/common/Message/Translation.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.Message.Translation + ( get + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Common.Message.Key +import Common.Message.Lang (Lang(..)) + +get :: Lang -> Key -> Text +get = m + +m :: Lang -> Key -> Text + +m l App_Title = + case l of + English -> "Shared Cost" + French -> "Partage des frais" + +m l Category_Add = + case l of + English -> "Add an category" + French -> "Ajouter une catégorie" + +m l Category_Clone = + case l of + English -> "Clone an category" + French -> "Cloner une catégorie" + +m l Category_Color = + case l of + English -> "Color" + French -> "Couleur" + +m l Category_DeleteConfirm = + case l of + English -> "Are you sure to delete this category ?" + French -> "Voulez-vous vraiment supprimer cette catégorie ?" + +m l Category_Edit = + case l of + English -> "Edit an category" + French -> "Modifier une catégorie" + +m l Category_Empty = + case l of + English -> "No category." + French -> "Aucune catégorie." + +m l Category_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Category_NotDeleted = + case l of + English -> "The category could not have been deleted." + French -> "La catégorie n’a pas pu être supprimé." + +m l Category_Title = + case l of + English -> "Categories" + French -> "Catégories" + +m l Category_Used = + case l of + English -> "This category is currently being used" + French -> "Cette catégorie est actuellement utilisée" + +m l (Date_Short day month year) = + case l of + English -> + T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] + French -> + T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] + where padded num pad = + let str = show num + in T.pack $ replicate (pad - length str) '0' ++ str + +m l (Date_ShortMonthAndYear month year) = + case l of + English -> + T.intercalate "-" . map (T.pack . show) $ [ year, month ] + French -> + T.intercalate "/" . map (T.pack . show) $ [ month, year ] + +m l (Date_Long day month year) = + case l of + English -> + T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] + French -> + T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] + +m l Dialog_Confirm = + case l of + English -> "Confirm" + French -> "Confirmer" + +m l Dialog_Undo = + case l of + English -> "Undo" + French -> "Annuler" + +m l Error_CategoryCreate = + case l of + English -> "Error at category creation" + French -> "Erreur lors de la création de la catégorie" + +m l Error_CategoryDelete = + case l of + English -> "Error at category deletion" + French -> "Erreur lors de la suppression de la catégorie" + +m l Error_CategoryEdit = + case l of + English -> "Error at category edition" + French -> "Erreur lors de la modification de la catégorie" + +m l Error_IncomeCreate = + case l of + English -> "Error at income creation" + French -> "Erreur lors de la création du revenu" + +m l Error_IncomeDelete = + case l of + English -> "Error at income deletion" + French -> "Erreur lors de la suppression du revenu" + +m l Error_IncomeEdit = + case l of + English -> "Error at income edition" + French -> "Erreur lors de la modification du revenu" + +m l Error_PaymentCreate = + case l of + English -> "Error at payment creation" + French -> "Erreur lors de la création du paiement" + +m l Error_PaymentDelete = + case l of + English -> "Error at payment deletion" + French -> "Erreur lors de la suppression du paiement" + +m l Error_PaymentEdit = + case l of + English -> "Error at payment edition" + French -> "Erreur lors de la modification du paiement" + +m l Error_SignOut = + case l of + English -> "Error at sign out" + French -> "Erreur lors de la déconnexion" + +m l Form_AlreadyExists = + case l of + English -> "Dupplicate field" + French -> "Doublon" + +m l Form_CostMustNotBeNull = + case l of + English -> "Cost must not be zero" + French -> "Le coût ne doît pas être nul" + +m l Form_Empty = + case l of + English -> "Required field" + French -> "Champ requis" + +m l (Form_GreaterIntThan number) = + case l of + English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] + +m l Form_InvalidCategory = + case l of + English -> "Invalid category" + French -> "Catégorie invalide" + +m l Form_InvalidColor = + case l of + English -> "Invalid color" + French -> "Couleur invalide" + +m l Form_InvalidDate = + case l of + English -> "day/month/year required" + French -> "jour/mois/année requis" + +m l Form_InvalidInt = + case l of + English -> "Integer required" + French -> "Entier requis" + +m l Form_InvalidString = + case l of + English -> "String required" + French -> "Chaîne de caractères requise" + +m l (Form_SmallerIntThan number) = + case l of + English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] + +m l HttpError_BadPayload = + case l of + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" + +m l HttpError_BadUrl = + case l of + English -> "URL not valid" + French -> "l’URL n’est pas valide" + +m l HttpError_NetworkError = + case l of + English -> "Network can not be reached" + French -> "Le serveur n’est pas accessible" + +m l HttpError_Timeout = + case l of + English -> "Timeout server error" + French -> "Le serveur met trop de temps à répondre" + +m l Income_AddLong = + case l of + English -> "Add an income" + French -> "Ajouter un revenu" + +m l Income_AddShort = + case l of + English -> "Add" + French -> "Ajouter" + +m l Income_Amount = + case l of + English -> "Amount" + French -> "Montant" + +m l Income_Clone = + case l of + English -> "Clone an income" + French -> "Cloner un revenu" + +m l (Income_CumulativeSince since) = + case l of + English -> T.concat [ "Cumulative incomes since ", since ] + French -> T.concat [ "Revenus nets cumulés depuis le ", since ] + +m l Income_Date = + case l of + English -> "Date" + French -> "Date" + +m l Income_DeleteConfirm = + case l of + English -> "Are you sure to delete this income ?" + French -> "Voulez-vous vraiment supprimer ce revenu ?" + +m l Income_Edit = + case l of + English -> "Edit an income" + French -> "Modifier un revenu" + +m l Income_Empty = + case l of + English -> "No income." + French -> "Aucun revenu." + +m l Income_MonthlyNet = + case l of + English -> "Net monthly incomes" + French -> "Revenus mensuels nets" + +m l Income_NotDeleted = + case l of + English -> "The income could not have been deleted." + French -> "Le revenu n’a pas pu être supprimé." + +m l Income_Title = + case l of + English -> "Income" + French -> "Revenu" + +m l Month_January = + case l of + English -> "january" + French -> "janvier" + +m l Month_February = + case l of + English -> "february" + French -> "février" + +m l Month_March = + case l of + English -> "march" + French -> "mars" + +m l Month_April = + case l of + English -> "april" + French -> "avril" + +m l Month_May = + case l of + English -> "may" + French -> "mai" + +m l Month_June = + case l of + English -> "june" + French -> "juin" + +m l Month_July = + case l of + English -> "july" + French -> "juillet" + +m l Month_August = + case l of + English -> "august" + French -> "août" + +m l Month_September = + case l of + English -> "september" + French -> "septembre" + +m l Month_October = + case l of + English -> "october" + French -> "octobre" + +m l Month_November = + case l of + English -> "november" + French -> "novembre" + +m l Month_December = + case l of + English -> "december" + French -> "décembre" + +m l PageNotFound_Title = + case l of + English -> "Page not found" + French -> "Page introuvable" + +m l Payment_Add = + case l of + English -> "Add a payment" + French -> "Ajouter un paiement" + +m l Payment_Balanced = + case l of + English -> "Payments are balanced." + French -> "Les paiements sont équilibrés." + +m l Payment_Category = + case l of + English -> "Category" + French -> "Catégorie" + +m l Payment_CloneLong = + case l of + English -> "Clone a payment" + French -> "Cloner un paiement" + +m l Payment_CloneShort = + case l of + English -> "Clone" + French -> "Cloner" + +m l Payment_Cost = + case l of + English -> "Cost" + French -> "Coût" + +m l Payment_Date = + case l of + English -> "Date" + French -> "Date" + +m l Payment_Delete = + case l of + English -> "Delete" + French -> "Supprimer" + +m l Payment_DeleteConfirm = + case l of + English -> "Are you sure to delete this payment ?" + French -> "Voulez-vous vraiment supprimer ce paiement ?" + +m l Payment_EditLong = + case l of + English -> "Edit a payment" + French -> "Modifier un paiement" + +m l Payment_EditShort = + case l of + English -> "Edit" + French -> "Modifier" + +m l Payment_Empty = + case l of + English -> "No payment found from your search criteria." + French -> "Aucun paiement ne correspond à vos critères de recherches." + +m l Payment_Frequency = + case l of + English -> "Frequency" + French -> "Fréquence" + +m l Payment_InvalidFrequency = + case l of + English -> "Invalid frequency" + French -> "Fréquence invalide" + +m l Payment_Many = + case l of + English -> "payments" + French -> "paiements" + +m l Payment_MonthlyFemale = + case l of + English -> "Monthly" + French -> "Mensuelle" + +m l Payment_MonthlyMale = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Payment_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Payment_NotDeleted = + case l of + English -> "The payment could not have been deleted." + French -> "Le paiement n’a pas pu être supprimé." + +m l Payment_One = + case l of + English -> "payment" + French -> "paiement" + +m l Payment_PunctualFemale = + case l of + English -> "Punctual" + French -> "Ponctuelle" + +m l Payment_PunctualMale = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Payment_Title = + case l of + English -> "Payments" + French -> "Paiements" + +m l Payment_User = + case l of + English -> "Payer" + French -> "Payeur" + +m l (Payment_Worth subject amount) = + case l of + English -> T.concat [ subject, " worth ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] + +m l Search_Monthly = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Search_Name = + case l of + English -> "Search" + French -> "Recherche" + +m l Search_Punctual = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Secure_Unauthorized = + case l of + English -> "You are not authorized to sign in." + French -> "Tu n’es pas autorisé à te connecter." + +m l Secure_Forbidden = + case l of + English -> "You need to be logged in to perform this action" + French -> "Tu dois te connecter pour effectuer cette action" + +m l SignIn_Button = + case l of + English -> "Sign in" + French -> "Connexion" + +m l SignIn_DisconnectSuccess = + case l of + English -> "You have successfully disconnected" + French -> "Vous êtes à présent déconnecté." + +m l SignIn_EmailInvalid = + case l of + English -> "Your email is not valid." + French -> "Votre courriel n’est pas valide." + +m l SignIn_EmailPlaceholder = + case l of + English -> "Email" + French -> "Courriel" + +m l SignIn_EmailSendFail = + case l of + English -> "You are authorized to sign in, but we failed to send you the sign up email." + French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." + +m l SignIn_EmailSent = + case l of + English -> "We sent you an email with a connexion link." + French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." + +m l SignIn_LinkExpired = + case l of + English -> "The link expired, please sign in again." + French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." + +m l SignIn_LinkInvalid = + case l of + English -> "The link is invalid, please sign in again." + French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." + +m l SignIn_LinkUsed = + case l of + English -> "You already used this link, please sign in again." + French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." + +m l SignIn_MailTitle = + case l of + English -> T.concat [ "Sign in to ", m l App_Title ] + French -> T.concat [ "Connexion à ", m l App_Title ] + +m l (SignIn_MailBody name url) = + T.intercalate + "\n" + ( case l of + English -> + [ T.concat [ "Hi ", name, "," ] + , "" + , T.concat + [ "Click to the following link in order to sign in to Shared Cost:" + , m l App_Title + , ":" + ] + , url + , "" + , "See you soon!" + ] + French -> + [ T.concat [ "Salut ", name, "," ] + , "" + , T.concat + [ "Clique sur le lien suivant pour te connecter à " + , m l App_Title + , ":" + ] + , url + , "" + , "À très vite !" + ] + ) + +m l SignIn_ParseError = + case l of + English -> "Error while reading initial data." + French -> "Erreur lors de la lecture des données initiales." + +m l (Statistic_By key value) = + case l of + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] + +m l (Statistic_ByMonthsAndMean amount) = + case l of + English -> + T.concat [ "Payments by category by month months (", amount, "on average)" ] + French -> + T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] + +m l Statistic_Title = + case l of + English -> "Statistics" + French -> "Statistiques" + +m l Statistic_Total = + case l of + English -> "Total" + French -> "Total" + +m l WeeklyReport_Empty = + case l of + English -> "No activity the previous week." + French -> "Pas d’activité la semaine passée." + +m l (WeeklyReport_IncomesCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes created:" ] + French -> T.concat [ T.pack . show $ count, " revenus créés :" ] + +m l (WeeklyReport_IncomesDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] + +m l (WeeklyReport_IncomesEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes edited:" ] + French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] + +m l (WeeklyReport_IncomeCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " income created:" ] + French -> T.concat [ T.pack . show $ count, " revenu créé :" ] + +m l (WeeklyReport_IncomeDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " income deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] + +m l (WeeklyReport_IncomeEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " income edited:" ] + French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] + +m l (WeeklyReport_PayedFor name amount for at) = + case l of + English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedForNot name amount for at) = + case l of + English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedFrom name amount for) = + case l of + English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PayedFromNot name amount for) = + case l of + English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PaymentsCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments created:" ] + French -> T.concat [ T.pack . show $ count, " paiements créés :" ] + +m l (WeeklyReport_PaymentsDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] + +m l (WeeklyReport_PaymentsEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments edited:" ] + French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] + +m l (WeeklyReport_PaymentCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment created:" ] + French -> T.concat [ T.pack . show $ count, " paiement créé :" ] + +m l (WeeklyReport_PaymentDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] + +m l (WeeklyReport_PaymentEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment edited:" ] + French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] + +m l WeeklyReport_Title = + case l of + English -> "Weekly report" + French -> "Rapport hebdomadaire" diff --git a/src/common/Model.hs b/src/common/Model.hs new file mode 100644 index 0000000..075021f --- /dev/null +++ b/src/common/Model.hs @@ -0,0 +1,40 @@ +module Common.Model + ( Category(..) + , CategoryId + , CreateCategory(..) + , CreateIncome(..) + , CreatePayment(..) + , Currency(..) + , EditCategory(..) + , EditIncome(..) + , EditPayment(..) + , Frequency(..) + , Income(..) + , IncomeId + , Init(..) + , InitResult(..) + , Payment(..) + , PaymentId + , PaymentCategory(..) + , PaymentCategoryId + , SignIn(..) + , User(..) + , UserId + ) where + +import Common.Model.Category (Category(..), CategoryId) +import Common.Model.CreateCategory (CreateCategory(..)) +import Common.Model.CreateIncome (CreateIncome(..)) +import Common.Model.CreatePayment (CreatePayment(..)) +import Common.Model.Currency (Currency(..)) +import Common.Model.EditCategory (EditCategory(..)) +import Common.Model.EditIncome (EditIncome(..)) +import Common.Model.EditPayment (EditPayment(..)) +import Common.Model.Frequency (Frequency(..)) +import Common.Model.Income (Income(..), IncomeId) +import Common.Model.Init (Init(..)) +import Common.Model.InitResult (InitResult(..)) +import Common.Model.Payment (Payment(..), PaymentId) +import Common.Model.PaymentCategory (PaymentCategory(..), PaymentCategoryId) +import Common.Model.SignIn (SignIn(..)) +import Common.Model.User (User(..), UserId) diff --git a/src/common/Model/Category.hs b/src/common/Model/Category.hs new file mode 100644 index 0000000..53a6bdb --- /dev/null +++ b/src/common/Model/Category.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Category + ( CategoryId + , Category(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type CategoryId = Int64 + +data Category = Category + { _category_id :: CategoryId + , _category_name :: Text + , _category_color :: Text + , _category_createdAt :: UTCTime + , _category_editedAt :: Maybe UTCTime + , _category_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Category +instance ToJSON Category diff --git a/src/common/Model/CreateCategory.hs b/src/common/Model/CreateCategory.hs new file mode 100644 index 0000000..bfe24c5 --- /dev/null +++ b/src/common/Model/CreateCategory.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategory diff --git a/src/common/Model/CreateIncome.hs b/src/common/Model/CreateIncome.hs new file mode 100644 index 0000000..4ee3a50 --- /dev/null +++ b/src/common/Model/CreateIncome.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +data CreateIncome = CreateIncome + { _createIncome_date :: Day + , _createIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON CreateIncome diff --git a/src/common/Model/CreatePayment.hs b/src/common/Model/CreatePayment.hs new file mode 100644 index 0000000..b5b6256 --- /dev/null +++ b/src/common/Model/CreatePayment.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON CreatePayment diff --git a/src/common/Model/Currency.hs b/src/common/Model/Currency.hs new file mode 100644 index 0000000..7c12545 --- /dev/null +++ b/src/common/Model/Currency.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Currency + ( Currency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Currency = Currency Text deriving (Show, Generic) + +instance FromJSON Currency +instance ToJSON Currency diff --git a/src/common/Model/EditCategory.hs b/src/common/Model/EditCategory.hs new file mode 100644 index 0000000..2a3a697 --- /dev/null +++ b/src/common/Model/EditCategory.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategory diff --git a/src/common/Model/EditIncome.hs b/src/common/Model/EditIncome.hs new file mode 100644 index 0000000..a55c39e --- /dev/null +++ b/src/common/Model/EditIncome.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_date :: Day + , _editIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON EditIncome diff --git a/src/common/Model/EditPayment.hs b/src/common/Model/EditPayment.hs new file mode 100644 index 0000000..172c0c1 --- /dev/null +++ b/src/common/Model/EditPayment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON EditPayment diff --git a/src/common/Model/Frequency.hs b/src/common/Model/Frequency.hs new file mode 100644 index 0000000..7c46605 --- /dev/null +++ b/src/common/Model/Frequency.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Frequency + ( Frequency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Frequency = + Punctual + | Monthly + deriving (Eq, Read, Show, Generic) + +instance FromJSON Frequency +instance ToJSON Frequency diff --git a/src/common/Model/Income.hs b/src/common/Model/Income.hs new file mode 100644 index 0000000..280812f --- /dev/null +++ b/src/common/Model/Income.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Income + ( IncomeId + , Income(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +type IncomeId = Int64 + +data Income = Income + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int + , _income_createdAt :: UTCTime + , _income_editedAt :: Maybe UTCTime + , _income_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Income +instance ToJSON Income diff --git a/src/common/Model/Init.hs b/src/common/Model/Init.hs new file mode 100644 index 0000000..68fcfb8 --- /dev/null +++ b/src/common/Model/Init.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Init + ( Init(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category) +import Common.Model.Currency (Currency) +import Common.Model.Income (Income) +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.User (UserId, User) + +data Init = Init + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] + , _init_paymentCategories :: [PaymentCategory] + , _init_currency :: Currency + } deriving (Show, Generic) + +instance FromJSON Init +instance ToJSON Init diff --git a/src/common/Model/InitResult.hs b/src/common/Model/InitResult.hs new file mode 100644 index 0000000..43c16f9 --- /dev/null +++ b/src/common/Model/InitResult.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.InitResult + ( InitResult(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Init (Init) + +data InitResult = + InitSuccess Init + | InitEmpty (Either Text (Maybe Text)) + deriving (Show, Generic) + +instance FromJSON InitResult +instance ToJSON InitResult diff --git a/src/common/Model/Payment.hs b/src/common/Model/Payment.hs new file mode 100644 index 0000000..804b501 --- /dev/null +++ b/src/common/Model/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Payment + ( PaymentId + , Payment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Frequency +import Common.Model.User (UserId) + +type PaymentId = Int64 + +data Payment = Payment + { _payment_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day + , _payment_frequency :: Frequency + , _payment_createdAt :: UTCTime + , _payment_editedAt :: Maybe UTCTime + , _payment_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Payment +instance ToJSON Payment diff --git a/src/common/Model/PaymentCategory.hs b/src/common/Model/PaymentCategory.hs new file mode 100644 index 0000000..a0e94f9 --- /dev/null +++ b/src/common/Model/PaymentCategory.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.PaymentCategory + ( PaymentCategoryId + , PaymentCategory(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +type PaymentCategoryId = Int64 + +data PaymentCategory = PaymentCategory + { _paymentCategory_id :: PaymentCategoryId + , _paymentCategory_name :: Text + , _paymentCategory_category :: CategoryId + , _paymentCategory_createdAt :: UTCTime + , _paymentCategory_editedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON PaymentCategory +instance ToJSON PaymentCategory diff --git a/src/common/Model/SignIn.hs b/src/common/Model/SignIn.hs new file mode 100644 index 0000000..f4da97f --- /dev/null +++ b/src/common/Model/SignIn.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.SignIn + ( SignIn(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data SignIn = SignIn + { _signIn_email :: Text + } deriving (Show, Generic) + +instance FromJSON SignIn +instance ToJSON SignIn diff --git a/src/common/Model/User.hs b/src/common/Model/User.hs new file mode 100644 index 0000000..8c64bc2 --- /dev/null +++ b/src/common/Model/User.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.User + ( UserId + , User(..) + , find + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.List as L +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type UserId = Int64 + +data User = User + { _user_id :: UserId + , _user_creation :: UTCTime + , _user_email :: Text + , _user_name :: Text + } deriving (Show, Generic) + +instance FromJSON User +instance ToJSON User + +find :: UserId -> [User] -> Maybe User +find userId users = L.find ((== userId) . _user_id) users diff --git a/src/common/Util/Text.hs b/src/common/Util/Text.hs new file mode 100644 index 0000000..4af7a4c --- /dev/null +++ b/src/common/Util/Text.hs @@ -0,0 +1,41 @@ +module Common.Util.Text + ( unaccent + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +unaccent :: Text -> Text +unaccent = T.map unaccentChar + +unaccentChar :: Char -> Char +unaccentChar c = case c of + 'à' -> 'a' + 'á' -> 'a' + 'â' -> 'a' + 'ã' -> 'a' + 'ä' -> 'a' + 'ç' -> 'c' + 'è' -> 'e' + 'é' -> 'e' + 'ê' -> 'e' + 'ë' -> 'e' + 'ì' -> 'i' + 'í' -> 'i' + 'î' -> 'i' + 'ï' -> 'i' + 'ñ' -> 'n' + 'ò' -> 'o' + 'ó' -> 'o' + 'ô' -> 'o' + 'õ' -> 'o' + 'ö' -> 'o' + 'š' -> 's' + 'ù' -> 'u' + 'ú' -> 'u' + 'û' -> 'u' + 'ü' -> 'u' + 'ý' -> 'y' + 'ÿ' -> 'y' + 'ž' -> 'z' + _ -> c diff --git a/src/common/View/Format.hs b/src/common/View/Format.hs new file mode 100644 index 0000000..a7fa4e3 --- /dev/null +++ b/src/common/View/Format.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.View.Format + ( shortDay + , longDay + , price + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, toGregorian) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.Currency (Currency(..)) + +shortDay :: Day -> Text +shortDay date = + Message.get $ Key.Date_Short + day + month + (fromIntegral year) + where (year, month, day) = toGregorian date + +longDay :: Day -> Text +longDay date = + Message.get $ Key.Date_Long + day + (fromMaybe "−" . fmap Message.get . monthToKey $ month) + (fromIntegral year) + where (year, month, day) = toGregorian date + + monthToKey 1 = Just Key.Month_January + monthToKey 2 = Just Key.Month_February + monthToKey 3 = Just Key.Month_March + monthToKey 4 = Just Key.Month_April + monthToKey 5 = Just Key.Month_May + monthToKey 6 = Just Key.Month_June + monthToKey 7 = Just Key.Month_July + monthToKey 8 = Just Key.Month_August + monthToKey 9 = Just Key.Month_September + monthToKey 10 = Just Key.Month_October + monthToKey 11 = Just Key.Month_November + monthToKey 12 = Just Key.Month_December + monthToKey _ = Nothing + +price :: Currency -> Int -> Text +price (Currency currency) amount = T.concat [ number amount, " ", currency ] + +number :: Int -> Text +number n = + T.pack + . (++) (if n < 0 then "-" else "") + . reverse + . concat + . intersperse " " + . group 3 + . reverse + . show + . abs $ n + +group :: Int -> [a] -> [[a]] +group n xs = + if length xs <= n + then [xs] + else (take n xs) : (group n (drop n xs)) diff --git a/src/migrations/2.sql b/src/migrations/2.sql new file mode 100644 index 0000000..ec0d1b0 --- /dev/null +++ b/src/migrations/2.sql @@ -0,0 +1,23 @@ +BEGIN TRANSACTION; + +ALTER TABLE payment RENAME TO tmp_payment; + +CREATE TABLE IF NOT EXISTS "payment"( + "id" INTEGER PRIMARY KEY, + "user" INTEGER NOT NULL REFERENCES "user", + "name" VARCHAR NOT NULL, + "cost" INTEGER NOT NULL, + "date" DATE NOT NULL, + "frequency" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +INSERT INTO payment(id, user, name, cost, date, frequency, created_at, edited_at, deleted_at) +SELECT id, user_id, name, cost, date, frequency, created_at, edited_at, deleted_at +FROM tmp_payment; + +DROP TABLE tmp_payment; + +COMMIT; diff --git a/src/server/Common b/src/server/Common new file mode 120000 index 0000000..60d3b0a --- /dev/null +++ b/src/server/Common @@ -0,0 +1 @@ +../common \ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs index a05349d..92df4e9 100644 --- a/src/server/Conf.hs +++ b/src/server/Conf.hs @@ -10,11 +10,13 @@ import qualified Data.Text as T import qualified Data.ConfigManager as Conf import Data.Time.Clock (NominalDiffTime) +import Common.Model.Currency (Currency(..)) + data Conf = Conf { hostname :: Text , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Text + , currency :: Currency , noReplyMail :: Text , https :: Bool } deriving Show @@ -28,7 +30,7 @@ get path = do Conf.lookup "hostname" conf <*> Conf.lookup "port" conf <*> Conf.lookup "signInExpiration" conf <*> - Conf.lookup "currency" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> Conf.lookup "https" conf ) diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 3f800da..1a44083 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -11,12 +11,14 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty hiding (delete) +import Common.Model.Category (CategoryId) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.CreateCategory as Json +import qualified Common.Model.EditCategory as Json + import Json (jsonId) -import Model.Category (CategoryId) import qualified Model.Category as Category -import qualified Model.Json.CreateCategory as Json -import qualified Model.Json.EditCategory as Json -import qualified Model.Message.Key as Key import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query import qualified Secure @@ -49,5 +51,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.CategoryNotDeleted + text . TL.fromStrict $ Message.get Key.Category_NotDeleted ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 18394d0..148b713 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -11,26 +11,25 @@ import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + import Json (jsonId) -import Model.Income (IncomeId) import qualified Model.Income as Income -import qualified Model.Json.CreateIncome as Json -import qualified Model.Json.EditIncome as Json -import qualified Model.Message.Key as Key import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure -create :: Json.CreateIncome -> ActionM () -create (Json.CreateIncome date amount) = +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId ) -editOwn :: Json.EditIncome -> ActionM () -editOwn (Json.EditIncome incomeId date amount) = +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -45,5 +44,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.IncomeNotDeleted + text . TL.fromStrict $ Message.get Key.Income_NotDeleted ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 9fb2aa0..8473c5c 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -7,15 +7,17 @@ import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) import Web.Scotty hiding (get) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + import Conf (Conf(..)) import Model.Init (getInit) -import Model.Json.Init (InitResult(..)) -import Model.Message.Key -import Model.User (User) import qualified LoginSession -import qualified Model.Json.Conf as M import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -29,17 +31,17 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitError $ errorKey + return . InitEmpty . Left . Message.get $ errorKey Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return InitEmpty + return . InitEmpty . Right $ Nothing Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) initResult + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -52,23 +54,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ SignInInvalid + return . Left $ Key.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ SignInUsed + return . Left $ Key.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ SignInExpired + return . Left $ Key.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn + User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left UnauthorizedSignIn + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d71b451..6a9ede7 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -11,37 +11,36 @@ import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status (ok200, badRequest400) import Web.Scotty +import qualified Common.Model.CreatePayment as M +import qualified Common.Model.EditPayment as M +import Common.Model (PaymentId, User(..)) + import Json (jsonId) -import Model.Payment (PaymentId) -import qualified Model.Json.CreatePayment as Json -import qualified Model.Json.EditPayment as Json -import qualified Model.Json.Payment as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.Query as Query -import qualified Model.User as User import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json + (liftIO . Query.run $ Payment.list) >>= json ) -create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date category frequency) = +create :: M.CreatePayment -> ActionM () +create (M.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> (liftIO . Query.run $ do PaymentCategory.save name category - Payment.create (User.id user) name cost date frequency + Payment.create (_user_id user) name cost date frequency ) >>= jsonId ) -editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date category frequency) = +editOwn :: M.EditPayment -> ActionM () +editOwn (M.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (User.id user) paymentId name cost date frequency + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -54,7 +53,7 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId if deleted then status ok200 else status badRequest400 diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 152168c..932ce53 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -5,15 +5,17 @@ module Controller.SignIn ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Web.Scotty +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import qualified Common.Model.SignIn as M + import Conf (Conf) -import Model.Message.Key import qualified Conf import qualified Model.Query as Query import qualified Model.SignIn as SignIn @@ -22,30 +24,24 @@ import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn -signIn :: Conf -> Text -> ActionM () -signIn conf login = - if Email.isValid (TE.encodeUtf8 login) +signIn :: Conf -> M.SignIn -> ActionM () +signIn conf (M.SignIn email) = + if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.getUser login + maybeUser <- liftIO . Query.run $ User.get email case maybeUser of Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login + token <- liftIO . Query.run $ SignIn.createSignInToken email let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, "?signInToken=", token ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> - status ok200 - Left _ -> do - status badRequest400 - text . TL.pack . show $ SendEmailFail - Nothing -> do - status badRequest400 - text . TL.pack . show $ UnauthorizedSignIn - else do - status badRequest400 - text . TL.pack . show $ EnterValidEmail + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs deleted file mode 100644 index d8604ac..0000000 --- a/src/server/Controller/User.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.User - ( getUsers - ) where - -import Web.Scotty - -import Control.Monad.IO.Class (liftIO) - -import qualified Secure - -import Model.Database -import qualified Model.User as User - -getUsers :: ActionM () -getUsers = - Secure.loggedAction (\_ -> - (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json - ) diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs index afc601f..06c468e 100644 --- a/src/server/Design/Color.hs +++ b/src/server/Design/Color.hs @@ -7,6 +7,9 @@ import qualified Clay.Color as C white :: C.Color white = C.white +black :: C.Color +black = C.black + chestnutRose :: C.Color chestnutRose = C.rgb 207 92 86 diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs index e742978..47ea4a9 100644 --- a/src/server/Design/Global.hs +++ b/src/server/Design/Global.hs @@ -8,9 +8,7 @@ import Clay import Data.Text.Lazy (Text) -import qualified Design.Header as Header -import qualified Design.SignIn as SignIn -import qualified Design.LoggedIn as LoggedIn +import qualified Design.Views as Views import qualified Design.Form as Form import qualified Design.Errors as Errors import qualified Design.Dialog as Dialog @@ -26,13 +24,10 @@ globalDesign = renderWith compact [] global global :: Css global = do - - header ? Header.design - ".signIn" ? SignIn.design - ".loggedIn" ? LoggedIn.design ".errors" ? Errors.design ".dialog" ? Dialog.design ".tooltip" ? Tooltip.design + Views.design Form.design body ? do @@ -49,6 +44,8 @@ global = do a ? cursor pointer + input ? fontSize inherit + h1 ? do color Color.chestnutRose marginBottom (em 1) diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs deleted file mode 100644 index 8feac64..0000000 --- a/src/server/Design/Header.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - let headerPadding = "padding" -: "0 20px" - display flex - "flex-wrap" -: "wrap" - lineHeightMedia - position relative - backgroundColor Color.chestnutRose - color Color.white - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - Media.mobile $ marginBottom (em 1.5) - - ".title" <> ".item" ? headerPadding - - ".title" ? do - height (pct 100) - textAlign (alignSide sideLeft) - - Media.mobile $ fontSize (px 22) - Media.mobileTablet $ width (pct 100) - Media.tabletDesktop $ do - display inlineBlock - fontSize (px 35) - - ".item" ? do - display inlineBlock - transition "background-color" (ms 50) easeIn (sec 0) - ".current" & backgroundColor (Color.chestnutRose -. 20) - Media.mobile $ fontSize (px 13) - - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) - - ".nameSignOut" ? do - display flex - heightMedia - position absolute - top (px 0) - right (px 0) - - ".name" ? do - Media.mobile $ display none - Media.tabletDesktop $ headerPadding - - ".signOut" ? do - heightMedia - svg ? do - Media.mobile $ width (px 20) - -lineHeightMedia :: Css -lineHeightMedia = do - Media.desktop $ lineHeight (px 80) - Media.tablet $ lineHeight (px 65) - Media.mobile $ lineHeight (px 50) - -heightMedia :: Css -heightMedia = do - Media.desktop $ height (px 80) - Media.tablet $ height (px 65) - Media.mobile $ height (px 50) diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs index 869616d..41528ed 100644 --- a/src/server/Design/Helper.hs +++ b/src/server/Design/Helper.hs @@ -3,8 +3,8 @@ module Design.Helper ( clearFix , button + , waitable , input - , iconButton , centeredWithMargin , verticalCentering ) where @@ -13,8 +13,6 @@ import Prelude hiding (span) import Clay hiding (button, input) -import Data.Monoid ((<>)) - import Design.Constants import Design.Color as Color @@ -27,6 +25,9 @@ clearFix = button :: Color -> Color -> Size a -> (Color -> Color) -> Css button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center backgroundColor backgroundCol padding (px 0) (px 10) (px 0) (px 10) color textCol @@ -38,19 +39,20 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) + waitable -iconButton :: Color -> Color -> Size LengthUnit -> (Color -> Color) -> Css -iconButton backgroundCol textCol h focusOp = do - button backgroundCol textCol h focusOp - i <> span ? do - height h - lineHeight h - span ? do - display inlineBlock - marginLeft (px 20) - i ? do - marginLeft (px 15) - marginRight (px 20) +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation input :: Double -> Css input h = do @@ -72,3 +74,17 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/LoggedIn.hs deleted file mode 100644 index 4a21832..0000000 --- a/src/server/Design/LoggedIn.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home as Home -import qualified Design.LoggedIn.Stat as Stat -import qualified Design.LoggedIn.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".home" ? Home.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Design/LoggedIn/Home.hs b/src/server/Design/LoggedIn/Home.hs deleted file mode 100644 index 7845434..0000000 --- a/src/server/Design/LoggedIn/Home.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home - ( design - ) where - -import Clay - -import qualified Design.LoggedIn.Home.Header as Header -import qualified Design.LoggedIn.Home.Table as Table -import qualified Design.LoggedIn.Home.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/LoggedIn/Home/Header.hs b/src/server/Design/LoggedIn/Home/Header.hs deleted file mode 100644 index 5fd2d79..0000000 --- a/src/server/Design/LoggedIn/Home/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/LoggedIn/Home/Pages.hs b/src/server/Design/LoggedIn/Home/Pages.hs deleted file mode 100644 index 71f3254..0000000 --- a/src/server/Design/LoggedIn/Home/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/LoggedIn/Home/Table.hs deleted file mode 100644 index cb46ac9..0000000 --- a/src/server/Design/LoggedIn/Home/Table.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Home.Table - ( design - ) where - -import Clay - -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) diff --git a/src/server/Design/LoggedIn/Stat.hs b/src/server/Design/LoggedIn/Stat.hs deleted file mode 100644 index 62028cb..0000000 --- a/src/server/Design/LoggedIn/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Stat - ( design - ) where - -import Clay - -design :: Css -design = do - h1 ? paddingBottom (px 0) - - ".exceedingPayers" ? ".userName" ? marginRight (px 5) - - ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/LoggedIn/Table.hs b/src/server/Design/LoggedIn/Table.hs deleted file mode 100644 index 44b001a..0000000 --- a/src/server/Design/LoggedIn/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.LoggedIn.Table - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".emptyTableMsg" ? do - margin (em 2) (em 2) (em 2) (em 2) - textAlign (alignSide sideCenter) - - ".lines" ? do - Media.tabletDesktop $ display displayTable - width (pct 100) - textAlign (alignSide (sideCenter)) - - ".header" <> ".row" ? do - Media.tabletDesktop $ display tableRow - - ".header" ? do - Media.desktop $ do - fontSize (px 18) - height (px 70) - - Media.tabletDesktop $ do - backgroundColor Color.gothic - color Color.white - - Media.tablet $ do - fontSize (px 16) - height (px 60) - - Media.mobile $ do - display none - - ".row" ? do - nthChild "even" & backgroundColor Color.wildSand - - Media.desktop $ do - fontSize (px 18) - height (px 60) - - Media.tablet $ do - height (px 50) - - Media.mobile $ do - lineHeight (px 25) - paddingTop (px 10) - paddingBottom (px 10) - - ".cell" ? do - Media.tabletDesktop $ display tableCell - position relative - verticalAlign middle - - firstChild & do - Media.mobile $ do - fontSize (px 20) - lineHeight (px 30) - color Color.gothic - - ".refund" & color Color.mossGreen - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - hover & "svg path" ? do - "fill" -: "rgb(237, 122, 116)" - - Media.tabletDesktop $ width (pct 3) - - Media.mobile $ do - display inlineBlock - button ? display flex diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs deleted file mode 100644 index 75f2f98..0000000 --- a/src/server/Design/SignIn.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.SignIn - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - - form ? do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - Helper.iconButton Color.gothic Color.white (px inputHeight) Constants.focusLighten - display block - width (pct 100) - fontSize (em 1.2) - ".waitingServer" & ("cursor" -: "not-allowed") - - ".result" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs new file mode 100644 index 0000000..20627e6 --- /dev/null +++ b/src/server/Design/View/Header.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + let headerPadding = "padding" -: "0 20px" + display flex + "flex-wrap" -: "wrap" + lineHeightMedia + position relative + backgroundColor Color.chestnutRose + color Color.white + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + Media.mobile $ marginBottom (em 1.5) + + ".title" <> ".item" ? headerPadding + + ".title" ? do + height (pct 100) + textAlign (alignSide sideLeft) + + Media.mobile $ fontSize (px 22) + Media.mobileTablet $ width (pct 100) + Media.tabletDesktop $ do + display inlineBlock + fontSize (px 35) + + ".item" ? do + display inlineBlock + transition "background-color" (ms 50) easeIn (sec 0) + ".current" & backgroundColor (Color.chestnutRose -. 20) + Media.mobile $ fontSize (px 13) + + (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) + (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + + ".nameSignOut" ? do + display flex + heightMedia + position absolute + top (px 0) + right (px 0) + + ".name" ? do + Media.mobile $ display none + Media.tabletDesktop $ headerPadding + + ".signOut" ? do + Helper.waitable + heightMedia + svg ? do + Media.tabletDesktop $ width (px 30) + Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") + +lineHeightMedia :: Css +lineHeightMedia = do + Media.desktop $ lineHeight (px 80) + Media.tablet $ lineHeight (px 65) + Media.mobile $ lineHeight (px 50) + +heightMedia :: Css +heightMedia = do + Media.desktop $ height (px 80) + Media.tablet $ height (px 65) + Media.mobile $ height (px 50) diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/src/server/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs new file mode 100644 index 0000000..f02da8a --- /dev/null +++ b/src/server/Design/View/Payment/Header.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Constants + +import qualified Design.Helper as Helper +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + marginLeft (pct blockPercentMargin) + marginRight (pct blockPercentMargin) + + ".payerAndAdd" ? do + Media.tabletDesktop $ display flex + marginBottom (em 1) + + ".exceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + + Media.tabletDesktop $ do + "flex-grow" -: "1" + marginRight (px 15) + + Media.mobile $ do + marginBottom (em 1) + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + + ".searchLine" ? do + marginBottom (em 1) + form ? do + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none + + ".infos" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs new file mode 100644 index 0000000..ade81a8 --- /dev/null +++ b/src/server/Design/View/Payment/Pages.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + textAlign (alignSide sideCenter) + Helper.clearFix + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs new file mode 100644 index 0000000..a866b40 --- /dev/null +++ b/src/server/Design/View/Payment/Table.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Table + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".cell" ? do + ".name" & do + Media.tabletDesktop $ width (pct 30) + + ".cost" & do + Media.tabletDesktop $ width (pct 10) + + ".user" & do + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) + + ".date" & do + Media.tabletDesktop $ width (pct 15) + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/src/server/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs new file mode 100644 index 0000000..0a5b258 --- /dev/null +++ b/src/server/Design/View/Stat.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Stat + ( design + ) where + +import Clay + +design :: Css +design = do + h1 ? paddingBottom (px 0) + + ".exceedingPayers" ? ".userName" ? marginRight (px 5) + + ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs new file mode 100644 index 0000000..95abf90 --- /dev/null +++ b/src/server/Design/View/Table.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Table + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".emptyTableMsg" ? do + margin (em 2) (em 2) (em 2) (em 2) + textAlign (alignSide sideCenter) + + ".lines" ? do + Media.tabletDesktop $ display displayTable + width (pct 100) + textAlign (alignSide (sideCenter)) + + ".header" <> ".row" ? do + Media.tabletDesktop $ display tableRow + + ".header" ? do + Media.desktop $ do + fontSize (px 18) + height (px 70) + + Media.tabletDesktop $ do + backgroundColor Color.gothic + color Color.white + + Media.tablet $ do + fontSize (px 16) + height (px 60) + + Media.mobile $ do + display none + + ".row" ? do + nthChild "even" & backgroundColor Color.wildSand + + Media.desktop $ do + fontSize (px 18) + height (px 60) + + Media.tablet $ do + height (px 50) + + Media.mobile $ do + lineHeight (px 25) + paddingTop (px 10) + paddingBottom (px 10) + + ".cell" ? do + Media.tabletDesktop $ display tableCell + position relative + verticalAlign middle + + firstChild & do + Media.mobile $ do + fontSize (px 20) + lineHeight (px 30) + color Color.gothic + + ".refund" & color Color.mossGreen + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + hover & "svg path" ? do + "fill" -: "rgb(237, 122, 116)" + + Media.tabletDesktop $ width (pct 3) + + Media.mobile $ do + display inlineBlock + button ? display flex diff --git a/src/server/Design/Views.hs b/src/server/Design/Views.hs new file mode 100644 index 0000000..bc6ac83 --- /dev/null +++ b/src/server/Design/Views.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.View.Header as Header +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design + ".stat" ? Stat.design + Table.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index 8c11ccf..ba24cca 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -4,7 +4,8 @@ module Job.MonthlyPayment import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Frequency +import Common.Model (Frequency(..), Payment(..)) + import qualified Model.Payment as Payment import Utils.Time (timeToDay) import qualified Model.Query as Query @@ -14,6 +15,12 @@ monthlyPayment _ = do monthlyPayments <- Query.run Payment.listMonthly now <- getCurrentTime actualDay <- timeToDay now - let punctualPayments = map (\p -> p { Payment.frequency = Punctual, Payment.date = actualDay, Payment.createdAt = now }) monthlyPayments + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments _ <- Query.run (Payment.createMany punctualPayments) return now diff --git a/src/server/Main.hs b/src/server/Main.hs index 17c2594..db73474 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -1,16 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + import Network.Wai.Middleware.Static import qualified Data.Text.Lazy as LT import Web.Scotty -import Job.Daemon (runDaemons) import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment import qualified Controller.SignIn as SignIn +import Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query main :: IO () main = do @@ -19,13 +28,19 @@ main = do scotty (Conf.port conf) $ do middleware . staticPolicy $ noDots >-> addBase "public" + get "/exceedingPayer" $ do + time <- liftIO Time.getCurrentTime + (users, incomes, payments) <- liftIO . Query.run $ + liftA3 (,,) UserM.list IncomeM.list PaymentM.list + let exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + get "/" $ do signInToken <- mbParam "signInToken" Index.get conf signInToken post "/signIn" $ do - email <- param "email" - SignIn.signIn conf email + jsonData >>= SignIn.signIn conf post "/signOut" $ Index.signOut conf diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs index 9597bd9..6b7a488 100644 --- a/src/server/Model/Category.hs +++ b/src/server/Model/Category.hs @@ -1,34 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category - ( CategoryId - , Category(..) - , list + ( list , create , edit , delete ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Model.Query (Query(Query)) - -type CategoryId = Int64 +import Common.Model (Category(..), CategoryId) -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow Category where fromRow = Category <$> diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs index f9958e1..4f7b83d 100644 --- a/src/server/Model/Frequency.hs +++ b/src/server/Model/Frequency.hs @@ -1,28 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Model.Frequency - ( Frequency(..) - ) where +module Model.Frequency () where -import Data.Aeson import Database.SQLite.Simple (SQLData(SQLText)) import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) import Database.SQLite.Simple.ToField (ToField(toField)) -import GHC.Generics import qualified Data.Text as T -import Web.Scotty (parseParam, Parsable, readEither) -data Frequency = - Punctual - | Monthly - deriving (Eq, Show, Read, Generic) - -instance Parsable Frequency where parseParam = readEither -instance FromJSON Frequency -instance ToJSON Frequency +import Common.Model.Frequency (Frequency) instance FromField Frequency where fromField field = case fieldData field of diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs index c6cdb55..bbe7657 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income - ( IncomeId - , Income(..) - , list + ( list , create , editOwn , deleteOwn , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime, getCurrentTime) @@ -18,27 +16,15 @@ import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite +import Common.Model (Income(..), IncomeId, User(..), UserId) + import Model.Query (Query(Query)) -import Model.User (User, UserId) -import qualified Model.User as User import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type IncomeId = Int64 - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Income where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt instance FromRow Income where fromRow = Income <$> @@ -70,7 +56,7 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == incomeUserId + if _income_userId income == incomeUserId then do now <- getCurrentTime SQLite.execute @@ -90,7 +76,7 @@ deleteOwn user incomeId = mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if userId income == User.id user + if _income_userId income == _user_id user then do now <- getCurrentTime SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs index 7a9ccea..8c6a961 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -4,27 +4,24 @@ module Model.Init ( getInit ) where -import Model.Json.Init (Init) +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf import Model.Query (Query) -import Model.User (User) import qualified Model.Category as Category import qualified Model.Income as Income -import qualified Model.Json.Category as Json -import qualified Model.Json.Income as Json -import qualified Model.Json.Init as Init -import qualified Model.Json.Payment as Json -import qualified Model.Json.PaymentCategory as Json -import qualified Model.Json.User as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory import qualified Model.User as User -getInit :: User -> Query Init -getInit user = - Init.Init <$> - (map Json.fromUser <$> User.list) <*> - (return . User.id $ user) <*> - (map Json.fromPayment <$> Payment.list) <*> - (map Json.fromIncome <$> Income.list) <*> - (map Json.fromCategory <$> Category.list) <*> - (map Json.fromPaymentCategory <$> PaymentCategory.list) +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs deleted file mode 100644 index 8b5e527..0000000 --- a/src/server/Model/Json/Category.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Category - ( Category(..) - , fromCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.Category as M - -data Category = Category - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance ToJSON Category - -fromCategory :: M.Category -> Category -fromCategory category = Category (M.id category) (M.name category) (M.color category) diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs deleted file mode 100644 index a66fb55..0000000 --- a/src/server/Model/Json/Conf.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Conf - ( Conf(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -data Conf = Conf - { currency :: Text - } deriving (Show, Generic) - -instance FromJSON Conf -instance ToJSON Conf diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs deleted file mode 100644 index fffc882..0000000 --- a/src/server/Model/Json/CreateCategory.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateCategory - ( CreateCategory(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text (Text) - -data CreateCategory = CreateCategory - { name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/server/Model/Json/CreateIncome.hs b/src/server/Model/Json/CreateIncome.hs deleted file mode 100644 index cf9b1c3..0000000 --- a/src/server/Model/Json/CreateIncome.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreateIncome - ( CreateIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -data CreateIncome = CreateIncome - { date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs deleted file mode 100644 index 6ab3a5b..0000000 --- a/src/server/Model/Json/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs deleted file mode 100644 index a10ce39..0000000 --- a/src/server/Model/Json/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) - -data EditCategory = EditCategory - { id :: CategoryId - , name :: Text - , color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs deleted file mode 100644 index 9b29379..0000000 --- a/src/server/Model/Json/EditIncome.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditIncome - ( EditIncome(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Time.Calendar (Day) - -import Model.Income (IncomeId) - -data EditIncome = EditIncome - { id :: IncomeId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs deleted file mode 100644 index b7d4d7d..0000000 --- a/src/server/Model/Json/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Category (CategoryId) -import Model.Frequency (Frequency) -import Model.Payment (PaymentId) - -data EditPayment = EditPayment - { id :: PaymentId - , name :: Text - , cost :: Int - , date :: Day - , category :: CategoryId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs deleted file mode 100644 index 7e23a84..0000000 --- a/src/server/Model/Json/Income.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Income - ( Income(..) - , fromIncome - ) where - -import Data.Aeson -import Data.Time.Calendar (Day) -import GHC.Generics - -import Model.Income (IncomeId) -import Model.User (UserId) -import qualified Model.Income as M - -data Income = Income - { id :: IncomeId - , userId :: UserId - , date :: Day - , amount :: Int - } deriving (Show, Generic) - -instance ToJSON Income - -fromIncome :: M.Income -> Income -fromIncome income = Income (M.id income) (M.userId income) (M.date income) (M.amount income) diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs deleted file mode 100644 index 530c3b7..0000000 --- a/src/server/Model/Json/Init.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Init - ( Init(..) - , InitResult(..) - ) where - -import Data.Aeson -import GHC.Generics - -import Model.Json.Category (Category) -import Model.Json.Income (Income) -import Model.Json.Payment (Payment) -import Model.Json.PaymentCategory (PaymentCategory) -import Model.Json.User (User) -import Model.Message.Key (Key) -import Model.User (UserId) - -data Init = Init - { users :: [User] - , me :: UserId - , payments :: [Payment] - , incomes :: [Income] - , categories :: [Category] - , paymentCategories :: [PaymentCategory] - } deriving (Show, Generic) - -instance ToJSON Init - -data InitResult = - InitEmpty - | InitSuccess Init - | InitError Key - deriving (Show, Generic) - -instance ToJSON InitResult diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs deleted file mode 100644 index 0753d7c..0000000 --- a/src/server/Model/Json/MessagePart.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.MessagePart - ( MessagePart(..) - ) where - -import Data.Text (Text) - -import Data.Aeson -import GHC.Generics - -data MessagePart = - Order Int - | Str Text - deriving (Eq, Show, Generic) - -instance FromJSON MessagePart -instance ToJSON MessagePart diff --git a/src/server/Model/Json/Number.hs b/src/server/Model/Json/Number.hs deleted file mode 100644 index 52c9da8..0000000 --- a/src/server/Model/Json/Number.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Number - ( Number(..) - ) where - -import Data.Aeson -import GHC.Generics - -data Number = Number - { number :: Int - } deriving (Show, Generic) - -instance FromJSON Number -instance ToJSON Number diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs deleted file mode 100644 index e406c0f..0000000 --- a/src/server/Model/Json/Payment.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Payment - ( Payment(..) - , fromPayment - ) where - -import Data.Aeson -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics -import Prelude hiding (id) - -import Model.Frequency -import Model.Payment (PaymentId) -import Model.User (UserId) -import qualified Model.Payment as M - -data Payment = Payment - { id :: PaymentId - , date :: Day - , name :: Text - , cost :: Int - , userId :: UserId - , frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment - -fromPayment :: M.Payment -> Payment -fromPayment payment = - Payment - { id = M.id payment - , date = M.date payment - , name = M.name payment - , cost = M.cost payment - , userId = M.userId payment - , frequency = M.frequency payment - } diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs deleted file mode 100644 index fd97674..0000000 --- a/src/server/Model/Json/PaymentCategory.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.PaymentCategory - ( PaymentCategory(..) - , fromPaymentCategory - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.Category (CategoryId) -import qualified Model.PaymentCategory as M - -data PaymentCategory = PaymentCategory - { name :: Text - , category :: CategoryId - } deriving (Show, Generic) - -instance ToJSON PaymentCategory - -fromPaymentCategory :: M.PaymentCategory -> PaymentCategory -fromPaymentCategory pc = PaymentCategory (M.name pc) (M.category pc) diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs deleted file mode 100644 index 9dcfe80..0000000 --- a/src/server/Model/Json/Translation.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.Translation - ( Translation(..) - ) where - -import GHC.Generics - -import Data.Aeson -import Data.Text - -import Model.Json.MessagePart - -data Translation = Translation - { key :: Text - , message :: [MessagePart] - } deriving (Show, Generic) - -instance FromJSON Translation -instance ToJSON Translation diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs deleted file mode 100644 index c289fe0..0000000 --- a/src/server/Model/Json/User.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Json.User - ( User(..) - , fromUser - ) where - -import Data.Aeson -import Data.Text (Text) -import GHC.Generics - -import Model.User (UserId) -import qualified Model.User as M - -data User = User - { id :: UserId - , name :: Text - , email :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -fromUser :: M.User -> User -fromUser user = User (M.id user) (M.name user) (M.email user) diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs deleted file mode 100644 index 026967f..0000000 --- a/src/server/Model/Message.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Model.Message - ( getMessage - , getParamMessage - , getTranslations - , plural - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key (Key) -import Model.Message.Lang -import Model.Message.Translations (getNonFormattedMessage) -import Model.Message.Parts - -import Model.Json.Translation - -getMessage :: Key -> Text -getMessage = getParamMessage [] - -getParamMessage :: [Text] -> Key -> Text -getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey) - -getTranslations :: [Translation] -getTranslations = (map getTranslation [minBound..]) - -getTranslation :: Key -> Translation -getTranslation translationKey = - Translation - (T.pack . show $ translationKey) - (getParts $ getNonFormattedMessage lang translationKey) - -plural :: Int -> Key -> Key -> Text -plural count singularKey pluralKey = - getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey) diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs deleted file mode 100644 index 18f16f0..0000000 --- a/src/server/Model/Message/Key.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Model.Message.Key - ( Key(..) - ) where - -import qualified Data.Aeson as Json -import qualified Data.Text as T - -data Key = - - -- Title - - SharedCost - - -- Sign - - | Email - | SignIn - | SendEmailFail - | InvalidEmail - | UnauthorizedSignIn - | Forbidden - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid - | SignInMailTitle - | SignInMail - | SignInEmailSent - - -- Dates - - | January - | February - | March - | April - | May - | June - | July - | August - | September - | October - | November - | December - - | ShortDate - | ShortMonthAndYear - | LongDate - - -- Search - - | SearchName - | SearchPunctual - | SearchMonthly - - -- Payments - - | PaymentsAreBalanced - | Name - | Cost - | Payer - | Date - | Frequency - | InvalidFrequency - | AddPayment - | ClonePayment - | EditPayment - | PaymentNotDeleted - | Punctual - | Monthly - - | PaymentsTitle - | Payment - | Payments - | Worth - | NoPayment - - | PaymentName - | PaymentCost - | PaymentDate - | PaymentCategory - | PaymentPunctual - | PaymentMonthly - - | Clone - | Edit - | Delete - | ConfirmPaymentDelete - - -- Categories - - | Categories - | NoCategories - | CategoryNotDeleted - | AddCategory - | CloneCategory - | EditCategory - | ConfirmCategoryDelete - | CategoryName - | CategoryColor - | Color - | UsedCategory - - -- Statistics - - | Statistics - | ByMonthsAndMean - | By - | Total - - -- Income - - | CumulativeIncomesSince - | NoIncome - | Income - | MonthlyNetIncomes - | AddIncome - | CloneIncome - | EditIncome - | IncomeNotDeleted - | IncomeAmount - | IncomeDate - | ConfirmIncomeDelete - | Add - - -- Form - - | Empty - | InvalidString - | InvalidDate - | CostMustNotBeNull - | InvalidInt - | InvalidCategory - | InvalidColor - | AlreadyExists - | SmallerIntThan - | GreaterIntThan - - -- Errors - - | CreatePaymentError - | EditPaymentError - | DeletePaymentError - | CreateIncomeError - | EditIncomeError - | DeleteIncomeError - | CreateCategoryError - | EditCategoryError - | DeleteCategoryError - | SignOutError - - -- Dialog - - | Confirm - | Undo - - -- Page not found - - | PageNotFound - - -- Weekly report - - | WeeklyReport - | WeeklyReportEmpty - | PaymentCreated - | PaymentsCreated - | PaymentEdited - | PaymentsEdited - | PaymentDeleted - | PaymentsDeleted - | IncomeCreated - | IncomesCreated - | IncomeEdited - | IncomesEdited - | IncomeDeleted - | IncomesDeleted - | PayedFor - | DidNotPayFor - | IsPayedFrom - | IsNotPayedFrom - - -- Http error - - | BadUrl - | Timeout - | NetworkError - | BadPayload - - deriving (Enum, Bounded, Show) - -instance Json.ToJSON Key where - toJSON = Json.String . T.pack . show diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs deleted file mode 100644 index f515c96..0000000 --- a/src/server/Model/Message/Lang.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Model.Message.Lang - ( Lang(..) - , lang - ) where - -data Lang = - English - | French - -lang :: Lang -lang = French diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs deleted file mode 100644 index d065cf2..0000000 --- a/src/server/Model/Message/Parts.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Parts - ( replaceParts - , getParts - ) where - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T - -import Text.ParserCombinators.Parsec - -import Model.Json.MessagePart - -replaceParts :: [Text] -> Text -> Text -replaceParts values message = - T.concat . map (replacePart values) $ getParts message - -replacePart :: [Text] -> MessagePart -> Text -replacePart _ (Str str) = str -replacePart values (Order n) = - fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values - -getParts :: Text -> [MessagePart] -getParts str = - case parse partsParser "" (T.unpack str) of - Right parts -> parts - Left _ -> [] - -partsParser :: Parser [MessagePart] -partsParser = many partParser - -partParser :: Parser MessagePart -partParser = - (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n)) - <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str)) diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs deleted file mode 100644 index 7d26c3f..0000000 --- a/src/server/Model/Message/Translations.hs +++ /dev/null @@ -1,729 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Message.Translations - ( getNonFormattedMessage - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Model.Message.Key -import Model.Message.Lang - -getNonFormattedMessage :: Lang -> Key -> Text -getNonFormattedMessage = m - -m :: Lang -> Key -> Text - --- Title - -m l SharedCost = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - --- Sign in - -m l Email = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn = - case l of - English -> "Sign in" - French -> "Connexion" - -m l InvalidEmail = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n'est pas valide." - -m l UnauthorizedSignIn = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n'es pas autorisé à te connecter." - -m l Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SendEmailFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n'avons pas pu t'envoyer le courriel de connexion." - -m l EnterValidEmail = - case l of - English -> "Please enter a valid email address." - French -> "Ton courriel n'est pas valide." - -m l SignInUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignInExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignInInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - -m l SignInMailTitle = - case l of - English -> T.concat ["Sign in to ", m l SharedCost] - French -> T.concat ["Connexion à ", m l SharedCost] - -m l SignInMail = - T.intercalate - "\n" - ( case l of - English -> - [ "Hi {1}," - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l SharedCost - , ":" - ] - , "{2}" - , "" - , "See you soon!" - ] - French -> - [ "Salut {1}," - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l SharedCost - , ":" - ] - , "{2}" - , "" - , "À très vite !" - ] - ) - -m l SignInEmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t'avons envoyé un courriel avec un lien pour te connecter." - --- Date - -m l January = - case l of - English -> "january" - French -> "janvier" - -m l February = - case l of - English -> "february" - French -> "février" - -m l March = - case l of - English -> "march" - French -> "mars" - -m l April = - case l of - English -> "april" - French -> "avril" - -m l May = - case l of - English -> "may" - French -> "mai" - -m l June = - case l of - English -> "june" - French -> "juin" - -m l July = - case l of - English -> "july" - French -> "juillet" - -m l August = - case l of - English -> "august" - French -> "août" - -m l September = - case l of - English -> "september" - French -> "septembre" - -m l October = - case l of - English -> "october" - French -> "octobre" - -m l November = - case l of - English -> "november" - French -> "novembre" - -m l December = - case l of - English -> "december" - French -> "décembre" - -m l ShortDate = - case l of - English -> "{3}-{2}-{1}" - French -> "{1}/{2}/{3}" - -m l ShortMonthAndYear = - case l of - English -> "{2}-{1}" - French -> "{1}/{2}" - -m l LongDate = - case l of - English -> "{2} {1}, {3}" - French -> "{1} {2} {3}" - --- Search - -m l SearchName = - case l of - English -> "Search" - French -> "Recherche" - -m l SearchPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l SearchMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - --- Payments - -m l PaymentsAreBalanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Name = - case l of - English -> "Name" - French -> "Nom" - -m l Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payer = - case l of - English -> "Payer" - French -> "Payeur" - -m l Date = - case l of - English -> "Date" - French -> "Date" - -m l Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l AddPayment = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l ClonePayment = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l EditPayment = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l PaymentNotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n'a pas pu être supprimé." - -m l Punctual = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Monthly = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l PaymentsTitle = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment = - case l of - English -> "payment" - French -> "paiement" - -m l Payments = - case l of - English -> "payments" - French -> "paiements" - -m l Worth = - case l of - English -> "{1} worth {2}" - French -> "{1} comptabilisant {2}" - -m l NoPayment = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l PaymentName = - case l of - English -> "Name" - French -> "Nom" - -m l PaymentCost = - case l of - English -> "Cost" - French -> "Coût" - -m l PaymentDate = - case l of - English -> "Date" - French -> "Date" - -m l PaymentCategory = - case l of - English -> "Category" - French -> "Catégorie" - -m l PaymentPunctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l PaymentMonthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l ConfirmPaymentDelete = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Edit = - case l of - English -> "Edit" - French -> "Modifier" - -m l Clone = - case l of - English -> "Clone" - French -> "Cloner" - -m l Delete = - case l of - English -> "Delete" - French -> "Supprimer" - --- Categories - -m l Categories = - case l of - English -> "Categories" - French -> "Catégories" - -m l NoCategories = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l CategoryNotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n'a pas pu être supprimé." - -m l AddCategory = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l CloneCategory = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l EditCategory = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l ConfirmCategoryDelete = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l CategoryName = - case l of - English -> "Name" - French -> "Nom" - -m l CategoryColor = - case l of - English -> "Color" - French -> "Couleur" - -m l Color = - case l of - English -> "Color" - French -> "Couleur" - -m l UsedCategory = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - --- Statistics - -m l Statistics = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l ByMonthsAndMean = - case l of - English -> "Payments by category by month months ({1} on average)" - French -> "Paiements par catégorie par mois (en moyenne {1})" - -m l By = - case l of - English -> "{1}: {2}" - French -> "{1} : {2}" - -m l Total = - case l of - English -> "Total" - French -> "Total" - --- Income - -m l CumulativeIncomesSince = - case l of - English -> "Cumulative incomes since {1}" - French -> "Revenus nets cumulés depuis le {1}" - -m l NoIncome = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income = - case l of - English -> "Income" - French -> "Revenu" - -m l MonthlyNetIncomes = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l AddIncome = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l CloneIncome = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l EditIncome = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l IncomeNotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n'a pas pu être supprimé." - -m l IncomeAmount = - case l of - English -> "Amount" - French -> "Montant" - -m l IncomeDate = - case l of - English -> "Date" - French -> "Date" - -m l ConfirmIncomeDelete = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Add = - case l of - English -> "Add" - French -> "Ajouter" - --- Form error - -m l Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l SmallerIntThan = - case l of - English -> "Integer bigger than {1} or equal required" - French -> "Entier supérieur ou égal à {1} requis" - -m l GreaterIntThan = - case l of - English -> "Integer smaller than {1} or equal required" - French -> "Entier inférieur ou égal à {1} requis" - --- Errors - -m l CreatePaymentError = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l EditPaymentError = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l DeletePaymentError = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l CreateIncomeError = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l EditIncomeError = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l DeleteIncomeError = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l CreateCategoryError = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l EditCategoryError = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l DeleteCategoryError = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l SignOutError = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - --- Dialog - -m l Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Undo = - case l of - English -> "Undo" - French -> "Annuler" - --- Page not found - -m l PageNotFound = - case l of - English -> "Page not found" - French -> "Page introuvable" - --- Weekly report - -m l WeeklyReport = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" - -m l WeeklyReportEmpty = - case l of - English -> "No activity the previous week." - French -> "Pas d'activité la semaine passée." - -m l PaymentCreated = - case l of - English -> "{1} payment created:" - French -> "{1} paiement créé :" - -m l PaymentsCreated = - case l of - English -> "{1} payments created:" - French -> "{1} paiements créés :" - -m l PaymentEdited = - case l of - English -> "{1} payment edited:" - French -> "{1} paiement modifié :" - -m l PaymentsEdited = - case l of - English -> "{1} payments edited:" - French -> "{1} paiements modifiés :" - -m l PaymentDeleted = - case l of - English -> "{1} payment deleted:" - French -> "{1} paiement supprimé :" - -m l PaymentsDeleted = - case l of - English -> "{1} payments deleted:" - French -> "{1} paiements supprimés :" - -m l IncomeCreated = - case l of - English -> "{1} income created:" - French -> "{1} revenu créé :" - -m l IncomesCreated = - case l of - English -> "{1} incomes created:" - French -> "{1} revenus créés :" - -m l IncomeEdited = - case l of - English -> "{1} income edited:" - French -> "{1} revenu modifié :" - -m l IncomesEdited = - case l of - English -> "{1} incomes edited:" - French -> "{1} revenus modifiés :" - -m l IncomeDeleted = - case l of - English -> "{1} income deleted:" - French -> "{1} revenu supprimé :" - -m l IncomesDeleted = - case l of - English -> "{1} incomes deleted:" - French -> "{1} revenus supprimés :" - -m l PayedFor = - case l of - English -> "{1} payed {2} for “{3}” at {4}" - French -> "{1} a payé {2} concernant « {3} » le {4}" - -m l DidNotPayFor = - case l of - English -> "{1} didn't pay {2} for “{3}” at {4}" - French -> "{1} n'a pas payé {2} concernant « {3} » le {4}" - -m l IsPayedFrom = - case l of - English -> "{1} is payed {2} of net monthly income from {3}" - French -> "{1} est payé {2} net par mois à partir du {3}" - -m l IsNotPayedFrom = - case l of - English -> "{1} isn't payed {2} of net monthly income from {3}" - French -> "{1} n'est pas payé {2} net par mois à partir du {3}" - --- Http error - -m l BadUrl = - case l of - English -> "URL not valid" - French -> "l'URL n'est pas valide" - -m l Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n'est pas accessible" - -m l BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/src/server/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5414d18..5b576c5 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment - ( PaymentId - , Payment(..) + ( Payment(..) , find , list , listMonthly @@ -13,7 +13,6 @@ module Model.Payment , modifiedDuring ) where -import Data.Int (Int64) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time (UTCTime) @@ -24,29 +23,19 @@ import Database.SQLite.Simple.ToField (ToField(toField)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Frequency +import Common.Model.Frequency +import Common.Model.Payment (Payment(..)) +import Common.Model.User (UserId) +import Common.Model.Payment (PaymentId) + +import Model.Frequency () import Model.Query (Query(Query)) -import Model.User (UserId) import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -type PaymentId = Int64 - -data Payment = Payment - { id :: PaymentId - , userId :: UserId - , name :: Text - , cost :: Int - , date :: Day - , frequency :: Frequency - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - , deletedAt :: Maybe UTCTime - } deriving Show - instance Resource Payment where - resourceCreatedAt = createdAt - resourceEditedAt = editedAt - resourceDeletedAt = deletedAt + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt instance FromRow Payment where fromRow = Payment <$> @@ -62,12 +51,12 @@ instance FromRow Payment where instance ToRow Payment where toRow p = - [ toField (userId p) - , toField (name p) - , toField (cost p) - , toField (date p) - , toField (frequency p) - , toField (createdAt p) + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_frequency p) + , toField (_payment_createdAt p) ] find :: PaymentId -> Query (Maybe Payment) @@ -92,13 +81,13 @@ listMonthly = ) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create paymentUserId paymentName paymentCost paymentDate paymentFrequency = +create userId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do now <- getCurrentTime SQLite.execute conn "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" - (paymentUserId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -112,13 +101,13 @@ createMany payments = ) editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequency = +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute @@ -133,13 +122,13 @@ editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequ ) deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn paymentUserId paymentId = +deleteOwn userId paymentId = Query (\conn -> do mbPayment <- listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) case mbPayment of Just payment -> - if userId payment == paymentUserId + if _payment_user payment == userId then do now <- getCurrentTime SQLite.execute diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs index 7c504dc..6e1d304 100644 --- a/src/server/Model/PaymentCategory.hs +++ b/src/server/Model/PaymentCategory.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - , list + ( list , listByCategory , save ) where -import Data.Int (Int64) import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Data.Text as T import qualified Database.SQLite.Simple as SQLite -import Model.Category (CategoryId) -import Model.Query (Query(Query)) -import qualified Utils.Text as T - -type PaymentCategoryId = Int64 +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T -data PaymentCategory = PaymentCategory - { id :: PaymentCategoryId - , name :: Text - , category :: CategoryId - , createdAt :: UTCTime - , editedAt :: Maybe UTCTime - } deriving Show +import Model.Query (Query(Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index c8a0d53..eb78a69 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User - ( UserId - , User(..) - , list - , getUser - , findUser + ( list + , get , createUser , deleteUser ) where -import Data.Int (Int64) -import Data.List (find) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import Prelude hiding (id) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) - -type UserId = Int64 +import Common.Model (UserId, User(..)) -data User = User - { id :: UserId - , creation :: UTCTime - , email :: Text - , name :: Text - } deriving Show +import Model.Query (Query(Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field @@ -37,15 +25,12 @@ instance FromRow User where list :: Query [User] list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") -getUser :: Text -> Query (Maybe User) -getUser userEmail = +get :: Text -> Query (Maybe User) +get userEmail = Query (\conn -> listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -findUser :: UserId -> [User] -> Maybe User -findUser userId = find ((==) userId . id) - createUser :: Text -> Text -> Query UserId createUser userEmail userName = Query (\conn -> do diff --git a/src/server/Secure.hs b/src/server/Secure.hs index da48878..f427304 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -11,11 +11,12 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import Model.Message (getMessage) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + import Model.Query (Query) -import Model.User (User) import qualified LoginSession -import qualified Model.Message.Key as Key import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -31,16 +32,16 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.UnauthorizedSignIn + html . fromStrict . Message.get $ Key.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . getMessage $ Key.Forbidden + html . fromStrict . Message.get $ Key.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do mbSignIn <- SignIn.getSignIn token case mbSignIn of Just signIn -> - User.getUser (SignIn.email signIn) + User.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/src/server/Utils/Text.hs b/src/server/Utils/Text.hs deleted file mode 100644 index 5ed77e4..0000000 --- a/src/server/Utils/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Utils.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs index 4a247e9..97457c7 100644 --- a/src/server/Utils/Time.hs +++ b/src/server/Utils/Time.hs @@ -2,7 +2,6 @@ module Utils.Time ( belongToCurrentMonth , belongToCurrentWeek , timeToDay - , monthToKey ) where import Data.Time.Clock (UTCTime, getCurrentTime) @@ -10,9 +9,6 @@ import Data.Time.LocalTime import Data.Time.Calendar import Data.Time.Calendar.WeekDate (toWeekDate) -import Model.Message.Key (Key) -import qualified Model.Message.Key as K - belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time @@ -27,18 +23,3 @@ belongToCurrentWeek time = do timeToDay :: UTCTime -> IO Day timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time - -monthToKey :: Int -> Maybe Key -monthToKey 1 = Just K.January -monthToKey 2 = Just K.February -monthToKey 3 = Just K.March -monthToKey 4 = Just K.April -monthToKey 5 = Just K.May -monthToKey 6 = Just K.June -monthToKey 7 = Just K.July -monthToKey 8 = Just K.August -monthToKey 9 = Just K.September -monthToKey 10 = Just K.October -monthToKey 11 = Just K.November -monthToKey 12 = Just K.December -monthToKey _ = Nothing diff --git a/src/server/View/Format.hs b/src/server/View/Format.hs deleted file mode 100644 index 354d46a..0000000 --- a/src/server/View/Format.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Format - ( price - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) - -import Conf (Conf) -import qualified Conf - -price :: Conf -> Int -> Text -price conf amount = T.concat [number amount, " ", Conf.currency conf] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index c7d40d8..12c4f34 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -6,10 +6,11 @@ module View.Mail.SignIn import Data.Text (Text) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model.User (User(..)) + import Conf (Conf) -import Model.Message -import Model.Message.Key -import Model.User (User(..)) import qualified Conf as Conf import qualified Model.Mail as M @@ -18,6 +19,6 @@ mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = (getMessage SignInMailTitle) - , M.plainBody = getParamMessage [name user, url] SignInMail + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index 1a80b95..0bafb70 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -9,38 +9,34 @@ import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime) import qualified Data.Map as M import qualified Data.Text as T -import Resource (Status(..), groupByStatus, statuses) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model.User as User +import qualified Common.View.Format as Format -import Model.Income (Income) import Model.Mail (Mail(Mail)) -import Model.Message (getMessage, getParamMessage, plural) -import Model.Payment (Payment) -import Model.User (findUser) -import Model.User (User, UserId) -import qualified Model.Income as Income +import Model.Payment () +import qualified Model.Income () import qualified Model.Mail as M -import qualified Model.Message.Key as K -import qualified Model.Payment as Payment -import qualified Model.User as User - +import Resource (Status(..), groupByStatus, statuses) import Conf (Conf) import qualified Conf as Conf -import qualified View.Format as Format - -import Utils.Time (monthToKey) - mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = Mail { M.from = Conf.noReplyMail conf - , M.to = map User.email users - , M.subject = T.concat [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport] + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -48,7 +44,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - getMessage K.WeeklyReportEmpty + Message.get Key.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -57,65 +53,45 @@ body conf users paymentsByStatus incomesByStatus = paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = - section - (plural (length payments) singleKey pluralKey) - (map (payedFor status conf users) . sortOn Payment.date $ payments) - where (singleKey, pluralKey) = - case status of - Created -> (K.PaymentCreated, K.PaymentsCreated) - Edited -> (K.PaymentEdited, K.PaymentsEdited) - Deleted -> (K.PaymentDeleted, K.PaymentsDeleted) + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = - getParamMessage - [ formatUserName (Payment.userId payment) users - , Format.price conf . Payment.cost $ payment - , Payment.name payment - , formatDay $ Payment.date payment - ] - ( case status of - Created -> K.PayedFor - Edited -> K.PayedFor - Deleted -> K.DidNotPayFor - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = - section - (plural (length incomes) singleKey pluralKey) - (map (isPayedFrom status conf users) . sortOn Income.date $ incomes) - where (singleKey, pluralKey) = - case status of - Created -> (K.IncomeCreated, K.IncomesCreated) - Edited -> (K.IncomeEdited, K.IncomesEdited) - Deleted -> (K.IncomeDeleted, K.IncomesDeleted) + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = - getParamMessage - [ formatUserName (Income.userId income) users - , Format.price conf . Income.amount $ income - , formatDay $ Income.date income - ] - ( case status of - Created -> K.IsPayedFrom - Edited -> K.IsPayedFrom - Deleted -> K.IsNotPayedFrom - ) + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income formatUserName :: UserId -> [User] -> Text -formatUserName userId = fromMaybe "−" . fmap User.name . findUser userId - -formatDay :: Day -> Text -formatDay d = - let (year, month, day) = toGregorian d - in getParamMessage - [ T.pack . show $ day - , fromMaybe "−" . fmap getMessage . monthToKey $ month - , T.pack . show $ year - ] - K.LongDate +formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId section :: Text -> [Text] -> Text section title items = diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 5a2e4f8..1c072a4 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -16,29 +16,24 @@ import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Html.Renderer.Text (renderHtml) -import Design.Global (globalDesign) +import qualified Common.Message as Message +import Common.Model.InitResult (InitResult) +import qualified Common.Message.Key as Key -import Model.Message -import Model.Json.Conf -import Model.Json.Init (InitResult) -import Model.Message.Key (Key(SharedCost)) +import Design.Global (globalDesign) -page :: Conf -> InitResult -> Text -page conf initResult = +page :: InitResult -> Text +page initResult = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ getMessage SharedCost) - script ! src "javascripts/client.js" $ "" - jsonScript "translations" getTranslations - jsonScript "conf" conf - jsonScript "result" initResult + H.title (toHtml $ Message.get Key.App_Title) + script ! src "javascript/main.js" $ "" + jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign - body $ do - script ! src "javascripts/main.js" $ "" jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index b72f9a0..0000000 --- a/stack.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: lts-8.3 -extra-deps: -- config-manager-0.3.0.1 -- cgit v1.2.3 From 903108a3b64758fa58783878756931e6cf187e53 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 7 Nov 2017 09:43:25 +0100 Subject: Reformat payment queries --- src/server/Model/Payment.hs | 36 +++++++++++++++++++++++++++++++----- src/server/Model/User.hs | 12 ++++++------ 2 files changed, 37 insertions(+), 11 deletions(-) diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs index 5b576c5..3893850 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -15,6 +15,7 @@ module Model.Payment import Data.Maybe (listToMaybe) import Data.Text (Text) +import qualified Data.Text as T import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Time.Clock (getCurrentTime) @@ -76,7 +77,12 @@ listMonthly = Query (\conn -> SQLite.query conn - "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ? ORDER BY name DESC" + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) (Only Monthly) ) @@ -86,7 +92,10 @@ create userId paymentName paymentCost paymentDate paymentFrequency = now <- getCurrentTime SQLite.execute conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) SQLite.lastInsertRowId conn ) @@ -96,7 +105,10 @@ createMany payments = Query (\conn -> SQLite.executeMany conn - "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)" + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) payments ) @@ -112,7 +124,15 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = now <- getCurrentTime SQLite.execute conn - "UPDATE payment SET edited_at = ?, name = ?, cost = ?, date = ?, frequency = ? WHERE id = ?" + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) return True else @@ -147,6 +167,12 @@ modifiedDuring start end = Query (\conn -> SQLite.query conn - "SELECT * FROM payment WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE (created_at >= ? AND created_at <= ?)" + , " OR (edited_at >= ? AND edited_at <= ?)" + , " OR (deleted_at >= ? AND deleted_at <= ?)" + ]) (start, end, start, end, start, end) ) diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs index eb78a69..e14fcef 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -4,8 +4,8 @@ module Model.User ( list , get - , createUser - , deleteUser + , create + , delete ) where import Data.Maybe (listToMaybe) @@ -31,8 +31,8 @@ get userEmail = SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) -createUser :: Text -> Text -> Query UserId -createUser userEmail userName = +create :: Text -> Text -> Query UserId +create userEmail userName = Query (\conn -> do now <- getCurrentTime SQLite.execute @@ -42,8 +42,8 @@ createUser userEmail userName = SQLite.lastInsertRowId conn ) -deleteUser :: Text -> Query () -deleteUser userEmail = +delete :: Text -> Query () +delete userEmail = Query (\conn -> SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) ) -- cgit v1.2.3 From a3601b5e6f5a3e41fa31752a2c704ccd3632790e Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 7 Nov 2017 09:44:35 +0100 Subject: Update README --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 1dc589e..b203cdb 100644 --- a/README.md +++ b/README.md @@ -58,7 +58,7 @@ See [application.conf](application.conf). TODO ---- -- remove duplicates server models / common models +- move persistence methods to a module - use another route to check the token and redirect to / - Add payment balance in weekly report -- cgit v1.2.3 From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- .gitignore | 10 +- .tmuxinator.yml | 4 +- LICENSE | 674 ---------------------------- Makefile | 57 ++- cabal-client.project | 4 + cabal-server.project | 3 + client/LICENSE | 674 ++++++++++++++++++++++++++++ client/Setup.hs | 2 + client/client.cabal | 24 + client/src/Component/Button.hs | 53 +++ client/src/Component/Input.hs | 34 ++ client/src/Icon.hs | 44 ++ client/src/Main.hs | 40 ++ client/src/View/App.hs | 44 ++ client/src/View/Header.hs | 86 ++++ client/src/View/Payment.hs | 33 ++ client/src/View/Payment/Table.hs | 90 ++++ client/src/View/SignIn.hs | 86 ++++ common/LICENSE | 674 ++++++++++++++++++++++++++++ common/Setup.hs | 2 + common/common.cabal | 41 ++ common/src/Common/Message.hs | 12 + common/src/Common/Message/Key.hs | 152 +++++++ common/src/Common/Message/Lang.hs | 7 + common/src/Common/Message/Translation.hs | 697 +++++++++++++++++++++++++++++ common/src/Common/Model.hs | 18 + common/src/Common/Model/Category.hs | 26 ++ common/src/Common/Model/CreateCategory.hs | 16 + common/src/Common/Model/CreateIncome.hs | 16 + common/src/Common/Model/CreatePayment.hs | 23 + common/src/Common/Model/Currency.hs | 14 + common/src/Common/Model/EditCategory.hs | 19 + common/src/Common/Model/EditIncome.hs | 19 + common/src/Common/Model/EditPayment.hs | 25 ++ common/src/Common/Model/Frequency.hs | 16 + common/src/Common/Model/Income.hs | 29 ++ common/src/Common/Model/Init.hs | 28 ++ common/src/Common/Model/InitResult.hs | 19 + common/src/Common/Model/Payment.hs | 33 ++ common/src/Common/Model/PaymentCategory.hs | 27 ++ common/src/Common/Model/SignIn.hs | 16 + common/src/Common/Model/User.hs | 29 ++ common/src/Common/Util/Text.hs | 41 ++ common/src/Common/View/Format.hs | 69 +++ default.nix | 24 + server/LICENSE | 674 ++++++++++++++++++++++++++++ server/Setup.hs | 2 + server/server.cabal | 47 ++ server/src/Conf.hs | 39 ++ server/src/Controller/Category.hs | 53 +++ server/src/Controller/Income.hs | 48 ++ server/src/Controller/Index.hs | 86 ++++ server/src/Controller/Payment.hs | 58 +++ server/src/Controller/SignIn.hs | 47 ++ server/src/Cookie.hs | 56 +++ server/src/Design/Color.hs | 35 ++ server/src/Design/Constants.hs | 27 ++ server/src/Design/Dialog.hs | 24 + server/src/Design/Errors.hs | 55 +++ server/src/Design/Form.hs | 130 ++++++ server/src/Design/Global.hs | 75 ++++ server/src/Design/Helper.hs | 90 ++++ server/src/Design/Media.hs | 36 ++ server/src/Design/Tooltip.hs | 16 + server/src/Design/View/Header.hs | 78 ++++ server/src/Design/View/Payment.hs | 17 + server/src/Design/View/Payment/Header.hs | 84 ++++ server/src/Design/View/Payment/Pages.hs | 54 +++ server/src/Design/View/Payment/Table.hs | 42 ++ server/src/Design/View/SignIn.hs | 42 ++ server/src/Design/View/Stat.hs | 15 + server/src/Design/View/Table.hs | 84 ++++ server/src/Design/Views.hs | 49 ++ server/src/Job/Daemon.hs | 36 ++ server/src/Job/Frequency.hs | 13 + server/src/Job/Kind.hs | 22 + server/src/Job/Model.hs | 47 ++ server/src/Job/MonthlyPayment.hs | 26 ++ server/src/Job/WeeklyReport.hs | 28 ++ server/src/Json.hs | 19 + server/src/LoginSession.hs | 53 +++ server/src/Main.hs | 79 ++++ server/src/MimeMail.hs | 672 +++++++++++++++++++++++++++ server/src/Model/Category.hs | 79 ++++ server/src/Model/Frequency.hs | 22 + server/src/Model/Income.hs | 97 ++++ server/src/Model/Init.hs | 27 ++ server/src/Model/Mail.hs | 12 + server/src/Model/Payer.hs | 216 +++++++++ server/src/Model/Payment.hs | 175 ++++++++ server/src/Model/PaymentCategory.hs | 62 +++ server/src/Model/Query.hs | 32 ++ server/src/Model/SignIn.hs | 66 +++ server/src/Model/UUID.hs | 10 + server/src/Model/User.hs | 49 ++ server/src/Resource.hs | 54 +++ server/src/Secure.hs | 47 ++ server/src/SendMail.hs | 44 ++ server/src/Utils/Time.hs | 25 ++ server/src/Validation.hs | 23 + server/src/View/Mail/SignIn.hs | 24 + server/src/View/Mail/WeeklyReport.hs | 102 +++++ server/src/View/Page.hs | 43 ++ sharedCost.cabal | 104 ----- shell.nix | 17 - src/client/Common | 1 - src/client/Component/Button.hs | 53 --- src/client/Component/Input.hs | 34 -- src/client/Debug.hs | 17 - src/client/Icon.hs | 44 -- src/client/Main.hs | 41 -- src/client/View/App.hs | 44 -- src/client/View/Header.hs | 86 ---- src/client/View/Payment.hs | 33 -- src/client/View/Payment/Table.hs | 90 ---- src/client/View/SignIn.hs | 86 ---- src/common/Message.hs | 12 - src/common/Message/Key.hs | 152 ------- src/common/Message/Lang.hs | 7 - src/common/Message/Translation.hs | 697 ----------------------------- src/common/Model.hs | 40 -- src/common/Model/Category.hs | 26 -- src/common/Model/CreateCategory.hs | 16 - src/common/Model/CreateIncome.hs | 16 - src/common/Model/CreatePayment.hs | 23 - src/common/Model/Currency.hs | 14 - src/common/Model/EditCategory.hs | 19 - src/common/Model/EditIncome.hs | 19 - src/common/Model/EditPayment.hs | 25 -- src/common/Model/Frequency.hs | 16 - src/common/Model/Income.hs | 29 -- src/common/Model/Init.hs | 28 -- src/common/Model/InitResult.hs | 19 - src/common/Model/Payment.hs | 33 -- src/common/Model/PaymentCategory.hs | 27 -- src/common/Model/SignIn.hs | 16 - src/common/Model/User.hs | 29 -- src/common/Util/Text.hs | 41 -- src/common/View/Format.hs | 69 --- src/migrations/1.sql | 65 --- src/migrations/2.sql | 23 - src/server/Common | 1 - src/server/Conf.hs | 39 -- src/server/Controller/Category.hs | 55 --- src/server/Controller/Income.hs | 48 -- src/server/Controller/Index.hs | 86 ---- src/server/Controller/Payment.hs | 60 --- src/server/Controller/SignIn.hs | 47 -- src/server/Cookie.hs | 56 --- src/server/Design/Color.hs | 35 -- src/server/Design/Constants.hs | 27 -- src/server/Design/Dialog.hs | 24 - src/server/Design/Errors.hs | 55 --- src/server/Design/Form.hs | 130 ------ src/server/Design/Global.hs | 75 ---- src/server/Design/Helper.hs | 90 ---- src/server/Design/Media.hs | 36 -- src/server/Design/Tooltip.hs | 16 - src/server/Design/View/Header.hs | 78 ---- src/server/Design/View/Payment.hs | 17 - src/server/Design/View/Payment/Header.hs | 84 ---- src/server/Design/View/Payment/Pages.hs | 54 --- src/server/Design/View/Payment/Table.hs | 42 -- src/server/Design/View/SignIn.hs | 42 -- src/server/Design/View/Stat.hs | 15 - src/server/Design/View/Table.hs | 84 ---- src/server/Design/Views.hs | 49 -- src/server/Job/Daemon.hs | 36 -- src/server/Job/Frequency.hs | 13 - src/server/Job/Kind.hs | 22 - src/server/Job/Model.hs | 47 -- src/server/Job/MonthlyPayment.hs | 26 -- src/server/Job/WeeklyReport.hs | 28 -- src/server/Json.hs | 19 - src/server/LoginSession.hs | 53 --- src/server/Main.hs | 79 ---- src/server/MimeMail.hs | 672 --------------------------- src/server/Model/Category.hs | 79 ---- src/server/Model/Frequency.hs | 22 - src/server/Model/Income.hs | 97 ---- src/server/Model/Init.hs | 27 -- src/server/Model/Mail.hs | 12 - src/server/Model/Payer.hs | 216 --------- src/server/Model/Payment.hs | 178 -------- src/server/Model/PaymentCategory.hs | 62 --- src/server/Model/Query.hs | 32 -- src/server/Model/SignIn.hs | 66 --- src/server/Model/UUID.hs | 10 - src/server/Model/User.hs | 49 -- src/server/Resource.hs | 54 --- src/server/Secure.hs | 47 -- src/server/SendMail.hs | 44 -- src/server/Utils/Time.hs | 25 -- src/server/Validation.hs | 23 - src/server/View/Mail/SignIn.hs | 24 - src/server/View/Mail/WeeklyReport.hs | 102 ----- src/server/View/Page.hs | 43 -- tools.nix | 12 + 198 files changed, 7620 insertions(+), 6376 deletions(-) delete mode 100644 LICENSE create mode 100644 cabal-client.project create mode 100644 cabal-server.project create mode 100644 client/LICENSE create mode 100644 client/Setup.hs create mode 100644 client/client.cabal create mode 100644 client/src/Component/Button.hs create mode 100644 client/src/Component/Input.hs create mode 100644 client/src/Icon.hs create mode 100644 client/src/Main.hs create mode 100644 client/src/View/App.hs create mode 100644 client/src/View/Header.hs create mode 100644 client/src/View/Payment.hs create mode 100644 client/src/View/Payment/Table.hs create mode 100644 client/src/View/SignIn.hs create mode 100644 common/LICENSE create mode 100644 common/Setup.hs create mode 100644 common/common.cabal create mode 100644 common/src/Common/Message.hs create mode 100644 common/src/Common/Message/Key.hs create mode 100644 common/src/Common/Message/Lang.hs create mode 100644 common/src/Common/Message/Translation.hs create mode 100644 common/src/Common/Model.hs create mode 100644 common/src/Common/Model/Category.hs create mode 100644 common/src/Common/Model/CreateCategory.hs create mode 100644 common/src/Common/Model/CreateIncome.hs create mode 100644 common/src/Common/Model/CreatePayment.hs create mode 100644 common/src/Common/Model/Currency.hs create mode 100644 common/src/Common/Model/EditCategory.hs create mode 100644 common/src/Common/Model/EditIncome.hs create mode 100644 common/src/Common/Model/EditPayment.hs create mode 100644 common/src/Common/Model/Frequency.hs create mode 100644 common/src/Common/Model/Income.hs create mode 100644 common/src/Common/Model/Init.hs create mode 100644 common/src/Common/Model/InitResult.hs create mode 100644 common/src/Common/Model/Payment.hs create mode 100644 common/src/Common/Model/PaymentCategory.hs create mode 100644 common/src/Common/Model/SignIn.hs create mode 100644 common/src/Common/Model/User.hs create mode 100644 common/src/Common/Util/Text.hs create mode 100644 common/src/Common/View/Format.hs create mode 100644 default.nix create mode 100644 server/LICENSE create mode 100644 server/Setup.hs create mode 100644 server/server.cabal create mode 100644 server/src/Conf.hs create mode 100644 server/src/Controller/Category.hs create mode 100644 server/src/Controller/Income.hs create mode 100644 server/src/Controller/Index.hs create mode 100644 server/src/Controller/Payment.hs create mode 100644 server/src/Controller/SignIn.hs create mode 100644 server/src/Cookie.hs create mode 100644 server/src/Design/Color.hs create mode 100644 server/src/Design/Constants.hs create mode 100644 server/src/Design/Dialog.hs create mode 100644 server/src/Design/Errors.hs create mode 100644 server/src/Design/Form.hs create mode 100644 server/src/Design/Global.hs create mode 100644 server/src/Design/Helper.hs create mode 100644 server/src/Design/Media.hs create mode 100644 server/src/Design/Tooltip.hs create mode 100644 server/src/Design/View/Header.hs create mode 100644 server/src/Design/View/Payment.hs create mode 100644 server/src/Design/View/Payment/Header.hs create mode 100644 server/src/Design/View/Payment/Pages.hs create mode 100644 server/src/Design/View/Payment/Table.hs create mode 100644 server/src/Design/View/SignIn.hs create mode 100644 server/src/Design/View/Stat.hs create mode 100644 server/src/Design/View/Table.hs create mode 100644 server/src/Design/Views.hs create mode 100644 server/src/Job/Daemon.hs create mode 100644 server/src/Job/Frequency.hs create mode 100644 server/src/Job/Kind.hs create mode 100644 server/src/Job/Model.hs create mode 100644 server/src/Job/MonthlyPayment.hs create mode 100644 server/src/Job/WeeklyReport.hs create mode 100644 server/src/Json.hs create mode 100644 server/src/LoginSession.hs create mode 100644 server/src/Main.hs create mode 100644 server/src/MimeMail.hs create mode 100644 server/src/Model/Category.hs create mode 100644 server/src/Model/Frequency.hs create mode 100644 server/src/Model/Income.hs create mode 100644 server/src/Model/Init.hs create mode 100644 server/src/Model/Mail.hs create mode 100644 server/src/Model/Payer.hs create mode 100644 server/src/Model/Payment.hs create mode 100644 server/src/Model/PaymentCategory.hs create mode 100644 server/src/Model/Query.hs create mode 100644 server/src/Model/SignIn.hs create mode 100644 server/src/Model/UUID.hs create mode 100644 server/src/Model/User.hs create mode 100644 server/src/Resource.hs create mode 100644 server/src/Secure.hs create mode 100644 server/src/SendMail.hs create mode 100644 server/src/Utils/Time.hs create mode 100644 server/src/Validation.hs create mode 100644 server/src/View/Mail/SignIn.hs create mode 100644 server/src/View/Mail/WeeklyReport.hs create mode 100644 server/src/View/Page.hs delete mode 100644 sharedCost.cabal delete mode 100644 shell.nix delete mode 120000 src/client/Common delete mode 100644 src/client/Component/Button.hs delete mode 100644 src/client/Component/Input.hs delete mode 100644 src/client/Debug.hs delete mode 100644 src/client/Icon.hs delete mode 100644 src/client/Main.hs delete mode 100644 src/client/View/App.hs delete mode 100644 src/client/View/Header.hs delete mode 100644 src/client/View/Payment.hs delete mode 100644 src/client/View/Payment/Table.hs delete mode 100644 src/client/View/SignIn.hs delete mode 100644 src/common/Message.hs delete mode 100644 src/common/Message/Key.hs delete mode 100644 src/common/Message/Lang.hs delete mode 100644 src/common/Message/Translation.hs delete mode 100644 src/common/Model.hs delete mode 100644 src/common/Model/Category.hs delete mode 100644 src/common/Model/CreateCategory.hs delete mode 100644 src/common/Model/CreateIncome.hs delete mode 100644 src/common/Model/CreatePayment.hs delete mode 100644 src/common/Model/Currency.hs delete mode 100644 src/common/Model/EditCategory.hs delete mode 100644 src/common/Model/EditIncome.hs delete mode 100644 src/common/Model/EditPayment.hs delete mode 100644 src/common/Model/Frequency.hs delete mode 100644 src/common/Model/Income.hs delete mode 100644 src/common/Model/Init.hs delete mode 100644 src/common/Model/InitResult.hs delete mode 100644 src/common/Model/Payment.hs delete mode 100644 src/common/Model/PaymentCategory.hs delete mode 100644 src/common/Model/SignIn.hs delete mode 100644 src/common/Model/User.hs delete mode 100644 src/common/Util/Text.hs delete mode 100644 src/common/View/Format.hs delete mode 100644 src/migrations/1.sql delete mode 100644 src/migrations/2.sql delete mode 120000 src/server/Common delete mode 100644 src/server/Conf.hs delete mode 100644 src/server/Controller/Category.hs delete mode 100644 src/server/Controller/Income.hs delete mode 100644 src/server/Controller/Index.hs delete mode 100644 src/server/Controller/Payment.hs delete mode 100644 src/server/Controller/SignIn.hs delete mode 100644 src/server/Cookie.hs delete mode 100644 src/server/Design/Color.hs delete mode 100644 src/server/Design/Constants.hs delete mode 100644 src/server/Design/Dialog.hs delete mode 100644 src/server/Design/Errors.hs delete mode 100644 src/server/Design/Form.hs delete mode 100644 src/server/Design/Global.hs delete mode 100644 src/server/Design/Helper.hs delete mode 100644 src/server/Design/Media.hs delete mode 100644 src/server/Design/Tooltip.hs delete mode 100644 src/server/Design/View/Header.hs delete mode 100644 src/server/Design/View/Payment.hs delete mode 100644 src/server/Design/View/Payment/Header.hs delete mode 100644 src/server/Design/View/Payment/Pages.hs delete mode 100644 src/server/Design/View/Payment/Table.hs delete mode 100644 src/server/Design/View/SignIn.hs delete mode 100644 src/server/Design/View/Stat.hs delete mode 100644 src/server/Design/View/Table.hs delete mode 100644 src/server/Design/Views.hs delete mode 100644 src/server/Job/Daemon.hs delete mode 100644 src/server/Job/Frequency.hs delete mode 100644 src/server/Job/Kind.hs delete mode 100644 src/server/Job/Model.hs delete mode 100644 src/server/Job/MonthlyPayment.hs delete mode 100644 src/server/Job/WeeklyReport.hs delete mode 100644 src/server/Json.hs delete mode 100644 src/server/LoginSession.hs delete mode 100644 src/server/Main.hs delete mode 100644 src/server/MimeMail.hs delete mode 100644 src/server/Model/Category.hs delete mode 100644 src/server/Model/Frequency.hs delete mode 100644 src/server/Model/Income.hs delete mode 100644 src/server/Model/Init.hs delete mode 100644 src/server/Model/Mail.hs delete mode 100644 src/server/Model/Payer.hs delete mode 100644 src/server/Model/Payment.hs delete mode 100644 src/server/Model/PaymentCategory.hs delete mode 100644 src/server/Model/Query.hs delete mode 100644 src/server/Model/SignIn.hs delete mode 100644 src/server/Model/UUID.hs delete mode 100644 src/server/Model/User.hs delete mode 100644 src/server/Resource.hs delete mode 100644 src/server/Secure.hs delete mode 100644 src/server/SendMail.hs delete mode 100644 src/server/Utils/Time.hs delete mode 100644 src/server/Validation.hs delete mode 100644 src/server/View/Mail/SignIn.hs delete mode 100644 src/server/View/Mail/WeeklyReport.hs delete mode 100644 src/server/View/Page.hs create mode 100644 tools.nix diff --git a/.gitignore b/.gitignore index 0650382..22c4f7e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,14 +1,8 @@ database database-shm database-wal -dist -sharedCost.nix +dist-server +dist-client public/javascript/main.js sessionKey local.conf -reflex-platform/ -*.js_hi -*.js_dyn_hi -*.js_o -*.js_dyn_o -Main.jsexe diff --git a/.tmuxinator.yml b/.tmuxinator.yml index d8b97c5..86612fb 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -5,7 +5,7 @@ windows: layout: 3747,239x59,0,0{144x59,0,0,0,94x59,145,0[94x30,145,0,1,94x28,145,31,2]} panes: - # Empty - - make install-client watch-client - - make install-server watch-server + - make watch-client + - make watch-server - db: - sqlite3 database diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 45644ff..0000000 --- a/LICENSE +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -. diff --git a/Makefile b/Makefile index 5d695f2..c8bb7ce 100644 --- a/Makefile +++ b/Makefile @@ -1,50 +1,49 @@ start: - @nix-shell --command "tmuxinator local" + @nix-shell tools.nix --command "tmuxinator local" stop: @tmux kill-session -t sharedCost dist: - @nix-shell --command "make clean install build" + @nix-shell tools.nix --command "make clean install build" -clean: clean-server clean-client -install: install-server install-client -build: build-server build-client +clean: clean-client clean-server +install: install-client install-server +build: build-client build-server -# Server +# Client # ------ -clean-server: - @cabal clean +build-client: + @nix-shell -A shells.ghcjs --run "build-client-inside" -install-server: - @cabal2nix --shell . > sharedCost.nix +build-client-inside: + @cabal --project-file=cabal-client.project --builddir=dist-client new-build all && make cp-client -build-server: - @nix-shell sharedCost.nix --command "cabal build" +cp-client: + @cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js -launch-server: - @killall sharedCost || : - @cabal run sharedCost +clean-client: + @rm -rf dist-client -watch-server: - @nodemon --watch src/server -e hs,conf --exec '(clear && make build-server && make launch-server) || :' +watch-client: + @nix-shell -A shells.ghcjs --run "nodemon --watch client --watch common --ext hs --exec '(clear && make build-client-inside) || true'" -# Client +# Server # ------ -clean-client: - @rm -rf reflex-platform +clean-server: + @rm -rf dist-server -install-client: - @git clone https://github.com/reflex-frp/reflex-platform 2>/dev/null || : - @cd reflex-platform && ./try-reflex --command exit >/dev/null +build-server: + @nix-shell -A shells.ghc --run "make build-server-inside" -build-client-inside: - @cd src/client && ghcjs -Wall -Werror --make Main && mv Main.jsexe/all.js ../../public/javascript/main.js +build-server-inside: + @cabal --project-file=cabal-server.project --builddir=dist-server new-build all -build-client: - @./reflex-platform/try-reflex --command "make build-client-inside" +run-server: + @(killall sharedCost &>/dev/null) || : + @./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server -watch-client: - @./reflex-platform/try-reflex --command "nodemon --watch src/client -e hs --exec '(clear && make build-client-inside) || true'" +watch-server: + @nix-shell -A shells.ghc --run "nodemon --watch server --watch common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" diff --git a/cabal-client.project b/cabal-client.project new file mode 100644 index 0000000..182ead2 --- /dev/null +++ b/cabal-client.project @@ -0,0 +1,4 @@ +compiler: ghcjs +packages: + common/ + client/ diff --git a/cabal-server.project b/cabal-server.project new file mode 100644 index 0000000..0ce5568 --- /dev/null +++ b/cabal-server.project @@ -0,0 +1,3 @@ +packages: + common/ + server/ diff --git a/client/LICENSE b/client/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/client/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/client/Setup.hs b/client/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/client/client.cabal b/client/client.cabal new file mode 100644 index 0000000..7807d37 --- /dev/null +++ b/client/client.cabal @@ -0,0 +1,24 @@ +name: client +version: 0.0.1 +license: GPL-3 +license-file: LICENSE +author: Joris Guyonvarch +maintainer: joris@guyonvarch.me +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable client + main-is: Main.hs + ghc-options: -Wall -Werror + build-depends: aeson + , base >=4.9 && <4.11 + , bytestring + , common + , containers + , ghcjs-dom-jsffi + , reflex-dom + , text + , time + hs-source-dirs: src + default-language: Haskell2010 diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs new file mode 100644 index 0000000..f21798c --- /dev/null +++ b/client/src/Component/Button.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Button + ( ButtonIn(..) + , buttonInDefault + , ButtonOut(..) + , button + ) where + +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Icon + +data ButtonIn t m = ButtonIn + { _buttonIn_class :: Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + } + +buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault = ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.blank + , _buttonIn_waiting = R.never + } + +data ButtonOut t = ButtonOut + { _buttonOut_clic :: Event t () + } + +button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) +button buttonIn = do + attr <- R.holdDyn + (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) + (fmap + (\w -> M.fromList $ + [ ("type", "button") ] + <> if w + then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] + else [("class", _buttonIn_class buttonIn)]) + (_buttonIn_waiting buttonIn)) + (e, _) <- R.elDynAttr' "button" attr $ do + Icon.loading + R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut + { _buttonOut_clic = R.domEvent R.Click e + } diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs new file mode 100644 index 0000000..7111630 --- /dev/null +++ b/client/src/Component/Input.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Component.Input + ( InputIn(..) + , InputOut(..) + , input + ) where + +import Data.Text (Text) +import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import qualified Reflex.Dom as R + +data InputIn t a b = InputIn + { _inputIn_reset :: Event t a + , _inputIn_placeHolder :: Text + } + +data InputOut t = InputOut + { _inputOut_value :: Dynamic t Text + , _inputOut_enter :: Event t () + } + +input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) +input inputIn = do + let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) + let value = fmap (const "") (_inputIn_reset inputIn) + textInput <- R.textInput $ R.def & R.attributes .~ placeHolder + & R.setValue .~ value + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + return $ InputOut + { _inputOut_value = R._textInput_value textInput + , _inputOut_enter = enter + } diff --git a/client/src/Icon.hs b/client/src/Icon.hs new file mode 100644 index 0000000..7223def --- /dev/null +++ b/client/src/Icon.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +module Icon + ( loading + , signOut + , clone + , edit + , delete + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/Main.hs b/client/src/Main.hs new file mode 100644 index 0000000..1f167d4 --- /dev/null +++ b/client/src/Main.hs @@ -0,0 +1,40 @@ +module Main + ( main + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import Data.JSString.Text (textFromJSString) +import qualified Data.Text.Encoding as T +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.NonElementParentNode as Dom +import GHCJS.DOM.Types (JSM, Element, JSString) +import Prelude hiding (init, error) + +import Common.Model (InitResult(InitEmpty)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import qualified View.App as App + +main :: JSM () +main = do + initResult <- readInit + App.widget initResult + +readInit :: JSM InitResult +readInit = do + document <- Dom.currentDocumentUnchecked + initNode <- Dom.getElementById document "init" + case initNode of + Just node -> do + text <- textFromJSString <$> js_getInnerText node + return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of + Just init -> init + Nothing -> initParseError + _ -> + return initParseError + where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + +foreign import javascript unsafe "$1[\"innerText\"]" + js_getInnerText :: Element -> IO JSString diff --git a/client/src/View/App.hs b/client/src/View/App.hs new file mode 100644 index 0000000..1466811 --- /dev/null +++ b/client/src/View/App.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.App + ( widget + ) where + +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import Common.Model (InitResult(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key + +import View.Header (HeaderIn(..)) +import View.Payment (PaymentIn(..)) +import qualified View.Header as Header +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn + +widget :: InitResult -> IO () +widget initResult = + R.mainWidget $ do + headerOut <- Header.view $ HeaderIn + { _headerIn_initResult = initResult + } + + let signOut = Header._headerOut_signOut headerOut + + initialContent = case initResult of + InitSuccess initSuccess -> do + _ <- Payment.widget $ PaymentIn + { _paymentIn_init = initSuccess + } + return () + InitEmpty result -> + SignIn.view result + + signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + + _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + + R.blank diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs new file mode 100644 index 0000000..705e054 --- /dev/null +++ b/client/src/View/Header.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Header + ( view + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R +import Prelude hiding (init, error) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), Init(..), User(..)) +import qualified Common.Model as CM + +import Component.Button (ButtonIn(..)) +import qualified Component.Button as Component +import qualified Icon + +data HeaderIn = HeaderIn + { _headerIn_initResult :: InitResult + } + +data HeaderOut t = HeaderOut + { _headerOut_signOut :: Event t () + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view headerIn = + R.el "header" $ do + + R.divClass "title" $ + R.text $ Message.get Key.App_Title + + signOut <- nameSignOut $ _headerIn_initResult headerIn + + return $ HeaderOut + { _headerOut_signOut = signOut + } + +nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) +nameSignOut initResult = case initResult of + (InitSuccess init) -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case CM.findUser (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never + +signOutButton :: forall t m. MonadWidget t m => m (Event t ()) +signOutButton = do + rec + signOut <- Component.button $ ButtonIn + { Component._buttonIn_class = "signOut item" + , Component._buttonIn_content = Icon.signOut + , Component._buttonIn_waiting = waiting + } + let signOutClic = Component._buttonOut_clic signOut + waiting = R.leftmost + [ fmap (const True) signOutClic + , fmap (const False) signOutSuccess + ] + signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) + + return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess + + where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) + askSignOut signOut = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + getResult = (== 200) . R._xhrResponse_status diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs new file mode 100644 index 0000000..e80790b --- /dev/null +++ b/client/src/View/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment + ( widget + , PaymentIn(..) + , PaymentOut(..) + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init) + +import View.Payment.Table (TableIn(..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +data PaymentOut = PaymentOut + { + } + +widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget paymentIn = do + R.divClass "payment" $ do + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + } + return $ PaymentOut {} diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs new file mode 100644 index 0000000..f3eb9a7 --- /dev/null +++ b/client/src/View/Payment/Table.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Table + ( widget + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List as L +import qualified Data.Map as M +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format + +import qualified Icon + +data TableIn = TableIn + { _tableIn_init :: Init + } + +data TableOut = TableOut + { + } + +widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +widget tableIn = do + R.divClass "table" $ + R.divClass "lines" $ do + R.divClass "header" $ do + R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name + R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost + R.divClass "cell user" $ R.text $ Message.get Key.Payment_User + R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category + R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank + let init = _tableIn_init tableIn + payments = _init_payments init + mapM_ + (paymentRow init) + (take 8 . reverse . L.sortOn _payment_date $ payments) + return $ TableOut {} + +paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow init payment = + R.divClass "row" $ do + R.divClass "cell name" . R.text $ _payment_name payment + R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell user" $ + case CM.findUser (_payment_user payment) (_init_users init) of + Just user -> R.text (_user_name user) + _ -> R.blank + R.divClass "cell category" $ + case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of + Just category -> + R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ + R.text $ _category_name category + _ -> + R.blank + R.divClass "cell date" $ do + R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) + R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.divClass "cell button" . R.el "button" $ Icon.clone + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.edit + else R.blank + R.divClass "cell button" $ + if _payment_user payment == (_init_currentUser init) + then R.el "button" $ Icon.delete + else R.blank + +findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category +findCategory categories paymentCategories paymentName = do + paymentCategory <- L.find + ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + paymentCategories + L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs new file mode 100644 index 0000000..e164ee7 --- /dev/null +++ b/client/src/View/SignIn.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.SignIn + ( view + ) where + +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (MonadWidget, Event) +import qualified Reflex.Dom as R + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(SignIn)) + +import Component.Input (InputIn(..), InputOut(..)) +import Component.Button (ButtonIn(..), ButtonOut(..)) +import qualified Component.Button as Component +import qualified Component.Input as Component + +view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () +view result = + R.divClass "signIn" $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + } + + let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button + + dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ + [ fmap (const True) userWantsEmailValidation + , fmap (const False) signInResult + ] + + uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail + + let validatedEmail = R.tagPromptlyDyn + (_inputOut_value input) + (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) + + let waiting = R.leftmost + [ fmap (const True) validatedEmail + , fmap (const False) signInResult + ] + + button <- Component.button $ ButtonIn + { _buttonIn_class = "" + , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_waiting = waiting + } + + signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) + + showSignInResult result signInResult + +askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) +askSignIn email = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + getResult response = + case R._xhrResponse_responseText response of + Just key -> + if R._xhrResponse_status response == 200 then Right key else Left key + _ -> Left "NoKey" + +showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () +showSignInResult result signInResult = do + _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult + R.blank + + where showInitResult (Left error) = showError error + showInitResult (Right (Just success)) = showSuccess success + showInitResult (Right Nothing) = R.blank + + showResult (Left error) = showError error + showResult (Right success) = showSuccess success + + showError = R.divClass "error" . R.text + showSuccess = R.divClass "success" . R.text diff --git a/common/LICENSE b/common/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/common/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/common/Setup.hs b/common/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/common/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/common/common.cabal b/common/common.cabal new file mode 100644 index 0000000..e072acf --- /dev/null +++ b/common/common.cabal @@ -0,0 +1,41 @@ +name: common +version: 0.0.1 +license: GPL-3 +license-file: LICENSE +author: Joris Guyonvarch +maintainer: joris@guyonvarch.me +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + ghc-options: -Wall -Werror + exposed-modules: Common.Message + , Common.Message.Key + , Common.Model + , Common.Util.Text + , Common.View.Format + other-modules: Common.Message.Lang + , Common.Message.Translation + , Common.Model.PaymentCategory + , Common.Model.CreateCategory + , Common.Model.CreatePayment + , Common.Model.CreateIncome + , Common.Model.EditCategory + , Common.Model.EditPayment + , Common.Model.InitResult + , Common.Model.EditIncome + , Common.Model.Frequency + , Common.Model.Currency + , Common.Model.Category + , Common.Model.Payment + , Common.Model.Income + , Common.Model.SignIn + , Common.Model.Init + , Common.Model.User + build-depends: aeson + , base >=4.9 && <4.11 + , text + , time + hs-source-dirs: src + default-language: Haskell2010 diff --git a/common/src/Common/Message.hs b/common/src/Common/Message.hs new file mode 100644 index 0000000..9ae735d --- /dev/null +++ b/common/src/Common/Message.hs @@ -0,0 +1,12 @@ +module Common.Message + ( get + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key) +import Common.Message.Lang (Lang(..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs new file mode 100644 index 0000000..4127808 --- /dev/null +++ b/common/src/Common/Message/Key.hs @@ -0,0 +1,152 @@ +module Common.Message.Key + ( Key(..) + ) where + +import Data.Text + +data Key = + + App_Title + + | Category_Add + | Category_Clone + | Category_Color + | Category_DeleteConfirm + | Category_Edit + | Category_Empty + | Category_Name + | Category_NotDeleted + | Category_Title + | Category_Used + + | Date_Long Int Text Int + | Date_Short Int Int Int + | Date_ShortMonthAndYear Int Int + + | Dialog_Confirm + | Dialog_Undo + + | Error_CategoryCreate + | Error_CategoryDelete + | Error_CategoryEdit + | Error_IncomeCreate + | Error_IncomeDelete + | Error_IncomeEdit + | Error_PaymentCreate + | Error_PaymentDelete + | Error_PaymentEdit + | Error_SignOut + + | Form_AlreadyExists + | Form_CostMustNotBeNull + | Form_Empty + | Form_GreaterIntThan Int + | Form_InvalidCategory + | Form_InvalidColor + | Form_InvalidDate + | Form_InvalidInt + | Form_InvalidString + | Form_SmallerIntThan Int + + | HttpError_BadPayload + | HttpError_BadUrl + | HttpError_NetworkError + | HttpError_Timeout + + | Income_AddLong + | Income_AddShort + | Income_Amount + | Income_Clone + | Income_CumulativeSince Text + | Income_Date + | Income_DeleteConfirm + | Income_Edit + | Income_Empty + | Income_MonthlyNet + | Income_NotDeleted + | Income_Title + + | Month_January + | Month_February + | Month_March + | Month_April + | Month_May + | Month_June + | Month_July + | Month_August + | Month_September + | Month_October + | Month_November + | Month_December + + | PageNotFound_Title + + | Payment_Add + | Payment_Balanced + | Payment_Category + | Payment_CloneLong + | Payment_CloneShort + | Payment_Cost + | Payment_Date + | Payment_Delete + | Payment_DeleteConfirm + | Payment_EditLong + | Payment_EditShort + | Payment_Empty + | Payment_Frequency + | Payment_InvalidFrequency + | Payment_Many + | Payment_MonthlyFemale + | Payment_MonthlyMale + | Payment_Name + | Payment_NotDeleted + | Payment_One + | Payment_PunctualFemale + | Payment_PunctualMale + | Payment_Title + | Payment_User + | Payment_Worth Text Text + + | Search_Monthly + | Search_Name + | Search_Punctual + + | Secure_Forbidden + | Secure_Unauthorized + + | SignIn_Button + | SignIn_DisconnectSuccess + | SignIn_EmailInvalid + | SignIn_EmailPlaceholder + | SignIn_EmailSendFail + | SignIn_EmailSent + | SignIn_LinkExpired + | SignIn_LinkInvalid + | SignIn_LinkUsed + | SignIn_MailTitle + | SignIn_MailBody Text Text + | SignIn_ParseError + + | Statistic_Title + | Statistic_ByMonthsAndMean Text + | Statistic_By Text Text + | Statistic_Total + + | WeeklyReport_Empty + | WeeklyReport_IncomesCreated Int + | WeeklyReport_IncomesDeleted Int + | WeeklyReport_IncomesEdited Int + | WeeklyReport_IncomeCreated Int + | WeeklyReport_IncomeDeleted Int + | WeeklyReport_IncomeEdited Int + | WeeklyReport_PayedFor Text Text Text Text + | WeeklyReport_PayedForNot Text Text Text Text + | WeeklyReport_PayedFrom Text Text Text + | WeeklyReport_PayedFromNot Text Text Text + | WeeklyReport_PaymentsCreated Int + | WeeklyReport_PaymentsDeleted Int + | WeeklyReport_PaymentsEdited Int + | WeeklyReport_PaymentCreated Int + | WeeklyReport_PaymentDeleted Int + | WeeklyReport_PaymentEdited Int + | WeeklyReport_Title diff --git a/common/src/Common/Message/Lang.hs b/common/src/Common/Message/Lang.hs new file mode 100644 index 0000000..0a32ede --- /dev/null +++ b/common/src/Common/Message/Lang.hs @@ -0,0 +1,7 @@ +module Common.Message.Lang + ( Lang(..) + ) where + +data Lang = + English + | French diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs new file mode 100644 index 0000000..900a9e9 --- /dev/null +++ b/common/src/Common/Message/Translation.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.Message.Translation + ( get + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Common.Message.Key +import Common.Message.Lang (Lang(..)) + +get :: Lang -> Key -> Text +get = m + +m :: Lang -> Key -> Text + +m l App_Title = + case l of + English -> "Shared Cost" + French -> "Partage des frais" + +m l Category_Add = + case l of + English -> "Add an category" + French -> "Ajouter une catégorie" + +m l Category_Clone = + case l of + English -> "Clone an category" + French -> "Cloner une catégorie" + +m l Category_Color = + case l of + English -> "Color" + French -> "Couleur" + +m l Category_DeleteConfirm = + case l of + English -> "Are you sure to delete this category ?" + French -> "Voulez-vous vraiment supprimer cette catégorie ?" + +m l Category_Edit = + case l of + English -> "Edit an category" + French -> "Modifier une catégorie" + +m l Category_Empty = + case l of + English -> "No category." + French -> "Aucune catégorie." + +m l Category_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Category_NotDeleted = + case l of + English -> "The category could not have been deleted." + French -> "La catégorie n’a pas pu être supprimé." + +m l Category_Title = + case l of + English -> "Categories" + French -> "Catégories" + +m l Category_Used = + case l of + English -> "This category is currently being used" + French -> "Cette catégorie est actuellement utilisée" + +m l (Date_Short day month year) = + case l of + English -> + T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] + French -> + T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] + where padded num pad = + let str = show num + in T.pack $ replicate (pad - length str) '0' ++ str + +m l (Date_ShortMonthAndYear month year) = + case l of + English -> + T.intercalate "-" . map (T.pack . show) $ [ year, month ] + French -> + T.intercalate "/" . map (T.pack . show) $ [ month, year ] + +m l (Date_Long day month year) = + case l of + English -> + T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] + French -> + T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] + +m l Dialog_Confirm = + case l of + English -> "Confirm" + French -> "Confirmer" + +m l Dialog_Undo = + case l of + English -> "Undo" + French -> "Annuler" + +m l Error_CategoryCreate = + case l of + English -> "Error at category creation" + French -> "Erreur lors de la création de la catégorie" + +m l Error_CategoryDelete = + case l of + English -> "Error at category deletion" + French -> "Erreur lors de la suppression de la catégorie" + +m l Error_CategoryEdit = + case l of + English -> "Error at category edition" + French -> "Erreur lors de la modification de la catégorie" + +m l Error_IncomeCreate = + case l of + English -> "Error at income creation" + French -> "Erreur lors de la création du revenu" + +m l Error_IncomeDelete = + case l of + English -> "Error at income deletion" + French -> "Erreur lors de la suppression du revenu" + +m l Error_IncomeEdit = + case l of + English -> "Error at income edition" + French -> "Erreur lors de la modification du revenu" + +m l Error_PaymentCreate = + case l of + English -> "Error at payment creation" + French -> "Erreur lors de la création du paiement" + +m l Error_PaymentDelete = + case l of + English -> "Error at payment deletion" + French -> "Erreur lors de la suppression du paiement" + +m l Error_PaymentEdit = + case l of + English -> "Error at payment edition" + French -> "Erreur lors de la modification du paiement" + +m l Error_SignOut = + case l of + English -> "Error at sign out" + French -> "Erreur lors de la déconnexion" + +m l Form_AlreadyExists = + case l of + English -> "Dupplicate field" + French -> "Doublon" + +m l Form_CostMustNotBeNull = + case l of + English -> "Cost must not be zero" + French -> "Le coût ne doît pas être nul" + +m l Form_Empty = + case l of + English -> "Required field" + French -> "Champ requis" + +m l (Form_GreaterIntThan number) = + case l of + English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] + +m l Form_InvalidCategory = + case l of + English -> "Invalid category" + French -> "Catégorie invalide" + +m l Form_InvalidColor = + case l of + English -> "Invalid color" + French -> "Couleur invalide" + +m l Form_InvalidDate = + case l of + English -> "day/month/year required" + French -> "jour/mois/année requis" + +m l Form_InvalidInt = + case l of + English -> "Integer required" + French -> "Entier requis" + +m l Form_InvalidString = + case l of + English -> "String required" + French -> "Chaîne de caractères requise" + +m l (Form_SmallerIntThan number) = + case l of + English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] + French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] + +m l HttpError_BadPayload = + case l of + English -> "Bad payload server error" + French -> "Contenu inattendu en provenance du serveur" + +m l HttpError_BadUrl = + case l of + English -> "URL not valid" + French -> "l’URL n’est pas valide" + +m l HttpError_NetworkError = + case l of + English -> "Network can not be reached" + French -> "Le serveur n’est pas accessible" + +m l HttpError_Timeout = + case l of + English -> "Timeout server error" + French -> "Le serveur met trop de temps à répondre" + +m l Income_AddLong = + case l of + English -> "Add an income" + French -> "Ajouter un revenu" + +m l Income_AddShort = + case l of + English -> "Add" + French -> "Ajouter" + +m l Income_Amount = + case l of + English -> "Amount" + French -> "Montant" + +m l Income_Clone = + case l of + English -> "Clone an income" + French -> "Cloner un revenu" + +m l (Income_CumulativeSince since) = + case l of + English -> T.concat [ "Cumulative incomes since ", since ] + French -> T.concat [ "Revenus nets cumulés depuis le ", since ] + +m l Income_Date = + case l of + English -> "Date" + French -> "Date" + +m l Income_DeleteConfirm = + case l of + English -> "Are you sure to delete this income ?" + French -> "Voulez-vous vraiment supprimer ce revenu ?" + +m l Income_Edit = + case l of + English -> "Edit an income" + French -> "Modifier un revenu" + +m l Income_Empty = + case l of + English -> "No income." + French -> "Aucun revenu." + +m l Income_MonthlyNet = + case l of + English -> "Net monthly incomes" + French -> "Revenus mensuels nets" + +m l Income_NotDeleted = + case l of + English -> "The income could not have been deleted." + French -> "Le revenu n’a pas pu être supprimé." + +m l Income_Title = + case l of + English -> "Income" + French -> "Revenu" + +m l Month_January = + case l of + English -> "january" + French -> "janvier" + +m l Month_February = + case l of + English -> "february" + French -> "février" + +m l Month_March = + case l of + English -> "march" + French -> "mars" + +m l Month_April = + case l of + English -> "april" + French -> "avril" + +m l Month_May = + case l of + English -> "may" + French -> "mai" + +m l Month_June = + case l of + English -> "june" + French -> "juin" + +m l Month_July = + case l of + English -> "july" + French -> "juillet" + +m l Month_August = + case l of + English -> "august" + French -> "août" + +m l Month_September = + case l of + English -> "september" + French -> "septembre" + +m l Month_October = + case l of + English -> "october" + French -> "octobre" + +m l Month_November = + case l of + English -> "november" + French -> "novembre" + +m l Month_December = + case l of + English -> "december" + French -> "décembre" + +m l PageNotFound_Title = + case l of + English -> "Page not found" + French -> "Page introuvable" + +m l Payment_Add = + case l of + English -> "Add a payment" + French -> "Ajouter un paiement" + +m l Payment_Balanced = + case l of + English -> "Payments are balanced." + French -> "Les paiements sont équilibrés." + +m l Payment_Category = + case l of + English -> "Category" + French -> "Catégorie" + +m l Payment_CloneLong = + case l of + English -> "Clone a payment" + French -> "Cloner un paiement" + +m l Payment_CloneShort = + case l of + English -> "Clone" + French -> "Cloner" + +m l Payment_Cost = + case l of + English -> "Cost" + French -> "Coût" + +m l Payment_Date = + case l of + English -> "Date" + French -> "Date" + +m l Payment_Delete = + case l of + English -> "Delete" + French -> "Supprimer" + +m l Payment_DeleteConfirm = + case l of + English -> "Are you sure to delete this payment ?" + French -> "Voulez-vous vraiment supprimer ce paiement ?" + +m l Payment_EditLong = + case l of + English -> "Edit a payment" + French -> "Modifier un paiement" + +m l Payment_EditShort = + case l of + English -> "Edit" + French -> "Modifier" + +m l Payment_Empty = + case l of + English -> "No payment found from your search criteria." + French -> "Aucun paiement ne correspond à vos critères de recherches." + +m l Payment_Frequency = + case l of + English -> "Frequency" + French -> "Fréquence" + +m l Payment_InvalidFrequency = + case l of + English -> "Invalid frequency" + French -> "Fréquence invalide" + +m l Payment_Many = + case l of + English -> "payments" + French -> "paiements" + +m l Payment_MonthlyFemale = + case l of + English -> "Monthly" + French -> "Mensuelle" + +m l Payment_MonthlyMale = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Payment_Name = + case l of + English -> "Name" + French -> "Nom" + +m l Payment_NotDeleted = + case l of + English -> "The payment could not have been deleted." + French -> "Le paiement n’a pas pu être supprimé." + +m l Payment_One = + case l of + English -> "payment" + French -> "paiement" + +m l Payment_PunctualFemale = + case l of + English -> "Punctual" + French -> "Ponctuelle" + +m l Payment_PunctualMale = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Payment_Title = + case l of + English -> "Payments" + French -> "Paiements" + +m l Payment_User = + case l of + English -> "Payer" + French -> "Payeur" + +m l (Payment_Worth subject amount) = + case l of + English -> T.concat [ subject, " worth ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] + +m l Search_Monthly = + case l of + English -> "Monthly" + French -> "Mensuel" + +m l Search_Name = + case l of + English -> "Search" + French -> "Recherche" + +m l Search_Punctual = + case l of + English -> "Punctual" + French -> "Ponctuel" + +m l Secure_Unauthorized = + case l of + English -> "You are not authorized to sign in." + French -> "Tu n’es pas autorisé à te connecter." + +m l Secure_Forbidden = + case l of + English -> "You need to be logged in to perform this action" + French -> "Tu dois te connecter pour effectuer cette action" + +m l SignIn_Button = + case l of + English -> "Sign in" + French -> "Connexion" + +m l SignIn_DisconnectSuccess = + case l of + English -> "You have successfully disconnected" + French -> "Vous êtes à présent déconnecté." + +m l SignIn_EmailInvalid = + case l of + English -> "Your email is not valid." + French -> "Votre courriel n’est pas valide." + +m l SignIn_EmailPlaceholder = + case l of + English -> "Email" + French -> "Courriel" + +m l SignIn_EmailSendFail = + case l of + English -> "You are authorized to sign in, but we failed to send you the sign up email." + French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." + +m l SignIn_EmailSent = + case l of + English -> "We sent you an email with a connexion link." + French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." + +m l SignIn_LinkExpired = + case l of + English -> "The link expired, please sign in again." + French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." + +m l SignIn_LinkInvalid = + case l of + English -> "The link is invalid, please sign in again." + French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." + +m l SignIn_LinkUsed = + case l of + English -> "You already used this link, please sign in again." + French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." + +m l SignIn_MailTitle = + case l of + English -> T.concat [ "Sign in to ", m l App_Title ] + French -> T.concat [ "Connexion à ", m l App_Title ] + +m l (SignIn_MailBody name url) = + T.intercalate + "\n" + ( case l of + English -> + [ T.concat [ "Hi ", name, "," ] + , "" + , T.concat + [ "Click to the following link in order to sign in to Shared Cost:" + , m l App_Title + , ":" + ] + , url + , "" + , "See you soon!" + ] + French -> + [ T.concat [ "Salut ", name, "," ] + , "" + , T.concat + [ "Clique sur le lien suivant pour te connecter à " + , m l App_Title + , ":" + ] + , url + , "" + , "À très vite !" + ] + ) + +m l SignIn_ParseError = + case l of + English -> "Error while reading initial data." + French -> "Erreur lors de la lecture des données initiales." + +m l (Statistic_By key value) = + case l of + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] + +m l (Statistic_ByMonthsAndMean amount) = + case l of + English -> + T.concat [ "Payments by category by month months (", amount, "on average)" ] + French -> + T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] + +m l Statistic_Title = + case l of + English -> "Statistics" + French -> "Statistiques" + +m l Statistic_Total = + case l of + English -> "Total" + French -> "Total" + +m l WeeklyReport_Empty = + case l of + English -> "No activity the previous week." + French -> "Pas d’activité la semaine passée." + +m l (WeeklyReport_IncomesCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes created:" ] + French -> T.concat [ T.pack . show $ count, " revenus créés :" ] + +m l (WeeklyReport_IncomesDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] + +m l (WeeklyReport_IncomesEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " incomes edited:" ] + French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] + +m l (WeeklyReport_IncomeCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " income created:" ] + French -> T.concat [ T.pack . show $ count, " revenu créé :" ] + +m l (WeeklyReport_IncomeDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " income deleted:" ] + French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] + +m l (WeeklyReport_IncomeEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " income edited:" ] + French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] + +m l (WeeklyReport_PayedFor name amount for at) = + case l of + English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedForNot name amount for at) = + case l of + English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] + French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] + +m l (WeeklyReport_PayedFrom name amount for) = + case l of + English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PayedFromNot name amount for) = + case l of + English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] + +m l (WeeklyReport_PaymentsCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments created:" ] + French -> T.concat [ T.pack . show $ count, " paiements créés :" ] + +m l (WeeklyReport_PaymentsDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] + +m l (WeeklyReport_PaymentsEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payments edited:" ] + French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] + +m l (WeeklyReport_PaymentCreated count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment created:" ] + French -> T.concat [ T.pack . show $ count, " paiement créé :" ] + +m l (WeeklyReport_PaymentDeleted count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment deleted:" ] + French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] + +m l (WeeklyReport_PaymentEdited count) = + case l of + English -> T.concat [ T.pack . show $ count, " payment edited:" ] + French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] + +m l WeeklyReport_Title = + case l of + English -> "Weekly report" + French -> "Rapport hebdomadaire" diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs new file mode 100644 index 0000000..80c344b --- /dev/null +++ b/common/src/Common/Model.hs @@ -0,0 +1,18 @@ +module Common.Model (module X) where + +import Common.Model.Category as X +import Common.Model.CreateCategory as X +import Common.Model.CreateIncome as X +import Common.Model.CreatePayment as X +import Common.Model.Currency as X +import Common.Model.EditCategory as X +import Common.Model.EditIncome as X +import Common.Model.EditPayment as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.Init as X +import Common.Model.InitResult as X +import Common.Model.Payment as X +import Common.Model.PaymentCategory as X +import Common.Model.SignIn as X +import Common.Model.User as X diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs new file mode 100644 index 0000000..53a6bdb --- /dev/null +++ b/common/src/Common/Model/Category.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Category + ( CategoryId + , Category(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type CategoryId = Int64 + +data Category = Category + { _category_id :: CategoryId + , _category_name :: Text + , _category_color :: Text + , _category_createdAt :: UTCTime + , _category_editedAt :: Maybe UTCTime + , _category_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Category +instance ToJSON Category diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs new file mode 100644 index 0000000..bfe24c5 --- /dev/null +++ b/common/src/Common/Model/CreateCategory.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategory diff --git a/common/src/Common/Model/CreateIncome.hs b/common/src/Common/Model/CreateIncome.hs new file mode 100644 index 0000000..4ee3a50 --- /dev/null +++ b/common/src/Common/Model/CreateIncome.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +data CreateIncome = CreateIncome + { _createIncome_date :: Day + , _createIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON CreateIncome diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs new file mode 100644 index 0000000..b5b6256 --- /dev/null +++ b/common/src/Common/Model/CreatePayment.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON CreatePayment diff --git a/common/src/Common/Model/Currency.hs b/common/src/Common/Model/Currency.hs new file mode 100644 index 0000000..7c12545 --- /dev/null +++ b/common/src/Common/Model/Currency.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Currency + ( Currency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Currency = Currency Text deriving (Show, Generic) + +instance FromJSON Currency +instance ToJSON Currency diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs new file mode 100644 index 0000000..2a3a697 --- /dev/null +++ b/common/src/Common/Model/EditCategory.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategory diff --git a/common/src/Common/Model/EditIncome.hs b/common/src/Common/Model/EditIncome.hs new file mode 100644 index 0000000..a55c39e --- /dev/null +++ b/common/src/Common/Model/EditIncome.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_date :: Day + , _editIncome_amount :: Int + } deriving (Show, Generic) + +instance FromJSON EditIncome diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs new file mode 100644 index 0000000..172c0c1 --- /dev/null +++ b/common/src/Common/Model/EditPayment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON EditPayment diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs new file mode 100644 index 0000000..7c46605 --- /dev/null +++ b/common/src/Common/Model/Frequency.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Frequency + ( Frequency(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Frequency = + Punctual + | Monthly + deriving (Eq, Read, Show, Generic) + +instance FromJSON Frequency +instance ToJSON Frequency diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs new file mode 100644 index 0000000..280812f --- /dev/null +++ b/common/src/Common/Model/Income.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Income + ( IncomeId + , Income(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +type IncomeId = Int64 + +data Income = Income + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int + , _income_createdAt :: UTCTime + , _income_editedAt :: Maybe UTCTime + , _income_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Income +instance ToJSON Income diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs new file mode 100644 index 0000000..68fcfb8 --- /dev/null +++ b/common/src/Common/Model/Init.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Init + ( Init(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category) +import Common.Model.Currency (Currency) +import Common.Model.Income (Income) +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.User (UserId, User) + +data Init = Init + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] + , _init_paymentCategories :: [PaymentCategory] + , _init_currency :: Currency + } deriving (Show, Generic) + +instance FromJSON Init +instance ToJSON Init diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs new file mode 100644 index 0000000..43c16f9 --- /dev/null +++ b/common/src/Common/Model/InitResult.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.InitResult + ( InitResult(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Init (Init) + +data InitResult = + InitSuccess Init + | InitEmpty (Either Text (Maybe Text)) + deriving (Show, Generic) + +instance FromJSON InitResult +instance ToJSON InitResult diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs new file mode 100644 index 0000000..804b501 --- /dev/null +++ b/common/src/Common/Model/Payment.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.Payment + ( PaymentId + , Payment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Frequency +import Common.Model.User (UserId) + +type PaymentId = Int64 + +data Payment = Payment + { _payment_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day + , _payment_frequency :: Frequency + , _payment_createdAt :: UTCTime + , _payment_editedAt :: Maybe UTCTime + , _payment_deletedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON Payment +instance ToJSON Payment diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs new file mode 100644 index 0000000..a0e94f9 --- /dev/null +++ b/common/src/Common/Model/PaymentCategory.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.PaymentCategory + ( PaymentCategoryId + , PaymentCategory(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +type PaymentCategoryId = Int64 + +data PaymentCategory = PaymentCategory + { _paymentCategory_id :: PaymentCategoryId + , _paymentCategory_name :: Text + , _paymentCategory_category :: CategoryId + , _paymentCategory_createdAt :: UTCTime + , _paymentCategory_editedAt :: Maybe UTCTime + } deriving (Show, Generic) + +instance FromJSON PaymentCategory +instance ToJSON PaymentCategory diff --git a/common/src/Common/Model/SignIn.hs b/common/src/Common/Model/SignIn.hs new file mode 100644 index 0000000..f4da97f --- /dev/null +++ b/common/src/Common/Model/SignIn.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.SignIn + ( SignIn(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data SignIn = SignIn + { _signIn_email :: Text + } deriving (Show, Generic) + +instance FromJSON SignIn +instance ToJSON SignIn diff --git a/common/src/Common/Model/User.hs b/common/src/Common/Model/User.hs new file mode 100644 index 0000000..694c70e --- /dev/null +++ b/common/src/Common/Model/User.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Common.Model.User + ( UserId + , User(..) + , findUser + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.List as L +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) + +type UserId = Int64 + +data User = User + { _user_id :: UserId + , _user_creation :: UTCTime + , _user_email :: Text + , _user_name :: Text + } deriving (Show, Generic) + +instance FromJSON User +instance ToJSON User + +findUser :: UserId -> [User] -> Maybe User +findUser userId users = L.find ((== userId) . _user_id) users diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs new file mode 100644 index 0000000..4af7a4c --- /dev/null +++ b/common/src/Common/Util/Text.hs @@ -0,0 +1,41 @@ +module Common.Util.Text + ( unaccent + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +unaccent :: Text -> Text +unaccent = T.map unaccentChar + +unaccentChar :: Char -> Char +unaccentChar c = case c of + 'à' -> 'a' + 'á' -> 'a' + 'â' -> 'a' + 'ã' -> 'a' + 'ä' -> 'a' + 'ç' -> 'c' + 'è' -> 'e' + 'é' -> 'e' + 'ê' -> 'e' + 'ë' -> 'e' + 'ì' -> 'i' + 'í' -> 'i' + 'î' -> 'i' + 'ï' -> 'i' + 'ñ' -> 'n' + 'ò' -> 'o' + 'ó' -> 'o' + 'ô' -> 'o' + 'õ' -> 'o' + 'ö' -> 'o' + 'š' -> 's' + 'ù' -> 'u' + 'ú' -> 'u' + 'û' -> 'u' + 'ü' -> 'u' + 'ý' -> 'y' + 'ÿ' -> 'y' + 'ž' -> 'z' + _ -> c diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs new file mode 100644 index 0000000..7165965 --- /dev/null +++ b/common/src/Common/View/Format.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Common.View.Format + ( shortDay + , longDay + , price + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, toGregorian) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Currency(..)) + +shortDay :: Day -> Text +shortDay date = + Message.get $ Key.Date_Short + day + month + (fromIntegral year) + where (year, month, day) = toGregorian date + +longDay :: Day -> Text +longDay date = + Message.get $ Key.Date_Long + day + (fromMaybe "−" . fmap Message.get . monthToKey $ month) + (fromIntegral year) + where (year, month, day) = toGregorian date + + monthToKey 1 = Just Key.Month_January + monthToKey 2 = Just Key.Month_February + monthToKey 3 = Just Key.Month_March + monthToKey 4 = Just Key.Month_April + monthToKey 5 = Just Key.Month_May + monthToKey 6 = Just Key.Month_June + monthToKey 7 = Just Key.Month_July + monthToKey 8 = Just Key.Month_August + monthToKey 9 = Just Key.Month_September + monthToKey 10 = Just Key.Month_October + monthToKey 11 = Just Key.Month_November + monthToKey 12 = Just Key.Month_December + monthToKey _ = Nothing + +price :: Currency -> Int -> Text +price (Currency currency) amount = T.concat [ number amount, " ", currency ] + +number :: Int -> Text +number n = + T.pack + . (++) (if n < 0 then "-" else "") + . reverse + . concat + . intersperse " " + . group 3 + . reverse + . show + . abs $ n + +group :: Int -> [a] -> [[a]] +group n xs = + if length xs <= n + then [xs] + else (take n xs) : (group n (drop n xs)) diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..15dfdae --- /dev/null +++ b/default.nix @@ -0,0 +1,24 @@ +with import {}; + +let + reflex-platform = import (pkgs.fetchFromGitHub { + owner = "reflex-frp"; + repo = "reflex-platform"; + rev = "504b0344dfa6d03e4c89cf70ab9792b0a1fa021b"; + sha256 = "01hvdwc6bw48falpha5kaq4p7w98hc804kkwrayipb5ld1snchpz"; + }) {}; + + buildInputs = [ pkgs.noDemon ]; +in + reflex-platform.project ({ pkgs, ... }: { + packages = { + common = ./common; + server = ./server; + client = ./client; + }; + + shells = { + ghc = [ "common" "server" ]; + ghcjs = [ "common" "client" ]; + }; + }) diff --git a/server/LICENSE b/server/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/server/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/server/Setup.hs b/server/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/server/server.cabal b/server/server.cabal new file mode 100644 index 0000000..2e1f7be --- /dev/null +++ b/server/server.cabal @@ -0,0 +1,47 @@ +name: server +version: 0.0.1 +license: GPL-3 +license-file: LICENSE +author: Joris Guyonvarch +maintainer: joris@guyonvarch.me +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable server + main-is: Main.hs + ghc-options: -Wall -Werror + build-depends: aeson + , base >=4.9 && <4.11 + , base64-bytestring + , blaze-builder + , blaze-html + , bytestring + , clay + , clientsession + , common + , config-manager + , containers + , cookie + , email-validate + , filepath + , http-conduit + , http-types + , lens + , monad-logger + , mtl + , parsec + , process + , resourcet + , random + , scotty + , sqlite-simple + , text + , time + , transformers + , unordered-containers + , uuid + , wai + , wai-middleware-static + hs-source-dirs: src + default-language: Haskell2010 diff --git a/server/src/Conf.hs b/server/src/Conf.hs new file mode 100644 index 0000000..26c5c28 --- /dev/null +++ b/server/src/Conf.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Conf + ( get + , Conf(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ConfigManager as Conf +import Data.Time.Clock (NominalDiffTime) + +import Common.Model (Currency(..)) + +data Conf = Conf + { hostname :: Text + , port :: Int + , signInExpiration :: NominalDiffTime + , currency :: Currency + , noReplyMail :: Text + , https :: Bool + } deriving Show + +get :: FilePath -> IO Conf +get path = do + conf <- + (flip fmap) (Conf.readConfig path) (\configOrError -> do + conf <- configOrError + Conf <$> + Conf.lookup "hostname" conf <*> + Conf.lookup "port" conf <*> + Conf.lookup "signInExpiration" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> + Conf.lookup "noReplyMail" conf <*> + Conf.lookup "https" conf + ) + case conf of + Left msg -> error (T.unpack msg) + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..d6ed2f2 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Category + ( create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty hiding (delete) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) + +import Json (jsonId) +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +create :: CreateCategory -> ActionM () +create (CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Category.create name color) >>= jsonId + ) + +edit :: EditCategory -> ActionM () +edit (EditCategory categoryId name color) = + Secure.loggedAction (\_ -> do + updated <- liftIO . Query.run $ Category.edit categoryId name color + if updated + then status ok200 + else status badRequest400 + ) + +delete :: CategoryId -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . Query.run $ do + paymentCategories <- PaymentCategory.listByCategory categoryId + if null paymentCategories + then Category.delete categoryId + else return False + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Category_NotDeleted + ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..148b713 --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Income + ( create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query +import qualified Secure + +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = + Secure.loggedAction (\user -> + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId + ) + +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = + Secure.loggedAction (\user -> do + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: IncomeId -> ActionM () +deleteOwn incomeId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Income_NotDeleted + ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..8473c5c --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,86 @@ +module Controller.Index + ( get + , signOut + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) + +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + +import Conf (Conf(..)) +import Model.Init (getInit) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import Secure (getUserFromToken) +import View.Page (page) + +get :: Conf -> Maybe Text -> ActionM () +get conf mbToken = do + initResult <- case mbToken of + Just token -> do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + return . InitEmpty . Left . Message.get $ errorKey + Right user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + Nothing -> do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult + +validateSignIn :: Conf -> Text -> ActionM (Either Key User) +validateSignIn conf textToken = do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Just loggedUser -> + return . Right $ loggedUser + Nothing -> do + mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken + now <- liftIO getCurrentTime + case mbSignIn of + Nothing -> + return . Left $ Key.SignIn_LinkInvalid + Just signIn -> + if SignIn.isUsed signIn + then + return . Left $ Key.SignIn_LinkUsed + else + let diffTime = now `diffUTCTime` (SignIn.creation signIn) + in if diffTime > signInExpiration conf + then + return . Left $ Key.SignIn_LinkExpired + else do + LoginSession.put conf (SignIn.token signIn) + mbUser <- liftIO . Query.run $ do + SignIn.signInTokenToUsed . SignIn.id $ signIn + User.get . SignIn.email $ signIn + return $ case mbUser of + Nothing -> Left Key.Secure_Unauthorized + Just user -> Right user + +getLoggedUser :: ActionM (Maybe User) +getLoggedUser = do + mbToken <- LoginSession.get + case mbToken of + Nothing -> + return Nothing + Just token -> do + liftIO . Query.run . getUserFromToken $ token + +signOut :: Conf -> ActionM () +signOut conf = LoginSession.delete conf >> status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..dc10311 --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Payment + ( list + , create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import Web.Scotty + +import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) + +import Json (jsonId) +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Payment.list) >>= json + ) + +create :: CreatePayment -> ActionM () +create (CreatePayment name cost date category frequency) = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + PaymentCategory.save name category + Payment.create (_user_id user) name cost date frequency + ) >>= jsonId + ) + +editOwn :: EditPayment -> ActionM () +editOwn (EditPayment paymentId name cost date category frequency) = + Secure.loggedAction (\user -> do + updated <- liftIO . Query.run $ do + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency + _ <- if edited + then PaymentCategory.save name category >> return () + else return () + return edited + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: PaymentId -> ActionM () +deleteOwn paymentId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId + if deleted + then status ok200 + else status badRequest400 + ) diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs new file mode 100644 index 0000000..0086fa5 --- /dev/null +++ b/server/src/Controller/SignIn.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.SignIn + ( signIn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(..)) + +import Conf (Conf) +import qualified Conf +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn + +signIn :: Conf -> SignIn -> ActionM () +signIn conf (SignIn email) = + if Email.isValid (TE.encodeUtf8 email) + then do + maybeUser <- liftIO . Query.run $ User.get email + case maybeUser of + Just user -> do + token <- liftIO . Query.run $ SignIn.createSignInToken email + let url = T.concat [ + if Conf.https conf then "https://" else "http://", + Conf.hostname conf, + "?signInToken=", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs new file mode 100644 index 0000000..96d45da --- /dev/null +++ b/server/src/Cookie.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cookie + ( makeSimpleCookie + , setCookie + , setSimpleCookie + , getCookie + , getCookies + , deleteCookie + ) where + +import Control.Monad ( liftM ) + +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL + +import Conf (Conf) +import qualified Conf + +import qualified Data.Map as Map + +import qualified Data.ByteString.Lazy as BSL + +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) + +import Blaze.ByteString.Builder ( toLazyByteString ) + +import Web.Scotty.Trans +import Web.Cookie + +makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie +makeSimpleCookie conf name value = + def + { setCookieName = TS.encodeUtf8 name + , setCookieValue = TS.encodeUtf8 value + , setCookiePath = Just $ TS.encodeUtf8 "/" + , setCookieSecure = Conf.https conf + } + +setCookie :: (Monad m) => SetCookie -> ActionT e m () +setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) + +setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () +setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value + +getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) +getCookie name = liftM (Map.lookup name) getCookies + +getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) +getCookies = + liftM (Map.fromList . maybe [] parse) $ header "Cookie" + where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 + +deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () +deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs new file mode 100644 index 0000000..06c468e --- /dev/null +++ b/server/src/Design/Color.hs @@ -0,0 +1,35 @@ +module Design.Color where + +import qualified Clay.Color as C + +-- http://chir.ag/projects/name-that-color/#969696 + +white :: C.Color +white = C.white + +black :: C.Color +black = C.black + +chestnutRose :: C.Color +chestnutRose = C.rgb 207 92 86 + +unknown :: C.Color +unknown = C.rgb 86 92 207 + +mossGreen :: C.Color +mossGreen = C.rgb 159 210 165 + +gothic :: C.Color +gothic = C.rgb 108 162 164 + +negroni :: C.Color +negroni = C.rgb 255 223 196 + +wildSand :: C.Color +wildSand = C.rgb 245 245 245 + +silver :: C.Color +silver = C.rgb 200 200 200 + +dustyGray :: C.Color +dustyGray = C.rgb 150 150 150 diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs new file mode 100644 index 0000000..4e2b8cc --- /dev/null +++ b/server/src/Design/Constants.hs @@ -0,0 +1,27 @@ +module Design.Constants where + +import Clay + +iconFontSize :: Size LengthUnit +iconFontSize = px 32 + +radius :: Size LengthUnit +radius = px 3 + +blockPadding :: Size LengthUnit +blockPadding = px 15 + +blockPercentWidth :: Double +blockPercentWidth = 90 + +blockPercentMargin :: Double +blockPercentMargin = (100 - blockPercentWidth) / 2 + +inputHeight :: Double +inputHeight = 40 + +focusLighten :: Color -> Color +focusLighten baseColor = baseColor +. 20 + +focusDarken :: Color -> Color +focusDarken baseColor = baseColor -. 20 diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs new file mode 100644 index 0000000..4678633 --- /dev/null +++ b/server/src/Design/Dialog.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Dialog + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +design :: Css +design = do + + ".content" ? do + minWidth (px 270) + + ".paymentDialog" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do + h1 ? marginBottom (em 1.5) diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs new file mode 100644 index 0000000..57aaeee --- /dev/null +++ b/server/src/Design/Errors.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Errors + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + position fixed + top (px 20) + left (pct 50) + "transform" -: "translateX(-50%)" + margin (px 0) (px 0) (px 0) (px 0) + disapearKeyframes + + ".error" ? do + disapearAnimation + let errorColor = Color.chestnutRose -. 15 + color errorColor + border solid (px 2) errorColor + backgroundColor Color.white + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + + before & display none + +disapearAnimation :: Css +disapearAnimation = do + animationName "disapear" + animationDelay (sec 5) + animationDuration (sec 1) + animationFillMode forwards + +disapearKeyframes :: Css +disapearKeyframes = keyframes + "disapear" + [ ( 10 + , do + opacity 0 + height (px 40) + lineHeight (px 40) + marginBottom (px 10) + ) + , ( 100 + , do + opacity 0 + height (px 0) + lineHeight (px 0) + marginBottom (px 0) + ) + ] diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs new file mode 100644 index 0000000..ebb8ac8 --- /dev/null +++ b/server/src/Design/Form.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Form + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color + +design :: Css +design = do + + let inputHeight = 30 + let inputTop = 22 + let inputPaddingBottom = 3 + let inputZIndex = 1 + + label ? do + cursor pointer + color Color.silver + + ".textInput" ? do + position relative + marginBottom (em 1.5) + paddingTop (px inputTop) + marginTop (px (-10)) + + input ? do + width (pct 100) + position relative + zIndex inputZIndex + backgroundColor transparent + paddingBottom (px inputPaddingBottom) + borderStyle none + borderBottom solid (px 1) Color.dustyGray + marginBottom (px 5) + height (px inputHeight) + lineHeight (px inputHeight) + focus & do + borderWidth (px 2) + paddingBottom (px $ inputPaddingBottom - 1) + + label ? do + lineHeight (px inputHeight) + position absolute + top (px inputTop) + left (px 0) + transition "all" (sec 0.2) easeIn (sec 0) + + button ? do + position absolute + right (px 0) + top (px 27) + zIndex inputZIndex + hover & "svg path" ? do + "fill" -: "rgb(220, 220, 220)" + + (input # ".filled" |+ label) <> (input # focus |+ label) ? do + top (px 0) + fontSize (pct 80) + + ".error" & do + input ? do + borderBottomColor Color.chestnutRose + + ".errorMessage" ? do + position absolute + color Color.chestnutRose + fontSize (pct 80) + + ".colorInput" ? do + display flex + alignItems center + marginBottom (em 1.5) + + input ? do + borderColor transparent + backgroundColor transparent + + ".radioGroup" ? do + position relative + marginBottom (em 2) + + ".title" ? do + color Color.silver + marginBottom (em 0.8) + + ".radioInputs" ? do + display flex + "justify-content" -: "center" + + ".radioInput:not(:last-child)::after" ? do + content (stringContent "/") + marginLeft (px 10) + marginRight (px 10) + + input ? do + opacity 0 + width (px 30) + margin (px 0) (px (-15)) (px 0) (px (-15)) + + "input:focus + label" ? do + textDecoration underline + + "input:checked + label" ? do + color Color.chestnutRose + fontWeight bold + + ".selectInput" ? do + label ? do + display block + marginBottom (px 10) + fontSize (pct 80) + select ? do + backgroundColor Color.white + border solid (px 1) Color.silver + sym borderRadius (px 3) + sym2 padding (px 5) (px 8) + option ? do + firstChild & display none + sym2 padding (px 5) (px 8) + ".error" & do + select ? borderColor Color.chestnutRose + ".errorMessage" ? do + color Color.chestnutRose + fontSize (pct 80) + marginTop (em 0.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs new file mode 100644 index 0000000..47ea4a9 --- /dev/null +++ b/server/src/Design/Global.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Global + ( globalDesign + ) where + +import Clay + +import Data.Text.Lazy (Text) + +import qualified Design.Views as Views +import qualified Design.Form as Form +import qualified Design.Errors as Errors +import qualified Design.Dialog as Dialog +import qualified Design.Tooltip as Tooltip + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +globalDesign :: Text +globalDesign = renderWith compact [] global + +global :: Css +global = do + ".errors" ? Errors.design + ".dialog" ? Dialog.design + ".tooltip" ? Tooltip.design + Views.design + Form.design + + body ? do + minWidth (px 320) + fontFamily ["Cantarell"] [sansSerif] + Media.tablet $ do + fontSize (px 15) + button ? fontSize (px 15) + input ? fontSize (px 15) + Media.mobile $ do + fontSize (px 14) + button ? fontSize (px 14) + input ? fontSize (px 14) + + a ? cursor pointer + + input ? fontSize inherit + + h1 ? do + color Color.chestnutRose + marginBottom (em 1) + lineHeight (em 1.2) + + Media.desktop $ fontSize (px 24) + Media.tablet $ fontSize (px 22) + Media.mobile $ fontSize (px 20) + + ul ? do + "margin-bottom" -: "3vh" + "margin-left" -: "1vh" + li Color -> Size a -> (Color -> Color) -> Css +button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center + backgroundColor backgroundCol + padding (px 0) (px 10) (px 0) (px 10) + color textCol + borderRadius radius radius radius radius + verticalAlign middle + cursor pointer + lineHeight h + height h + textAlign (alignSide sideCenter) + hover & backgroundColor (focusOp backgroundCol) + focus & backgroundColor (focusOp backgroundCol) + waitable + +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation + +input :: Double -> Css +input h = do + height (px h) + padding (px 10) (px 10) (px 10) (px 10) + borderRadius radius radius radius radius + border solid (px 1) Color.dustyGray + focus & borderColor Color.silver + verticalAlign middle + +centeredWithMargin :: Css +centeredWithMargin = do + width (pct blockPercentWidth) + marginLeft auto + marginRight auto + +verticalCentering :: Css +verticalCentering = do + position absolute + top (pct 50) + "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs new file mode 100644 index 0000000..77220ee --- /dev/null +++ b/server/src/Design/Media.hs @@ -0,0 +1,36 @@ +module Design.Media + ( mobile + , mobileTablet + , tablet + , tabletDesktop + , desktop + ) where + +import Clay hiding (query) +import qualified Clay +import Clay.Stylesheet (Feature) +import qualified Clay.Media as Media + +mobile :: Css -> Css +mobile = query [Media.maxWidth mobileTabletLimit] + +mobileTablet :: Css -> Css +mobileTablet = query [Media.maxWidth tabletDesktopLimit] + +tablet :: Css -> Css +tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] + +tabletDesktop :: Css -> Css +tabletDesktop = query [Media.minWidth mobileTabletLimit] + +desktop :: Css -> Css +desktop = query [Media.minWidth tabletDesktopLimit] + +query :: [Feature] -> Css -> Css +query = Clay.query Media.screen + +mobileTabletLimit :: Size LengthUnit +mobileTabletLimit = (px 520) + +tabletDesktopLimit :: Size LengthUnit +tabletDesktopLimit = (px 950) diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs new file mode 100644 index 0000000..1da8764 --- /dev/null +++ b/server/src/Design/Tooltip.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Tooltip + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + color Color.white diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs new file mode 100644 index 0000000..20627e6 --- /dev/null +++ b/server/src/Design/View/Header.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + let headerPadding = "padding" -: "0 20px" + display flex + "flex-wrap" -: "wrap" + lineHeightMedia + position relative + backgroundColor Color.chestnutRose + color Color.white + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + Media.mobile $ marginBottom (em 1.5) + + ".title" <> ".item" ? headerPadding + + ".title" ? do + height (pct 100) + textAlign (alignSide sideLeft) + + Media.mobile $ fontSize (px 22) + Media.mobileTablet $ width (pct 100) + Media.tabletDesktop $ do + display inlineBlock + fontSize (px 35) + + ".item" ? do + display inlineBlock + transition "background-color" (ms 50) easeIn (sec 0) + ".current" & backgroundColor (Color.chestnutRose -. 20) + Media.mobile $ fontSize (px 13) + + (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) + (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + + ".nameSignOut" ? do + display flex + heightMedia + position absolute + top (px 0) + right (px 0) + + ".name" ? do + Media.mobile $ display none + Media.tabletDesktop $ headerPadding + + ".signOut" ? do + Helper.waitable + heightMedia + svg ? do + Media.tabletDesktop $ width (px 30) + Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") + +lineHeightMedia :: Css +lineHeightMedia = do + Media.desktop $ lineHeight (px 80) + Media.tablet $ lineHeight (px 65) + Media.mobile $ lineHeight (px 50) + +heightMedia :: Css +heightMedia = do + Media.desktop $ height (px 80) + Media.tablet $ height (px 65) + Media.mobile $ height (px 50) diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/server/src/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs new file mode 100644 index 0000000..f02da8a --- /dev/null +++ b/server/src/Design/View/Payment/Header.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Constants + +import qualified Design.Helper as Helper +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + marginLeft (pct blockPercentMargin) + marginRight (pct blockPercentMargin) + + ".payerAndAdd" ? do + Media.tabletDesktop $ display flex + marginBottom (em 1) + + ".exceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + + Media.tabletDesktop $ do + "flex-grow" -: "1" + marginRight (px 15) + + Media.mobile $ do + marginBottom (em 1) + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + + ".searchLine" ? do + marginBottom (em 1) + form ? do + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none + + ".infos" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs new file mode 100644 index 0000000..ade81a8 --- /dev/null +++ b/server/src/Design/View/Payment/Pages.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + textAlign (alignSide sideCenter) + Helper.clearFix + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs new file mode 100644 index 0000000..a866b40 --- /dev/null +++ b/server/src/Design/View/Payment/Table.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Table + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".cell" ? do + ".name" & do + Media.tabletDesktop $ width (pct 30) + + ".cost" & do + Media.tabletDesktop $ width (pct 10) + + ".user" & do + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) + + ".date" & do + Media.tabletDesktop $ width (pct 15) + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/server/src/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs new file mode 100644 index 0000000..0a5b258 --- /dev/null +++ b/server/src/Design/View/Stat.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Stat + ( design + ) where + +import Clay + +design :: Css +design = do + h1 ? paddingBottom (px 0) + + ".exceedingPayers" ? ".userName" ? marginRight (px 5) + + ".mean" ? marginBottom (em 1.5) diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs new file mode 100644 index 0000000..95abf90 --- /dev/null +++ b/server/src/Design/View/Table.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Table + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".emptyTableMsg" ? do + margin (em 2) (em 2) (em 2) (em 2) + textAlign (alignSide sideCenter) + + ".lines" ? do + Media.tabletDesktop $ display displayTable + width (pct 100) + textAlign (alignSide (sideCenter)) + + ".header" <> ".row" ? do + Media.tabletDesktop $ display tableRow + + ".header" ? do + Media.desktop $ do + fontSize (px 18) + height (px 70) + + Media.tabletDesktop $ do + backgroundColor Color.gothic + color Color.white + + Media.tablet $ do + fontSize (px 16) + height (px 60) + + Media.mobile $ do + display none + + ".row" ? do + nthChild "even" & backgroundColor Color.wildSand + + Media.desktop $ do + fontSize (px 18) + height (px 60) + + Media.tablet $ do + height (px 50) + + Media.mobile $ do + lineHeight (px 25) + paddingTop (px 10) + paddingBottom (px 10) + + ".cell" ? do + Media.tabletDesktop $ display tableCell + position relative + verticalAlign middle + + firstChild & do + Media.mobile $ do + fontSize (px 20) + lineHeight (px 30) + color Color.gothic + + ".refund" & color Color.mossGreen + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + hover & "svg path" ? do + "fill" -: "rgb(237, 122, 116)" + + Media.tabletDesktop $ width (pct 3) + + Media.mobile $ do + display inlineBlock + button ? display flex diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs new file mode 100644 index 0000000..bc6ac83 --- /dev/null +++ b/server/src/Design/Views.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.View.Header as Header +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design + ".stat" ? Stat.design + Table.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs new file mode 100644 index 0000000..0bc6f6e --- /dev/null +++ b/server/src/Job/Daemon.hs @@ -0,0 +1,36 @@ +module Job.Daemon + ( runDaemons + ) where + +import Control.Concurrent (threadDelay, forkIO, ThreadId) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) + +import Conf (Conf) +import Job.Frequency (Frequency(..), microSeconds) +import Job.Kind (Kind(..)) +import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) + +runDaemons :: Conf -> IO () +runDaemons conf = do + _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment + _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) + return () + +runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId +runDaemon kind frequency isLastExecutionTooOld runJob = + forkIO . forever $ do + mbLastExecution <- Query.run $ do + actualizeLastCheck kind + getLastExecution kind + hasToRun <- case mbLastExecution of + Just lastExecution -> isLastExecutionTooOld lastExecution + Nothing -> return True + if hasToRun + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) + else return () + threadDelay . microSeconds $ frequency diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs new file mode 100644 index 0000000..263f6e6 --- /dev/null +++ b/server/src/Job/Frequency.hs @@ -0,0 +1,13 @@ +module Job.Frequency + ( Frequency(..) + , microSeconds + ) where + +data Frequency = + EveryHour + | EveryDay + deriving (Eq, Read, Show) + +microSeconds :: Frequency -> Int +microSeconds EveryHour = 1000000 * 60 * 60 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs new file mode 100644 index 0000000..af5d4f8 --- /dev/null +++ b/server/src/Job/Kind.hs @@ -0,0 +1,22 @@ +module Job.Kind + ( Kind(..) + ) where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +data Kind = + MonthlyPayment + | WeeklyReport + deriving (Eq, Show, Read) + +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs new file mode 100644 index 0000000..e1a3c77 --- /dev/null +++ b/server/src/Job/Model.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Job.Model + ( Job(..) + , getLastExecution + , actualizeLastExecution + , actualizeLastCheck + ) where + +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Job.Kind +import Model.Query (Query(Query)) + +data Job = Job + { id :: String + , kind :: Kind + , lastExecution :: Maybe UTCTime + , lastCheck :: Maybe UTCTime + } deriving (Show) + +getLastExecution :: Kind -> Query (Maybe UTCTime) +getLastExecution jobKind = + Query (\conn -> do + [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] + return time + ) + +actualizeLastExecution :: Kind -> UTCTime -> Query () +actualizeLastExecution jobKind time = + Query (\conn -> do + [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] + if isJust result + then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) + else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) + ) + +actualizeLastCheck :: Kind -> Query () +actualizeLastCheck jobKind = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) + ) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs new file mode 100644 index 0000000..ba24cca --- /dev/null +++ b/server/src/Job/MonthlyPayment.hs @@ -0,0 +1,26 @@ +module Job.MonthlyPayment + ( monthlyPayment + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (Frequency(..), Payment(..)) + +import qualified Model.Payment as Payment +import Utils.Time (timeToDay) +import qualified Model.Query as Query + +monthlyPayment :: Maybe UTCTime -> IO UTCTime +monthlyPayment _ = do + monthlyPayments <- Query.run Payment.listMonthly + now <- getCurrentTime + actualDay <- timeToDay now + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments + _ <- Query.run (Payment.createMany punctualPayments) + return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs new file mode 100644 index 0000000..5737c75 --- /dev/null +++ b/server/src/Job/WeeklyReport.hs @@ -0,0 +1,28 @@ +module Job.WeeklyReport + ( weeklyReport + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Conf (Conf) +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import qualified Model.User as User +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport + +weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime +weeklyReport conf mbLastExecution = do + now <- getCurrentTime + case mbLastExecution of + Nothing -> return () + Just lastExecution -> do + (payments, incomes, users) <- Query.run $ + (,,) <$> + Payment.modifiedDuring lastExecution now <*> + Income.modifiedDuring lastExecution now <*> + User.list + _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) + return () + return now diff --git a/server/src/Json.hs b/server/src/Json.hs new file mode 100644 index 0000000..cc6327a --- /dev/null +++ b/server/src/Json.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Json + ( jsonObject + , jsonId + ) where + +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Aeson.Types as Json +import qualified Data.HashMap.Strict as M +import Web.Scotty + +jsonObject :: [(Text, Json.Value)] -> ActionM () +jsonObject = json . Json.Object . M.fromList + +jsonId :: Int64 -> ActionM () +jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs new file mode 100644 index 0000000..6f6d620 --- /dev/null +++ b/server/src/LoginSession.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LoginSession + ( put + , get + , delete + ) where + +import Web.Scotty (ActionM) +import Cookie (setSimpleCookie, getCookie, deleteCookie) +import qualified Web.ClientSession as CS + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Conf (Conf) + +sessionName :: Text +sessionName = "SESSION" + +sessionKeyFile :: FilePath +sessionKeyFile = "sessionKey" + +put :: Conf -> Text -> ActionM () +put conf value = do + encrypted <- liftIO $ encrypt value + setSimpleCookie conf sessionName encrypted + +encrypt :: Text -> IO Text +encrypt value = do + iv <- CS.randomIV + key <- CS.getKey sessionKeyFile + return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) + +get :: ActionM (Maybe Text) +get = do + maybeEncrypted <- getCookie sessionName + case maybeEncrypted of + Just encrypted -> + liftIO $ decrypt encrypted + Nothing -> + return Nothing + +decrypt :: Text -> IO (Maybe Text) +decrypt encrypted = do + key <- CS.getKey sessionKeyFile + let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) + return decrypted + +delete :: Conf -> ActionM () +delete conf = deleteCookie conf sessionName diff --git a/server/src/Main.hs b/server/src/Main.hs new file mode 100644 index 0000000..db73474 --- /dev/null +++ b/server/src/Main.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + +import Network.Wai.Middleware.Static +import qualified Data.Text.Lazy as LT +import Web.Scotty + +import qualified Conf +import qualified Controller.Category as Category +import qualified Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.Payment as Payment +import qualified Controller.SignIn as SignIn +import Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query + +main :: IO () +main = do + conf <- Conf.get "application.conf" + _ <- runDaemons conf + scotty (Conf.port conf) $ do + middleware . staticPolicy $ noDots >-> addBase "public" + + get "/exceedingPayer" $ do + time <- liftIO Time.getCurrentTime + (users, incomes, payments) <- liftIO . Query.run $ + liftA3 (,,) UserM.list IncomeM.list PaymentM.list + let exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + + get "/" $ do + signInToken <- mbParam "signInToken" + Index.get conf signInToken + + post "/signIn" $ do + jsonData >>= SignIn.signIn conf + + post "/signOut" $ + Index.signOut conf + + post "/payment" $ + jsonData >>= Payment.create + + put "/payment" $ + jsonData >>= Payment.editOwn + + delete "/payment" $ do + paymentId <- param "id" + Payment.deleteOwn paymentId + + post "/income" $ + jsonData >>= Income.create + + put "/income" $ + jsonData >>= Income.editOwn + + delete "/income" $ do + incomeId <- param "id" + Income.deleteOwn incomeId + + post "/category" $ + jsonData >>= Category.create + + put "/category" $ + jsonData >>= Category.edit + + delete "/category" $ do + categoryId <- param "id" + Category.delete categoryId + +mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) +mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs new file mode 100644 index 0000000..0faaf98 --- /dev/null +++ b/server/src/MimeMail.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MimeMail + ( -- * Datatypes + Boundary (..) + , Mail (..) + , emptyMail + , Address (..) + , Alternatives + , Part (..) + , Encoding (..) + , Headers + -- * Render a message + , renderMail + , renderMail' + -- * Sending messages + , sendmail + , sendmailCustom + , sendmailCustomCaptureOutput + , renderSendMail + , renderSendMailCustom + -- * High-level 'Mail' creation + , simpleMail + , simpleMail' + , simpleMailInMemory + -- * Utilities + , addPart + , addAttachment + , addAttachmentCid + , addAttachments + , addAttachmentBS + , addAttachmentBSCid + , addAttachmentsBS + , renderAddress + , htmlPart + , plainPart + , randomString + , quotedPrintable + ) where + +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder.Char.Utf8 +import Blaze.ByteString.Builder +import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) +import Data.Monoid +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import System.FilePath (takeFileName) +import qualified Data.ByteString.Base64 as Base64 +import Control.Monad ((<=<), foldM, void) +import Control.Exception (throwIO, ErrorCall (ErrorCall)) +import Data.List (intersperse) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.ByteString.Char8 () +import Data.Bits ((.&.), shiftR) +import Data.Char (isAscii, isControl) +import Data.Word (Word8) +import qualified Data.ByteString as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | Generates a random sequence of alphanumerics of the given length. +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | MIME boundary between parts of a message. +newtype Boundary = Boundary { unBoundary :: Text } + deriving (Eq, Show) +instance Random Boundary where + randomR = const random + random = first (Boundary . T.pack) . randomString 10 + +-- | An entire mail message. +data Mail = Mail + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] + -- | Other headers, excluding from, to, cc and bcc. + , mailHeaders :: Headers + -- | A list of different sets of alternatives. As a concrete example: + -- + -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] + -- + -- Make sure when specifying alternatives to place the most preferred + -- version last. + , mailParts :: [Alternatives] + } + deriving Show + +-- | A mail message with the provided 'from' address and no other +-- fields filled in. +emptyMail :: Address -> Mail +emptyMail from = Mail + { mailFrom = from + , mailTo = [] + , mailCc = [] + , mailBcc = [] + , mailHeaders = [] + , mailParts = [] + } + +data Address = Address + { addressName :: Maybe Text + , addressEmail :: Text + } + deriving (Eq, Show) + +-- | How to encode a single part. You should use 'Base64' for binary data. +data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary + deriving (Eq, Show) + +-- | Multiple alternative representations of the same data. For example, you +-- could provide a plain-text and HTML version of a message. +type Alternatives = [Part] + +-- | A single part of a multipart message. +data Part = Part + { partType :: Text -- ^ content type + , partEncoding :: Encoding + -- | The filename for this part, if it is to be sent with an attachemnt + -- disposition. + , partFilename :: Maybe Text + , partHeaders :: Headers + , partContent :: L.ByteString + } + deriving (Eq, Show) + +type Headers = [(S.ByteString, Text)] +type Pair = (Headers, Builder) + +partToPair :: Part -> Pair +partToPair (Part contentType encoding disposition headers content) = + (headers', builder) + where + headers' = + ((:) ("Content-Type", contentType)) + $ (case encoding of + None -> id + Base64 -> (:) ("Content-Transfer-Encoding", "base64") + QuotedPrintableText -> + (:) ("Content-Transfer-Encoding", "quoted-printable") + QuotedPrintableBinary -> + (:) ("Content-Transfer-Encoding", "quoted-printable")) + $ (case disposition of + Nothing -> id + Just fn -> + (:) ("Content-Disposition", "attachment; filename=" + `T.append` fn)) + $ headers + builder = + case encoding of + None -> fromWriteList writeByteString $ L.toChunks content + Base64 -> base64 content + QuotedPrintableText -> quotedPrintable True content + QuotedPrintableBinary -> quotedPrintable False content + +showPairs :: RandomGen g + => Text -- ^ multipart type, eg mixed, alternative + -> [Pair] + -> g + -> (Pair, g) +showPairs _ [] _ = error "renderParts called with null parts" +showPairs _ [pair] gen = (pair, gen) +showPairs mtype parts gen = + ((headers, builder), gen') + where + (Boundary b, gen') = random gen + headers = + [ ("Content-Type", T.concat + [ "multipart/" + , mtype + , "; boundary=\"" + , b + , "\"" + ]) + ] + builder = mconcat + [ mconcat $ intersperse (fromByteString "\n") + $ map (showBoundPart $ Boundary b) parts + , showBoundEnd $ Boundary b + ] + +-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. +renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) +renderMail g0 (Mail from to cc bcc headers parts) = + (toLazyByteString builder, g'') + where + addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] + pairs = map (map partToPair) parts + (pairs', g') = helper g0 $ map (showPairs "alternative") pairs + helper :: g -> [g -> (x, g)] -> ([x], g) + helper g [] = ([], g) + helper g (x:xs) = + let (b, g_) = x g + (bs, g__) = helper g_ xs + in (b : bs, g__) + ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' + builder = mconcat + [ mconcat addressHeaders + , mconcat $ map showHeader headers + , showHeader ("MIME-Version", "1.0") + , mconcat $ map showHeader finalHeaders + , fromByteString "\n" + , finalBuilder + ] + +-- | Format an E-Mail address according to the name-addr form (see: RFC5322 +-- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') +-- This can be handy for adding custom headers that require such format. +-- +-- @since 0.4.11 +renderAddress :: Address -> Text +renderAddress address = + TE.decodeUtf8 $ toByteString $ showAddress address + +-- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) +sanitizeFieldName :: S.ByteString -> S.ByteString +sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) + +showHeader :: (S.ByteString, Text) -> Builder +showHeader (k, v) = mconcat + [ fromByteString (sanitizeFieldName k) + , fromByteString ": " + , encodeIfNeeded (sanitizeHeader v) + , fromByteString "\n" + ] + +showAddressHeader :: (S.ByteString, [Address]) -> Builder +showAddressHeader (k, as) = + if null as + then mempty + else mconcat + [ fromByteString k + , fromByteString ": " + , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) + , fromByteString "\n" + ] + +-- | +-- +-- Since 0.4.3 +showAddress :: Address -> Builder +showAddress a = mconcat + [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) + , fromByteString "<" + , fromText (sanitizeHeader $ addressEmail a) + , fromByteString ">" + ] + +-- Filter out control characters to prevent CRLF injection. +sanitizeHeader :: Text -> Text +sanitizeHeader = T.filter (not . isControl) + +showBoundPart :: Boundary -> (Headers, Builder) -> Builder +showBoundPart (Boundary b) (headers, content) = mconcat + [ fromByteString "--" + , fromText b + , fromByteString "\n" + , mconcat $ map showHeader headers + , fromByteString "\n" + , content + ] + +showBoundEnd :: Boundary -> Builder +showBoundEnd (Boundary b) = mconcat + [ fromByteString "\n--" + , fromText b + , fromByteString "--" + ] + +-- | Like 'renderMail', but generates a random boundary. +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + g <- getStdGen + let (lbs, g') = renderMail g m + setStdGen g' + return lbs + +-- | Send a fully-formed email message via the default sendmail +-- executable with default options. +sendmail :: L.ByteString -> IO () +sendmail = sendmailCustom sendmailPath ["-t"] + +sendmailPath :: String +sendmailPath = "sendmail" + +-- | Render an email message and send via the default sendmail +-- executable with default options. +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' + +-- | Send a fully-formed email message via the specified sendmail +-- executable with specified options. +sendmailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> L.ByteString -- ^ mail message as lazy bytestring + -> IO () +sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs + +-- | Like 'sendmailCustom', but also returns sendmail's output to stderr and +-- stdout as strict ByteStrings. +-- +-- Since 0.4.9 +sendmailCustomCaptureOutput :: FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs + +sendmailCustomAux :: Bool + -> FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomAux captureOut sm opts lbs = do + let baseOpts = (proc sm opts) { std_in = CreatePipe } + pOpts = if captureOut + then baseOpts { std_out = CreatePipe + , std_err = CreatePipe + } + else baseOpts + (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts + L.hPut hin lbs + hClose hin + errMVar <- newEmptyMVar + outMVar <- newEmptyMVar + case (mHOut, mHErr) of + (Nothing, Nothing) -> return () + (Just hOut, Just hErr) -> do + void . forkIO $ S.hGetContents hOut >>= putMVar outMVar + void . forkIO $ S.hGetContents hErr >>= putMVar errMVar + _ -> error "error in sendmailCustomAux: missing a handle" + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> if captureOut + then do + errOutput <- takeMVar errMVar + outOutput <- takeMVar outMVar + return (outOutput, errOutput) + else return (S.empty, S.empty) + _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) + +-- | Render an email message and send via the specified sendmail +-- executable with specified options. +renderSendMailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> Mail -- ^ mail to render and send + -> IO () +renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' + +-- FIXME usage of FilePath below can lead to issues with filename encoding + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some file attachments. +-- +-- Note that we use lazy IO for reading in the attachment contents. +simpleMail :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, FilePath)] -- ^ content type and path of attachments + -> IO Mail +simpleMail to from subject plainBody htmlBody attachments = + addAttachments attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with only plain-text body. +simpleMail' :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ body + -> Mail +simpleMail' to from subject body = addPart [plainPart body] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some 'ByteString' attachments. +-- +-- Since 0.4.7 +simpleMailInMemory :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments + -> Mail +simpleMailInMemory to from subject plainBody htmlBody attachments = + addAttachmentsBS attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +mailFromToSubject :: Address -- ^ from + -> Address -- ^ to + -> Text -- ^ subject + -> Mail +mailFromToSubject from to subject = + (emptyMail from) { mailTo = [to] + , mailHeaders = [("Subject", subject)] + } + +-- | Add an 'Alternative' to the 'Mail's parts. +-- +-- To e.g. add a plain text body use +-- > addPart [plainPart body] (emptyMail from) +addPart :: Alternatives -> Mail -> Mail +addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } + +-- | Construct a UTF-8-encoded plain-text 'Part'. +plainPart :: LT.Text -> Part +plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/plain; charset=utf-8" + +-- | Construct a UTF-8-encoded html 'Part'. +htmlPart :: LT.Text -> Part +htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/html; charset=utf-8" + +-- | Add an attachment from a file and construct a 'Part'. +addAttachment :: Text -> FilePath -> Mail -> IO Mail +addAttachment ct fn mail = do + part <- getAttachmentPart ct fn + return $ addPart [part] mail + +-- | Add an attachment from a file and construct a 'Part' +-- with the specified content id in the Content-ID header. +-- +-- @since 0.4.12 +addAttachmentCid :: Text -- ^ content type + -> FilePath -- ^ file name + -> Text -- ^ content ID + -> Mail + -> IO Mail +addAttachmentCid ct fn cid mail = + getAttachmentPart ct fn >>= (return.addToMail.addHeader) + where + addToMail part = addPart [part] mail + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail +addAttachments xs mail = foldM fun mail xs + where fun m (c, f) = addAttachment c f m + +-- | Add an attachment from a 'ByteString' and construct a 'Part'. +-- +-- Since 0.4.7 +addAttachmentBS :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Mail -> Mail +addAttachmentBS ct fn content mail = + let part = getAttachmentPartBS ct fn content + in addPart [part] mail + +-- | @since 0.4.12 +addAttachmentBSCid :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Text -- ^ content ID + -> Mail -> Mail +addAttachmentBSCid ct fn content cid mail = + let part = addHeader $ getAttachmentPartBS ct fn content + in addPart [part] mail + where + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +-- | +-- Since 0.4.7 +addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail +addAttachmentsBS xs mail = foldl fun mail xs + where fun m (ct, fn, content) = addAttachmentBS ct fn content m + +getAttachmentPartBS :: Text + -> Text + -> L.ByteString + -> Part +getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content + +getAttachmentPart :: Text -> FilePath -> IO Part +getAttachmentPart ct fn = do + content <- L.readFile fn + return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content + +data QP = QPPlain S.ByteString + | QPNewline + | QPTab + | QPSpace + | QPEscape S.ByteString + +data QPC = QPCCR + | QPCLF + | QPCSpace + | QPCTab + | QPCPlain + | QPCEscape + deriving Eq + +toQP :: Bool -- ^ text? + -> L.ByteString + -> [QP] +toQP isText = + go + where + go lbs = + case L.uncons lbs of + Nothing -> [] + Just (c, rest) -> + case toQPC c of + QPCCR -> go rest + QPCLF -> QPNewline : go rest + QPCSpace -> QPSpace : go rest + QPCTab -> QPTab : go rest + QPCPlain -> + let (x, y) = L.span ((== QPCPlain) . toQPC) lbs + in QPPlain (toStrict x) : go y + QPCEscape -> + let (x, y) = L.span ((== QPCEscape) . toQPC) lbs + in QPEscape (toStrict x) : go y + + toStrict = S.concat . L.toChunks + + toQPC :: Word8 -> QPC + toQPC 13 | isText = QPCCR + toQPC 10 | isText = QPCLF + toQPC 9 = QPCTab + toQPC 0x20 = QPCSpace + toQPC 46 = QPCEscape + toQPC 61 = QPCEscape + toQPC w + | 33 <= w && w <= 126 = QPCPlain + | otherwise = QPCEscape + +buildQPs :: [QP] -> Builder +buildQPs = + go (0 :: Int) + where + go _ [] = mempty + go currLine (qp:qps) = + case qp of + QPNewline -> copyByteString "\r\n" `mappend` go 0 qps + QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) + QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) + QPPlain bs -> + let toTake = 75 - currLine + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPPlain y : qps + in helper (S.length x) (copyByteString x) (S.null y) rest + QPEscape bs -> + let toTake = (75 - currLine) `div` 3 + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPEscape y : qps + in if toTake == 0 + then copyByteString "=\r\n" `mappend` go 0 (qp:qps) + else helper (S.length x * 3) (escape x) (S.null y) rest + where + escape = + S.foldl' add mempty + where + add builder w = + builder `mappend` escaped + where + escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + + helper added builder noMore rest = + builder' `mappend` go newLine rest + where + (newLine, builder') + | not noMore || (added + currLine) >= 75 = + (0, builder `mappend` copyByteString "=\r\n") + | otherwise = (added + currLine, builder) + + wsHelper enc raw + | null qps = + if currLine <= 73 + then enc + else copyByteString "\r\n=" `mappend` enc + | otherwise = helper 1 raw (currLine < 76) qps + +-- | The first parameter denotes whether the input should be treated as text. +-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If +-- binary, then CRs and LFs will be escaped. +quotedPrintable :: Bool -> L.ByteString -> Builder +quotedPrintable isText = buildQPs . toQP isText + +hex :: Word8 -> Builder +hex x + | x < 10 = fromWord8 $ x + 48 + | otherwise = fromWord8 $ x + 55 + +encodeIfNeeded :: Text -> Builder +encodeIfNeeded t = + if needsEncodedWord t + then encodedWord t + else fromText t + +needsEncodedWord :: Text -> Bool +needsEncodedWord = not . T.all isAscii + +encodedWord :: Text -> Builder +encodedWord t = mconcat + [ fromByteString "=?utf-8?Q?" + , S.foldl' go mempty $ TE.encodeUtf8 t + , fromByteString "?=" + ] + where + go front w = front `mappend` go' w + go' 32 = fromWord8 95 -- space + go' 95 = go'' 95 -- _ + go' 63 = go'' 63 -- ? + go' 61 = go'' 61 -- = + + -- The special characters from RFC 2822. Not all of these always give + -- problems, but at least @[];"<>, gave problems with some mail servers + -- when used in the 'name' part of an address. + go' 34 = go'' 34 -- " + go' 40 = go'' 40 -- ( + go' 41 = go'' 41 -- ) + go' 44 = go'' 44 -- , + go' 46 = go'' 46 -- . + go' 58 = go'' 58 -- ; + go' 59 = go'' 59 -- ; + go' 60 = go'' 60 -- < + go' 62 = go'' 62 -- > + go' 64 = go'' 64 -- @ + go' 91 = go'' 91 -- [ + go' 92 = go'' 92 -- \ + go' 93 = go'' 93 -- ] + go' w + | 33 <= w && w <= 126 = fromWord8 w + | otherwise = go'' w + go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + +-- 57 bytes, when base64-encoded, becomes 76 characters. +-- Perform the encoding 57-bytes at a time, and then append a newline. +base64 :: L.ByteString -> Builder +base64 lbs + | L.null lbs = mempty + | otherwise = fromByteString x64 `mappend` + fromByteString "\r\n" `mappend` + base64 y + where + (x', y) = L.splitAt 57 lbs + x = S.concat $ L.toChunks x' + x64 = Base64.encode x diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs new file mode 100644 index 0000000..6b7a488 --- /dev/null +++ b/server/src/Model/Category.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Category + ( list + , create + , edit + , delete + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Category(..), CategoryId) + +import Model.Query (Query(Query)) + +instance FromRow Category where + fromRow = Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [Category] +list = + Query (\conn -> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query CategoryId +create categoryName categoryColor = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" + (categoryName, categoryColor, now) + SQLite.lastInsertRowId conn + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit categoryId categoryName categoryColor = + Query (\conn -> do + mbCategory <- listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" + (now, categoryName, categoryColor, categoryId) + return True + else + return False + ) + +delete :: CategoryId -> Query Bool +delete categoryId = + Query (\conn -> do + mbCategory <- listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + return True + else + return False + ) diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs new file mode 100644 index 0000000..b334a40 --- /dev/null +++ b/server/src/Model/Frequency.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Frequency () where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +import Common.Model (Frequency) + +instance FromField Frequency where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Frequency) + _ -> Errors [error "SQLText field required for frequency"] + +instance ToField Frequency where + toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs new file mode 100644 index 0000000..bbe7657 --- /dev/null +++ b/server/src/Model/Income.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Income + ( list + , create + , editOwn + , deleteOwn + , modifiedDuring + ) where + +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Income(..), IncomeId, User(..), UserId) + +import Model.Query (Query(Query)) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) + +instance Resource Income where + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt + +instance FromRow Income where + fromRow = Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [Income] +list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") + +create :: UserId -> Day -> Int -> Query IncomeId +create incomeUserId incomeDate incomeAmount = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" + (incomeUserId, incomeDate, incomeAmount, now) + SQLite.lastInsertRowId conn + ) + +editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool +editOwn incomeUserId incomeId incomeDate incomeAmount = + Query (\conn -> do + mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == incomeUserId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" + (now, incomeDate, incomeAmount, incomeId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: User -> IncomeId -> Query Bool +deleteOwn user incomeId = + Query (\conn -> do + mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == _user_id user + then do + now <- getCurrentTime + SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) + return True + else + return False + Nothing -> + return False + ) + +modifiedDuring :: UTCTime -> UTCTime -> Query [Income] +modifiedDuring start end = + Query (\conn -> + SQLite.query + conn + "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" + (start, end, start, end, start, end) + ) diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs new file mode 100644 index 0000000..8c6a961 --- /dev/null +++ b/server/src/Model/Init.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.Init + ( getInit + ) where + +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf +import Model.Query (Query) +import qualified Model.Category as Category +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.User as User + +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs new file mode 100644 index 0000000..9a4db73 --- /dev/null +++ b/server/src/Model/Mail.hs @@ -0,0 +1,12 @@ +module Model.Mail + ( Mail(..) + ) where + +import Data.Text (Text) + +data Mail = Mail + { from :: Text + , to :: [Text] + , subject :: Text + , plainBody :: Text + } deriving (Eq, Show) diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/server/src/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs new file mode 100644 index 0000000..14efe77 --- /dev/null +++ b/server/src/Model/Payment.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Payment + ( Payment(..) + , find + , list + , listMonthly + , create + , createMany + , editOwn + , deleteOwn + , modifiedDuring + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) +import Database.SQLite.Simple.ToField (ToField(toField)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Frequency(..), Payment(..), PaymentId, UserId) + +import Model.Frequency () +import Model.Query (Query(Query)) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) + +instance Resource Payment where + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt + +instance FromRow Payment where + fromRow = Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +instance ToRow Payment where + toRow p = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_frequency p) + , toField (_payment_createdAt p) + ] + +find :: PaymentId -> Query (Maybe Payment) +find paymentId = + Query (\conn -> listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + ) + +list :: Query [Payment] +list = + Query (\conn -> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + ) + +listMonthly :: Query [Payment] +listMonthly = + Query (\conn -> + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) + (Only Monthly) + ) + +create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId +create userId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + SQLite.lastInsertRowId conn + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + payments + ) + +editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) + (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: UserId -> PaymentId -> Query Bool +deleteOwn userId paymentId = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE payment SET deleted_at = ? WHERE id = ?" + (now, paymentId) + return True + else + return False + Nothing -> + return False + ) + +modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] +modifiedDuring start end = + Query (\conn -> + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE (created_at >= ? AND created_at <= ?)" + , " OR (edited_at >= ? AND edited_at <= ?)" + , " OR (deleted_at >= ? AND deleted_at <= ?)" + ]) + (start, end, start, end, start, end) + ) diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs new file mode 100644 index 0000000..6e1d304 --- /dev/null +++ b/server/src/Model/PaymentCategory.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.PaymentCategory + ( list + , listByCategory + , save + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Data.Text as T +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T + +import Model.Query (Query(Query)) + +instance FromRow PaymentCategory where + fromRow = PaymentCategory <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [PaymentCategory] +list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") + +listByCategory :: CategoryId -> Query [PaymentCategory] +listByCategory cat = + Query (\conn -> + SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) + ) + +save :: Text -> CategoryId -> Query () +save newName categoryId = + Query (\conn -> do + now <- getCurrentTime + mbPaymentCategory <- listToMaybe <$> + (SQLite.query + conn + "SELECT * FROM payment_category WHERE name = ?" + (Only (formatPaymentName newName)) :: IO [PaymentCategory]) + if isJust mbPaymentCategory + then + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formatPaymentName newName) + else do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formatPaymentName newName, categoryId, now) + ) + where + formatPaymentName :: Text -> Text + formatPaymentName = T.unaccent . T.toLower diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs new file mode 100644 index 0000000..d15fb5f --- /dev/null +++ b/server/src/Model/Query.hs @@ -0,0 +1,32 @@ +module Model.Query + ( Query(..) + , run + ) where + +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) +import qualified Database.SQLite.Simple as SQLite + +data Query a = Query (Connection -> IO a) + +instance Functor Query where + fmap f (Query call) = Query (fmap f . call) + +instance Applicative Query where + pure x = Query (const $ return x) + (Query callF) <*> (Query callX) = Query (\conn -> do + x <- callX conn + f <- callF conn + return (f x)) + +instance Monad Query where + (Query callX) >>= f = Query (\conn -> do + x <- callX conn + case f x of Query callY -> callY conn) + +run :: Query a -> IO a +run (Query call) = do + conn <- SQLite.open "database" + result <- call conn + _ <- SQLite.close conn + return result diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs new file mode 100644 index 0000000..c5182f0 --- /dev/null +++ b/server/src/Model/SignIn.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.SignIn + ( SignIn(..) + , createSignInToken + , getSignIn + , signInTokenToUsed + , isLastTokenValid + ) where + +import Data.Int (Int64) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Database.SQLite.Simple as SQLite + +import Model.Query (Query(Query)) +import Model.UUID (generateUUID) + +type SignInId = Int64 + +data SignIn = SignIn + { id :: SignInId + , token :: Text + , creation :: UTCTime + , email :: Text + , isUsed :: Bool + } deriving Show + +instance FromRow SignIn where + fromRow = SignIn <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +createSignInToken :: Text -> Query Text +createSignInToken signInEmail = + Query (\conn -> do + now <- getCurrentTime + signInToken <- generateUUID + SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) + return signInToken + ) + +getSignIn :: Text -> Query (Maybe SignIn) +getSignIn signInToken = + Query (\conn -> do + listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) + ) + +signInTokenToUsed :: SignInId -> Query () +signInTokenToUsed tokenId = + Query (\conn -> + SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) + ) + +isLastTokenValid :: SignIn -> Query Bool +isLastTokenValid signIn = + Query (\conn -> do + [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) + return . maybe False (== (token signIn)) $ lastToken + ) diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs new file mode 100644 index 0000000..6cb7ce0 --- /dev/null +++ b/server/src/Model/UUID.hs @@ -0,0 +1,10 @@ +module Model.UUID + ( generateUUID + ) where + +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) +import Data.Text (Text, pack) + +generateUUID :: IO Text +generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs new file mode 100644 index 0000000..e14fcef --- /dev/null +++ b/server/src/Model/User.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.User + ( list + , get + , create + , delete + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (UserId, User(..)) + +import Model.Query (Query(Query)) + +instance FromRow User where + fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field + +list :: Query [User] +list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") + +get :: Text -> Query (Maybe User) +get userEmail = + Query (\conn -> listToMaybe <$> + SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + ) + +create :: Text -> Text -> Query UserId +create userEmail userName = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" + (now, userEmail, userName) + SQLite.lastInsertRowId conn + ) + +delete :: Text -> Query () +delete userEmail = + Query (\conn -> + SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) + ) diff --git a/server/src/Resource.hs b/server/src/Resource.hs new file mode 100644 index 0000000..f52bbfa --- /dev/null +++ b/server/src/Resource.hs @@ -0,0 +1,54 @@ +module Resource + ( Resource + , resourceCreatedAt + , resourceEditedAt + , resourceDeletedAt + , Status(..) + , statuses + , groupByStatus + , statusDuring + ) where + +import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Time.Clock (UTCTime) + +class Resource a where + resourceCreatedAt :: a -> UTCTime + resourceEditedAt :: a -> Maybe UTCTime + resourceDeletedAt :: a -> Maybe UTCTime + +data Status = + Created + | Edited + | Deleted + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +statuses :: [Status] +statuses = [minBound..] + +groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] +groupByStatus start end resources = + foldl + (\m resource -> + case statusDuring start end resource of + Just status -> M.insertWith (++) status [resource] m + Nothing -> m + ) + M.empty + resources + +statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status +statusDuring start end resource + | created && not deleted = Just Created + | not created && edited && not deleted = Just Edited + | not created && deleted = Just Deleted + | otherwise = Nothing + where + created = belongs (resourceCreatedAt resource) start end + edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) + deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) + +belongs :: UTCTime -> UTCTime -> UTCTime -> Bool +belongs time start end = time >= start && time < end diff --git a/server/src/Secure.hs b/server/src/Secure.hs new file mode 100644 index 0000000..f427304 --- /dev/null +++ b/server/src/Secure.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Secure + ( loggedAction + , getUserFromToken + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + +import Model.Query (Query) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User + +loggedAction :: (User -> ActionM ()) -> ActionM () +loggedAction action = do + maybeToken <- LoginSession.get + case maybeToken of + Just token -> do + maybeUser <- liftIO . Query.run . getUserFromToken $ token + case maybeUser of + Just user -> + action user + Nothing -> do + status forbidden403 + html . fromStrict . Message.get $ Key.Secure_Unauthorized + Nothing -> do + status forbidden403 + html . fromStrict . Message.get $ Key.Secure_Forbidden + +getUserFromToken :: Text -> Query (Maybe User) +getUserFromToken token = do + mbSignIn <- SignIn.getSignIn token + case mbSignIn of + Just signIn -> + User.get (SignIn.email signIn) + Nothing -> + return Nothing diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs new file mode 100644 index 0000000..f7ba3fd --- /dev/null +++ b/server/src/SendMail.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SendMail + ( sendMail + ) where + +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) + +import Data.Text (Text) +import Data.Text.Lazy.Builder (toLazyText, fromText) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified MimeMail as M + +import Model.Mail (Mail(Mail)) + +sendMail :: Mail -> IO (Either Text ()) +sendMail mail = do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else putStrLn "OK" + return result + +getMimeMail :: Mail -> M.Mail +getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = + let fromMail = M.emptyMail (address mailFrom) + in fromMail + { M.mailTo = map address mailTo + , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] + , M.mailHeaders = [("Subject", mailSubject)] + } + +address :: Text -> M.Address +address addressEmail = + M.Address + { M.addressName = Nothing + , M.addressEmail = addressEmail + } + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs new file mode 100644 index 0000000..97457c7 --- /dev/null +++ b/server/src/Utils/Time.hs @@ -0,0 +1,25 @@ +module Utils.Time + ( belongToCurrentMonth + , belongToCurrentWeek + , timeToDay + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/Validation.hs b/server/src/Validation.hs new file mode 100644 index 0000000..1f332c9 --- /dev/null +++ b/server/src/Validation.hs @@ -0,0 +1,23 @@ +module Validation + ( nonEmpty + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +nonEmpty :: Text -> Maybe Text +nonEmpty str = + if T.null str + then Nothing + else Just str + +number :: (Int -> Bool) -> Text -> Maybe Int +number numberForm str = + case reads (T.unpack str) :: [(Int, String)] of + (num, _) : _ -> + if numberForm num + then Just num + else Nothing + _ -> + Nothing diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs new file mode 100644 index 0000000..1daca1e --- /dev/null +++ b/server/src/View/Mail/SignIn.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.SignIn + ( mail + ) where + +import Data.Text (Text) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User(..)) + +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M + +mail :: Conf -> User -> Text -> [Text] -> M.Mail +mail conf user url to = + M.Mail + { M.from = Conf.noReplyMail conf + , M.to = to + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) + } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs new file mode 100644 index 0000000..b5f2b67 --- /dev/null +++ b/server/src/View/Mail/WeeklyReport.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.WeeklyReport + ( mail + ) where + +import Data.List (sortOn) +import Data.Map (Map) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import qualified Data.Map as M +import qualified Data.Text as T + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model as CM +import qualified Common.View.Format as Format + +import Model.Mail (Mail(Mail)) +import Model.Payment () +import qualified Model.Income () +import qualified Model.Mail as M +import Resource (Status(..), groupByStatus, statuses) +import Conf (Conf) +import qualified Conf as Conf + +mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail +mail conf users payments incomes start end = + Mail + { M.from = Conf.noReplyMail conf + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] + , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) + } + +body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +body conf users paymentsByStatus incomesByStatus = + if M.null paymentsByStatus && M.null incomesByStatus + then + Message.get Key.WeeklyReport_Empty + else + T.intercalate "\n" . catMaybes . concat $ + [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses + , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses + ] + +paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text +paymentSection status conf users payments = + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments + +payedFor :: Status -> Conf -> [User] -> Payment -> Text +payedFor status conf users payment = + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment + +incomeSection :: Status -> Conf -> [User] -> [Income] -> Text +incomeSection status conf users incomes = + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes + +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text +isPayedFrom status conf users income = + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income + +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap _user_name . CM.findUser userId + +section :: Text -> [Text] -> Text +section title items = + T.concat + [ title + , "\n\n" + , T.unlines . map (" - " <>) $ items + ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs new file mode 100644 index 0000000..6bf9527 --- /dev/null +++ b/server/src/View/Page.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Page + ( page + ) where + +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json + +import Text.Blaze.Html +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult) + +import Design.Global (globalDesign) + +page :: InitResult -> Text +page initResult = + renderHtml . docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" + H.title (toHtml $ Message.get Key.App_Title) + script ! src "javascript/main.js" $ "" + jsonScript "init" initResult + link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" + link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" + H.style $ toHtml globalDesign + +jsonScript :: Json.ToJSON a => Text -> a -> Html +jsonScript scriptId json = + script + ! A.id (toValue scriptId) + ! type_ "application/json" + $ toHtml . decodeUtf8 . encode $ json diff --git a/sharedCost.cabal b/sharedCost.cabal deleted file mode 100644 index 275c849..0000000 --- a/sharedCost.cabal +++ /dev/null @@ -1,104 +0,0 @@ -name: sharedCost -version: 0.1 -license: GPL-3 -license-file: LICENSE -author: Joris -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 - -executable sharedCost - main-is: Main.hs - hs-source-dirs: src/server - default-language: Haskell2010 - ghc-options: -Wall -Werror - build-depends: base < 5 - , scotty - , wai - , wai-middleware-static - , http-types - , http-conduit - , time - , text - , blaze-builder - , cookie - , bytestring - , monad-logger - , resourcet - , transformers - , blaze-html - , clay - , aeson - , clientsession - , uuid - , mtl - , lens - , parsec - , unordered-containers - , containers - , email-validate - , config-manager - , process - , sqlite-simple - - , random - , process - , filepath - , base64-bytestring - -- , mime-mail - - other-modules: Common.Model.SignIn - , Conf - , Controller.Category - , Controller.Income - , Controller.Index - , Controller.Payment - , Controller.SignIn - , Cookie - , Design.View.Payment.Table - , Design.View.Stat - , Design.View.Table - , Design.Media - , Design.Tooltip - , Design.Color - , Design.Constants - , Design.Dialog - , Design.Errors - , Design.Form - , Design.Global - , Design.Helper - , Design.Views - , Design.View.Header - , Design.View.Payment - , Design.View.Payment.Header - , Design.View.Payment.Pages - , Design.View.SignIn - , Job.Daemon - , Job.Frequency - , Job.Kind - , Job.Model - , Job.MonthlyPayment - , Job.WeeklyReport - , Json - , LoginSession - , MimeMail - , Model.Category - , Model.Frequency - , Model.Income - , Model.Init - , Model.Mail - , Model.Payer - , Model.Payment - , Model.PaymentCategory - , Model.Query - , Model.SignIn - , Model.UUID - , Model.User - , Resource - , Secure - , SendMail - , Utils.Time - , View.Mail.SignIn - , View.Mail.WeeklyReport - , View.Page diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 23a7255..0000000 --- a/shell.nix +++ /dev/null @@ -1,17 +0,0 @@ -with import {}; { - env = stdenv.mkDerivation { - name = "env"; - buildInputs = with pkgs; [ - elmPackages.elm - nodePackages.nodemon - sqlite - cabal-install - cabal2nix - tmux - tmuxinator - ]; - shellHook = '' - export PATH=node_modules/.bin:$PATH; - ''; - }; -} diff --git a/src/client/Common b/src/client/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/client/Common +++ /dev/null @@ -1 +0,0 @@ -../common \ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs deleted file mode 100644 index f21798c..0000000 --- a/src/client/Component/Button.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Component.Button - ( ButtonIn(..) - , buttonInDefault - , ButtonOut(..) - , button - ) where - -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R - -import qualified Icon - -data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool - } - -buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m -buttonInDefault = ButtonIn - { _buttonIn_class = "" - , _buttonIn_content = R.blank - , _buttonIn_waiting = R.never - } - -data ButtonOut t = ButtonOut - { _buttonOut_clic :: Event t () - } - -button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) -button buttonIn = do - attr <- R.holdDyn - (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) - (fmap - (\w -> M.fromList $ - [ ("type", "button") ] - <> if w - then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] - else [("class", _buttonIn_class buttonIn)]) - (_buttonIn_waiting buttonIn)) - (e, _) <- R.elDynAttr' "button" attr $ do - Icon.loading - R.divClass "content" $ _buttonIn_content buttonIn - return $ ButtonOut - { _buttonOut_clic = R.domEvent R.Click e - } diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs deleted file mode 100644 index 7111630..0000000 --- a/src/client/Component/Input.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Component.Input - ( InputIn(..) - , InputOut(..) - , input - ) where - -import Data.Text (Text) -import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) -import qualified Reflex.Dom as R - -data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_placeHolder :: Text - } - -data InputOut t = InputOut - { _inputOut_value :: Dynamic t Text - , _inputOut_enter :: Event t () - } - -input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = do - let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) - let value = fmap (const "") (_inputIn_reset inputIn) - textInput <- R.textInput $ R.def & R.attributes .~ placeHolder - & R.setValue .~ value - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_value = R._textInput_value textInput - , _inputOut_enter = enter - } diff --git a/src/client/Debug.hs b/src/client/Debug.hs deleted file mode 100644 index 0c5c979..0000000 --- a/src/client/Debug.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Debug - ( event - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event, Dynamic) -import qualified Reflex.Dom as R - -event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () -event name e = do - count <- R.count e :: m (Dynamic t Int) - let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count - R.el "div" $ R.dynText text diff --git a/src/client/Icon.hs b/src/client/Icon.hs deleted file mode 100644 index 7223def..0000000 --- a/src/client/Icon.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Icon - ( loading - , signOut - , clone - , edit - , delete - ) where - -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank - -clone :: forall t m. MonadWidget t m => m () -clone = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank - -edit :: forall t m. MonadWidget t m => m () -edit = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank - -delete :: forall t m. MonadWidget t m => m () -delete = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank - -svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a -svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/src/client/Main.hs b/src/client/Main.hs deleted file mode 100644 index c5f2c50..0000000 --- a/src/client/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Main - ( main - ) where - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LB -import Data.JSString.Text (textFromJSString) -import qualified Data.Text.Encoding as T -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.NonElementParentNode as Dom -import GHCJS.DOM.Types (JSM, Element, JSString) -import Prelude hiding (init, error) - -import Common.Model (InitResult(InitEmpty)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key - -import qualified View.App as App - -main :: JSM () -main = do - initResult <- readInit - putStrLn . show $ initResult - App.widget initResult - -readInit :: JSM InitResult -readInit = do - document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document "init" - case initNode of - Just node -> do - text <- textFromJSString <$> js_getInnerText node - return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of - Just init -> init - Nothing -> initParseError - _ -> - return initParseError - where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) - -foreign import javascript unsafe "$1[\"innerText\"]" - js_getInnerText :: Element -> IO JSString diff --git a/src/client/View/App.hs b/src/client/View/App.hs deleted file mode 100644 index 1466811..0000000 --- a/src/client/View/App.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.App - ( widget - ) where - -import qualified Reflex.Dom as R -import Prelude hiding (init, error) - -import Common.Model (InitResult(..)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key - -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn - -widget :: InitResult -> IO () -widget initResult = - R.mainWidget $ do - headerOut <- Header.view $ HeaderIn - { _headerIn_initResult = initResult - } - - let signOut = Header._headerOut_signOut headerOut - - initialContent = case initResult of - InitSuccess initSuccess -> do - _ <- Payment.widget $ PaymentIn - { _paymentIn_init = initSuccess - } - return () - InitEmpty result -> - SignIn.view result - - signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) - - _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) - - R.blank diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs deleted file mode 100644 index 32738f1..0000000 --- a/src/client/View/Header.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Header - ( view - , HeaderIn(..) - , HeaderOut(..) - ) where - -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model.User as User - -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component -import qualified Icon - -data HeaderIn = HeaderIn - { _headerIn_initResult :: InitResult - } - -data HeaderOut t = HeaderOut - { _headerOut_signOut :: Event t () - } - -view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) -view headerIn = - R.el "header" $ do - - R.divClass "title" $ - R.text $ Message.get Key.App_Title - - signOut <- nameSignOut $ _headerIn_initResult headerIn - - return $ HeaderOut - { _headerOut_signOut = signOut - } - -nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) -nameSignOut initResult = case initResult of - (InitSuccess init) -> do - rec - attr <- R.holdDyn - (M.singleton "class" "nameSignOut") - (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) - - signOut <- R.elDynAttr "nameSignOut" attr $ do - case User.find (_init_currentUser init) (_init_users init) of - Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank - signOutButton - - return signOut - _ -> - return R.never - -signOutButton :: forall t m. MonadWidget t m => m (Event t ()) -signOutButton = do - rec - signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = "signOut item" - , Component._buttonIn_content = Icon.signOut - , Component._buttonIn_waiting = waiting - } - let signOutClic = Component._buttonOut_clic signOut - waiting = R.leftmost - [ fmap (const True) signOutClic - , fmap (const False) signOutSuccess - ] - signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) - - return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess - - where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) - askSignOut signOut = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut - getResult = (== 200) . R._xhrResponse_status diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs deleted file mode 100644 index e80790b..0000000 --- a/src/client/View/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Payment - ( widget - , PaymentIn(..) - , PaymentOut(..) - ) where - -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init) - -import View.Payment.Table (TableIn(..)) -import qualified View.Payment.Table as Table - -data PaymentIn = PaymentIn - { _paymentIn_init :: Init - } - -data PaymentOut = PaymentOut - { - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut -widget paymentIn = do - R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - return $ PaymentOut {} diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs deleted file mode 100644 index 878e7da..0000000 --- a/src/client/View/Payment/Table.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Payment.Table - ( widget - , TableIn(..) - , TableOut(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model.User as User -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format - -import qualified Icon - -data TableIn = TableIn - { _tableIn_init :: Init - } - -data TableOut = TableOut - { - } - -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut -widget tableIn = do - R.divClass "table" $ - R.divClass "lines" $ do - R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name - R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost - R.divClass "cell user" $ R.text $ Message.get Key.Payment_User - R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category - R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - let init = _tableIn_init tableIn - payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) - return $ TableOut {} - -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () -paymentRow init payment = - R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment - R.divClass "cell user" $ - case User.find (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) - R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank - -findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category -findCategory categories paymentCategories paymentName = do - paymentCategory <- L.find - ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) - paymentCategories - L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs deleted file mode 100644 index e164ee7..0000000 --- a/src/client/View/SignIn.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.SignIn - ( view - ) where - -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) - -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component - -view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () -view result = - R.divClass "signIn" $ do - rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder - } - - let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button - - dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ - [ fmap (const True) userWantsEmailValidation - , fmap (const False) signInResult - ] - - uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail - - let validatedEmail = R.tagPromptlyDyn - (_inputOut_value input) - (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) - - let waiting = R.leftmost - [ fmap (const True) validatedEmail - , fmap (const False) signInResult - ] - - button <- Component.button $ ButtonIn - { _buttonIn_class = "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) - , _buttonIn_waiting = waiting - } - - signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) - - showSignInResult result signInResult - -askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) -askSignIn email = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email - getResult response = - case R._xhrResponse_responseText response of - Just key -> - if R._xhrResponse_status response == 200 then Right key else Left key - _ -> Left "NoKey" - -showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () -showSignInResult result signInResult = do - _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult - R.blank - - where showInitResult (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank - - showResult (Left error) = showError error - showResult (Right success) = showSuccess success - - showError = R.divClass "error" . R.text - showSuccess = R.divClass "success" . R.text diff --git a/src/common/Message.hs b/src/common/Message.hs deleted file mode 100644 index 9ae735d..0000000 --- a/src/common/Message.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Common.Message - ( get - ) where - -import Data.Text (Text) - -import Common.Message.Key (Key) -import Common.Message.Lang (Lang(..)) -import qualified Common.Message.Translation as Translation - -get :: Key -> Text -get = Translation.get French diff --git a/src/common/Message/Key.hs b/src/common/Message/Key.hs deleted file mode 100644 index 4127808..0000000 --- a/src/common/Message/Key.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Common.Message.Key - ( Key(..) - ) where - -import Data.Text - -data Key = - - App_Title - - | Category_Add - | Category_Clone - | Category_Color - | Category_DeleteConfirm - | Category_Edit - | Category_Empty - | Category_Name - | Category_NotDeleted - | Category_Title - | Category_Used - - | Date_Long Int Text Int - | Date_Short Int Int Int - | Date_ShortMonthAndYear Int Int - - | Dialog_Confirm - | Dialog_Undo - - | Error_CategoryCreate - | Error_CategoryDelete - | Error_CategoryEdit - | Error_IncomeCreate - | Error_IncomeDelete - | Error_IncomeEdit - | Error_PaymentCreate - | Error_PaymentDelete - | Error_PaymentEdit - | Error_SignOut - - | Form_AlreadyExists - | Form_CostMustNotBeNull - | Form_Empty - | Form_GreaterIntThan Int - | Form_InvalidCategory - | Form_InvalidColor - | Form_InvalidDate - | Form_InvalidInt - | Form_InvalidString - | Form_SmallerIntThan Int - - | HttpError_BadPayload - | HttpError_BadUrl - | HttpError_NetworkError - | HttpError_Timeout - - | Income_AddLong - | Income_AddShort - | Income_Amount - | Income_Clone - | Income_CumulativeSince Text - | Income_Date - | Income_DeleteConfirm - | Income_Edit - | Income_Empty - | Income_MonthlyNet - | Income_NotDeleted - | Income_Title - - | Month_January - | Month_February - | Month_March - | Month_April - | Month_May - | Month_June - | Month_July - | Month_August - | Month_September - | Month_October - | Month_November - | Month_December - - | PageNotFound_Title - - | Payment_Add - | Payment_Balanced - | Payment_Category - | Payment_CloneLong - | Payment_CloneShort - | Payment_Cost - | Payment_Date - | Payment_Delete - | Payment_DeleteConfirm - | Payment_EditLong - | Payment_EditShort - | Payment_Empty - | Payment_Frequency - | Payment_InvalidFrequency - | Payment_Many - | Payment_MonthlyFemale - | Payment_MonthlyMale - | Payment_Name - | Payment_NotDeleted - | Payment_One - | Payment_PunctualFemale - | Payment_PunctualMale - | Payment_Title - | Payment_User - | Payment_Worth Text Text - - | Search_Monthly - | Search_Name - | Search_Punctual - - | Secure_Forbidden - | Secure_Unauthorized - - | SignIn_Button - | SignIn_DisconnectSuccess - | SignIn_EmailInvalid - | SignIn_EmailPlaceholder - | SignIn_EmailSendFail - | SignIn_EmailSent - | SignIn_LinkExpired - | SignIn_LinkInvalid - | SignIn_LinkUsed - | SignIn_MailTitle - | SignIn_MailBody Text Text - | SignIn_ParseError - - | Statistic_Title - | Statistic_ByMonthsAndMean Text - | Statistic_By Text Text - | Statistic_Total - - | WeeklyReport_Empty - | WeeklyReport_IncomesCreated Int - | WeeklyReport_IncomesDeleted Int - | WeeklyReport_IncomesEdited Int - | WeeklyReport_IncomeCreated Int - | WeeklyReport_IncomeDeleted Int - | WeeklyReport_IncomeEdited Int - | WeeklyReport_PayedFor Text Text Text Text - | WeeklyReport_PayedForNot Text Text Text Text - | WeeklyReport_PayedFrom Text Text Text - | WeeklyReport_PayedFromNot Text Text Text - | WeeklyReport_PaymentsCreated Int - | WeeklyReport_PaymentsDeleted Int - | WeeklyReport_PaymentsEdited Int - | WeeklyReport_PaymentCreated Int - | WeeklyReport_PaymentDeleted Int - | WeeklyReport_PaymentEdited Int - | WeeklyReport_Title diff --git a/src/common/Message/Lang.hs b/src/common/Message/Lang.hs deleted file mode 100644 index 0a32ede..0000000 --- a/src/common/Message/Lang.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Common.Message.Lang - ( Lang(..) - ) where - -data Lang = - English - | French diff --git a/src/common/Message/Translation.hs b/src/common/Message/Translation.hs deleted file mode 100644 index 900a9e9..0000000 --- a/src/common/Message/Translation.hs +++ /dev/null @@ -1,697 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Common.Message.Translation - ( get - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Common.Message.Key -import Common.Message.Lang (Lang(..)) - -get :: Lang -> Key -> Text -get = m - -m :: Lang -> Key -> Text - -m l App_Title = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - -m l Category_Add = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l Category_Clone = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l Category_Color = - case l of - English -> "Color" - French -> "Couleur" - -m l Category_DeleteConfirm = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l Category_Edit = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l Category_Empty = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l Category_Name = - case l of - English -> "Name" - French -> "Nom" - -m l Category_NotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n’a pas pu être supprimé." - -m l Category_Title = - case l of - English -> "Categories" - French -> "Catégories" - -m l Category_Used = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - -m l (Date_Short day month year) = - case l of - English -> - T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] - French -> - T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] - where padded num pad = - let str = show num - in T.pack $ replicate (pad - length str) '0' ++ str - -m l (Date_ShortMonthAndYear month year) = - case l of - English -> - T.intercalate "-" . map (T.pack . show) $ [ year, month ] - French -> - T.intercalate "/" . map (T.pack . show) $ [ month, year ] - -m l (Date_Long day month year) = - case l of - English -> - T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] - French -> - T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] - -m l Dialog_Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Dialog_Undo = - case l of - English -> "Undo" - French -> "Annuler" - -m l Error_CategoryCreate = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l Error_CategoryDelete = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l Error_CategoryEdit = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l Error_IncomeCreate = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l Error_IncomeDelete = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l Error_IncomeEdit = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l Error_PaymentCreate = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l Error_PaymentDelete = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l Error_PaymentEdit = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l Error_SignOut = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - -m l Form_AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l Form_CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l Form_Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l (Form_GreaterIntThan number) = - case l of - English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] - French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] - -m l Form_InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l Form_InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l Form_InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l Form_InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l Form_InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l (Form_SmallerIntThan number) = - case l of - English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] - French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] - -m l HttpError_BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" - -m l HttpError_BadUrl = - case l of - English -> "URL not valid" - French -> "l’URL n’est pas valide" - -m l HttpError_NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n’est pas accessible" - -m l HttpError_Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l Income_AddLong = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l Income_AddShort = - case l of - English -> "Add" - French -> "Ajouter" - -m l Income_Amount = - case l of - English -> "Amount" - French -> "Montant" - -m l Income_Clone = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l (Income_CumulativeSince since) = - case l of - English -> T.concat [ "Cumulative incomes since ", since ] - French -> T.concat [ "Revenus nets cumulés depuis le ", since ] - -m l Income_Date = - case l of - English -> "Date" - French -> "Date" - -m l Income_DeleteConfirm = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Income_Edit = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l Income_Empty = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income_MonthlyNet = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l Income_NotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n’a pas pu être supprimé." - -m l Income_Title = - case l of - English -> "Income" - French -> "Revenu" - -m l Month_January = - case l of - English -> "january" - French -> "janvier" - -m l Month_February = - case l of - English -> "february" - French -> "février" - -m l Month_March = - case l of - English -> "march" - French -> "mars" - -m l Month_April = - case l of - English -> "april" - French -> "avril" - -m l Month_May = - case l of - English -> "may" - French -> "mai" - -m l Month_June = - case l of - English -> "june" - French -> "juin" - -m l Month_July = - case l of - English -> "july" - French -> "juillet" - -m l Month_August = - case l of - English -> "august" - French -> "août" - -m l Month_September = - case l of - English -> "september" - French -> "septembre" - -m l Month_October = - case l of - English -> "october" - French -> "octobre" - -m l Month_November = - case l of - English -> "november" - French -> "novembre" - -m l Month_December = - case l of - English -> "december" - French -> "décembre" - -m l PageNotFound_Title = - case l of - English -> "Page not found" - French -> "Page introuvable" - -m l Payment_Add = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l Payment_Balanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Payment_Category = - case l of - English -> "Category" - French -> "Catégorie" - -m l Payment_CloneLong = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l Payment_CloneShort = - case l of - English -> "Clone" - French -> "Cloner" - -m l Payment_Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payment_Date = - case l of - English -> "Date" - French -> "Date" - -m l Payment_Delete = - case l of - English -> "Delete" - French -> "Supprimer" - -m l Payment_DeleteConfirm = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Payment_EditLong = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l Payment_EditShort = - case l of - English -> "Edit" - French -> "Modifier" - -m l Payment_Empty = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l Payment_Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l Payment_InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l Payment_Many = - case l of - English -> "payments" - French -> "paiements" - -m l Payment_MonthlyFemale = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l Payment_MonthlyMale = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l Payment_Name = - case l of - English -> "Name" - French -> "Nom" - -m l Payment_NotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n’a pas pu être supprimé." - -m l Payment_One = - case l of - English -> "payment" - French -> "paiement" - -m l Payment_PunctualFemale = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Payment_PunctualMale = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l Payment_Title = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment_User = - case l of - English -> "Payer" - French -> "Payeur" - -m l (Payment_Worth subject amount) = - case l of - English -> T.concat [ subject, " worth ", amount ] - French -> T.concat [ subject, " comptabilisant ", amount ] - -m l Search_Monthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l Search_Name = - case l of - English -> "Search" - French -> "Recherche" - -m l Search_Punctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l Secure_Unauthorized = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n’es pas autorisé à te connecter." - -m l Secure_Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SignIn_Button = - case l of - English -> "Sign in" - French -> "Connexion" - -m l SignIn_DisconnectSuccess = - case l of - English -> "You have successfully disconnected" - French -> "Vous êtes à présent déconnecté." - -m l SignIn_EmailInvalid = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n’est pas valide." - -m l SignIn_EmailPlaceholder = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn_EmailSendFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." - -m l SignIn_EmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." - -m l SignIn_LinkExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignIn_LinkInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - -m l SignIn_LinkUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignIn_MailTitle = - case l of - English -> T.concat [ "Sign in to ", m l App_Title ] - French -> T.concat [ "Connexion à ", m l App_Title ] - -m l (SignIn_MailBody name url) = - T.intercalate - "\n" - ( case l of - English -> - [ T.concat [ "Hi ", name, "," ] - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l App_Title - , ":" - ] - , url - , "" - , "See you soon!" - ] - French -> - [ T.concat [ "Salut ", name, "," ] - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l App_Title - , ":" - ] - , url - , "" - , "À très vite !" - ] - ) - -m l SignIn_ParseError = - case l of - English -> "Error while reading initial data." - French -> "Erreur lors de la lecture des données initiales." - -m l (Statistic_By key value) = - case l of - English -> T.concat [ key, ": ", value ] - French -> T.concat [ key, " : ", value ] - -m l (Statistic_ByMonthsAndMean amount) = - case l of - English -> - T.concat [ "Payments by category by month months (", amount, "on average)" ] - French -> - T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] - -m l Statistic_Title = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l Statistic_Total = - case l of - English -> "Total" - French -> "Total" - -m l WeeklyReport_Empty = - case l of - English -> "No activity the previous week." - French -> "Pas d’activité la semaine passée." - -m l (WeeklyReport_IncomesCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes created:" ] - French -> T.concat [ T.pack . show $ count, " revenus créés :" ] - -m l (WeeklyReport_IncomesDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] - French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] - -m l (WeeklyReport_IncomesEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes edited:" ] - French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] - -m l (WeeklyReport_IncomeCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " income created:" ] - French -> T.concat [ T.pack . show $ count, " revenu créé :" ] - -m l (WeeklyReport_IncomeDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " income deleted:" ] - French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] - -m l (WeeklyReport_IncomeEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " income edited:" ] - French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] - -m l (WeeklyReport_PayedFor name amount for at) = - case l of - English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] - -m l (WeeklyReport_PayedForNot name amount for at) = - case l of - English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] - -m l (WeeklyReport_PayedFrom name amount for) = - case l of - English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] - -m l (WeeklyReport_PayedFromNot name amount for) = - case l of - English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] - -m l (WeeklyReport_PaymentsCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments created:" ] - French -> T.concat [ T.pack . show $ count, " paiements créés :" ] - -m l (WeeklyReport_PaymentsDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments deleted:" ] - French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] - -m l (WeeklyReport_PaymentsEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments edited:" ] - French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] - -m l (WeeklyReport_PaymentCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment created:" ] - French -> T.concat [ T.pack . show $ count, " paiement créé :" ] - -m l (WeeklyReport_PaymentDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment deleted:" ] - French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] - -m l (WeeklyReport_PaymentEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment edited:" ] - French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] - -m l WeeklyReport_Title = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" diff --git a/src/common/Model.hs b/src/common/Model.hs deleted file mode 100644 index 075021f..0000000 --- a/src/common/Model.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Common.Model - ( Category(..) - , CategoryId - , CreateCategory(..) - , CreateIncome(..) - , CreatePayment(..) - , Currency(..) - , EditCategory(..) - , EditIncome(..) - , EditPayment(..) - , Frequency(..) - , Income(..) - , IncomeId - , Init(..) - , InitResult(..) - , Payment(..) - , PaymentId - , PaymentCategory(..) - , PaymentCategoryId - , SignIn(..) - , User(..) - , UserId - ) where - -import Common.Model.Category (Category(..), CategoryId) -import Common.Model.CreateCategory (CreateCategory(..)) -import Common.Model.CreateIncome (CreateIncome(..)) -import Common.Model.CreatePayment (CreatePayment(..)) -import Common.Model.Currency (Currency(..)) -import Common.Model.EditCategory (EditCategory(..)) -import Common.Model.EditIncome (EditIncome(..)) -import Common.Model.EditPayment (EditPayment(..)) -import Common.Model.Frequency (Frequency(..)) -import Common.Model.Income (Income(..), IncomeId) -import Common.Model.Init (Init(..)) -import Common.Model.InitResult (InitResult(..)) -import Common.Model.Payment (Payment(..), PaymentId) -import Common.Model.PaymentCategory (PaymentCategory(..), PaymentCategoryId) -import Common.Model.SignIn (SignIn(..)) -import Common.Model.User (User(..), UserId) diff --git a/src/common/Model/Category.hs b/src/common/Model/Category.hs deleted file mode 100644 index 53a6bdb..0000000 --- a/src/common/Model/Category.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Category - ( CategoryId - , Category(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -type CategoryId = Int64 - -data Category = Category - { _category_id :: CategoryId - , _category_name :: Text - , _category_color :: Text - , _category_createdAt :: UTCTime - , _category_editedAt :: Maybe UTCTime - , _category_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Category -instance ToJSON Category diff --git a/src/common/Model/CreateCategory.hs b/src/common/Model/CreateCategory.hs deleted file mode 100644 index bfe24c5..0000000 --- a/src/common/Model/CreateCategory.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreateCategory - ( CreateCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data CreateCategory = CreateCategory - { _createCategory_name :: Text - , _createCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/common/Model/CreateIncome.hs b/src/common/Model/CreateIncome.hs deleted file mode 100644 index 4ee3a50..0000000 --- a/src/common/Model/CreateIncome.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreateIncome - ( CreateIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -data CreateIncome = CreateIncome - { _createIncome_date :: Day - , _createIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/common/Model/CreatePayment.hs b/src/common/Model/CreatePayment.hs deleted file mode 100644 index b5b6256..0000000 --- a/src/common/Model/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { _createPayment_name :: Text - , _createPayment_cost :: Int - , _createPayment_date :: Day - , _createPayment_category :: CategoryId - , _createPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/common/Model/Currency.hs b/src/common/Model/Currency.hs deleted file mode 100644 index 7c12545..0000000 --- a/src/common/Model/Currency.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Currency - ( Currency(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -newtype Currency = Currency Text deriving (Show, Generic) - -instance FromJSON Currency -instance ToJSON Currency diff --git a/src/common/Model/EditCategory.hs b/src/common/Model/EditCategory.hs deleted file mode 100644 index 2a3a697..0000000 --- a/src/common/Model/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text - , _editCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/common/Model/EditIncome.hs b/src/common/Model/EditIncome.hs deleted file mode 100644 index a55c39e..0000000 --- a/src/common/Model/EditIncome.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditIncome - ( EditIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Income (IncomeId) - -data EditIncome = EditIncome - { _editIncome_id :: IncomeId - , _editIncome_date :: Day - , _editIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/common/Model/EditPayment.hs b/src/common/Model/EditPayment.hs deleted file mode 100644 index 172c0c1..0000000 --- a/src/common/Model/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) -import Common.Model.Payment (PaymentId) - -data EditPayment = EditPayment - { _editPayment_id :: PaymentId - , _editPayment_name :: Text - , _editPayment_cost :: Int - , _editPayment_date :: Day - , _editPayment_category :: CategoryId - , _editPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/common/Model/Frequency.hs b/src/common/Model/Frequency.hs deleted file mode 100644 index 7c46605..0000000 --- a/src/common/Model/Frequency.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Frequency - ( Frequency(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -data Frequency = - Punctual - | Monthly - deriving (Eq, Read, Show, Generic) - -instance FromJSON Frequency -instance ToJSON Frequency diff --git a/src/common/Model/Income.hs b/src/common/Model/Income.hs deleted file mode 100644 index 280812f..0000000 --- a/src/common/Model/Income.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Income - ( IncomeId - , Income(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.User (UserId) - -type IncomeId = Int64 - -data Income = Income - { _income_id :: IncomeId - , _income_userId :: UserId - , _income_date :: Day - , _income_amount :: Int - , _income_createdAt :: UTCTime - , _income_editedAt :: Maybe UTCTime - , _income_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Income -instance ToJSON Income diff --git a/src/common/Model/Init.hs b/src/common/Model/Init.hs deleted file mode 100644 index 68fcfb8..0000000 --- a/src/common/Model/Init.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Init - ( Init(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Category (Category) -import Common.Model.Currency (Currency) -import Common.Model.Income (Income) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.User (UserId, User) - -data Init = Init - { _init_users :: [User] - , _init_currentUser :: UserId - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - , _init_currency :: Currency - } deriving (Show, Generic) - -instance FromJSON Init -instance ToJSON Init diff --git a/src/common/Model/InitResult.hs b/src/common/Model/InitResult.hs deleted file mode 100644 index 43c16f9..0000000 --- a/src/common/Model/InitResult.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.InitResult - ( InitResult(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Init (Init) - -data InitResult = - InitSuccess Init - | InitEmpty (Either Text (Maybe Text)) - deriving (Show, Generic) - -instance FromJSON InitResult -instance ToJSON InitResult diff --git a/src/common/Model/Payment.hs b/src/common/Model/Payment.hs deleted file mode 100644 index 804b501..0000000 --- a/src/common/Model/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Payment - ( PaymentId - , Payment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Frequency -import Common.Model.User (UserId) - -type PaymentId = Int64 - -data Payment = Payment - { _payment_id :: PaymentId - , _payment_user :: UserId - , _payment_name :: Text - , _payment_cost :: Int - , _payment_date :: Day - , _payment_frequency :: Frequency - , _payment_createdAt :: UTCTime - , _payment_editedAt :: Maybe UTCTime - , _payment_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment diff --git a/src/common/Model/PaymentCategory.hs b/src/common/Model/PaymentCategory.hs deleted file mode 100644 index a0e94f9..0000000 --- a/src/common/Model/PaymentCategory.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -type PaymentCategoryId = Int64 - -data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId - , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON PaymentCategory -instance ToJSON PaymentCategory diff --git a/src/common/Model/SignIn.hs b/src/common/Model/SignIn.hs deleted file mode 100644 index f4da97f..0000000 --- a/src/common/Model/SignIn.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.SignIn - ( SignIn(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data SignIn = SignIn - { _signIn_email :: Text - } deriving (Show, Generic) - -instance FromJSON SignIn -instance ToJSON SignIn diff --git a/src/common/Model/User.hs b/src/common/Model/User.hs deleted file mode 100644 index 8c64bc2..0000000 --- a/src/common/Model/User.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.User - ( UserId - , User(..) - , find - ) where - -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.List as L -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -type UserId = Int64 - -data User = User - { _user_id :: UserId - , _user_creation :: UTCTime - , _user_email :: Text - , _user_name :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -find :: UserId -> [User] -> Maybe User -find userId users = L.find ((== userId) . _user_id) users diff --git a/src/common/Util/Text.hs b/src/common/Util/Text.hs deleted file mode 100644 index 4af7a4c..0000000 --- a/src/common/Util/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Common.Util.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/common/View/Format.hs b/src/common/View/Format.hs deleted file mode 100644 index a7fa4e3..0000000 --- a/src/common/View/Format.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Common.View.Format - ( shortDay - , longDay - , price - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, toGregorian) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.Currency (Currency(..)) - -shortDay :: Day -> Text -shortDay date = - Message.get $ Key.Date_Short - day - month - (fromIntegral year) - where (year, month, day) = toGregorian date - -longDay :: Day -> Text -longDay date = - Message.get $ Key.Date_Long - day - (fromMaybe "−" . fmap Message.get . monthToKey $ month) - (fromIntegral year) - where (year, month, day) = toGregorian date - - monthToKey 1 = Just Key.Month_January - monthToKey 2 = Just Key.Month_February - monthToKey 3 = Just Key.Month_March - monthToKey 4 = Just Key.Month_April - monthToKey 5 = Just Key.Month_May - monthToKey 6 = Just Key.Month_June - monthToKey 7 = Just Key.Month_July - monthToKey 8 = Just Key.Month_August - monthToKey 9 = Just Key.Month_September - monthToKey 10 = Just Key.Month_October - monthToKey 11 = Just Key.Month_November - monthToKey 12 = Just Key.Month_December - monthToKey _ = Nothing - -price :: Currency -> Int -> Text -price (Currency currency) amount = T.concat [ number amount, " ", currency ] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/migrations/1.sql b/src/migrations/1.sql deleted file mode 100644 index d7c300e..0000000 --- a/src/migrations/1.sql +++ /dev/null @@ -1,65 +0,0 @@ -CREATE TABLE IF NOT EXISTS "user" ( - "id" INTEGER PRIMARY KEY, - "creation" TIMESTAMP NOT NULL, - "email" VARCHAR NOT NULL, - "name" VARCHAR NOT NULL, - CONSTRAINT "uniq_user_email" UNIQUE ("email"), - CONSTRAINT "uniq_user_name" UNIQUE ("name") -); - -CREATE TABLE IF NOT EXISTS "job" ( - "id" INTEGER PRIMARY KEY, - "kind" VARCHAR NOT NULL, - "last_execution" TIMESTAMP NULL, - "last_check" TIMESTAMP NULL, - CONSTRAINT "uniq_job_kind" UNIQUE ("kind") -); - -CREATE TABLE IF NOT EXISTS "sign_in"( - "id" INTEGER PRIMARY KEY, - "token" VARCHAR NOT NULL, - "creation" TIMESTAMP NOT NULL, - "email" VARCHAR NOT NULL, - "is_used" BOOLEAN NOT NULL, - CONSTRAINT "uniq_sign_in_token" UNIQUE ("token") -); - -CREATE TABLE IF NOT EXISTS "payment"( - "id" INTEGER PRIMARY KEY, - "user_id" INTEGER NOT NULL REFERENCES "user", - "name" VARCHAR NOT NULL, - "cost" INTEGER NOT NULL, - "date" DATE NOT NULL, - "frequency" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "income"( - "id" INTEGER PRIMARY KEY, - "user_id" INTEGER NOT NULL REFERENCES "user", - "date" DATE NOT NULL, - "amount" INTEGERNOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "category"( - "id" INTEGER PRIMARY KEY, - "name" VARCHAR NOT NULL, - "color" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "payment_category"( - "id" INTEGER PRIMARY KEY, - "name" VARCHAR NOT NULL, - "category" INTEGER NOT NULL REFERENCES "category", - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - CONSTRAINT "uniq_payment_category_name" UNIQUE ("name") -); diff --git a/src/migrations/2.sql b/src/migrations/2.sql deleted file mode 100644 index ec0d1b0..0000000 --- a/src/migrations/2.sql +++ /dev/null @@ -1,23 +0,0 @@ -BEGIN TRANSACTION; - -ALTER TABLE payment RENAME TO tmp_payment; - -CREATE TABLE IF NOT EXISTS "payment"( - "id" INTEGER PRIMARY KEY, - "user" INTEGER NOT NULL REFERENCES "user", - "name" VARCHAR NOT NULL, - "cost" INTEGER NOT NULL, - "date" DATE NOT NULL, - "frequency" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -INSERT INTO payment(id, user, name, cost, date, frequency, created_at, edited_at, deleted_at) -SELECT id, user_id, name, cost, date, frequency, created_at, edited_at, deleted_at -FROM tmp_payment; - -DROP TABLE tmp_payment; - -COMMIT; diff --git a/src/server/Common b/src/server/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/server/Common +++ /dev/null @@ -1 +0,0 @@ -../common \ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs deleted file mode 100644 index 92df4e9..0000000 --- a/src/server/Conf.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Conf - ( get - , Conf(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) - -import Common.Model.Currency (Currency(..)) - -data Conf = Conf - { hostname :: Text - , port :: Int - , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: Bool - } deriving Show - -get :: FilePath -> IO Conf -get path = do - conf <- - (flip fmap) (Conf.readConfig path) (\configOrError -> do - conf <- configOrError - Conf <$> - Conf.lookup "hostname" conf <*> - Conf.lookup "port" conf <*> - Conf.lookup "signInExpiration" conf <*> - fmap Currency (Conf.lookup "currency" conf) <*> - Conf.lookup "noReplyMail" conf <*> - Conf.lookup "https" conf - ) - case conf of - Left msg -> error (T.unpack msg) - Right c -> return c diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs deleted file mode 100644 index 1a44083..0000000 --- a/src/server/Controller/Category.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Category - ( create - , edit - , delete - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty hiding (delete) - -import Common.Model.Category (CategoryId) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.CreateCategory as Json -import qualified Common.Model.EditCategory as Json - -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -create :: Json.CreateCategory -> ActionM () -create (Json.CreateCategory name color) = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Category.create name color) >>= jsonId - ) - -edit :: Json.EditCategory -> ActionM () -edit (Json.EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color - if updated - then status ok200 - else status badRequest400 - ) - -delete :: CategoryId -> ActionM () -delete categoryId = - Secure.loggedAction (\_ -> do - deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId - if null paymentCategories - then Category.delete categoryId - else return False - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted - ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs deleted file mode 100644 index 148b713..0000000 --- a/src/server/Controller/Income.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Income - ( create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) - -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query -import qualified Secure - -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId - ) - -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted - ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs deleted file mode 100644 index 8473c5c..0000000 --- a/src/server/Controller/Index.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Controller.Index - ( get - , signOut - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) - -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) - -import Conf (Conf(..)) -import Model.Init (getInit) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) - -get :: Conf -> Maybe Text -> ActionM () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of - Nothing -> - return . Left $ Key.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Key.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Key.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized - Just user -> Right user - -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of - Nothing -> - return Nothing - Just token -> do - liftIO . Query.run . getUserFromToken $ token - -signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs deleted file mode 100644 index 6a9ede7..0000000 --- a/src/server/Controller/Payment.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Payment - ( list - , create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import qualified Common.Model.CreatePayment as M -import qualified Common.Model.EditPayment as M -import Common.Model (PaymentId, User(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json - ) - -create :: M.CreatePayment -> ActionM () -create (M.CreatePayment name cost date category frequency) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId - ) - -editOwn :: M.EditPayment -> ActionM () -editOwn (M.EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency - _ <- if edited - then PaymentCategory.save name category >> return () - else return () - return edited - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId - if deleted - then status ok200 - else status badRequest400 - ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs deleted file mode 100644 index 932ce53..0000000 --- a/src/server/Controller/SignIn.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.SignIn as M - -import Conf (Conf) -import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn - -signIn :: Conf -> M.SignIn -> ActionM () -signIn conf (M.SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Cookie.hs b/src/server/Cookie.hs deleted file mode 100644 index 96d45da..0000000 --- a/src/server/Cookie.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Cookie - ( makeSimpleCookie - , setCookie - , setSimpleCookie - , getCookie - , getCookies - , deleteCookie - ) where - -import Control.Monad ( liftM ) - -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy.Encoding as TL - -import Conf (Conf) -import qualified Conf - -import qualified Data.Map as Map - -import qualified Data.ByteString.Lazy as BSL - -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) - -import Blaze.ByteString.Builder ( toLazyByteString ) - -import Web.Scotty.Trans -import Web.Cookie - -makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie -makeSimpleCookie conf name value = - def - { setCookieName = TS.encodeUtf8 name - , setCookieValue = TS.encodeUtf8 value - , setCookiePath = Just $ TS.encodeUtf8 "/" - , setCookieSecure = Conf.https conf - } - -setCookie :: (Monad m) => SetCookie -> ActionT e m () -setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) - -setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () -setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value - -getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) -getCookie name = liftM (Map.lookup name) getCookies - -getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) -getCookies = - liftM (Map.fromList . maybe [] parse) $ header "Cookie" - where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 - -deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () -deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs deleted file mode 100644 index 06c468e..0000000 --- a/src/server/Design/Color.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.Color where - -import qualified Clay.Color as C - --- http://chir.ag/projects/name-that-color/#969696 - -white :: C.Color -white = C.white - -black :: C.Color -black = C.black - -chestnutRose :: C.Color -chestnutRose = C.rgb 207 92 86 - -unknown :: C.Color -unknown = C.rgb 86 92 207 - -mossGreen :: C.Color -mossGreen = C.rgb 159 210 165 - -gothic :: C.Color -gothic = C.rgb 108 162 164 - -negroni :: C.Color -negroni = C.rgb 255 223 196 - -wildSand :: C.Color -wildSand = C.rgb 245 245 245 - -silver :: C.Color -silver = C.rgb 200 200 200 - -dustyGray :: C.Color -dustyGray = C.rgb 150 150 150 diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs deleted file mode 100644 index 4e2b8cc..0000000 --- a/src/server/Design/Constants.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Design.Constants where - -import Clay - -iconFontSize :: Size LengthUnit -iconFontSize = px 32 - -radius :: Size LengthUnit -radius = px 3 - -blockPadding :: Size LengthUnit -blockPadding = px 15 - -blockPercentWidth :: Double -blockPercentWidth = 90 - -blockPercentMargin :: Double -blockPercentMargin = (100 - blockPercentWidth) / 2 - -inputHeight :: Double -inputHeight = 40 - -focusLighten :: Color -> Color -focusLighten baseColor = baseColor +. 20 - -focusDarken :: Color -> Color -focusDarken baseColor = baseColor -. 20 diff --git a/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs deleted file mode 100644 index 4678633..0000000 --- a/src/server/Design/Dialog.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/src/server/Design/Errors.hs b/src/server/Design/Errors.hs deleted file mode 100644 index 57aaeee..0000000 --- a/src/server/Design/Errors.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Errors - ( design - ) where - -import Clay - -import Design.Color as Color - -design :: Css -design = do - position fixed - top (px 20) - left (pct 50) - "transform" -: "translateX(-50%)" - margin (px 0) (px 0) (px 0) (px 0) - disapearKeyframes - - ".error" ? do - disapearAnimation - let errorColor = Color.chestnutRose -. 15 - color errorColor - border solid (px 2) errorColor - backgroundColor Color.white - borderRadius (px 5) (px 5) (px 5) (px 5) - padding (px 5) (px 5) (px 5) (px 5) - - before & display none - -disapearAnimation :: Css -disapearAnimation = do - animationName "disapear" - animationDelay (sec 5) - animationDuration (sec 1) - animationFillMode forwards - -disapearKeyframes :: Css -disapearKeyframes = keyframes - "disapear" - [ ( 10 - , do - opacity 0 - height (px 40) - lineHeight (px 40) - marginBottom (px 10) - ) - , ( 100 - , do - opacity 0 - height (px 0) - lineHeight (px 0) - marginBottom (px 0) - ) - ] diff --git a/src/server/Design/Form.hs b/src/server/Design/Form.hs deleted file mode 100644 index ebb8ac8..0000000 --- a/src/server/Design/Form.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Form - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color - -design :: Css -design = do - - let inputHeight = 30 - let inputTop = 22 - let inputPaddingBottom = 3 - let inputZIndex = 1 - - label ? do - cursor pointer - color Color.silver - - ".textInput" ? do - position relative - marginBottom (em 1.5) - paddingTop (px inputTop) - marginTop (px (-10)) - - input ? do - width (pct 100) - position relative - zIndex inputZIndex - backgroundColor transparent - paddingBottom (px inputPaddingBottom) - borderStyle none - borderBottom solid (px 1) Color.dustyGray - marginBottom (px 5) - height (px inputHeight) - lineHeight (px inputHeight) - focus & do - borderWidth (px 2) - paddingBottom (px $ inputPaddingBottom - 1) - - label ? do - lineHeight (px inputHeight) - position absolute - top (px inputTop) - left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) - - button ? do - position absolute - right (px 0) - top (px 27) - zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" - - (input # ".filled" |+ label) <> (input # focus |+ label) ? do - top (px 0) - fontSize (pct 80) - - ".error" & do - input ? do - borderBottomColor Color.chestnutRose - - ".errorMessage" ? do - position absolute - color Color.chestnutRose - fontSize (pct 80) - - ".colorInput" ? do - display flex - alignItems center - marginBottom (em 1.5) - - input ? do - borderColor transparent - backgroundColor transparent - - ".radioGroup" ? do - position relative - marginBottom (em 2) - - ".title" ? do - color Color.silver - marginBottom (em 0.8) - - ".radioInputs" ? do - display flex - "justify-content" -: "center" - - ".radioInput:not(:last-child)::after" ? do - content (stringContent "/") - marginLeft (px 10) - marginRight (px 10) - - input ? do - opacity 0 - width (px 30) - margin (px 0) (px (-15)) (px 0) (px (-15)) - - "input:focus + label" ? do - textDecoration underline - - "input:checked + label" ? do - color Color.chestnutRose - fontWeight bold - - ".selectInput" ? do - label ? do - display block - marginBottom (px 10) - fontSize (pct 80) - select ? do - backgroundColor Color.white - border solid (px 1) Color.silver - sym borderRadius (px 3) - sym2 padding (px 5) (px 8) - option ? do - firstChild & display none - sym2 padding (px 5) (px 8) - ".error" & do - select ? borderColor Color.chestnutRose - ".errorMessage" ? do - color Color.chestnutRose - fontSize (pct 80) - marginTop (em 0.5) diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs deleted file mode 100644 index 47ea4a9..0000000 --- a/src/server/Design/Global.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Global - ( globalDesign - ) where - -import Clay - -import Data.Text.Lazy (Text) - -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -globalDesign :: Text -globalDesign = renderWith compact [] global - -global :: Css -global = do - ".errors" ? Errors.design - ".dialog" ? Dialog.design - ".tooltip" ? Tooltip.design - Views.design - Form.design - - body ? do - minWidth (px 320) - fontFamily ["Cantarell"] [sansSerif] - Media.tablet $ do - fontSize (px 15) - button ? fontSize (px 15) - input ? fontSize (px 15) - Media.mobile $ do - fontSize (px 14) - button ? fontSize (px 14) - input ? fontSize (px 14) - - a ? cursor pointer - - input ? fontSize inherit - - h1 ? do - color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) - - Media.desktop $ fontSize (px 24) - Media.tablet $ fontSize (px 22) - Media.mobile $ fontSize (px 20) - - ul ? do - "margin-bottom" -: "3vh" - "margin-left" -: "1vh" - li Color -> Size a -> (Color -> Color) -> Css -button backgroundCol textCol h focusOp = do - display flex - alignItems center - justifyContent center - backgroundColor backgroundCol - padding (px 0) (px 10) (px 0) (px 10) - color textCol - borderRadius radius radius radius radius - verticalAlign middle - cursor pointer - lineHeight h - height h - textAlign (alignSide sideCenter) - hover & backgroundColor (focusOp backgroundCol) - focus & backgroundColor (focusOp backgroundCol) - waitable - -waitable :: Css -waitable = do - svg # ".loader" ? display none - ".waiting" & do - ".content" ? do - display flex - fontSize (px 0) - opacity 0 - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation - -input :: Double -> Css -input h = do - height (px h) - padding (px 10) (px 10) (px 10) (px 10) - borderRadius radius radius radius radius - border solid (px 1) Color.dustyGray - focus & borderColor Color.silver - verticalAlign middle - -centeredWithMargin :: Css -centeredWithMargin = do - width (pct blockPercentWidth) - marginLeft auto - marginRight auto - -verticalCentering :: Css -verticalCentering = do - position absolute - top (pct 50) - "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/src/server/Design/Media.hs b/src/server/Design/Media.hs deleted file mode 100644 index 77220ee..0000000 --- a/src/server/Design/Media.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Design.Media - ( mobile - , mobileTablet - , tablet - , tabletDesktop - , desktop - ) where - -import Clay hiding (query) -import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media - -mobile :: Css -> Css -mobile = query [Media.maxWidth mobileTabletLimit] - -mobileTablet :: Css -> Css -mobileTablet = query [Media.maxWidth tabletDesktopLimit] - -tablet :: Css -> Css -tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] - -tabletDesktop :: Css -> Css -tabletDesktop = query [Media.minWidth mobileTabletLimit] - -desktop :: Css -> Css -desktop = query [Media.minWidth tabletDesktopLimit] - -query :: [Feature] -> Css -> Css -query = Clay.query Media.screen - -mobileTabletLimit :: Size LengthUnit -mobileTabletLimit = (px 520) - -tabletDesktopLimit :: Size LengthUnit -tabletDesktopLimit = (px 950) diff --git a/src/server/Design/Tooltip.hs b/src/server/Design/Tooltip.hs deleted file mode 100644 index 1da8764..0000000 --- a/src/server/Design/Tooltip.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Tooltip - ( design - ) where - -import Clay - -import Design.Color as Color - -design :: Css -design = do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - padding (px 5) (px 5) (px 5) (px 5) - color Color.white diff --git a/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs deleted file mode 100644 index 20627e6..0000000 --- a/src/server/Design/View/Header.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Media as Media - -design :: Css -design = do - let headerPadding = "padding" -: "0 20px" - display flex - "flex-wrap" -: "wrap" - lineHeightMedia - position relative - backgroundColor Color.chestnutRose - color Color.white - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - Media.mobile $ marginBottom (em 1.5) - - ".title" <> ".item" ? headerPadding - - ".title" ? do - height (pct 100) - textAlign (alignSide sideLeft) - - Media.mobile $ fontSize (px 22) - Media.mobileTablet $ width (pct 100) - Media.tabletDesktop $ do - display inlineBlock - fontSize (px 35) - - ".item" ? do - display inlineBlock - transition "background-color" (ms 50) easeIn (sec 0) - ".current" & backgroundColor (Color.chestnutRose -. 20) - Media.mobile $ fontSize (px 13) - - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) - - ".nameSignOut" ? do - display flex - heightMedia - position absolute - top (px 0) - right (px 0) - - ".name" ? do - Media.mobile $ display none - Media.tabletDesktop $ headerPadding - - ".signOut" ? do - Helper.waitable - heightMedia - svg ? do - Media.tabletDesktop $ width (px 30) - Media.mobile $ width (px 20) - "path" ? ("fill" -: "white") - -lineHeightMedia :: Css -lineHeightMedia = do - Media.desktop $ lineHeight (px 80) - Media.tablet $ lineHeight (px 65) - Media.mobile $ lineHeight (px 50) - -heightMedia :: Css -heightMedia = do - Media.desktop $ height (px 80) - Media.tablet $ height (px 65) - Media.mobile $ height (px 50) diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs deleted file mode 100644 index d3c7650..0000000 --- a/src/server/Design/View/Payment.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment - ( design - ) where - -import Clay - -import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs deleted file mode 100644 index f02da8a..0000000 --- a/src/server/Design/View/Payment/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs deleted file mode 100644 index ade81a8..0000000 --- a/src/server/Design/View/Payment/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs deleted file mode 100644 index a866b40..0000000 --- a/src/server/Design/View/Payment/Table.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Table - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) - - ".button" & svg ? do - "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) - width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs deleted file mode 100644 index 214e663..0000000 --- a/src/server/Design/View/SignIn.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.SignIn - ( design - ) where - -import Clay -import Data.Monoid ((<>)) - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten - display flex - alignItems center - justifyContent center - width (pct 100) - fontSize (em 1.2) - svg ? "path" ? ("fill" -: "white") - - ".success" <> ".error" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs deleted file mode 100644 index 0a5b258..0000000 --- a/src/server/Design/View/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Stat - ( design - ) where - -import Clay - -design :: Css -design = do - h1 ? paddingBottom (px 0) - - ".exceedingPayers" ? ".userName" ? marginRight (px 5) - - ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs deleted file mode 100644 index 95abf90..0000000 --- a/src/server/Design/View/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Table - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".emptyTableMsg" ? do - margin (em 2) (em 2) (em 2) (em 2) - textAlign (alignSide sideCenter) - - ".lines" ? do - Media.tabletDesktop $ display displayTable - width (pct 100) - textAlign (alignSide (sideCenter)) - - ".header" <> ".row" ? do - Media.tabletDesktop $ display tableRow - - ".header" ? do - Media.desktop $ do - fontSize (px 18) - height (px 70) - - Media.tabletDesktop $ do - backgroundColor Color.gothic - color Color.white - - Media.tablet $ do - fontSize (px 16) - height (px 60) - - Media.mobile $ do - display none - - ".row" ? do - nthChild "even" & backgroundColor Color.wildSand - - Media.desktop $ do - fontSize (px 18) - height (px 60) - - Media.tablet $ do - height (px 50) - - Media.mobile $ do - lineHeight (px 25) - paddingTop (px 10) - paddingBottom (px 10) - - ".cell" ? do - Media.tabletDesktop $ display tableCell - position relative - verticalAlign middle - - firstChild & do - Media.mobile $ do - fontSize (px 20) - lineHeight (px 30) - color Color.gothic - - ".refund" & color Color.mossGreen - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - hover & "svg path" ? do - "fill" -: "rgb(237, 122, 116)" - - Media.tabletDesktop $ width (pct 3) - - Media.mobile $ do - display inlineBlock - button ? display flex diff --git a/src/server/Design/Views.hs b/src/server/Design/Views.hs deleted file mode 100644 index bc6ac83..0000000 --- a/src/server/Design/Views.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Views - ( design - ) where - -import Clay - -import qualified Design.View.Header as Header -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - header ? Header.design - ".payment" ? Payment.design - ".signIn" ? SignIn.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs deleted file mode 100644 index 0bc6f6e..0000000 --- a/src/server/Job/Daemon.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Job.Daemon - ( runDaemons - ) where - -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) - -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) - -runDaemons :: Conf -> IO () -runDaemons conf = do - _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment - _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) - return () - -runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId -runDaemon kind frequency isLastExecutionTooOld runJob = - forkIO . forever $ do - mbLastExecution <- Query.run $ do - actualizeLastCheck kind - getLastExecution kind - hasToRun <- case mbLastExecution of - Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True - if hasToRun - then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) - else return () - threadDelay . microSeconds $ frequency diff --git a/src/server/Job/Frequency.hs b/src/server/Job/Frequency.hs deleted file mode 100644 index 263f6e6..0000000 --- a/src/server/Job/Frequency.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Job.Frequency - ( Frequency(..) - , microSeconds - ) where - -data Frequency = - EveryHour - | EveryDay - deriving (Eq, Read, Show) - -microSeconds :: Frequency -> Int -microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/src/server/Job/Kind.hs b/src/server/Job/Kind.hs deleted file mode 100644 index af5d4f8..0000000 --- a/src/server/Job/Kind.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Job.Kind - ( Kind(..) - ) where - -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T - -data Kind = - MonthlyPayment - | WeeklyReport - deriving (Eq, Show, Read) - -instance FromField Kind where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Kind) - _ -> Errors [error "SQLText field required for job kind"] - -instance ToField Kind where - toField kind = SQLText . T.pack . show $ kind diff --git a/src/server/Job/Model.hs b/src/server/Job/Model.hs deleted file mode 100644 index e1a3c77..0000000 --- a/src/server/Job/Model.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Job.Model - ( Job(..) - , getLastExecution - , actualizeLastExecution - , actualizeLastCheck - ) where - -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Job.Kind -import Model.Query (Query(Query)) - -data Job = Job - { id :: String - , kind :: Kind - , lastExecution :: Maybe UTCTime - , lastCheck :: Maybe UTCTime - } deriving (Show) - -getLastExecution :: Kind -> Query (Maybe UTCTime) -getLastExecution jobKind = - Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time - ) - -actualizeLastExecution :: Kind -> UTCTime -> Query () -actualizeLastExecution jobKind time = - Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result - then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) - else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) - ) - -actualizeLastCheck :: Kind -> Query () -actualizeLastCheck jobKind = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) - ) diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs deleted file mode 100644 index ba24cca..0000000 --- a/src/server/Job/MonthlyPayment.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Job.MonthlyPayment - ( monthlyPayment - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Common.Model (Frequency(..), Payment(..)) - -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query - -monthlyPayment :: Maybe UTCTime -> IO UTCTime -monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly - now <- getCurrentTime - actualDay <- timeToDay now - let punctualPayments = map - (\p -> p - { _payment_frequency = Punctual - , _payment_date = actualDay - , _payment_createdAt = now - }) - monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) - return now diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs deleted file mode 100644 index 5737c75..0000000 --- a/src/server/Job/WeeklyReport.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Job.WeeklyReport - ( weeklyReport - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import qualified Model.User as User -import qualified SendMail -import qualified View.Mail.WeeklyReport as WeeklyReport - -weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime -weeklyReport conf mbLastExecution = do - now <- getCurrentTime - case mbLastExecution of - Nothing -> return () - Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) - return () - return now diff --git a/src/server/Json.hs b/src/server/Json.hs deleted file mode 100644 index cc6327a..0000000 --- a/src/server/Json.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} - -module Json - ( jsonObject - , jsonId - ) where - -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs deleted file mode 100644 index 6f6d620..0000000 --- a/src/server/LoginSession.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LoginSession - ( put - , get - , delete - ) where - -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS - -import Control.Monad.IO.Class (liftIO) - -import Data.Text (Text) -import qualified Data.Text.Encoding as TE - -import Conf (Conf) - -sessionName :: Text -sessionName = "SESSION" - -sessionKeyFile :: FilePath -sessionKeyFile = "sessionKey" - -put :: Conf -> Text -> ActionM () -put conf value = do - encrypted <- liftIO $ encrypt value - setSimpleCookie conf sessionName encrypted - -encrypt :: Text -> IO Text -encrypt value = do - iv <- CS.randomIV - key <- CS.getKey sessionKeyFile - return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) - -get :: ActionM (Maybe Text) -get = do - maybeEncrypted <- getCookie sessionName - case maybeEncrypted of - Just encrypted -> - liftIO $ decrypt encrypted - Nothing -> - return Nothing - -decrypt :: Text -> IO (Maybe Text) -decrypt encrypted = do - key <- CS.getKey sessionKeyFile - let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) - return decrypted - -delete :: Conf -> ActionM () -delete conf = deleteCookie conf sessionName diff --git a/src/server/Main.hs b/src/server/Main.hs deleted file mode 100644 index db73474..0000000 --- a/src/server/Main.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) - -import Network.Wai.Middleware.Static -import qualified Data.Text.Lazy as LT -import Web.Scotty - -import qualified Conf -import qualified Controller.Category as Category -import qualified Controller.Income as Income -import qualified Controller.Index as Index -import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query - -main :: IO () -main = do - conf <- Conf.get "application.conf" - _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware . staticPolicy $ noDots >-> addBase "public" - - get "/exceedingPayer" $ do - time <- liftIO Time.getCurrentTime - (users, incomes, payments) <- liftIO . Query.run $ - liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments - text . LT.pack . show $ exceedingPayers - - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken - - post "/signIn" $ do - jsonData >>= SignIn.signIn conf - - post "/signOut" $ - Index.signOut conf - - post "/payment" $ - jsonData >>= Payment.create - - put "/payment" $ - jsonData >>= Payment.editOwn - - delete "/payment" $ do - paymentId <- param "id" - Payment.deleteOwn paymentId - - post "/income" $ - jsonData >>= Income.create - - put "/income" $ - jsonData >>= Income.editOwn - - delete "/income" $ do - incomeId <- param "id" - Income.deleteOwn incomeId - - post "/category" $ - jsonData >>= Category.create - - put "/category" $ - jsonData >>= Category.edit - - delete "/category" $ do - categoryId <- param "id" - Category.delete categoryId - -mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) -mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/src/server/MimeMail.hs b/src/server/MimeMail.hs deleted file mode 100644 index 0faaf98..0000000 --- a/src/server/MimeMail.hs +++ /dev/null @@ -1,672 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module MimeMail - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , sendmailCustomCaptureOutput - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachmentCid - , addAttachments - , addAttachmentBS - , addAttachmentBSCid - , addAttachmentsBS - , renderAddress - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM, void) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii, isControl) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - ((:) ("Content-Type", contentType)) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - $ headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\n" - , finalBuilder - ] - --- | Format an E-Mail address according to the name-addr form (see: RFC5322 --- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') --- This can be handy for adding custom headers that require such format. --- --- @since 0.4.11 -renderAddress :: Address -> Text -renderAddress address = - TE.decodeUtf8 $ toByteString $ showAddress address - --- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) -sanitizeFieldName :: S.ByteString -> S.ByteString -sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString (sanitizeFieldName k) - , fromByteString ": " - , encodeIfNeeded (sanitizeHeader v) - , fromByteString "\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (sanitizeHeader $ addressEmail a) - , fromByteString ">" - ] - --- Filter out control characters to prevent CRLF injection. -sanitizeHeader :: Text -> Text -sanitizeHeader = T.filter (not . isControl) - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\n" - , mconcat $ map showHeader headers - , fromByteString "\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -sendmailPath = "sendmail" - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs - --- | Like 'sendmailCustom', but also returns sendmail's output to stderr and --- stdout as strict ByteStrings. --- --- Since 0.4.9 -sendmailCustomCaptureOutput :: FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs - -sendmailCustomAux :: Bool - -> FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomAux captureOut sm opts lbs = do - let baseOpts = (proc sm opts) { std_in = CreatePipe } - pOpts = if captureOut - then baseOpts { std_out = CreatePipe - , std_err = CreatePipe - } - else baseOpts - (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts - L.hPut hin lbs - hClose hin - errMVar <- newEmptyMVar - outMVar <- newEmptyMVar - case (mHOut, mHErr) of - (Nothing, Nothing) -> return () - (Just hOut, Just hErr) -> do - void . forkIO $ S.hGetContents hOut >>= putMVar outMVar - void . forkIO $ S.hGetContents hErr >>= putMVar errMVar - _ -> error "error in sendmailCustomAux: missing a handle" - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> if captureOut - then do - errOutput <- takeMVar errMVar - outOutput <- takeMVar outMVar - return (outOutput, errOutput) - else return (S.empty, S.empty) - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - part <- getAttachmentPart ct fn - return $ addPart [part] mail - --- | Add an attachment from a file and construct a 'Part' --- with the specified content id in the Content-ID header. --- --- @since 0.4.12 -addAttachmentCid :: Text -- ^ content type - -> FilePath -- ^ file name - -> Text -- ^ content ID - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = - getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = getAttachmentPartBS ct fn content - in addPart [part] mail - --- | @since 0.4.12 -addAttachmentBSCid :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Text -- ^ content ID - -> Mail -> Mail -addAttachmentBSCid ct fn content cid mail = - let part = addHeader $ getAttachmentPartBS ct fn content - in addPart [part] mail - where - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -getAttachmentPartBS :: Text - -> Text - -> L.ByteString - -> Part -getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content - -getAttachmentPart :: Text -> FilePath -> IO Part -getAttachmentPart ct fn = do - content <- L.readFile fn - return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 46 = QPCEscape - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs deleted file mode 100644 index 6b7a488..0000000 --- a/src/server/Model/Category.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category - ( list - , create - , edit - , delete - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (Category(..), CategoryId) - -import Model.Query (Query(Query)) - -instance FromRow Category where - fromRow = Category <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Category] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" - ) - -create :: Text -> Text -> Query CategoryId -create categoryName categoryColor = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn - ) - -edit :: CategoryId -> Text -> Text -> Query Bool -edit categoryId categoryName categoryColor = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) - return True - else - return False - ) - -delete :: CategoryId -> Query Bool -delete categoryId = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) - return True - else - return False - ) diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs deleted file mode 100644 index 4f7b83d..0000000 --- a/src/server/Model/Frequency.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where - -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T - -import Common.Model.Frequency (Frequency) - -instance FromField Frequency where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Frequency) - _ -> Errors [error "SQLText field required for frequency"] - -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs deleted file mode 100644 index bbe7657..0000000 --- a/src/server/Model/Income.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income - ( list - , create - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (Income(..), IncomeId, User(..), UserId) - -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) - -instance Resource Income where - resourceCreatedAt = _income_createdAt - resourceEditedAt = _income_editedAt - resourceDeletedAt = _income_deletedAt - -instance FromRow Income where - fromRow = Income <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Income] -list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") - -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn - ) - -editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool -editOwn incomeUserId incomeId incomeDate incomeAmount = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False - ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Income] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" - (start, end, start, end, start, end) - ) diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs deleted file mode 100644 index 8c6a961..0000000 --- a/src/server/Model/Init.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.Init - ( getInit - ) where - -import Common.Model (Init(Init), User(..)) - -import Conf (Conf) -import qualified Conf -import Model.Query (Query) -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.User as User - -getInit :: User -> Conf -> Query Init -getInit user conf = - Init <$> - User.list <*> - (return . _user_id $ user) <*> - Payment.list <*> - Income.list <*> - Category.list <*> - PaymentCategory.list <*> - (return . Conf.currency $ conf) diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs deleted file mode 100644 index 9a4db73..0000000 --- a/src/server/Model/Mail.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Model.Mail - ( Mail(..) - ) where - -import Data.Text (Text) - -data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text - , plainBody :: Text - } deriving (Eq, Show) diff --git a/src/server/Model/Payer.hs b/src/server/Model/Payer.hs deleted file mode 100644 index de4abd1..0000000 --- a/src/server/Model/Payer.hs +++ /dev/null @@ -1,216 +0,0 @@ -module Model.Payer - ( getOrderedExceedingPayers - ) where - -import Data.Map (Map) -import Data.Time (UTCTime(..), NominalDiffTime) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Time as Time - -import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) - -type Users = Map UserId User - -type Payers = Map UserId Payer - -type Incomes = Map IncomeId Income - -type Payments = [Payment] - -data Payer = Payer - { preIncomePaymentSum :: Int - , postIncomePaymentSum :: Int - , _incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float - } - -data ExceedingPayer = ExceedingPayer - { _userId :: UserId - , amount :: Int - } deriving (Show) - -getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] -getOrderedExceedingPayers currentTime users incomes payments = - let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users - incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes - payers = getPayers currentTime usersMap incomesMap payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts - . Map.toList - . Map.map preIncomePaymentSum - $ payers - mbSince = useIncomesFrom usersMap incomesMap payments - in case mbSince of - Just since -> - let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - safeMaximum - . map (ratio . snd) - . Map.toList - $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . Map.toList - . Map.map (getFinalDiff maxRatio) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime -useIncomesFrom users incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing - -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date - -getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Map.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in Map.fromList - . map (\userId -> - ( userId - , Payer - { preIncomePaymentSum = - totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> paymentTime p >= t - ) - userId - payments - , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) - } - ) - ) - $ userIds - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _preIncomePaymentSum = preIncomePaymentSum payer - , _cumulativeIncome = cumulativeIncome - , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) - in postIncomeDiff + _preIncomePaymentSum payer - -incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } - else Nothing - x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs deleted file mode 100644 index 3893850..0000000 --- a/src/server/Model/Payment.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment - ( Payment(..) - , find - , list - , listMonthly - , create - , createMany - , editOwn - , deleteOwn - , modifiedDuring - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) -import Database.SQLite.Simple.ToField (ToField(toField)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model.Frequency -import Common.Model.Payment (Payment(..)) -import Common.Model.User (UserId) -import Common.Model.Payment (PaymentId) - -import Model.Frequency () -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) - -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt - -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -instance ToRow Payment where - toRow p = - [ toField (_payment_user p) - , toField (_payment_name p) - , toField (_payment_cost p) - , toField (_payment_date p) - , toField (_payment_frequency p) - , toField (_payment_createdAt p) - ] - -find :: PaymentId -> Query (Maybe Payment) -find paymentId = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - ) - -list :: Query [Payment] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" - ) - -listMonthly :: Query [Payment] -listMonthly = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" - , "ORDER BY name DESC" - ]) - (Only Monthly) - ) - -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False - ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE (created_at >= ? AND created_at <= ?)" - , " OR (edited_at >= ? AND edited_at <= ?)" - , " OR (deleted_at >= ? AND deleted_at <= ?)" - ]) - (start, end, start, end, start, end) - ) diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs deleted file mode 100644 index 6e1d304..0000000 --- a/src/server/Model/PaymentCategory.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory - ( list - , listByCategory - , save - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Data.Text as T -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory(..)) -import qualified Common.Util.Text as T - -import Model.Query (Query(Query)) - -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [PaymentCategory] -list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query () -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) - ) - where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower diff --git a/src/server/Model/Query.hs b/src/server/Model/Query.hs deleted file mode 100644 index d15fb5f..0000000 --- a/src/server/Model/Query.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Model.Query - ( Query(..) - , run - ) where - -import Data.Functor (Functor) -import Database.SQLite.Simple (Connection) -import qualified Database.SQLite.Simple as SQLite - -data Query a = Query (Connection -> IO a) - -instance Functor Query where - fmap f (Query call) = Query (fmap f . call) - -instance Applicative Query where - pure x = Query (const $ return x) - (Query callF) <*> (Query callX) = Query (\conn -> do - x <- callX conn - f <- callF conn - return (f x)) - -instance Monad Query where - (Query callX) >>= f = Query (\conn -> do - x <- callX conn - case f x of Query callY -> callY conn) - -run :: Query a -> IO a -run (Query call) = do - conn <- SQLite.open "database" - result <- call conn - _ <- SQLite.close conn - return result diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs deleted file mode 100644 index c5182f0..0000000 --- a/src/server/Model/SignIn.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Model.SignIn - ( SignIn(..) - , createSignInToken - , getSignIn - , signInTokenToUsed - , isLastTokenValid - ) where - -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Database.SQLite.Simple as SQLite - -import Model.Query (Query(Query)) -import Model.UUID (generateUUID) - -type SignInId = Int64 - -data SignIn = SignIn - { id :: SignInId - , token :: Text - , creation :: UTCTime - , email :: Text - , isUsed :: Bool - } deriving Show - -instance FromRow SignIn where - fromRow = SignIn <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -createSignInToken :: Text -> Query Text -createSignInToken signInEmail = - Query (\conn -> do - now <- getCurrentTime - signInToken <- generateUUID - SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) - return signInToken - ) - -getSignIn :: Text -> Query (Maybe SignIn) -getSignIn signInToken = - Query (\conn -> do - listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) - ) - -signInTokenToUsed :: SignInId -> Query () -signInTokenToUsed tokenId = - Query (\conn -> - SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) - ) - -isLastTokenValid :: SignIn -> Query Bool -isLastTokenValid signIn = - Query (\conn -> do - [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) - return . maybe False (== (token signIn)) $ lastToken - ) diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs deleted file mode 100644 index 6cb7ce0..0000000 --- a/src/server/Model/UUID.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Model.UUID - ( generateUUID - ) where - -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import Data.Text (Text, pack) - -generateUUID :: IO Text -generateUUID = pack . toString <$> nextRandom diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs deleted file mode 100644 index e14fcef..0000000 --- a/src/server/Model/User.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.User - ( list - , get - , create - , delete - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (UserId, User(..)) - -import Model.Query (Query(Query)) - -instance FromRow User where - fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field - -list :: Query [User] -list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") - -get :: Text -> Query (Maybe User) -get userEmail = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) - ) - -create :: Text -> Text -> Query UserId -create userEmail userName = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" - (now, userEmail, userName) - SQLite.lastInsertRowId conn - ) - -delete :: Text -> Query () -delete userEmail = - Query (\conn -> - SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) - ) diff --git a/src/server/Resource.hs b/src/server/Resource.hs deleted file mode 100644 index f52bbfa..0000000 --- a/src/server/Resource.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Resource - ( Resource - , resourceCreatedAt - , resourceEditedAt - , resourceDeletedAt - , Status(..) - , statuses - , groupByStatus - , statusDuring - ) where - -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) - -class Resource a where - resourceCreatedAt :: a -> UTCTime - resourceEditedAt :: a -> Maybe UTCTime - resourceDeletedAt :: a -> Maybe UTCTime - -data Status = - Created - | Edited - | Deleted - deriving (Eq, Show, Read, Ord, Enum, Bounded) - -statuses :: [Status] -statuses = [minBound..] - -groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] -groupByStatus start end resources = - foldl - (\m resource -> - case statusDuring start end resource of - Just status -> M.insertWith (++) status [resource] m - Nothing -> m - ) - M.empty - resources - -statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status -statusDuring start end resource - | created && not deleted = Just Created - | not created && edited && not deleted = Just Edited - | not created && deleted = Just Deleted - | otherwise = Nothing - where - created = belongs (resourceCreatedAt resource) start end - edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) - deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) - -belongs :: UTCTime -> UTCTime -> UTCTime -> Bool -belongs time start end = time >= start && time < end diff --git a/src/server/Secure.hs b/src/server/Secure.hs deleted file mode 100644 index f427304..0000000 --- a/src/server/Secure.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Secure - ( loggedAction - , getUserFromToken - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) - -import Model.Query (Query) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User - -loggedAction :: (User -> ActionM ()) -> ActionM () -loggedAction action = do - maybeToken <- LoginSession.get - case maybeToken of - Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token - case maybeUser of - Just user -> - action user - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - User.get (SignIn.email signIn) - Nothing -> - return Nothing diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs deleted file mode 100644 index f7ba3fd..0000000 --- a/src/server/SendMail.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module SendMail - ( sendMail - ) where - -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) - -import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified MimeMail as M - -import Model.Mail (Mail(Mail)) - -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = do - result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) - if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) - else putStrLn "OK" - return result - -getMimeMail :: Mail -> M.Mail -getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = - let fromMail = M.emptyMail (address mailFrom) - in fromMail - { M.mailTo = map address mailTo - , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] - , M.mailHeaders = [("Subject", mailSubject)] - } - -address :: Text -> M.Address -address addressEmail = - M.Address - { M.addressName = Nothing - , M.addressEmail = addressEmail - } - -strictToLazy :: Text -> LT.Text -strictToLazy = toLazyText . fromText diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs deleted file mode 100644 index 97457c7..0000000 --- a/src/server/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/src/server/Validation.hs b/src/server/Validation.hs deleted file mode 100644 index 1f332c9..0000000 --- a/src/server/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs deleted file mode 100644 index 12c4f34..0000000 --- a/src/server/View/Mail/SignIn.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.User (User(..)) - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) - } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs deleted file mode 100644 index 0bafb70..0000000 --- a/src/server/View/Mail/WeeklyReport.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.WeeklyReport - ( mail - ) where - -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model.User as User -import qualified Common.View.Format as Format - -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf - -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = - Mail - { M.from = Conf.noReplyMail conf - , M.to = map _user_email users - , M.subject = T.concat - [ Message.get Key.App_Title - , " − " - , Message.get Key.WeeklyReport_Title - ] - , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) - } - -body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text -body conf users paymentsByStatus incomesByStatus = - if M.null paymentsByStatus && M.null incomesByStatus - then - Message.get Key.WeeklyReport_Empty - else - T.intercalate "\n" . catMaybes . concat $ - [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses - , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses - ] - -paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text -paymentSection status conf users payments = - section sectionTitle sectionItems - where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count - sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments - -payedFor :: Status -> Conf -> [User] -> Payment -> Text -payedFor status conf users payment = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) - where name = formatUserName (_payment_user payment) users - amount = Format.price (Conf.currency conf) . _payment_cost $ payment - for = _payment_name payment - at = Format.longDay $ _payment_date payment - -incomeSection :: Status -> Conf -> [User] -> [Income] -> Text -incomeSection status conf users incomes = - section sectionTitle sectionItems - where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count - sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes - -isPayedFrom :: Status -> Conf -> [User] -> Income -> Text -isPayedFrom status conf users income = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) - where name = formatUserName (_income_userId income) users - amount = Format.price (Conf.currency conf) . _income_amount $ income - for = Format.longDay $ _income_date income - -formatUserName :: UserId -> [User] -> Text -formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId - -section :: Text -> [Text] -> Text -section title items = - T.concat - [ title - , "\n\n" - , T.unlines . map (" - " <>) $ items - ] diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs deleted file mode 100644 index 1c072a4..0000000 --- a/src/server/View/Page.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Page - ( page - ) where - -import Data.Text.Internal.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Aeson (encode) -import qualified Data.Aeson.Types as Json - -import Text.Blaze.Html -import Text.Blaze.Html5 -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) - -import qualified Common.Message as Message -import Common.Model.InitResult (InitResult) -import qualified Common.Message.Key as Key - -import Design.Global (globalDesign) - -page :: InitResult -> Text -page initResult = - renderHtml . docTypeHtml $ do - H.head $ do - meta ! charset "UTF-8" - meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ Message.get Key.App_Title) - script ! src "javascript/main.js" $ "" - jsonScript "init" initResult - link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" - link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" - H.style $ toHtml globalDesign - -jsonScript :: Json.ToJSON a => Text -> a -> Html -jsonScript scriptId json = - script - ! A.id (toValue scriptId) - ! type_ "application/json" - $ toHtml . decodeUtf8 . encode $ json diff --git a/tools.nix b/tools.nix new file mode 100644 index 0000000..a06757e --- /dev/null +++ b/tools.nix @@ -0,0 +1,12 @@ +with import {}; { + env = stdenv.mkDerivation { + name = "tools"; + buildInputs = with pkgs; [ + nodePackages.nodemon + sqlite + cabal-install + tmux + tmuxinator + ]; + }; +} -- cgit v1.2.3 From 30f786e277b4ece6a09311de364082691f261ca3 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 10 Nov 2017 01:23:49 +0100 Subject: Minify javascript in dist mode, compress served files with gzip --- .gitignore | 4 +++- .tmuxinator.yml | 4 ++-- Makefile | 24 +++++++++++++----------- README.md | 3 +-- result-client | 1 + result-server | 1 + server/server.cabal | 1 + server/src/Main.hs | 5 ++++- 8 files changed, 26 insertions(+), 17 deletions(-) create mode 120000 result-client create mode 120000 result-server diff --git a/.gitignore b/.gitignore index 22c4f7e..d8cc83e 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,8 @@ database-shm database-wal dist-server dist-client +local.conf public/javascript/main.js +result-client +result-server sessionKey -local.conf diff --git a/.tmuxinator.yml b/.tmuxinator.yml index 86612fb..48b5add 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -5,7 +5,7 @@ windows: layout: 3747,239x59,0,0{144x59,0,0,0,94x59,145,0[94x30,145,0,1,94x28,145,31,2]} panes: - # Empty - - make watch-client - - make watch-server + - make clean-client watch-client + - make clean-server watch-server - db: - sqlite3 database diff --git a/Makefile b/Makefile index c8bb7ce..8ece441 100644 --- a/Makefile +++ b/Makefile @@ -5,29 +5,31 @@ stop: @tmux kill-session -t sharedCost dist: - @nix-shell tools.nix --command "make clean install build" + @nix-build -o result-server -A ghc.server + @nix-build -o result-client -A ghcjs.client + @nix-shell -p closurecompiler --command 'closure-compiler result-client/bin/client.jsexe/all.js --js_output_file public/javascript/main.js' -clean: clean-client clean-server -install: install-client install-server -build: build-client build-server +clean: clean-server clean-client + +build: build-server build-client cp-client # Client # ------ +clean-client: + @rm -rf dist-client + build-client: @nix-shell -A shells.ghcjs --run "build-client-inside" build-client-inside: - @cabal --project-file=cabal-client.project --builddir=dist-client new-build all && make cp-client + @cabal --project-file=cabal-client.project --builddir=dist-client new-build all cp-client: @cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js -clean-client: - @rm -rf dist-client - watch-client: - @nix-shell -A shells.ghcjs --run "nodemon --watch client --watch common --ext hs --exec '(clear && make build-client-inside) || true'" + @nix-shell -A shells.ghcjs --run "nodemon --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" # Server # ------ @@ -42,8 +44,8 @@ build-server-inside: @cabal --project-file=cabal-server.project --builddir=dist-server new-build all run-server: - @(killall sharedCost &>/dev/null) || : + @(fuser -k 3000/tcp &>/dev/null) || : @./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server watch-server: - @nix-shell -A shells.ghc --run "nodemon --watch server --watch common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" + @nix-shell -A shells.ghc --run "nodemon --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" diff --git a/README.md b/README.md index b203cdb..800a984 100644 --- a/README.md +++ b/README.md @@ -58,11 +58,10 @@ See [application.conf](application.conf). TODO ---- +- use jsaddle-dom in client/Main.hs - move persistence methods to a module - use another route to check the token and redirect to / - Add payment balance in weekly report - search by payment category and payment date - Move up element ids security (editOwn is actually at db level) -- Minify javascript -- Extract persistence from model files diff --git a/result-client b/result-client new file mode 120000 index 0000000..157e7ca --- /dev/null +++ b/result-client @@ -0,0 +1 @@ +/nix/store/j41w9i28pasvvy6dgqrygj34s30hscad-client-0.0.1 \ No newline at end of file diff --git a/result-server b/result-server new file mode 120000 index 0000000..561c4ee --- /dev/null +++ b/result-server @@ -0,0 +1 @@ +/nix/store/6myvk196ip9xv91xi04g43zbqis84a1i-server-0.0.1 \ No newline at end of file diff --git a/server/server.cabal b/server/server.cabal index 2e1f7be..8bbe5f2 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -42,6 +42,7 @@ executable server , unordered-containers , uuid , wai + , wai-extra , wai-middleware-static hs-source-dirs: src default-language: Haskell2010 diff --git a/server/src/Main.hs b/server/src/Main.hs index db73474..96c13ee 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -3,8 +3,10 @@ import Control.Applicative (liftA3) import Control.Monad.IO.Class (liftIO) -import Network.Wai.Middleware.Static import qualified Data.Text.Lazy as LT +import Network.Wai.Middleware.Gzip (GzipFiles(GzipCompress)) +import qualified Network.Wai.Middleware.Gzip as W +import Network.Wai.Middleware.Static import Web.Scotty import qualified Conf @@ -26,6 +28,7 @@ main = do conf <- Conf.get "application.conf" _ <- runDaemons conf scotty (Conf.port conf) $ do + middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } middleware . staticPolicy $ noDots >-> addBase "public" get "/exceedingPayer" $ do -- cgit v1.2.3 From 213cf7ede058b781fc957de2cd9f6a5988c08004 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 12 Nov 2017 22:58:23 +0100 Subject: Add mocked pages --- Makefile | 2 +- README.md | 2 +- client/client.cabal | 12 ++++++- client/src/Icon.hs | 58 +++++++++++++++++++++++---------- client/src/Main.hs | 15 ++++----- client/src/View/Payment.hs | 7 +++- client/src/View/Payment/Pages.hs | 42 ++++++++++++++++++++++++ common/common.cabal | 12 +++---- server/server.cabal | 57 +++++++++++++++++++++++++++++++- server/src/Design/Color.hs | 5 +++ server/src/Design/View/Payment/Pages.hs | 6 ++-- server/src/Design/View/Payment/Table.hs | 2 +- 12 files changed, 181 insertions(+), 39 deletions(-) create mode 100644 client/src/View/Payment/Pages.hs diff --git a/Makefile b/Makefile index 8ece441..d18fb6d 100644 --- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ clean-client: @rm -rf dist-client build-client: - @nix-shell -A shells.ghcjs --run "build-client-inside" + @nix-shell -A shells.ghcjs --run "make build-client-inside" build-client-inside: @cabal --project-file=cabal-client.project --builddir=dist-client new-build all diff --git a/README.md b/README.md index 800a984..e9762ea 100644 --- a/README.md +++ b/README.md @@ -58,9 +58,9 @@ See [application.conf](application.conf). TODO ---- -- use jsaddle-dom in client/Main.hs - move persistence methods to a module - use another route to check the token and redirect to / +- migration diff (use flyway?) - Add payment balance in weekly report - search by payment category and payment date diff --git a/client/client.cabal b/client/client.cabal index 7807d37..9d3e873 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -16,9 +16,19 @@ executable client , bytestring , common , containers - , ghcjs-dom-jsffi + , jsaddle-dom , reflex-dom , text , time hs-source-dirs: src default-language: Haskell2010 + other-modules: Component.Button + , Component.Input + , Icon + , Main + , View.App + , View.Header + , View.Payment + , View.Payment.Pages + , View.Payment.Table + , View.SignIn diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 7223def..6b2749a 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -2,11 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} module Icon - ( loading - , signOut - , clone - , edit + ( clone , delete + , edit + , loading + , doubleLeft + , doubleLeftBar + , doubleRight + , doubleRightBar + , signOut ) where import Data.Map (Map) @@ -15,30 +19,50 @@ import Data.Text (Text) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank - clone :: forall t m. MonadWidget t m => m () clone = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + +doubleLeft :: forall t m. MonadWidget t m => m () +doubleLeft = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank + +doubleLeftBar :: forall t m. MonadWidget t m => m () +doubleLeftBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank + +doubleRight :: forall t m. MonadWidget t m => m () +doubleRight = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +doubleRightBar :: forall t m. MonadWidget t m => m () +doubleRightBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + edit :: forall t m. MonadWidget t m => m () edit = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank -delete :: forall t m. MonadWidget t m => m () -delete = +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/Main.hs b/client/src/Main.hs index 1f167d4..14f0fee 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -4,11 +4,13 @@ module Main import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LB -import Data.JSString.Text (textFromJSString) +import qualified Data.JSString.Text as Dom import qualified Data.Text.Encoding as T -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.NonElementParentNode as Dom -import GHCJS.DOM.Types (JSM, Element, JSString) +import qualified JSDOM as Dom +import qualified JSDOM.Generated.HTMLElement as Dom +import qualified JSDOM.Generated.NonElementParentNode as Dom +import JSDOM.Types (JSM, HTMLElement(..)) +import qualified JSDOM.Types as Dom import Prelude hiding (init, error) import Common.Model (InitResult(InitEmpty)) @@ -28,13 +30,10 @@ readInit = do initNode <- Dom.getElementById document "init" case initNode of Just node -> do - text <- textFromJSString <$> js_getInnerText node + text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init Nothing -> initParseError _ -> return initParseError where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) - -foreign import javascript unsafe "$1[\"innerText\"]" - js_getInnerText :: Element -> IO JSString diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index e80790b..d1430c9 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -11,8 +11,10 @@ module View.Payment import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init) +import Common.Model (Init(..)) +import View.Payment.Pages (PagesIn(..)) +import qualified View.Payment.Pages as Pages import View.Payment.Table (TableIn(..)) import qualified View.Payment.Table as Table @@ -30,4 +32,7 @@ widget paymentIn = do _ <- Table.widget $ TableIn { _tableIn_init = _paymentIn_init paymentIn } + _ <- Pages.widget $ PagesIn + { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + } return $ PaymentOut {} diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs new file mode 100644 index 0000000..f9a2b4e --- /dev/null +++ b/client/src/View/Payment/Pages.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module View.Payment.Pages + ( widget + , PagesIn(..) + , PagesOut(..) + ) where + +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment(..)) + +import qualified Icon + +data PagesIn = PagesIn + { _pagesIn_payments :: [Payment] + } + +data PagesOut = PagesOut + { + } + +widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget _ = do + R.divClass "pages" $ do + page Icon.doubleLeftBar + page Icon.doubleLeft + page (R.text . T.pack . show $ (1 :: Integer)) + page (R.text . T.pack . show $ (2 :: Integer)) + page (R.text . T.pack . show $ (3 :: Integer)) + page (R.text . T.pack . show $ (4 :: Integer)) + page (R.text . T.pack . show $ (5 :: Integer)) + page Icon.doubleRight + page Icon.doubleRightBar + return $ PagesOut {} + +page :: forall t m. MonadWidget t m => m () -> m () +page content = R.elClass "button" "page" $ content diff --git a/common/common.cabal b/common/common.cabal index e072acf..8b60743 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -10,6 +10,12 @@ cabal-version: >=1.10 library ghc-options: -Wall -Werror + build-depends: aeson + , base >=4.9 && <4.11 + , text + , time + hs-source-dirs: src + default-language: Haskell2010 exposed-modules: Common.Message , Common.Message.Key , Common.Model @@ -33,9 +39,3 @@ library , Common.Model.SignIn , Common.Model.Init , Common.Model.User - build-depends: aeson - , base >=4.9 && <4.11 - , text - , time - hs-source-dirs: src - default-language: Haskell2010 diff --git a/server/server.cabal b/server/server.cabal index 8bbe5f2..41b2fd6 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -32,8 +32,8 @@ executable server , mtl , parsec , process - , resourcet , random + , resourcet , scotty , sqlite-simple , text @@ -46,3 +46,58 @@ executable server , wai-middleware-static hs-source-dirs: src default-language: Haskell2010 + other-modules: Conf + , Controller.Category + , Controller.Income + , Controller.Index + , Controller.Payment + , Controller.SignIn + , Cookie + , Design.Color + , Design.Constants + , Design.Dialog + , Design.Errors + , Design.Form + , Design.Global + , Design.Helper + , Design.Media + , Design.Tooltip + , Design.View.Header + , Design.View.Payment + , Design.View.Payment.Header + , Design.View.Payment.Pages + , Design.View.Payment.Table + , Design.View.SignIn + , Design.View.Stat + , Design.View.Table + , Design.Views + , Job.Daemon + , Job.Frequency + , Job.Kind + , Job.Model + , Job.MonthlyPayment + , Job.WeeklyReport + , Json + , LoginSession + , Main + , MimeMail + , Model.Category + , Model.Frequency + , Model.Income + , Model.Init + , Model.Mail + , Model.Payer + , Model.Payment + , Model.PaymentCategory + , Model.Query + , Model.SignIn + , Model.UUID + , Model.User + , Resource + , Secure + , SendMail + , Utils.Time + , Validation + , View.Mail.SignIn + , View.Mail.WeeklyReport + , View.Page diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs index 06c468e..9a5797f 100644 --- a/server/src/Design/Color.hs +++ b/server/src/Design/Color.hs @@ -1,6 +1,8 @@ module Design.Color where +import Clay import qualified Clay.Color as C +import Data.Text (Text) -- http://chir.ag/projects/name-that-color/#969696 @@ -33,3 +35,6 @@ silver = C.rgb 200 200 200 dustyGray :: C.Color dustyGray = C.rgb 150 150 150 + +toString :: C.Color -> Text +toString = plain . unValue . value diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index ade81a8..5fc13f0 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -13,8 +13,8 @@ import qualified Design.Media as Media design :: Css design = do - textAlign (alignSide sideCenter) - Helper.clearFix + display flex + justifyContent center Media.desktop $ do padding (px 40) (px 30) (px 30) (px 30) @@ -26,6 +26,8 @@ design = do padding (px 20) (px 0) (px 20) (px 0) lineHeight (px 40) + svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) + ".page" ? do display inlineBlock fontWeight bold diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index a866b40..f8326e4 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -38,5 +38,5 @@ design = do marginBottom (em 0.5) ".button" & svg ? do - "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + "path" ? ("fill" -: Color.toString Color.chestnutRose) width (px 18) -- cgit v1.2.3 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- .stylish-haskell.yaml | 30 ++++ Makefile | 4 +- client/Setup.hs | 2 +- client/client.cabal | 73 +++++----- client/src/Component.hs | 4 + client/src/Component/Button.hs | 17 ++- client/src/Component/Input.hs | 9 +- client/src/Icon.hs | 11 +- client/src/Main.hs | 28 ++-- client/src/View/App.hs | 23 ++-- client/src/View/Header.hs | 27 ++-- client/src/View/Payment.hs | 29 ++-- client/src/View/Payment/Pages.hs | 57 ++++---- client/src/View/Payment/Table.hs | 102 ++++++++------ client/src/View/SignIn.hs | 36 +++-- common/Setup.hs | 2 +- common/common.cabal | 86 ++++++------ common/src/Common/Message.hs | 6 +- common/src/Common/Message/Key.hs | 2 +- common/src/Common/Message/Translation.hs | 16 +-- common/src/Common/Model.hs | 32 ++--- common/src/Common/Model/Category.hs | 18 +-- common/src/Common/Model/CreateCategory.hs | 8 +- common/src/Common/Model/CreateIncome.hs | 8 +- common/src/Common/Model/CreatePayment.hs | 20 +-- common/src/Common/Model/Currency.hs | 6 +- common/src/Common/Model/EditCategory.hs | 12 +- common/src/Common/Model/EditIncome.hs | 12 +- common/src/Common/Model/EditPayment.hs | 24 ++-- common/src/Common/Model/Frequency.hs | 4 +- common/src/Common/Model/Income.hs | 22 +-- common/src/Common/Model/Init.hs | 28 ++-- common/src/Common/Model/InitResult.hs | 8 +- common/src/Common/Model/Payment.hs | 28 ++-- common/src/Common/Model/PaymentCategory.hs | 20 +-- common/src/Common/Model/SignIn.hs | 6 +- common/src/Common/Model/User.hs | 18 +-- common/src/Common/Util/Text.hs | 4 +- common/src/Common/View/Format.hs | 16 +-- result-client | 1 - result-server | 1 - server/Setup.hs | 2 +- server/server.cabal | 211 +++++++++++++++-------------- server/src/Conf.hs | 20 +-- server/src/Controller/Category.hs | 23 ++-- server/src/Controller/Income.hs | 21 +-- server/src/Controller/Index.hs | 36 ++--- server/src/Controller/Payment.hs | 22 +-- server/src/Controller/SignIn.hs | 32 ++--- server/src/Cookie.hs | 22 +-- server/src/Design/Color.hs | 4 +- server/src/Design/Constants.hs | 2 +- server/src/Design/Dialog.hs | 4 +- server/src/Design/Errors.hs | 4 +- server/src/Design/Form.hs | 6 +- server/src/Design/Global.hs | 20 +-- server/src/Design/Helper.hs | 8 +- server/src/Design/Media.hs | 6 +- server/src/Design/Tooltip.hs | 4 +- server/src/Design/View/Header.hs | 8 +- server/src/Design/View/Payment.hs | 6 +- server/src/Design/View/Payment/Header.hs | 12 +- server/src/Design/View/Payment/Pages.hs | 8 +- server/src/Design/View/Payment/Table.hs | 2 +- server/src/Design/View/SignIn.hs | 8 +- server/src/Design/View/Stat.hs | 2 +- server/src/Design/View/Table.hs | 6 +- server/src/Design/Views.hs | 20 +-- server/src/Job/Daemon.hs | 25 ++-- server/src/Job/Frequency.hs | 2 +- server/src/Job/Kind.hs | 13 +- server/src/Job/Model.hs | 18 +-- server/src/Job/MonthlyPayment.hs | 10 +- server/src/Job/WeeklyReport.hs | 12 +- server/src/Json.hs | 10 +- server/src/LoginSession.hs | 15 +- server/src/Main.hs | 38 +++--- server/src/MimeMail.hs | 68 +++++----- server/src/Model/Category.hs | 16 +-- server/src/Model/Frequency.hs | 21 +-- server/src/Model/Income.hs | 18 +-- server/src/Model/Init.hs | 14 +- server/src/Model/Mail.hs | 8 +- server/src/Model/Payer.hs | 31 +++-- server/src/Model/Payment.hs | 34 +++-- server/src/Model/PaymentCategory.hs | 18 +-- server/src/Model/Query.hs | 4 +- server/src/Model/SignIn.hs | 24 ++-- server/src/Model/UUID.hs | 6 +- server/src/Model/User.hs | 16 +-- server/src/Resource.hs | 10 +- server/src/Secure.hs | 24 ++-- server/src/SendMail.hs | 18 +-- server/src/Utils/Time.hs | 8 +- server/src/Validation.hs | 2 +- server/src/View/Mail/SignIn.hs | 12 +- server/src/View/Mail/WeeklyReport.hs | 41 +++--- server/src/View/Page.hs | 28 ++-- stylish-haskell/default.nix | 44 ++++++ tools.nix | 9 +- 100 files changed, 1067 insertions(+), 929 deletions(-) create mode 100644 .stylish-haskell.yaml create mode 100644 client/src/Component.hs delete mode 120000 result-client delete mode 120000 result-server create mode 100644 stylish-haskell/default.nix diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..3642d0e --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,30 @@ +steps: + - simple_align: + cases: true + top_level_patterns: true + records: true + + - imports: + align: global + list_align: after_alias + pad_module_names: true + long_list_align: inline + empty_list_align: inherit + list_padding: 4 + separate_lists: true + space_surround: false + + - language_pragmas: + style: vertical + align: true + remove_redundant: true + + - trailing_whitespace: {} + +columns: 80 + +newline: native + +language_extensions: + - ExistentialQuantification + - MultiParamTypeClasses diff --git a/Makefile b/Makefile index d18fb6d..16bf753 100644 --- a/Makefile +++ b/Makefile @@ -29,7 +29,7 @@ cp-client: @cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js watch-client: - @nix-shell -A shells.ghcjs --run "nodemon --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" + @nix-shell -A shells.ghcjs --run "nodemon --delay 0.1 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" # Server # ------ @@ -48,4 +48,4 @@ run-server: @./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server watch-server: - @nix-shell -A shells.ghc --run "nodemon --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" + @nix-shell -A shells.ghc --run "nodemon --delay 0.1 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" diff --git a/client/Setup.hs b/client/Setup.hs index 9a994af..4467109 100644 --- a/client/Setup.hs +++ b/client/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/client/client.cabal b/client/client.cabal index 9d3e873..ac74d9c 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -1,34 +1,41 @@ -name: client -version: 0.0.1 -license: GPL-3 -license-file: LICENSE -author: Joris Guyonvarch -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 +Name: client +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 -executable client - main-is: Main.hs - ghc-options: -Wall -Werror - build-depends: aeson - , base >=4.9 && <4.11 - , bytestring - , common - , containers - , jsaddle-dom - , reflex-dom - , text - , time - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Component.Button - , Component.Input - , Icon - , Main - , View.App - , View.Header - , View.Payment - , View.Payment.Pages - , View.Payment.Table - , View.SignIn +Executable client + Main-Is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + Extensions: + ExistentialQuantification + MultiParamTypeClasses + + Build-depends: + aeson + , base >=4.9 && <4.11 + , bytestring + , common + , containers + , jsaddle-dom + , reflex-dom + , text + , time + + other-modules: + Component.Button + Component.Input + Icon + Main + View.App + View.Header + View.Payment + View.Payment.Pages + View.Payment.Table + View.SignIn diff --git a/client/src/Component.hs b/client/src/Component.hs new file mode 100644 index 0000000..4c9541b --- /dev/null +++ b/client/src/Component.hs @@ -0,0 +1,4 @@ +module Component (module X) where + +import Component.Button as X +import Component.Input as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index f21798c..9499045 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Component.Button ( ButtonIn(..) @@ -8,17 +7,17 @@ module Component.Button , button ) where -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text + { _buttonIn_class :: Text , _buttonIn_content :: m () , _buttonIn_waiting :: Event t Bool } diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 7111630..c3864b4 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Component.Input ( InputIn(..) @@ -7,12 +6,12 @@ module Component.Input , input ) where -import Data.Text (Text) -import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:)) import qualified Reflex.Dom as R data InputIn t a b = InputIn - { _inputIn_reset :: Event t a + { _inputIn_reset :: Event t a , _inputIn_placeHolder :: Text } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 6b2749a..cd5a0b4 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Icon ( clone @@ -13,10 +12,10 @@ module Icon , signOut ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R clone :: forall t m. MonadWidget t m => m () diff --git a/client/src/Main.hs b/client/src/Main.hs index 14f0fee..cbc881c 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -2,22 +2,22 @@ module Main ( main ) where -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LB -import qualified Data.JSString.Text as Dom -import qualified Data.Text.Encoding as T -import qualified JSDOM as Dom -import qualified JSDOM.Generated.HTMLElement as Dom +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import qualified Data.JSString.Text as Dom +import qualified Data.Text.Encoding as T +import qualified JSDOM as Dom +import qualified JSDOM.Generated.HTMLElement as Dom import qualified JSDOM.Generated.NonElementParentNode as Dom -import JSDOM.Types (JSM, HTMLElement(..)) -import qualified JSDOM.Types as Dom -import Prelude hiding (init, error) +import JSDOM.Types (HTMLElement (..), JSM) +import qualified JSDOM.Types as Dom +import Prelude hiding (error, init) -import Common.Model (InitResult(InitEmpty)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult (InitEmpty)) -import qualified View.App as App +import qualified View.App as App main :: JSM () main = do @@ -33,7 +33,7 @@ readInit = do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init - Nothing -> initParseError + Nothing -> initParseError _ -> return initParseError where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 1466811..442fa3e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.App ( widget ) where -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import Common.Model (InitResult(..)) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key +import Common.Model (InitResult (..)) -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 705e054..711ba80 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Header ( view @@ -8,19 +7,19 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -55,7 +54,7 @@ nameSignOut initResult = case initResult of signOut <- R.elDynAttr "nameSignOut" attr $ do case CM.findUser (_init_currentUser init) (_init_users init) of Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank + Nothing -> R.blank signOutButton return signOut diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index d1430c9..f70c8cd 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment ( widget @@ -8,14 +7,14 @@ module View.Payment , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init(..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn(..)) +import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn(..)) +import View.Payment.Table (TableIn (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -29,10 +28,12 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - _ <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn - } + rec + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + , _tableIn_currentPage = _pagesOut_currentPage pagesOut + } + pagesOut <- Pages.widget $ PagesIn + { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + } return $ PaymentOut {} diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f9a2b4e..cf3e115 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Pages ( widget @@ -8,35 +7,45 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Event, Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment(..)) +import Common.Model (Payment (..)) +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon data PagesIn = PagesIn { _pagesIn_payments :: [Payment] } -data PagesOut = PagesOut - { +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) widget _ = do - R.divClass "pages" $ do - page Icon.doubleLeftBar - page Icon.doubleLeft - page (R.text . T.pack . show $ (1 :: Integer)) - page (R.text . T.pack . show $ (2 :: Integer)) - page (R.text . T.pack . show $ (3 :: Integer)) - page (R.text . T.pack . show $ (4 :: Integer)) - page (R.text . T.pack . show $ (5 :: Integer)) - page Icon.doubleRight - page Icon.doubleRightBar - return $ PagesOut {} - -page :: forall t m. MonadWidget t m => m () -> m () -page content = R.elClass "button" "page" $ content + currentPage <- R.divClass "pages" $ do + a <- page 1 Icon.doubleLeftBar + b <- page 1 Icon.doubleLeft + c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) + d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) + e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) + f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) + g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) + h <- page 5 Icon.doubleRight + i <- page 5 Icon.doubleRightBar + R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + +page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) +page n content = + ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn + { _buttonIn_class = "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f3eb9a7..734511d 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Table ( widget @@ -8,34 +7,40 @@ module View.Payment.Table , TableOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget, Dynamic) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T import qualified Common.View.Format as Format import qualified Icon -data TableIn = TableIn +data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int } data TableOut = TableOut { } -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +visiblePayments :: Int +visiblePayments = 8 + +widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.divClass "table" $ + R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) + _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name @@ -48,39 +53,50 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) + paymentRange = fmap + (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) + (_tableIn_currentPage tableIn) + R.simpleList paymentRange (paymentRow init) return $ TableOut {} -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell name" . R.dynText . fmap _payment_name $ payment + R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment + + let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) R.divClass "cell user" $ - case CM.findUser (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank + R.dynText $ flip fmap user $ \mbUser -> case mbUser of + Just u -> _user_name u + _ -> "" + + let category = flip fmap payment $ \p -> findCategory + (_init_categories init) + (_init_paymentCategories init) + (_payment_name p) + R.divClass "cell category" $ do + let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of + Just c -> M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ + R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of + Just c -> _category_name c + _ -> "" + R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment + R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank + let modifyAttrs = flip fmap payment $ \p -> + M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.edit + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.delete findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index e164ee7..70c6b1f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) +import Common.Model (SignIn (SignIn)) -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -75,11 +73,11 @@ showSignInResult result signInResult = do _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error + where showInitResult (Left error) = showError error showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + showInitResult (Right Nothing) = R.blank - showResult (Left error) = showError error + showResult (Left error) = showError error showResult (Right success) = showSuccess success showError = R.divClass "error" . R.text diff --git a/common/Setup.hs b/common/Setup.hs index 9a994af..4467109 100644 --- a/common/Setup.hs +++ b/common/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/common/common.cabal b/common/common.cabal index 8b60743..c3073d9 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -1,41 +1,47 @@ -name: common -version: 0.0.1 -license: GPL-3 -license-file: LICENSE -author: Joris Guyonvarch -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 +Name: common +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 -library - ghc-options: -Wall -Werror - build-depends: aeson - , base >=4.9 && <4.11 - , text - , time - hs-source-dirs: src - default-language: Haskell2010 - exposed-modules: Common.Message - , Common.Message.Key - , Common.Model - , Common.Util.Text - , Common.View.Format - other-modules: Common.Message.Lang - , Common.Message.Translation - , Common.Model.PaymentCategory - , Common.Model.CreateCategory - , Common.Model.CreatePayment - , Common.Model.CreateIncome - , Common.Model.EditCategory - , Common.Model.EditPayment - , Common.Model.InitResult - , Common.Model.EditIncome - , Common.Model.Frequency - , Common.Model.Currency - , Common.Model.Category - , Common.Model.Payment - , Common.Model.Income - , Common.Model.SignIn - , Common.Model.Init - , Common.Model.User +Library + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + + Build-depends: + aeson + , base >=4.9 && <4.11 + , text + , time + + Exposed-modules: + Common.Message + Common.Message.Key + Common.Model + Common.Util.Text + Common.View.Format + + other-modules: + Common.Message.Lang + Common.Message.Translation + Common.Model.PaymentCategory + Common.Model.CreateCategory + Common.Model.CreatePayment + Common.Model.CreateIncome + Common.Model.EditCategory + Common.Model.EditPayment + Common.Model.InitResult + Common.Model.EditIncome + Common.Model.Frequency + Common.Model.Currency + Common.Model.Category + Common.Model.Payment + Common.Model.Income + Common.Model.SignIn + Common.Model.Init + Common.Model.User diff --git a/common/src/Common/Message.hs b/common/src/Common/Message.hs index 9ae735d..745e457 100644 --- a/common/src/Common/Message.hs +++ b/common/src/Common/Message.hs @@ -2,10 +2,10 @@ module Common.Message ( get ) where -import Data.Text (Text) +import Data.Text (Text) -import Common.Message.Key (Key) -import Common.Message.Lang (Lang(..)) +import Common.Message.Key (Key) +import Common.Message.Lang (Lang (..)) import qualified Common.Message.Translation as Translation get :: Key -> Text diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 4127808..991c407 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -2,7 +2,7 @@ module Common.Message.Key ( Key(..) ) where -import Data.Text +import Data.Text data Key = diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 900a9e9..16a56dd 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -4,11 +4,11 @@ module Common.Message.Translation ( get ) where -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T -import Common.Message.Key -import Common.Message.Lang (Lang(..)) +import Common.Message.Key +import Common.Message.Lang (Lang (..)) get :: Lang -> Key -> Text get = m @@ -162,7 +162,7 @@ m l Form_AlreadyExists = m l Form_CostMustNotBeNull = case l of English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" + French -> "Le coût ne doît pas être nul" m l Form_Empty = case l of @@ -462,7 +462,7 @@ m l Payment_PunctualMale = m l Payment_Title = case l of English -> "Payments" - French -> "Paiements" + French -> "Paiements" m l Payment_User = case l of @@ -472,7 +472,7 @@ m l Payment_User = m l (Payment_Worth subject amount) = case l of English -> T.concat [ subject, " worth ", amount ] - French -> T.concat [ subject, " comptabilisant ", amount ] + French -> T.concat [ subject, " comptabilisant ", amount ] m l Search_Monthly = case l of @@ -517,7 +517,7 @@ m l SignIn_EmailInvalid = m l SignIn_EmailPlaceholder = case l of English -> "Email" - French -> "Courriel" + French -> "Courriel" m l SignIn_EmailSendFail = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 80c344b..20e86c1 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -1,18 +1,18 @@ module Common.Model (module X) where -import Common.Model.Category as X -import Common.Model.CreateCategory as X -import Common.Model.CreateIncome as X -import Common.Model.CreatePayment as X -import Common.Model.Currency as X -import Common.Model.EditCategory as X -import Common.Model.EditIncome as X -import Common.Model.EditPayment as X -import Common.Model.Frequency as X -import Common.Model.Income as X -import Common.Model.Init as X -import Common.Model.InitResult as X -import Common.Model.Payment as X -import Common.Model.PaymentCategory as X -import Common.Model.SignIn as X -import Common.Model.User as X +import Common.Model.Category as X +import Common.Model.CreateCategory as X +import Common.Model.CreateIncome as X +import Common.Model.CreatePayment as X +import Common.Model.Currency as X +import Common.Model.EditCategory as X +import Common.Model.EditIncome as X +import Common.Model.EditPayment as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.Init as X +import Common.Model.InitResult as X +import Common.Model.Payment as X +import Common.Model.PaymentCategory as X +import Common.Model.SignIn as X +import Common.Model.User as X diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs index 53a6bdb..bbd3c33 100644 --- a/common/src/Common/Model/Category.hs +++ b/common/src/Common/Model/Category.hs @@ -5,20 +5,20 @@ module Common.Model.Category , Category(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) type CategoryId = Int64 data Category = Category - { _category_id :: CategoryId - , _category_name :: Text - , _category_color :: Text + { _category_id :: CategoryId + , _category_name :: Text + , _category_color :: Text , _category_createdAt :: UTCTime - , _category_editedAt :: Maybe UTCTime + , _category_editedAt :: Maybe UTCTime , _category_deletedAt :: Maybe UTCTime } deriving (Show, Generic) diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs index bfe24c5..11d84e9 100644 --- a/common/src/Common/Model/CreateCategory.hs +++ b/common/src/Common/Model/CreateCategory.hs @@ -4,12 +4,12 @@ module Common.Model.CreateCategory ( CreateCategory(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) data CreateCategory = CreateCategory - { _createCategory_name :: Text + { _createCategory_name :: Text , _createCategory_color :: Text } deriving (Show, Generic) diff --git a/common/src/Common/Model/CreateIncome.hs b/common/src/Common/Model/CreateIncome.hs index 4ee3a50..583ebbb 100644 --- a/common/src/Common/Model/CreateIncome.hs +++ b/common/src/Common/Model/CreateIncome.hs @@ -4,12 +4,12 @@ module Common.Model.CreateIncome ( CreateIncome(..) ) where -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) data CreateIncome = CreateIncome - { _createIncome_date :: Day + { _createIncome_date :: Day , _createIncome_amount :: Int } deriving (Show, Generic) diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index b5b6256..7a283e5 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -4,19 +4,19 @@ module Common.Model.CreatePayment ( CreatePayment(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) data CreatePayment = CreatePayment - { _createPayment_name :: Text - , _createPayment_cost :: Int - , _createPayment_date :: Day - , _createPayment_category :: CategoryId + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId , _createPayment_frequency :: Frequency } deriving (Show, Generic) diff --git a/common/src/Common/Model/Currency.hs b/common/src/Common/Model/Currency.hs index 7c12545..6d74ea7 100644 --- a/common/src/Common/Model/Currency.hs +++ b/common/src/Common/Model/Currency.hs @@ -4,9 +4,9 @@ module Common.Model.Currency ( Currency(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) newtype Currency = Currency Text deriving (Show, Generic) diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs index 2a3a697..5b08b86 100644 --- a/common/src/Common/Model/EditCategory.hs +++ b/common/src/Common/Model/EditCategory.hs @@ -4,15 +4,15 @@ module Common.Model.EditCategory ( EditCategory(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) +import Common.Model.Category (CategoryId) data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text + { _editCategory_id :: CategoryId + , _editCategory_name :: Text , _editCategory_color :: Text } deriving (Show, Generic) diff --git a/common/src/Common/Model/EditIncome.hs b/common/src/Common/Model/EditIncome.hs index a55c39e..867b406 100644 --- a/common/src/Common/Model/EditIncome.hs +++ b/common/src/Common/Model/EditIncome.hs @@ -4,15 +4,15 @@ module Common.Model.EditIncome ( EditIncome(..) ) where -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Income (IncomeId) +import Common.Model.Income (IncomeId) data EditIncome = EditIncome - { _editIncome_id :: IncomeId - , _editIncome_date :: Day + { _editIncome_id :: IncomeId + , _editIncome_date :: Day , _editIncome_amount :: Int } deriving (Show, Generic) diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs index 172c0c1..32228f0 100644 --- a/common/src/Common/Model/EditPayment.hs +++ b/common/src/Common/Model/EditPayment.hs @@ -4,21 +4,21 @@ module Common.Model.EditPayment ( EditPayment(..) ) where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON) +import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) -import Common.Model.Payment (PaymentId) +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) data EditPayment = EditPayment - { _editPayment_id :: PaymentId - , _editPayment_name :: Text - , _editPayment_cost :: Int - , _editPayment_date :: Day - , _editPayment_category :: CategoryId + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId , _editPayment_frequency :: Frequency } deriving (Show, Generic) diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs index 7c46605..085163d 100644 --- a/common/src/Common/Model/Frequency.hs +++ b/common/src/Common/Model/Frequency.hs @@ -4,8 +4,8 @@ module Common.Model.Frequency ( Frequency(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) data Frequency = Punctual diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs index 280812f..10b4cf2 100644 --- a/common/src/Common/Model/Income.hs +++ b/common/src/Common/Model/Income.hs @@ -5,23 +5,23 @@ module Common.Model.Income , Income(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.User (UserId) +import Common.Model.User (UserId) type IncomeId = Int64 data Income = Income - { _income_id :: IncomeId - , _income_userId :: UserId - , _income_date :: Day - , _income_amount :: Int + { _income_id :: IncomeId + , _income_userId :: UserId + , _income_date :: Day + , _income_amount :: Int , _income_createdAt :: UTCTime - , _income_editedAt :: Maybe UTCTime + , _income_editedAt :: Maybe UTCTime , _income_deletedAt :: Maybe UTCTime } deriving (Show, Generic) diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs index 68fcfb8..ae23bb5 100644 --- a/common/src/Common/Model/Init.hs +++ b/common/src/Common/Model/Init.hs @@ -4,24 +4,24 @@ module Common.Model.Init ( Init(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) -import Common.Model.Category (Category) -import Common.Model.Currency (Currency) -import Common.Model.Income (Income) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.User (UserId, User) +import Common.Model.Category (Category) +import Common.Model.Currency (Currency) +import Common.Model.Income (Income) +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.User (User, UserId) data Init = Init - { _init_users :: [User] - , _init_currentUser :: UserId - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] , _init_paymentCategories :: [PaymentCategory] - , _init_currency :: Currency + , _init_currency :: Currency } deriving (Show, Generic) instance FromJSON Init diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs index 43c16f9..12be65a 100644 --- a/common/src/Common/Model/InitResult.hs +++ b/common/src/Common/Model/InitResult.hs @@ -4,11 +4,11 @@ module Common.Model.InitResult ( InitResult(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) -import Common.Model.Init (Init) +import Common.Model.Init (Init) data InitResult = InitSuccess Init diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 804b501..4741058 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -5,27 +5,27 @@ module Common.Model.Payment , Payment(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.Frequency -import Common.Model.User (UserId) +import Common.Model.Frequency +import Common.Model.User (UserId) type PaymentId = Int64 data Payment = Payment - { _payment_id :: PaymentId - , _payment_user :: UserId - , _payment_name :: Text - , _payment_cost :: Int - , _payment_date :: Day + { _payment_id :: PaymentId + , _payment_user :: UserId + , _payment_name :: Text + , _payment_cost :: Int + , _payment_date :: Day , _payment_frequency :: Frequency , _payment_createdAt :: UTCTime - , _payment_editedAt :: Maybe UTCTime + , _payment_editedAt :: Maybe UTCTime , _payment_deletedAt :: Maybe UTCTime } deriving (Show, Generic) diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs index a0e94f9..24cf9e1 100644 --- a/common/src/Common/Model/PaymentCategory.hs +++ b/common/src/Common/Model/PaymentCategory.hs @@ -5,22 +5,22 @@ module Common.Model.PaymentCategory , PaymentCategory(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) -import Common.Model.Category (CategoryId) +import Common.Model.Category (CategoryId) type PaymentCategoryId = Int64 data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId + { _paymentCategory_id :: PaymentCategoryId + , _paymentCategory_name :: Text + , _paymentCategory_category :: CategoryId , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime + , _paymentCategory_editedAt :: Maybe UTCTime } deriving (Show, Generic) instance FromJSON PaymentCategory diff --git a/common/src/Common/Model/SignIn.hs b/common/src/Common/Model/SignIn.hs index f4da97f..baccd88 100644 --- a/common/src/Common/Model/SignIn.hs +++ b/common/src/Common/Model/SignIn.hs @@ -4,9 +4,9 @@ module Common.Model.SignIn ( SignIn(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) data SignIn = SignIn { _signIn_email :: Text diff --git a/common/src/Common/Model/User.hs b/common/src/Common/Model/User.hs index 694c70e..e491c31 100644 --- a/common/src/Common/Model/User.hs +++ b/common/src/Common/Model/User.hs @@ -6,20 +6,20 @@ module Common.Model.User , findUser ) where -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.List as L -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int64) +import qualified Data.List as L +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) type UserId = Int64 data User = User - { _user_id :: UserId + { _user_id :: UserId , _user_creation :: UTCTime - , _user_email :: Text - , _user_name :: Text + , _user_email :: Text + , _user_name :: Text } deriving (Show, Generic) instance FromJSON User diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index 4af7a4c..7e5c8c2 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -2,7 +2,7 @@ module Common.Util.Text ( unaccent ) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T unaccent :: Text -> Text @@ -38,4 +38,4 @@ unaccentChar c = case c of 'ý' -> 'y' 'ÿ' -> 'y' 'ž' -> 'z' - _ -> c + _ -> c diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs index 7165965..783ad67 100644 --- a/common/src/Common/View/Format.hs +++ b/common/src/Common/View/Format.hs @@ -7,15 +7,15 @@ module Common.View.Format , number ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, toGregorian) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day, toGregorian) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Currency(..)) +import Common.Model (Currency (..)) shortDay :: Day -> Text shortDay date = @@ -45,7 +45,7 @@ longDay date = monthToKey 10 = Just Key.Month_October monthToKey 11 = Just Key.Month_November monthToKey 12 = Just Key.Month_December - monthToKey _ = Nothing + monthToKey _ = Nothing price :: Currency -> Int -> Text price (Currency currency) amount = T.concat [ number amount, " ", currency ] diff --git a/result-client b/result-client deleted file mode 120000 index 157e7ca..0000000 --- a/result-client +++ /dev/null @@ -1 +0,0 @@ -/nix/store/j41w9i28pasvvy6dgqrygj34s30hscad-client-0.0.1 \ No newline at end of file diff --git a/result-server b/result-server deleted file mode 120000 index 561c4ee..0000000 --- a/result-server +++ /dev/null @@ -1 +0,0 @@ -/nix/store/6myvk196ip9xv91xi04g43zbqis84a1i-server-0.0.1 \ No newline at end of file diff --git a/server/Setup.hs b/server/Setup.hs index 9a994af..4467109 100644 --- a/server/Setup.hs +++ b/server/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/server/server.cabal b/server/server.cabal index 41b2fd6..d30060b 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -1,103 +1,110 @@ -name: server -version: 0.0.1 -license: GPL-3 -license-file: LICENSE -author: Joris Guyonvarch -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 +Name: server +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 -executable server - main-is: Main.hs - ghc-options: -Wall -Werror - build-depends: aeson - , base >=4.9 && <4.11 - , base64-bytestring - , blaze-builder - , blaze-html - , bytestring - , clay - , clientsession - , common - , config-manager - , containers - , cookie - , email-validate - , filepath - , http-conduit - , http-types - , lens - , monad-logger - , mtl - , parsec - , process - , random - , resourcet - , scotty - , sqlite-simple - , text - , time - , transformers - , unordered-containers - , uuid - , wai - , wai-extra - , wai-middleware-static - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Conf - , Controller.Category - , Controller.Income - , Controller.Index - , Controller.Payment - , Controller.SignIn - , Cookie - , Design.Color - , Design.Constants - , Design.Dialog - , Design.Errors - , Design.Form - , Design.Global - , Design.Helper - , Design.Media - , Design.Tooltip - , Design.View.Header - , Design.View.Payment - , Design.View.Payment.Header - , Design.View.Payment.Pages - , Design.View.Payment.Table - , Design.View.SignIn - , Design.View.Stat - , Design.View.Table - , Design.Views - , Job.Daemon - , Job.Frequency - , Job.Kind - , Job.Model - , Job.MonthlyPayment - , Job.WeeklyReport - , Json - , LoginSession - , Main - , MimeMail - , Model.Category - , Model.Frequency - , Model.Income - , Model.Init - , Model.Mail - , Model.Payer - , Model.Payment - , Model.PaymentCategory - , Model.Query - , Model.SignIn - , Model.UUID - , Model.User - , Resource - , Secure - , SendMail - , Utils.Time - , Validation - , View.Mail.SignIn - , View.Mail.WeeklyReport - , View.Page +Executable server + Main-is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + Extensions: + ExistentialQuantification + MultiParamTypeClasses + + Build-depends: + aeson + , base >=4.9 && <4.11 + , base64-bytestring + , blaze-builder + , blaze-html + , bytestring + , clay + , clientsession + , common + , config-manager + , containers + , cookie + , email-validate + , filepath + , http-conduit + , http-types + , lens + , monad-logger + , mtl + , parsec + , process + , random + , resourcet + , scotty + , sqlite-simple + , text + , time + , transformers + , unordered-containers + , uuid + , wai + , wai-extra + , wai-middleware-static + + other-modules: + Conf + Controller.Category + Controller.Income + Controller.Index + Controller.Payment + Controller.SignIn + Cookie + Design.Color + Design.Constants + Design.Dialog + Design.Errors + Design.Form + Design.Global + Design.Helper + Design.Media + Design.Tooltip + Design.View.Header + Design.View.Payment + Design.View.Payment.Header + Design.View.Payment.Pages + Design.View.Payment.Table + Design.View.SignIn + Design.View.Stat + Design.View.Table + Design.Views + Job.Daemon + Job.Frequency + Job.Kind + Job.Model + Job.MonthlyPayment + Job.WeeklyReport + Json + LoginSession + Main + MimeMail + Model.Category + Model.Frequency + Model.Income + Model.Init + Model.Mail + Model.Payer + Model.Payment + Model.PaymentCategory + Model.Query + Model.SignIn + Model.UUID + Model.User + Resource + Secure + SendMail + Utils.Time + Validation + View.Mail.SignIn + View.Mail.WeeklyReport + View.Page diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 26c5c28..299f071 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -5,20 +5,20 @@ module Conf , Conf(..) ) where -import Data.Text (Text) -import qualified Data.Text as T import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) -import Common.Model (Currency(..)) +import Common.Model (Currency (..)) data Conf = Conf - { hostname :: Text - , port :: Int + { hostname :: Text + , port :: Int , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: Bool + , currency :: Currency + , noReplyMail :: Text + , https :: Bool } deriving Show get :: FilePath -> IO Conf @@ -36,4 +36,4 @@ get path = do ) case conf of Left msg -> error (T.unpack msg) - Right c -> return c + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index d6ed2f2..a646496 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -6,19 +6,20 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty hiding (delete) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure create :: CreateCategory -> ActionM () diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 148b713..c42f6a7 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -6,18 +6,19 @@ module Controller.Income , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome (..), EditIncome (..), + IncomeId, User (..)) -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query import qualified Secure create :: CreateIncome -> ActionM () diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 8473c5c..bf4859d 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -3,26 +3,26 @@ module Controller.Index , signOut ) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult (..), User (..)) -import Conf (Conf(..)) -import Model.Init (getInit) +import Conf (Conf (..)) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) +import Model.Init (getInit) +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import Secure (getUserFromToken) +import View.Page (page) get :: Conf -> Maybe Text -> ActionM () get conf mbToken = do @@ -70,7 +70,7 @@ validateSignIn conf textToken = do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index dc10311..e4104eb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -7,16 +7,18 @@ module Controller.Payment , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty + +import Common.Model (CreatePayment (..), + EditPayment (..), PaymentId, + User (..)) + +import Json (jsonId) +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure list :: ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 0086fa5..5552781 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -4,25 +4,25 @@ module Controller.SignIn ( signIn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn (..)) -import Conf (Conf) +import Conf (Conf) import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn signIn :: Conf -> SignIn -> ActionM () signIn conf (SignIn email) = @@ -41,7 +41,7 @@ signIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail Nothing -> textKey badRequest400 Key.Secure_Unauthorized else textKey badRequest400 Key.SignIn_EmailInvalid where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs index 96d45da..511dd42 100644 --- a/server/src/Cookie.hs +++ b/server/src/Cookie.hs @@ -9,25 +9,25 @@ module Cookie , deleteCookie ) where -import Control.Monad ( liftM ) +import Control.Monad (liftM) -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL -import Conf (Conf) +import Conf (Conf) import qualified Conf -import qualified Data.Map as Map +import qualified Data.Map as Map -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as BSL -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Blaze.ByteString.Builder ( toLazyByteString ) +import Blaze.ByteString.Builder (toLazyByteString) -import Web.Scotty.Trans -import Web.Cookie +import Web.Cookie +import Web.Scotty.Trans makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie makeSimpleCookie conf name value = diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs index 9a5797f..e7f5aec 100644 --- a/server/src/Design/Color.hs +++ b/server/src/Design/Color.hs @@ -1,8 +1,8 @@ module Design.Color where -import Clay +import Clay import qualified Clay.Color as C -import Data.Text (Text) +import Data.Text (Text) -- http://chir.ag/projects/name-that-color/#969696 diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs index 4e2b8cc..a3123d9 100644 --- a/server/src/Design/Constants.hs +++ b/server/src/Design/Constants.hs @@ -1,6 +1,6 @@ module Design.Constants where -import Clay +import Clay iconFontSize :: Size LengthUnit iconFontSize = px 32 diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs index 4678633..6759606 100644 --- a/server/src/Design/Dialog.hs +++ b/server/src/Design/Dialog.hs @@ -4,9 +4,9 @@ module Design.Dialog ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay design :: Css design = do diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs index 57aaeee..2c6c16b 100644 --- a/server/src/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -4,9 +4,9 @@ module Design.Errors ( design ) where -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index ebb8ac8..a4a1de0 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -4,11 +4,11 @@ module Design.Form ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 47ea4a9..1fe6a80 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -4,20 +4,20 @@ module Design.Global ( globalDesign ) where -import Clay +import Clay -import Data.Text.Lazy (Text) +import Data.Text.Lazy (Text) -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip +import qualified Design.Dialog as Dialog +import qualified Design.Errors as Errors +import qualified Design.Form as Form +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media globalDesign :: Text globalDesign = renderWith compact [] global diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 41528ed..0913511 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -9,12 +9,12 @@ module Design.Helper , verticalCentering ) where -import Prelude hiding (span) +import Prelude hiding (span) -import Clay hiding (button, input) +import Clay hiding (button, input) -import Design.Constants -import Design.Color as Color +import Design.Color as Color +import Design.Constants clearFix :: Css clearFix = diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs index 77220ee..19a3b8c 100644 --- a/server/src/Design/Media.hs +++ b/server/src/Design/Media.hs @@ -6,10 +6,10 @@ module Design.Media , desktop ) where -import Clay hiding (query) +import Clay hiding (query) import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media +import qualified Clay.Media as Media +import Clay.Stylesheet (Feature) mobile :: Css -> Css mobile = query [Media.maxWidth mobileTabletLimit] diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs index 1da8764..57aec33 100644 --- a/server/src/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -4,9 +4,9 @@ module Design.Tooltip ( design ) where -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color design :: Css design = do diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 20627e6..d05f748 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -4,13 +4,13 @@ module Design.View.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color import qualified Design.Helper as Helper -import qualified Design.Media as Media +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index d3c7650..62f7061 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,11 +4,11 @@ module Design.View.Payment ( design ) where -import Clay +import Clay import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages +import qualified Design.View.Payment.Pages as Pages +import qualified Design.View.Payment.Table as Table design :: Css design = do diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index f02da8a..d87e95b 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -4,16 +4,16 @@ module Design.View.Payment.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Constants +import Design.Constants -import qualified Design.Helper as Helper -import qualified Design.Color as Color +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index 5fc13f0..f6660a1 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -4,12 +4,12 @@ module Design.View.Payment.Pages ( design ) where -import Clay +import Clay -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Media as Media +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index f8326e4..243d7f4 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -4,7 +4,7 @@ module Design.View.Payment.Table ( design ) where -import Clay +import Clay import qualified Design.Color as Color import qualified Design.Media as Media diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 214e663..2b1252f 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -4,12 +4,12 @@ module Design.View.SignIn ( design ) where -import Clay -import Data.Monoid ((<>)) +import Clay +import Data.Monoid ((<>)) -import qualified Design.Color as Color -import qualified Design.Helper as Helper +import qualified Design.Color as Color import qualified Design.Constants as Constants +import qualified Design.Helper as Helper design :: Css design = do diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index 0a5b258..b10dd7b 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -4,7 +4,7 @@ module Design.View.Stat ( design ) where -import Clay +import Clay design :: Css design = do diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index 95abf90..fd55656 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -4,11 +4,11 @@ module Design.View.Table ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import Clay +import Clay -import Design.Color as Color +import Design.Color as Color import qualified Design.Media as Media design :: Css diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index bc6ac83..1157b68 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,18 +4,18 @@ module Design.Views ( design ) where -import Clay +import Clay -import qualified Design.View.Header as Header +import qualified Design.View.Header as Header import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media design :: Css design = do diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 0bc6f6e..26977d1 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -2,18 +2,19 @@ module Job.Daemon ( runDaemons ) where -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Conf (Conf) +import Job.Frequency (Frequency (..), microSeconds) +import Job.Kind (Kind (..)) +import Job.Model (actualizeLastCheck, actualizeLastExecution, + getLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do @@ -29,7 +30,7 @@ runDaemon kind frequency isLastExecutionTooOld runJob = getLastExecution kind hasToRun <- case mbLastExecution of Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True + Nothing -> return True if hasToRun then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) else return () diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs index 263f6e6..c5bef42 100644 --- a/server/src/Job/Frequency.hs +++ b/server/src/Job/Frequency.hs @@ -10,4 +10,4 @@ data Frequency = microSeconds :: Frequency -> Int microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs index af5d4f8..17997f7 100644 --- a/server/src/Job/Kind.hs +++ b/server/src/Job/Kind.hs @@ -2,11 +2,12 @@ module Job.Kind ( Kind(..) ) where -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) data Kind = MonthlyPayment @@ -16,7 +17,7 @@ data Kind = instance FromField Kind where fromField field = case fieldData field of SQLText text -> Ok (read (T.unpack text) :: Kind) - _ -> Errors [error "SQLText field required for job kind"] + _ -> Errors [error "SQLText field required for job kind"] instance ToField Kind where toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index e1a3c77..b90dca0 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -7,20 +7,20 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id) -import Job.Kind -import Model.Query (Query(Query)) +import Job.Kind +import Model.Query (Query (Query)) data Job = Job - { id :: String - , kind :: Kind + { id :: String + , kind :: Kind , lastExecution :: Maybe UTCTime - , lastCheck :: Maybe UTCTime + , lastCheck :: Maybe UTCTime } deriving (Show) getLastExecution :: Kind -> Query (Maybe UTCTime) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ba24cca..8cb1c27 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,13 +2,13 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Common.Model (Frequency(..), Payment(..)) +import Common.Model (Frequency (..), Payment (..)) -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import Utils.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 5737c75..74180df 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -2,13 +2,13 @@ module Job.WeeklyReport ( weeklyReport ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import qualified Model.User as User +import Conf (Conf) +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import qualified Model.User as User import qualified SendMail import qualified View.Mail.WeeklyReport as WeeklyReport diff --git a/server/src/Json.hs b/server/src/Json.hs index cc6327a..eb5c572 100644 --- a/server/src/Json.hs +++ b/server/src/Json.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} module Json ( jsonObject , jsonId ) where -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Aeson.Types as Json +import qualified Data.Aeson.Types as Json import qualified Data.HashMap.Strict as M -import Web.Scotty +import Data.Int (Int64) +import Data.Text (Text) +import Web.Scotty jsonObject :: [(Text, Json.Value)] -> ActionM () jsonObject = json . Json.Object . M.fromList diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs index 6f6d620..beca697 100644 --- a/server/src/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -6,16 +6,17 @@ module LoginSession , delete ) where -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS +import Cookie (deleteCookie, getCookie, + setSimpleCookie) +import qualified Web.ClientSession as CS +import Web.Scotty (ActionM) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import qualified Data.Text.Encoding as TE +import Data.Text (Text) +import qualified Data.Text.Encoding as TE -import Conf (Conf) +import Conf (Conf) sessionName :: Text sessionName = "SESSION" diff --git a/server/src/Main.hs b/server/src/Main.hs index 96c13ee..5ac68db 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,27 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as LT -import Network.Wai.Middleware.Gzip (GzipFiles(GzipCompress)) -import qualified Network.Wai.Middleware.Gzip as W -import Network.Wai.Middleware.Static -import Web.Scotty +import qualified Data.Text.Lazy as LT +import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) +import qualified Network.Wai.Middleware.Gzip as W +import Network.Wai.Middleware.Static +import Web.Scotty import qualified Conf -import qualified Controller.Category as Category -import qualified Controller.Income as Income -import qualified Controller.Index as Index -import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query +import qualified Controller.Category as Category +import qualified Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.Payment as Payment +import qualified Controller.SignIn as SignIn +import qualified Data.Time as Time +import Job.Daemon (runDaemons) +import qualified Model.Income as IncomeM +import Model.Payer (getOrderedExceedingPayers) +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query +import qualified Model.User as UserM main :: IO () main = do diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs index 0faaf98..7fe98ed 100644 --- a/server/src/MimeMail.hs +++ b/server/src/MimeMail.hs @@ -38,31 +38,33 @@ module MimeMail , quotedPrintable ) where -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM, void) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii, isControl) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Control.Arrow +import Control.Concurrent (forkIO, newEmptyMVar, + putMVar, takeMVar) +import Control.Exception (ErrorCall (ErrorCall), + throwIO) +import Control.Monad (foldM, void, (<=<)) +import Data.Bits (shiftR, (.&.)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Base64 as Base64 +import Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as L +import Data.Char (isAscii, isControl) +import Data.List (intersperse) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Word (Word8) +import System.Exit +import System.FilePath (takeFileName) +import System.IO +import System.Process +import System.Random -- | Generates a random sequence of alphanumerics of the given length. randomString :: RandomGen d => Int -> d -> (String, d) @@ -88,10 +90,10 @@ instance Random Boundary where -- | An entire mail message. data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] -- | Other headers, excluding from, to, cc and bcc. , mailHeaders :: Headers -- | A list of different sets of alternatives. As a concrete example: @@ -100,7 +102,7 @@ data Mail = Mail -- -- Make sure when specifying alternatives to place the most preferred -- version last. - , mailParts :: [Alternatives] + , mailParts :: [Alternatives] } deriving Show @@ -132,13 +134,13 @@ type Alternatives = [Part] -- | A single part of a multipart message. data Part = Part - { partType :: Text -- ^ content type + { partType :: Text -- ^ content type , partEncoding :: Encoding -- | The filename for this part, if it is to be sent with an attachemnt -- disposition. , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString + , partHeaders :: Headers + , partContent :: L.ByteString } deriving (Eq, Show) diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs index 6b7a488..b972ebd 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Model/Category.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category @@ -8,16 +8,16 @@ module Model.Category , delete ) where -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id) -import Common.Model (Category(..), CategoryId) +import Common.Model (Category (..), CategoryId) -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow Category where fromRow = Category <$> diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs index b334a40..41a325d 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Model/Frequency.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Frequency () where -import Database.SQLite.Simple (SQLData(SQLText)) -import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) -import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) -import Database.SQLite.Simple.ToField (ToField(toField)) -import qualified Data.Text as T +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) -import Common.Model (Frequency) +import Common.Model (Frequency) instance FromField Frequency where fromField field = case fieldData field of SQLText text -> Ok (read (T.unpack text) :: Frequency) - _ -> Errors [error "SQLText field required for frequency"] + _ -> Errors [error "SQLText field required for frequency"] instance ToField Frequency where toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index bbe7657..a69112a 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -9,17 +9,19 @@ module Model.Income , modifiedDuring ) where -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Common.Model (Income(..), IncomeId, User(..), UserId) +import Common.Model (Income (..), IncomeId, User (..), + UserId) -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) +import Model.Query (Query (Query)) +import Resource (Resource, resourceCreatedAt, + resourceDeletedAt, resourceEditedAt) instance Resource Income where resourceCreatedAt = _income_createdAt diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index 8c6a961..c030c58 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -4,16 +4,16 @@ module Model.Init ( getInit ) where -import Common.Model (Init(Init), User(..)) +import Common.Model (Init (Init), User (..)) -import Conf (Conf) +import Conf (Conf) import qualified Conf -import Model.Query (Query) -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment +import qualified Model.Category as Category +import qualified Model.Income as Income +import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.User as User +import Model.Query (Query) +import qualified Model.User as User getInit :: User -> Conf -> Query Init getInit user conf = diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs index 9a4db73..a19f9ae 100644 --- a/server/src/Model/Mail.hs +++ b/server/src/Model/Mail.hs @@ -2,11 +2,11 @@ module Model.Mail ( Mail(..) ) where -import Data.Text (Text) +import Data.Text (Text) data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text + { from :: Text + , to :: [Text] + , subject :: Text , plainBody :: Text } deriving (Eq, Show) diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs index de4abd1..db3f37c 100644 --- a/server/src/Model/Payer.hs +++ b/server/src/Model/Payer.hs @@ -2,14 +2,15 @@ module Model.Payer ( getOrderedExceedingPayers ) where -import Data.Map (Map) -import Data.Time (UTCTime(..), NominalDiffTime) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Time as Time +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time -import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) +import Common.Model (Income (..), IncomeId, Payment (..), User (..), + UserId) type Users = Map UserId User @@ -20,20 +21,20 @@ type Incomes = Map IncomeId Income type Payments = [Payment] data Payer = Payer - { preIncomePaymentSum :: Int + { preIncomePaymentSum :: Int , postIncomePaymentSum :: Int - , _incomes :: [Income] + , _incomes :: [Income] } data PostPaymentPayer = PostPaymentPayer { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float + , _cumulativeIncome :: Int + , ratio :: Float } data ExceedingPayer = ExceedingPayer { _userId :: UserId - , amount :: Int + , amount :: Int } deriving (Show) getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] @@ -72,7 +73,7 @@ useIncomesFrom users incomes payments = mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes in case (firstPaymentTime, mbIncomeTime) of (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing + _ -> Nothing paymentTime :: Payment -> UTCTime paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date @@ -95,7 +96,7 @@ getPayers currentTime users incomes payments = (\p -> case incomesDefined of Nothing -> False - Just t -> paymentTime p >= t + Just t -> paymentTime p >= t ) userId payments @@ -197,7 +198,7 @@ nominalDay :: NominalDiffTime nominalDay = 86400 safeHead :: [a] -> Maybe a -safeHead [] = Nothing +safeHead [] = Nothing safeHead (x : _) = Just x safeMinimum :: (Ord a) => [a] -> Maybe a diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index 14efe77..c1b109f 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment @@ -13,22 +13,26 @@ module Model.Payment , modifiedDuring ) where -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) -import Database.SQLite.Simple.ToField (ToField(toField)) -import Prelude hiding (id) -import qualified Database.SQLite.Simple as SQLite +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only), + ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id) -import Common.Model (Frequency(..), Payment(..), PaymentId, UserId) +import Common.Model (Frequency (..), Payment (..), + PaymentId, UserId) -import Model.Frequency () -import Model.Query (Query(Query)) -import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) +import Model.Frequency () +import Model.Query (Query (Query)) +import Resource (Resource, resourceCreatedAt, + resourceDeletedAt, + resourceEditedAt) instance Resource Payment where resourceCreatedAt = _payment_createdAt diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs index 6e1d304..6d02136 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Model/PaymentCategory.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory @@ -7,17 +7,17 @@ module Model.PaymentCategory , save ) where -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import qualified Data.Text as T +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Common.Model (CategoryId, PaymentCategory(..)) -import qualified Common.Util.Text as T +import Common.Model (CategoryId, PaymentCategory (..)) +import qualified Common.Util.Text as T -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow PaymentCategory where fromRow = PaymentCategory <$> diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs index d15fb5f..22ae95b 100644 --- a/server/src/Model/Query.hs +++ b/server/src/Model/Query.hs @@ -3,8 +3,8 @@ module Model.Query , run ) where -import Data.Functor (Functor) -import Database.SQLite.Simple (Connection) +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) import qualified Database.SQLite.Simple as SQLite data Query a = Query (Connection -> IO a) diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index c5182f0..6f38fe7 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -8,25 +8,25 @@ module Model.SignIn , isLastTokenValid ) where -import Data.Int (Int64) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Data.Int (Int64) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Model.Query (Query(Query)) -import Model.UUID (generateUUID) +import Model.Query (Query (Query)) +import Model.UUID (generateUUID) type SignInId = Int64 data SignIn = SignIn - { id :: SignInId - , token :: Text + { id :: SignInId + , token :: Text , creation :: UTCTime - , email :: Text - , isUsed :: Bool + , email :: Text + , isUsed :: Bool } deriving Show instance FromRow SignIn where diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs index 6cb7ce0..0959a8e 100644 --- a/server/src/Model/UUID.hs +++ b/server/src/Model/UUID.hs @@ -2,9 +2,9 @@ module Model.UUID ( generateUUID ) where -import Data.UUID (toString) -import Data.UUID.V4 (nextRandom) -import Data.Text (Text, pack) +import Data.Text (Text, pack) +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) generateUUID :: IO Text generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs index e14fcef..f17f545 100644 --- a/server/src/Model/User.hs +++ b/server/src/Model/User.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User @@ -8,16 +8,16 @@ module Model.User , delete ) where -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) -import Prelude hiding (id) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) -import Common.Model (UserId, User(..)) +import Common.Model (User (..), UserId) -import Model.Query (Query(Query)) +import Model.Query (Query (Query)) instance FromRow User where fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field diff --git a/server/src/Resource.hs b/server/src/Resource.hs index f52bbfa..a12a0f2 100644 --- a/server/src/Resource.hs +++ b/server/src/Resource.hs @@ -9,10 +9,10 @@ module Resource , statusDuring ) where -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Time.Clock (UTCTime) class Resource a where resourceCreatedAt :: a -> UTCTime @@ -34,7 +34,7 @@ groupByStatus start end resources = (\m resource -> case statusDuring start end resource of Just status -> M.insertWith (++) status [resource] m - Nothing -> m + Nothing -> m ) M.empty resources diff --git a/server/src/Secure.hs b/server/src/Secure.hs index f427304..88bdcda 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -5,21 +5,21 @@ module Secure , getUserFromToken ) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) -import Model.Query (Query) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User +import Model.Query (Query) +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User loggedAction :: (User -> ActionM ()) -> ActionM () loggedAction action = do diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index f7ba3fd..959f21d 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -4,17 +4,17 @@ module SendMail ( sendMail ) where -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) -import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified MimeMail as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder (fromText, toLazyText) +import qualified MimeMail as M -import Model.Mail (Mail(Mail)) +import Model.Mail (Mail (Mail)) sendMail :: Mail -> IO (Either Text ()) sendMail mail = do diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs index 97457c7..e1a94d3 100644 --- a/server/src/Utils/Time.hs +++ b/server/src/Utils/Time.hs @@ -4,10 +4,10 @@ module Utils.Time , timeToDay ) where -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do diff --git a/server/src/Validation.hs b/server/src/Validation.hs index 1f332c9..fd739cd 100644 --- a/server/src/Validation.hs +++ b/server/src/Validation.hs @@ -3,7 +3,7 @@ module Validation , number ) where -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T nonEmpty :: Text -> Maybe Text diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index 1daca1e..d542fd8 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -4,15 +4,15 @@ module View.Mail.SignIn ( mail ) where -import Data.Text (Text) +import Data.Text (Text) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (User(..)) +import Common.Model (User (..)) -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index b5f2b67..c0e89d5 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -4,28 +4,29 @@ module View.Mail.WeeklyReport ( mail ) where -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model as CM +import Common.Model (Income (..), Payment (..), User (..), + UserId) +import qualified Common.Model as CM import qualified Common.View.Format as Format -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Income () +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.Payment () +import Resource (Status (..), groupByStatus, statuses) mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = @@ -65,7 +66,7 @@ payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = case status of Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) where name = formatUserName (_payment_user payment) users amount = Format.price (Conf.currency conf) . _payment_cost $ payment for = _payment_name payment @@ -85,7 +86,7 @@ isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = case status of Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) where name = formatUserName (_income_userId income) users amount = Format.price (Conf.currency conf) . _income_amount $ income for = Format.longDay $ _income_date income diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 6bf9527..ff7bdc7 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -4,23 +4,23 @@ module View.Page ( page ) where -import Data.Text.Internal.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Aeson (encode) -import qualified Data.Aeson.Types as Json +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) -import Text.Blaze.Html -import Text.Blaze.Html5 -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult) -import Design.Global (globalDesign) +import Design.Global (globalDesign) page :: InitResult -> Text page initResult = diff --git a/stylish-haskell/default.nix b/stylish-haskell/default.nix new file mode 100644 index 0000000..bd73cf8 --- /dev/null +++ b/stylish-haskell/default.nix @@ -0,0 +1,44 @@ +{ HUnit, aeson, base, bytestring, containers, directory, fetchFromGitHub +, filepath, haskell-src-exts, mkDerivation, mtl, optparse-applicative, stdenv +, strict, stylish-haskell, syb, test-framework, test-framework-hunit, yaml +}: + +let regularDependencies = [ + aeson + base + bytestring + containers + directory + filepath + haskell-src-exts + mtl + syb + yaml + ]; +in mkDerivation { + pname = "stylish-haskell"; + version = "0.8.1.0"; + + src = fetchFromGitHub { + owner = "jaspervdj"; + repo = "stylish-haskell"; + rev = "dc3a73e82c19ff97a1544840dac8f7f4568b24bc"; + sha256 = "0kx9m3j9w2357ff5y651s9cdbjiyax9fksyf4rk8pzabc0dv6dpg"; + }; + + isLibrary = true; + isExecutable = true; + + libraryHaskellDepends = + regularDependencies; + + executableHaskellDepends = + regularDependencies ++ [ optparse-applicative strict stylish-haskell ]; + + testHaskellDepends = + regularDependencies ++ [ HUnit test-framework test-framework-hunit ]; + + homepage = "https://github.com/jaspervdj/stylish-haskell"; + description = "Simple Haskell code prettifier"; + license = stdenv.lib.licenses.bsd3; + } diff --git a/tools.nix b/tools.nix index a06757e..f09ad13 100644 --- a/tools.nix +++ b/tools.nix @@ -1,12 +1,17 @@ with import {}; { env = stdenv.mkDerivation { name = "tools"; - buildInputs = with pkgs; [ - nodePackages.nodemon + buildInputs = with pkgs; with nodePackages; with haskellPackages; [ + nodemon sqlite cabal-install tmux tmuxinator + (import ./stylish-haskell { + inherit mkDerivation aeson base bytestring containers directory filepath + fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict + optparse-applicative HUnit test-framework test-framework-hunit stdenv; + }) ]; }; } -- cgit v1.2.3 From 42e94a45e26f40edc3ad71b1e77a4bf47c13fd3d Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 15 Nov 2017 23:50:44 +0100 Subject: Add dynamic pages --- Makefile | 4 +- client/src/Component/Button.hs | 40 +++++++++++--------- client/src/View/Header.hs | 2 +- client/src/View/Payment/Constants.hs | 6 +++ client/src/View/Payment/Pages.hs | 71 +++++++++++++++++++++++------------- client/src/View/Payment/Table.hs | 50 +++++++++++++------------ client/src/View/SignIn.hs | 2 +- 7 files changed, 105 insertions(+), 70 deletions(-) create mode 100644 client/src/View/Payment/Constants.hs diff --git a/Makefile b/Makefile index 16bf753..ac939fc 100644 --- a/Makefile +++ b/Makefile @@ -29,7 +29,7 @@ cp-client: @cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js watch-client: - @nix-shell -A shells.ghcjs --run "nodemon --delay 0.1 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" + @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" # Server # ------ @@ -48,4 +48,4 @@ run-server: @./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server watch-server: - @nix-shell -A shells.ghc --run "nodemon --delay 0.1 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" + @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 9499045..c31cdc6 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -7,24 +7,23 @@ module Component.Button , button ) where -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text + { _buttonIn_class :: Dynamic t Text , _buttonIn_content :: m () , _buttonIn_waiting :: Event t Bool } buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m buttonInDefault = ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.blank , _buttonIn_waiting = R.never } @@ -35,18 +34,25 @@ data ButtonOut t = ButtonOut button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do - attr <- R.holdDyn - (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) - (fmap - (\w -> M.fromList $ - [ ("type", "button") ] - <> if w - then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] - else [("class", _buttonIn_class buttonIn)]) - (_buttonIn_waiting buttonIn)) + dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn + + let attr = do + buttonClass <- _buttonIn_class buttonIn + waiting <- dynWaiting + return $ if waiting + then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])] + else M.fromList [("type", "button"), ("class", buttonClass)] + (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading R.divClass "content" $ _buttonIn_content buttonIn + return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } + +-- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text +-- mergeAttr = M.unionWithKey $ \k a b -> +-- if k == "class" +-- then T.intercalate " " [ a, b ] +-- else b diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 711ba80..7afd9bd 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -65,7 +65,7 @@ signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = "signOut item" + { Component._buttonIn_class = R.constDyn "signOut item" , Component._buttonIn_content = Icon.signOut , Component._buttonIn_waiting = waiting } diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs new file mode 100644 index 0000000..ac2320a --- /dev/null +++ b/client/src/View/Payment/Constants.hs @@ -0,0 +1,6 @@ +module View.Payment.Constants + ( paymentsPerPage + ) where + +paymentsPerPage :: Int +paymentsPerPage = 8 diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index cf3e115..f96cb8e 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -7,15 +7,17 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Event, Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment (..)) +import Common.Model (Payment (..)) + +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component import qualified Icon +import qualified View.Payment.Constants as Constants data PagesIn = PagesIn { _pagesIn_payments :: [Payment] @@ -26,26 +28,43 @@ data PagesOut t = PagesOut } widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) -widget _ = do - currentPage <- R.divClass "pages" $ do - a <- page 1 Icon.doubleLeftBar - b <- page 1 Icon.doubleLeft - c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) - d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) - e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) - f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) - g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) - h <- page 5 Icon.doubleRight - i <- page 5 Icon.doubleRightBar - R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] - return $ PagesOut - { _pagesOut_currentPage = currentPage - } - -page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) -page n content = - ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn - { _buttonIn_class = "page" +widget pagesIn = do + R.divClass "pages" $ do + rec + currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] + + firstPageClic <- pageButton (R.constDyn 0) (R.constDyn 1) Icon.doubleLeftBar + + previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + + pageClic <- pageEvent <$> (R.simpleList (fmap (range maxPage) currentPage) $ \p -> + pageButton currentPage p (R.dynText $ fmap (T.pack . show) p)) + + nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight + + lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage + pageEvent = R.switchPromptlyDyn . fmap R.leftmost + +range :: Int -> Int -> [Int] +range maxPage currentPage = [start..end] + where sidePages = 2 + start = max 1 (currentPage - sidePages) + end = min maxPage (start + sidePages * 2) + +pageButton :: forall t m. MonadWidget t m => Dynamic t Int -> Dynamic t Int -> m () -> m (Event t Int) +pageButton currentPage page content = do + clic <- _buttonOut_clic <$> (Component.button $ ButtonIn + { _buttonIn_class = do + cp <- currentPage + p <- page + if cp == p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never }) + return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 734511d..5c0b709 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -7,26 +7,27 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (MonadWidget, Dynamic) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format import qualified Icon +import qualified View.Payment.Constants as Constants data TableIn t = TableIn - { _tableIn_init :: Init + { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int } @@ -34,12 +35,8 @@ data TableOut = TableOut { } -visiblePayments :: Int -visiblePayments = 8 - widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do @@ -52,13 +49,20 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank let init = _tableIn_init tableIn + currentPage = _tableIn_currentPage tableIn payments = _init_payments init - paymentRange = fmap - (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) - (_tableIn_currentPage tableIn) + paymentRange = fmap (getPaymentRange payments) currentPage R.simpleList paymentRange (paymentRow init) return $ TableOut {} +getPaymentRange :: [Payment] -> Int -> [Payment] +getPaymentRange payments currentPage = + take Constants.paymentsPerPage + . drop ((currentPage - 1) * Constants.paymentsPerPage) + . reverse + . L.sortOn _payment_date + $ payments + paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do @@ -69,7 +73,7 @@ paymentRow init payment = R.divClass "cell user" $ R.dynText $ flip fmap user $ \mbUser -> case mbUser of Just u -> _user_name u - _ -> "" + _ -> "" let category = flip fmap payment $ \p -> findCategory (_init_categories init) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 70c6b1f..1f5b900 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -49,7 +49,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = "" + { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.text (Message.get Key.SignIn_Button) , _buttonIn_waiting = waiting } -- cgit v1.2.3 From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- .stylish-haskell.yaml | 2 + client/client.cabal | 9 +++- client/src/Component/Button.hs | 2 - client/src/Component/Input.hs | 2 - client/src/Icon.hs | 2 - client/src/Main.hs | 9 ++-- client/src/Util/List.hs | 13 ++++++ client/src/View/App.hs | 24 +++++----- client/src/View/Header.hs | 26 +++++------ client/src/View/Payment.hs | 22 +++++----- client/src/View/Payment/Constants.hs | 2 +- client/src/View/Payment/Header.hs | 70 ++++++++++++++++++++++++++++++ client/src/View/Payment/Pages.hs | 8 ++-- client/src/View/Payment/Table.hs | 28 ++++++------ client/src/View/SignIn.hs | 32 ++++++-------- common/common.cabal | 26 ++++++----- common/src/Common/Message.hs | 12 ----- common/src/Common/Message/Key.hs | 2 +- common/src/Common/Message/Translation.hs | 12 +++-- common/src/Common/Model/Category.hs | 2 - common/src/Common/Model/CreateCategory.hs | 2 - common/src/Common/Model/CreateIncome.hs | 2 - common/src/Common/Model/CreatePayment.hs | 2 - common/src/Common/Model/Currency.hs | 2 - common/src/Common/Model/EditCategory.hs | 2 - common/src/Common/Model/EditIncome.hs | 2 - common/src/Common/Model/EditPayment.hs | 2 - common/src/Common/Model/Frequency.hs | 2 - common/src/Common/Model/Income.hs | 2 - common/src/Common/Model/Init.hs | 2 - common/src/Common/Model/InitResult.hs | 2 - common/src/Common/Model/Payment.hs | 2 - common/src/Common/Model/PaymentCategory.hs | 2 - common/src/Common/Model/SignIn.hs | 2 - common/src/Common/Model/User.hs | 2 - common/src/Common/Msg.hs | 13 ++++++ common/src/Common/View/Format.hs | 35 +++++++-------- server/server.cabal | 7 +-- server/src/Conf.hs | 2 - server/src/Controller/Category.hs | 7 +-- server/src/Controller/Income.hs | 7 +-- server/src/Controller/Index.hs | 15 +++---- server/src/Controller/Payment.hs | 2 - server/src/Controller/SignIn.hs | 15 +++---- server/src/Cookie.hs | 2 - server/src/Design/Dialog.hs | 2 - server/src/Design/Errors.hs | 2 - server/src/Design/Form.hs | 2 - server/src/Design/Global.hs | 2 - server/src/Design/Helper.hs | 2 - server/src/Design/Tooltip.hs | 2 - server/src/Design/View/Header.hs | 2 - server/src/Design/View/Payment.hs | 2 - server/src/Design/View/Payment/Header.hs | 2 - server/src/Design/View/Payment/Pages.hs | 2 - server/src/Design/View/Payment/Table.hs | 2 - server/src/Design/View/SignIn.hs | 2 - server/src/Design/View/Stat.hs | 2 - server/src/Design/View/Table.hs | 2 - server/src/Design/Views.hs | 2 - server/src/Job/Daemon.hs | 2 +- server/src/Job/Model.hs | 2 - server/src/Job/MonthlyPayment.hs | 2 +- server/src/Json.hs | 3 -- server/src/LoginSession.hs | 2 - server/src/Main.hs | 7 +-- server/src/MimeMail.hs | 2 - server/src/Model/Category.hs | 1 - server/src/Model/Frequency.hs | 3 -- server/src/Model/Income.hs | 1 - server/src/Model/Init.hs | 2 - server/src/Model/Payment.hs | 1 - server/src/Model/PaymentCategory.hs | 1 - server/src/Model/SignIn.hs | 2 - server/src/Model/User.hs | 1 - server/src/Secure.hs | 9 ++-- server/src/SendMail.hs | 2 - server/src/Util/Time.hs | 25 +++++++++++ server/src/Utils/Time.hs | 25 ----------- server/src/View/Mail/SignIn.hs | 19 ++++---- server/src/View/Mail/WeeklyReport.hs | 35 +++++++-------- server/src/View/Page.hs | 7 +-- 82 files changed, 293 insertions(+), 331 deletions(-) create mode 100644 client/src/Util/List.hs create mode 100644 client/src/View/Payment/Header.hs delete mode 100644 common/src/Common/Message.hs create mode 100644 common/src/Common/Msg.hs create mode 100644 server/src/Util/Time.hs delete mode 100644 server/src/Utils/Time.hs diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 3642d0e..a3f992d 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -28,3 +28,5 @@ newline: native language_extensions: - ExistentialQuantification - MultiParamTypeClasses + - OverloadedStrings + - RecursiveDo diff --git a/client/client.cabal b/client/client.cabal index ac74d9c..fdf764e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -13,9 +13,12 @@ Executable client Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 - Extensions: + + Default-extensions: ExistentialQuantification MultiParamTypeClasses + OverloadedStrings + RecursiveDo Build-depends: aeson @@ -32,10 +35,12 @@ Executable client Component.Button Component.Input Icon - Main + Util.List View.App View.Header View.Payment + View.Payment.Constants + View.Payment.Header View.Payment.Pages View.Payment.Table View.SignIn diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index c31cdc6..09c93cd 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Component.Button ( ButtonIn(..) , buttonInDefault diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index c3864b4..1923463 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Component.Input ( InputIn(..) , InputOut(..) diff --git a/client/src/Icon.hs b/client/src/Icon.hs index cd5a0b4..fbf5388 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Icon ( clone , delete diff --git a/client/src/Main.hs b/client/src/Main.hs index cbc881c..d55eefe 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -13,9 +13,8 @@ import JSDOM.Types (HTMLElement (..), JSM) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (InitResult (InitEmpty)) +import qualified Common.Msg as Msg import qualified View.App as App @@ -27,7 +26,8 @@ main = do readInit :: JSM InitResult readInit = do document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document "init" + initNode <- Dom.getElementById document ("init" :: Dom.JSString) + case initNode of Just node -> do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) @@ -36,4 +36,5 @@ readInit = do Nothing -> initParseError _ -> return initParseError - where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) + + where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError) diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs new file mode 100644 index 0000000..4e22ba8 --- /dev/null +++ b/client/src/Util/List.hs @@ -0,0 +1,13 @@ +module Util.List + ( groupBy + ) where + +import Control.Arrow ((&&&)) +import Data.Function (on) +import qualified Data.List as L + +groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] +groupBy f = + map (f . head &&& id) + . L.groupBy ((==) `on` f) + . L.sortBy (compare `on` f) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 442fa3e..64ca303 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,22 +1,18 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.App ( widget ) where -import Prelude hiding (error, init) -import qualified Reflex.Dom as R +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult (..)) +import Common.Model (InitResult (..)) +import qualified Common.Msg as Msg -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -36,7 +32,7 @@ widget initResult = InitEmpty result -> SignIn.view result - signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) + signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess) _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 7afd9bd..4c74383 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Header ( view , HeaderIn(..) , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg -import Component.Button (ButtonIn (..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -35,7 +31,7 @@ view headerIn = R.el "header" $ do R.divClass "title" $ - R.text $ Message.get Key.App_Title + R.text $ Msg.get Msg.App_Title signOut <- nameSignOut $ _headerIn_initResult headerIn diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f70c8cd..934f720 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment ( widget , PaymentIn(..) , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn (..), PagesOut (..)) -import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..)) -import qualified View.Payment.Table as Table +import View.Payment.Header (HeaderIn (..)) +import qualified View.Payment.Header as Header +import View.Payment.Pages (PagesIn (..), PagesOut (..)) +import qualified View.Payment.Pages as Pages +import View.Payment.Table (TableIn (..)) +import qualified View.Payment.Table as Table data PaymentIn = PaymentIn { _paymentIn_init :: Init @@ -29,6 +28,9 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do rec + _ <- Header.widget $ HeaderIn + { _headerIn_init = _paymentIn_init $ paymentIn + } _ <- Table.widget $ TableIn { _tableIn_init = _paymentIn_init paymentIn , _tableIn_currentPage = _pagesOut_currentPage pagesOut diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs index ac2320a..028e328 100644 --- a/client/src/View/Payment/Constants.hs +++ b/client/src/View/Payment/Constants.hs @@ -3,4 +3,4 @@ module View.Payment.Constants ) where paymentsPerPage :: Int -paymentsPerPage = 8 +paymentsPerPage = 7 diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs new file mode 100644 index 0000000..67b4eb4 --- /dev/null +++ b/client/src/View/Payment/Header.hs @@ -0,0 +1,70 @@ +module View.Payment.Header + ( widget + , HeaderIn(..) + , HeaderOut(..) + ) where + +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency (..), Init (..), + Payment (..), User (..), UserId) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Util.List as L + +data HeaderIn t = HeaderIn + { _headerIn_init :: Init + } + +data HeaderOut = HeaderOut + { + } + +widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut +widget headerIn = + R.divClass "header" $ do + infos payments users currency + return $ HeaderOut {} + where init = _headerIn_init headerIn + payments = _init_payments init + users = _init_users init + currency = _init_currency init + +infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () +infos payments users currency = + R.divClass "infos" $ do + R.elClass "span" "total" $ do + R.text . Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency total) + R.elClass "span" "partition" . R.text $ + T.intercalate ", " + . map (\(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (Format.price currency userTotal) + ) + $ totalByUser + + where punctualPayments = filter ((==) Punctual . _payment_frequency) payments + paymentCount = length punctualPayments + total = sum . map _payment_cost $ punctualPayments + + totalByUser :: [(UserId, Int)] + totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ punctualPayments diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f96cb8e..81555ab 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment.Pages ( widget , PagesIn(..) @@ -11,7 +8,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Payment (..)) +import Common.Model (Frequency (..), Payment (..)) import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component @@ -48,7 +45,8 @@ widget pagesIn = do { _pagesOut_currentPage = currentPage } - where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage + where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn + maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage pageEvent = R.switchPromptlyDyn . fmap R.leftmost range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 5c0b709..d8093a5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.Payment.Table ( widget , TableIn(..) @@ -15,11 +12,11 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Category (..), Init (..), Payment (..), +import Common.Model (Category (..), Frequency (..), + Init (..), Payment (..), PaymentCategory (..), User (..)) import qualified Common.Model as CM +import qualified Common.Msg as Msg import qualified Common.Util.Text as T import qualified Common.View.Format as Format @@ -40,11 +37,11 @@ widget tableIn = do _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name - R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost - R.divClass "cell user" $ R.text $ Message.get Key.Payment_User - R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category - R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date + R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name + R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost + R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User + R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category + R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank @@ -58,10 +55,11 @@ widget tableIn = do getPaymentRange :: [Payment] -> Int -> [Payment] getPaymentRange payments currentPage = take Constants.paymentsPerPage - . drop ((currentPage - 1) * Constants.paymentsPerPage) - . reverse - . L.sortOn _payment_date - $ payments + . drop ((currentPage - 1) * Constants.paymentsPerPage) + . reverse + . L.sortOn _payment_date + . filter ((==) Punctual . _payment_frequency) + $ payments paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 1f5b900..69596d8 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,25 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn (SignIn)) +import Common.Model (SignIn (SignIn)) +import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..), InputIn (..), + InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -27,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder + , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button @@ -50,7 +46,7 @@ view result = button <- Component.button $ ButtonIn { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) + , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } diff --git a/common/common.cabal b/common/common.cabal index c3073d9..e4a9c59 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -13,6 +13,12 @@ Library Hs-source-dirs: src Default-language: Haskell2010 + Default-extensions: + DeriveGeneric + ExistentialQuantification + MultiParamTypeClasses + OverloadedStrings + Build-depends: aeson , base >=4.9 && <4.11 @@ -20,28 +26,28 @@ Library , time Exposed-modules: - Common.Message - Common.Message.Key Common.Model + Common.Msg Common.Util.Text Common.View.Format other-modules: + Common.Message.Key Common.Message.Lang Common.Message.Translation - Common.Model.PaymentCategory + Common.Model.Category Common.Model.CreateCategory - Common.Model.CreatePayment Common.Model.CreateIncome + Common.Model.CreatePayment + Common.Model.Currency Common.Model.EditCategory - Common.Model.EditPayment - Common.Model.InitResult Common.Model.EditIncome + Common.Model.EditPayment Common.Model.Frequency - Common.Model.Currency - Common.Model.Category - Common.Model.Payment Common.Model.Income - Common.Model.SignIn Common.Model.Init + Common.Model.InitResult + Common.Model.Payment + Common.Model.PaymentCategory + Common.Model.SignIn Common.Model.User diff --git a/common/src/Common/Message.hs b/common/src/Common/Message.hs deleted file mode 100644 index 745e457..0000000 --- a/common/src/Common/Message.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Common.Message - ( get - ) where - -import Data.Text (Text) - -import Common.Message.Key (Key) -import Common.Message.Lang (Lang (..)) -import qualified Common.Message.Translation as Translation - -get :: Key -> Text -get = Translation.get French diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 991c407..ad8a7f1 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -83,6 +83,7 @@ data Key = | Payment_Add | Payment_Balanced + | Payment_By Text Text | Payment_Category | Payment_CloneLong | Payment_CloneShort @@ -129,7 +130,6 @@ data Key = | Statistic_Title | Statistic_ByMonthsAndMean Text - | Statistic_By Text Text | Statistic_Total | WeeklyReport_Empty diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 16a56dd..0a6084d 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Common.Message.Translation ( get ) where @@ -359,6 +357,11 @@ m l Payment_Balanced = English -> "Payments are balanced." French -> "Les paiements sont équilibrés." +m l (Payment_By key value) = + case l of + English -> T.concat [ key, ": ", value ] + French -> T.concat [ key, " : ", value ] + m l Payment_Category = case l of English -> "Category" @@ -584,11 +587,6 @@ m l SignIn_ParseError = English -> "Error while reading initial data." French -> "Erreur lors de la lecture des données initiales." -m l (Statistic_By key value) = - case l of - English -> T.concat [ key, ": ", value ] - French -> T.concat [ key, " : ", value ] - m l (Statistic_ByMonthsAndMean amount) = case l of English -> diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs index bbd3c33..db1da53 100644 --- a/common/src/Common/Model/Category.hs +++ b/common/src/Common/Model/Category.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Category ( CategoryId , Category(..) diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs index 11d84e9..51bd2a0 100644 --- a/common/src/Common/Model/CreateCategory.hs +++ b/common/src/Common/Model/CreateCategory.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.CreateCategory ( CreateCategory(..) ) where diff --git a/common/src/Common/Model/CreateIncome.hs b/common/src/Common/Model/CreateIncome.hs index 583ebbb..644a51c 100644 --- a/common/src/Common/Model/CreateIncome.hs +++ b/common/src/Common/Model/CreateIncome.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.CreateIncome ( CreateIncome(..) ) where diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index 7a283e5..8e2ab73 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.CreatePayment ( CreatePayment(..) ) where diff --git a/common/src/Common/Model/Currency.hs b/common/src/Common/Model/Currency.hs index 6d74ea7..175aeba 100644 --- a/common/src/Common/Model/Currency.hs +++ b/common/src/Common/Model/Currency.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Currency ( Currency(..) ) where diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs index 5b08b86..8b9d9eb 100644 --- a/common/src/Common/Model/EditCategory.hs +++ b/common/src/Common/Model/EditCategory.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.EditCategory ( EditCategory(..) ) where diff --git a/common/src/Common/Model/EditIncome.hs b/common/src/Common/Model/EditIncome.hs index 867b406..0e65f12 100644 --- a/common/src/Common/Model/EditIncome.hs +++ b/common/src/Common/Model/EditIncome.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.EditIncome ( EditIncome(..) ) where diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs index 32228f0..d2c223f 100644 --- a/common/src/Common/Model/EditPayment.hs +++ b/common/src/Common/Model/EditPayment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.EditPayment ( EditPayment(..) ) where diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs index 085163d..ee502e8 100644 --- a/common/src/Common/Model/Frequency.hs +++ b/common/src/Common/Model/Frequency.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Frequency ( Frequency(..) ) where diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs index 10b4cf2..0423704 100644 --- a/common/src/Common/Model/Income.hs +++ b/common/src/Common/Model/Income.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Income ( IncomeId , Income(..) diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs index ae23bb5..68b3f5d 100644 --- a/common/src/Common/Model/Init.hs +++ b/common/src/Common/Model/Init.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Init ( Init(..) ) where diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs index 12be65a..542e6c7 100644 --- a/common/src/Common/Model/InitResult.hs +++ b/common/src/Common/Model/InitResult.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.InitResult ( InitResult(..) ) where diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 4741058..37a090d 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.Payment ( PaymentId , Payment(..) diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs index 24cf9e1..2a559ce 100644 --- a/common/src/Common/Model/PaymentCategory.hs +++ b/common/src/Common/Model/PaymentCategory.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.PaymentCategory ( PaymentCategoryId , PaymentCategory(..) diff --git a/common/src/Common/Model/SignIn.hs b/common/src/Common/Model/SignIn.hs index baccd88..bfd7fbc 100644 --- a/common/src/Common/Model/SignIn.hs +++ b/common/src/Common/Model/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.SignIn ( SignIn(..) ) where diff --git a/common/src/Common/Model/User.hs b/common/src/Common/Model/User.hs index e491c31..a30d104 100644 --- a/common/src/Common/Model/User.hs +++ b/common/src/Common/Model/User.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Common.Model.User ( UserId , User(..) diff --git a/common/src/Common/Msg.hs b/common/src/Common/Msg.hs new file mode 100644 index 0000000..9e4cfe2 --- /dev/null +++ b/common/src/Common/Msg.hs @@ -0,0 +1,13 @@ +module Common.Msg + ( get + , Key(..) + ) where + +import Data.Text (Text) + +import Common.Message.Key (Key (..)) +import Common.Message.Lang (Lang (..)) +import qualified Common.Message.Translation as Translation + +get :: Key -> Text +get = Translation.get French diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs index 783ad67..0597d17 100644 --- a/common/src/Common/View/Format.hs +++ b/common/src/Common/View/Format.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Common.View.Format ( shortDay , longDay @@ -13,13 +11,12 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, toGregorian) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (Currency (..)) +import qualified Common.Msg as Msg shortDay :: Day -> Text shortDay date = - Message.get $ Key.Date_Short + Msg.get $ Msg.Date_Short day month (fromIntegral year) @@ -27,24 +24,24 @@ shortDay date = longDay :: Day -> Text longDay date = - Message.get $ Key.Date_Long + Msg.get $ Msg.Date_Long day - (fromMaybe "−" . fmap Message.get . monthToKey $ month) + (fromMaybe "−" . fmap Msg.get . monthToKey $ month) (fromIntegral year) where (year, month, day) = toGregorian date - monthToKey 1 = Just Key.Month_January - monthToKey 2 = Just Key.Month_February - monthToKey 3 = Just Key.Month_March - monthToKey 4 = Just Key.Month_April - monthToKey 5 = Just Key.Month_May - monthToKey 6 = Just Key.Month_June - monthToKey 7 = Just Key.Month_July - monthToKey 8 = Just Key.Month_August - monthToKey 9 = Just Key.Month_September - monthToKey 10 = Just Key.Month_October - monthToKey 11 = Just Key.Month_November - monthToKey 12 = Just Key.Month_December + monthToKey 1 = Just Msg.Month_January + monthToKey 2 = Just Msg.Month_February + monthToKey 3 = Just Msg.Month_March + monthToKey 4 = Just Msg.Month_April + monthToKey 5 = Just Msg.Month_May + monthToKey 6 = Just Msg.Month_June + monthToKey 7 = Just Msg.Month_July + monthToKey 8 = Just Msg.Month_August + monthToKey 9 = Just Msg.Month_September + monthToKey 10 = Just Msg.Month_October + monthToKey 11 = Just Msg.Month_November + monthToKey 12 = Just Msg.Month_December monthToKey _ = Nothing price :: Currency -> Int -> Text diff --git a/server/server.cabal b/server/server.cabal index d30060b..e4a1730 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -13,9 +13,11 @@ Executable server Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 - Extensions: + + Default-extensions: ExistentialQuantification MultiParamTypeClasses + OverloadedStrings Build-depends: aeson @@ -86,7 +88,6 @@ Executable server Job.WeeklyReport Json LoginSession - Main MimeMail Model.Category Model.Frequency @@ -103,7 +104,7 @@ Executable server Resource Secure SendMail - Utils.Time + Util.Time Validation View.Mail.SignIn View.Mail.WeeklyReport diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 299f071..2422a93 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Conf ( get , Conf(..) diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index a646496..5565b43 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Category ( create , edit @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CategoryId, CreateCategory (..), EditCategory (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Category as Category @@ -50,5 +47,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index c42f6a7..19f0cfc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Income ( create , editOwn @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Income as Income @@ -45,5 +42,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index bf4859d..f05ce6f 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -10,10 +10,9 @@ import Network.HTTP.Types.Status (ok200) import Prelude hiding (error) import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key import Common.Model (InitResult (..), User (..)) +import Common.Msg (Key) +import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession @@ -31,7 +30,7 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey + return . InitEmpty . Left . Msg.get $ errorKey Right user -> liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do @@ -54,23 +53,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ Key.SignIn_LinkInvalid + return . Left $ Msg.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ Key.SignIn_LinkUsed + return . Left $ Msg.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ Key.SignIn_LinkExpired + return . Left $ Msg.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e4104eb..c6c874a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Payment ( list , create diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 5552781..cf92c9f 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.SignIn ( signIn ) where @@ -11,9 +9,8 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (SignIn (..)) +import qualified Common.Msg as Msg import Conf (Conf) import qualified Conf @@ -40,8 +37,8 @@ signIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs index 511dd42..f79a1fa 100644 --- a/server/src/Cookie.hs +++ b/server/src/Cookie.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Cookie ( makeSimpleCookie , setCookie diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs index 6759606..034a8b1 100644 --- a/server/src/Design/Dialog.hs +++ b/server/src/Design/Dialog.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Dialog ( design ) where diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs index 2c6c16b..9f435eb 100644 --- a/server/src/Design/Errors.hs +++ b/server/src/Design/Errors.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Errors ( design ) where diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index a4a1de0..be0e74f 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Form ( design ) where diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 1fe6a80..34d772e 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Global ( globalDesign ) where diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 0913511..9bf7878 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Helper ( clearFix , button diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs index 57aec33..eef804e 100644 --- a/server/src/Design/Tooltip.hs +++ b/server/src/Design/Tooltip.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Tooltip ( design ) where diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index d05f748..792d482 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Header ( design ) where diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 62f7061..0d59fa0 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment ( design ) where diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index d87e95b..36bc8d9 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Header ( design ) where diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs index f6660a1..2028c1b 100644 --- a/server/src/Design/View/Payment/Pages.hs +++ b/server/src/Design/View/Payment/Pages.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Pages ( design ) where diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index 243d7f4..26dc9ed 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Payment.Table ( design ) where diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 2b1252f..4d4be7b 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.SignIn ( design ) where diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index b10dd7b..4d7021e 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Stat ( design ) where diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index fd55656..cd406fc 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.View.Table ( design ) where diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 1157b68..a73a1fa 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Design.Views ( design ) where diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs index 26977d1..d8cd522 100644 --- a/server/src/Job/Daemon.hs +++ b/server/src/Job/Daemon.hs @@ -14,7 +14,7 @@ import Job.Model (actualizeLastCheck, actualizeLastExecution, import Job.MonthlyPayment (monthlyPayment) import Job.WeeklyReport (weeklyReport) import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) +import Util.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () runDaemons conf = do diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index b90dca0..a5fa62b 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Job.Model ( Job(..) , getLastExecution diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 8cb1c27..ca7e007 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -8,7 +8,7 @@ import Common.Model (Frequency (..), Payment (..)) import qualified Model.Payment as Payment import qualified Model.Query as Query -import Utils.Time (timeToDay) +import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do diff --git a/server/src/Json.hs b/server/src/Json.hs index eb5c572..6d40305 100644 --- a/server/src/Json.hs +++ b/server/src/Json.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - module Json ( jsonObject , jsonId diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs index beca697..86f1329 100644 --- a/server/src/LoginSession.hs +++ b/server/src/LoginSession.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module LoginSession ( put , get diff --git a/server/src/Main.hs b/server/src/Main.hs index 5ac68db..d7b9b93 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - import Control.Applicative (liftA3) import Control.Monad.IO.Class (liftIO) @@ -9,6 +7,8 @@ import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static import Web.Scotty +import Common.Model (Frequency (..), Payment (..)) + import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income @@ -35,7 +35,8 @@ main = do time <- liftIO Time.getCurrentTime (users, incomes, payments) <- liftIO . Query.run $ liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments + let punctualPayments = filter ((==) Punctual . _payment_frequency) payments + exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments text . LT.pack . show $ exceedingPayers get "/" $ do diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs index 7fe98ed..c994905 100644 --- a/server/src/MimeMail.hs +++ b/server/src/MimeMail.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module MimeMail ( -- * Datatypes Boundary (..) diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs index b972ebd..ee406bc 100644 --- a/server/src/Model/Category.hs +++ b/server/src/Model/Category.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Category diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs index 41a325d..c29cf37 100644 --- a/server/src/Model/Frequency.hs +++ b/server/src/Model/Frequency.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Frequency () where diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs index a69112a..a6174bc 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Income diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index c030c58..be44c72 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Model.Init ( getInit ) where diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index c1b109f..33551e5 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.Payment diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs index 6d02136..c60c1a2 100644 --- a/server/src/Model/PaymentCategory.hs +++ b/server/src/Model/PaymentCategory.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.PaymentCategory diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index 6f38fe7..0cc4a03 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Model.SignIn ( SignIn(..) , createSignInToken diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs index f17f545..8dc1fc8 100644 --- a/server/src/Model/User.hs +++ b/server/src/Model/User.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Model.User diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 88bdcda..6e5b998 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Secure ( loggedAction , getUserFromToken @@ -11,9 +9,8 @@ import Data.Text.Lazy (fromStrict) import Network.HTTP.Types.Status (forbidden403) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (User) +import qualified Common.Msg as Msg import qualified LoginSession import Model.Query (Query) @@ -32,10 +29,10 @@ loggedAction action = do action user Nothing -> do status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized + html . fromStrict . Msg.get $ Msg.Secure_Unauthorized Nothing -> do status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden + html . fromStrict . Msg.get $ Msg.Secure_Forbidden getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index 959f21d..d00912f 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module SendMail ( sendMail ) where diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs new file mode 100644 index 0000000..3e0856d --- /dev/null +++ b/server/src/Util/Time.hs @@ -0,0 +1,25 @@ +module Util.Time + ( belongToCurrentMonth + , belongToCurrentWeek + , timeToDay + ) where + +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs deleted file mode 100644 index e1a94d3..0000000 --- a/server/src/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index d542fd8..22c3cb0 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -1,24 +1,21 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Mail.SignIn ( mail ) where -import Data.Text (Text) +import Data.Text (Text) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User (..)) +import Common.Model (User (..)) +import qualified Common.Msg as Msg -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = M.Mail { M.from = Conf.noReplyMail conf , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) + , M.subject = Msg.get Msg.SignIn_MailTitle + , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url) } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index c0e89d5..4ad8b77 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Mail.WeeklyReport ( mail ) where @@ -13,11 +11,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (Income (..), Payment (..), User (..), UserId) import qualified Common.Model as CM +import qualified Common.Msg as Msg import qualified Common.View.Format as Format import Conf (Conf) @@ -34,9 +31,9 @@ mail conf users payments incomes start end = { M.from = Conf.noReplyMail conf , M.to = map _user_email users , M.subject = T.concat - [ Message.get Key.App_Title + [ Msg.get Msg.App_Title , " − " - , Message.get Key.WeeklyReport_Title + , Msg.get Msg.WeeklyReport_Title ] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } @@ -45,7 +42,7 @@ body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then - Message.get Key.WeeklyReport_Empty + Msg.get Msg.WeeklyReport_Empty else T.intercalate "\n" . catMaybes . concat $ [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses @@ -56,17 +53,17 @@ paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = section sectionTitle sectionItems where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at) + _ -> Msg.get (Msg.WeeklyReport_PayedFor name amount for at) where name = formatUserName (_payment_user payment) users amount = Format.price (Conf.currency conf) . _payment_cost $ payment for = _payment_name payment @@ -76,17 +73,17 @@ incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = section sectionTitle sectionItems where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionTitle = Msg.get $ case status of + Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for) + _ -> Msg.get (Msg.WeeklyReport_PayedFrom name amount for) where name = formatUserName (_income_userId income) users amount = Format.price (Conf.currency conf) . _income_amount $ income for = Format.longDay $ _income_date income diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index ff7bdc7..27b4f26 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module View.Page ( page ) where @@ -16,9 +14,8 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (InitResult) +import qualified Common.Msg as Msg import Design.Global (globalDesign) @@ -28,7 +25,7 @@ page initResult = H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ Message.get Key.App_Title) + H.title (toHtml $ Msg.get Msg.App_Title) script ! src "javascript/main.js" $ "" jsonScript "init" initResult link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" -- cgit v1.2.3 From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:00:07 +0100 Subject: Add exceeding payer block --- client/src/Component/Button.hs | 6 -- client/src/Icon.hs | 4 +- client/src/View/Payment.hs | 8 +- client/src/View/Payment/Header.hs | 66 ++++++++---- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/Payer.hs | 198 ++++++++++++++++++++++++++++++++++ server/server.cabal | 1 - server/src/Design/View/Header.hs | 2 +- server/src/Main.hs | 4 +- server/src/Model/Payer.hs | 217 -------------------------------------- 11 files changed, 258 insertions(+), 250 deletions(-) create mode 100644 common/src/Common/Model/Payer.hs delete mode 100644 server/src/Model/Payer.hs diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 09c93cd..754b903 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -48,9 +48,3 @@ button buttonIn = do return $ ButtonOut { _buttonOut_clic = R.domEvent R.Click e } - --- mergeAttr :: Map Text Text -> Map Text Text -> Map Text Text --- mergeAttr = M.unionWithKey $ \k a b -> --- if k == "class" --- then T.intercalate " " [ a, b ] --- else b diff --git a/client/src/Icon.hs b/client/src/Icon.hs index fbf5388..e04e2a8 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -58,8 +58,8 @@ loading = signOut :: forall t m. MonadWidget t m => m () signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 934f720..15892c4 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,6 +4,7 @@ module View.Payment , PaymentOut(..) ) where +import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -29,13 +30,14 @@ widget paymentIn = do R.divClass "payment" $ do rec _ <- Header.widget $ HeaderIn - { _headerIn_init = _paymentIn_init $ paymentIn + { _headerIn_init = init } _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn + { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pagesOut } pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + { _pagesIn_payments = _init_payments init } return $ PaymentOut {} + where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 67b4eb4..3f2adc3 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -4,22 +4,29 @@ module View.Payment.Header , HeaderOut(..) ) where -import qualified Data.List as L hiding (groupBy) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Time as Time +import Prelude hiding (init) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Frequency (..), Init (..), - Payment (..), User (..), UserId) -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (Currency, ExceedingPayer (..), + Frequency (..), Income (..), Init (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format -import qualified Util.List as L +import Component (ButtonIn (..)) +import qualified Component as Component +import qualified Util.List as L data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init } data HeaderOut = HeaderOut @@ -29,13 +36,37 @@ data HeaderOut = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut widget headerIn = R.divClass "header" $ do + payerAndAdd incomes payments users currency infos payments users currency return $ HeaderOut {} where init = _headerIn_init headerIn - payments = _init_payments init + incomes = _init_incomes init + payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) users = _init_users init currency = _init_currency init +payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () +payerAndAdd incomes payments users currency = do + time <- liftIO Time.getCurrentTime + R.divClass "payerAndAdd" $ do + R.divClass "exceedingPayers" $ + forM_ + (CM.getExceedingPayers time users incomes payments) + (\p -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount p + ) + _ <- Component.button $ ButtonIn + { _buttonIn_class = R.constDyn "addPayment" + , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add + , _buttonIn_waiting = R.never + } + return () + infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () infos payments users currency = R.divClass "infos" $ do @@ -52,14 +83,13 @@ infos payments users currency = T.intercalate ", " . map (\(userId, userTotal) -> Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users) + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) (Format.price currency userTotal) ) $ totalByUser - where punctualPayments = filter ((==) Punctual . _payment_frequency) payments - paymentCount = length punctualPayments - total = sum . map _payment_cost $ punctualPayments + where paymentCount = length payments + total = sum . map _payment_cost $ payments totalByUser :: [(UserId, Int)] totalByUser = @@ -67,4 +97,4 @@ infos payments users currency = . map (\(u, xs) -> (u, sum . map snd $ xs)) . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) - $ punctualPayments + $ payments diff --git a/common/common.cabal b/common/common.cabal index e4a9c59..7eadb49 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -47,6 +47,7 @@ Library Common.Model.Income Common.Model.Init Common.Model.InitResult + Common.Model.Payer Common.Model.Payment Common.Model.PaymentCategory Common.Model.SignIn diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 20e86c1..cb38b2f 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -12,6 +12,7 @@ import Common.Model.Frequency as X import Common.Model.Income as X import Common.Model.Init as X import Common.Model.InitResult as X +import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X import Common.Model.SignIn as X diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs new file mode 100644 index 0000000..d09dbf6 --- /dev/null +++ b/common/src/Common/Model/Payer.hs @@ -0,0 +1,198 @@ +module Common.Model.Payer + ( getExceedingPayers + , ExceedingPayer(..) + ) where + +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time + +import Common.Model.Income (Income (..)) +import Common.Model.Payment (Payment (..)) +import Common.Model.User (User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _exceedingPayer_userId :: UserId + , _exceedingPayer_amount :: Int + } deriving (Show) + +getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] +getExceedingPayers currentTime users incomes payments = + let userIds = map _user_id users + payers = getPayers currentTime userIds incomes payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers + mbSince = useIncomesFrom userIds incomes payments + in case mbSince of + Just since -> + let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: [UserId] -> [Income] -> [Payment] -> Maybe UTCTime +useIncomesFrom userIds incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll userIds incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer] +getPayers currentTime userIds incomes payments = + let incomesDefined = incomeDefinedForAll userIds incomes + in flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , _payer_postIncomePayments = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _payer_incomes = filter ((==) userId . _income_userId) incomes + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = cumulativeIncome + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/server/server.cabal b/server/server.cabal index e4a1730..771a961 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -94,7 +94,6 @@ Executable server Model.Income Model.Init Model.Mail - Model.Payer Model.Payment Model.PaymentCategory Model.Query diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 792d482..904a2f5 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -57,7 +57,7 @@ design = do ".signOut" ? do Helper.waitable - heightMedia + display flex svg ? do Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) diff --git a/server/src/Main.hs b/server/src/Main.hs index d7b9b93..c8080dc 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -8,6 +8,7 @@ import Network.Wai.Middleware.Static import Web.Scotty import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Model as CM import qualified Conf import qualified Controller.Category as Category @@ -18,7 +19,6 @@ import qualified Controller.SignIn as SignIn import qualified Data.Time as Time import Job.Daemon (runDaemons) import qualified Model.Income as IncomeM -import Model.Payer (getOrderedExceedingPayers) import qualified Model.Payment as PaymentM import qualified Model.Query as Query import qualified Model.User as UserM @@ -36,7 +36,7 @@ main = do (users, incomes, payments) <- liftIO . Query.run $ liftA3 (,,) UserM.list IncomeM.list PaymentM.list let punctualPayments = filter ((==) Punctual . _payment_frequency) payments - exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments + exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments text . LT.pack . show $ exceedingPayers get "/" $ do diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs deleted file mode 100644 index db3f37c..0000000 --- a/server/src/Model/Payer.hs +++ /dev/null @@ -1,217 +0,0 @@ -module Model.Payer - ( getOrderedExceedingPayers - ) where - -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time - -import Common.Model (Income (..), IncomeId, Payment (..), User (..), - UserId) - -type Users = Map UserId User - -type Payers = Map UserId Payer - -type Incomes = Map IncomeId Income - -type Payments = [Payment] - -data Payer = Payer - { preIncomePaymentSum :: Int - , postIncomePaymentSum :: Int - , _incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _preIncomePaymentSum :: Int - , _cumulativeIncome :: Int - , ratio :: Float - } - -data ExceedingPayer = ExceedingPayer - { _userId :: UserId - , amount :: Int - } deriving (Show) - -getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] -getOrderedExceedingPayers currentTime users incomes payments = - let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users - incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes - payers = getPayers currentTime usersMap incomesMap payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts - . Map.toList - . Map.map preIncomePaymentSum - $ payers - mbSince = useIncomesFrom usersMap incomesMap payments - in case mbSince of - Just since -> - let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = - safeMaximum - . map (ratio . snd) - . Map.toList - $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . Map.toList - . Map.map (getFinalDiff maxRatio) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime -useIncomesFrom users incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing - -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date - -getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers -getPayers currentTime users incomes payments = - let userIds = Map.keys users - incomesDefined = incomeDefinedForAll userIds incomes - in Map.fromList - . map (\userId -> - ( userId - , Payer - { preIncomePaymentSum = - totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) - userId - payments - , postIncomePaymentSum = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> paymentTime p >= t - ) - userId - payments - , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) - } - ) - ) - $ userIds - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _userId = fst userAmount - , amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _preIncomePaymentSum = preIncomePaymentSum payer - , _cumulativeIncome = cumulativeIncome - , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) - in postIncomeDiff + _preIncomePaymentSum payer - -incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = - case incomes of - [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } - else Nothing - x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments -- cgit v1.2.3 From 554880727d833befab00666c7a4f95611e8370b9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 15:39:11 +0100 Subject: Remove local MimeMail --- server/server.cabal | 2 +- server/src/Design/Helper.hs | 6 +- server/src/MimeMail.hs | 672 -------------------------------------------- server/src/SendMail.hs | 2 +- 4 files changed, 5 insertions(+), 677 deletions(-) delete mode 100644 server/src/MimeMail.hs diff --git a/server/server.cabal b/server/server.cabal index 771a961..3715105 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -37,6 +37,7 @@ Executable server , http-conduit , http-types , lens + , mime-mail , monad-logger , mtl , parsec @@ -88,7 +89,6 @@ Executable server Job.WeeklyReport Json LoginSession - MimeMail Model.Category Model.Frequency Model.Income diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 9bf7878..89f5958 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -41,12 +41,12 @@ button backgroundCol textCol h focusOp = do waitable :: Css waitable = do + ".content" ? display flex svg # ".loader" ? display none + ".waiting" & do ".content" ? do - display flex - fontSize (px 0) - opacity 0 + display none svg # ".loader" ? do display block rotateKeyframes diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs deleted file mode 100644 index c994905..0000000 --- a/server/src/MimeMail.hs +++ /dev/null @@ -1,672 +0,0 @@ -module MimeMail - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , sendmailCustomCaptureOutput - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachmentCid - , addAttachments - , addAttachmentBS - , addAttachmentBSCid - , addAttachmentsBS - , renderAddress - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char.Utf8 -import Control.Arrow -import Control.Concurrent (forkIO, newEmptyMVar, - putMVar, takeMVar) -import Control.Exception (ErrorCall (ErrorCall), - throwIO) -import Control.Monad (foldM, void, (<=<)) -import Data.Bits (shiftR, (.&.)) -import qualified Data.ByteString as S -import qualified Data.ByteString.Base64 as Base64 -import Data.ByteString.Char8 () -import qualified Data.ByteString.Lazy as L -import Data.Char (isAscii, isControl) -import Data.List (intersperse) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.Word (Word8) -import System.Exit -import System.FilePath (takeFileName) -import System.IO -import System.Process -import System.Random - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - ((:) ("Content-Type", contentType)) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - $ headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\n" - , finalBuilder - ] - --- | Format an E-Mail address according to the name-addr form (see: RFC5322 --- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') --- This can be handy for adding custom headers that require such format. --- --- @since 0.4.11 -renderAddress :: Address -> Text -renderAddress address = - TE.decodeUtf8 $ toByteString $ showAddress address - --- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) -sanitizeFieldName :: S.ByteString -> S.ByteString -sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString (sanitizeFieldName k) - , fromByteString ": " - , encodeIfNeeded (sanitizeHeader v) - , fromByteString "\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (sanitizeHeader $ addressEmail a) - , fromByteString ">" - ] - --- Filter out control characters to prevent CRLF injection. -sanitizeHeader :: Text -> Text -sanitizeHeader = T.filter (not . isControl) - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\n" - , mconcat $ map showHeader headers - , fromByteString "\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -sendmailPath = "sendmail" - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs - --- | Like 'sendmailCustom', but also returns sendmail's output to stderr and --- stdout as strict ByteStrings. --- --- Since 0.4.9 -sendmailCustomCaptureOutput :: FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs - -sendmailCustomAux :: Bool - -> FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomAux captureOut sm opts lbs = do - let baseOpts = (proc sm opts) { std_in = CreatePipe } - pOpts = if captureOut - then baseOpts { std_out = CreatePipe - , std_err = CreatePipe - } - else baseOpts - (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts - L.hPut hin lbs - hClose hin - errMVar <- newEmptyMVar - outMVar <- newEmptyMVar - case (mHOut, mHErr) of - (Nothing, Nothing) -> return () - (Just hOut, Just hErr) -> do - void . forkIO $ S.hGetContents hOut >>= putMVar outMVar - void . forkIO $ S.hGetContents hErr >>= putMVar errMVar - _ -> error "error in sendmailCustomAux: missing a handle" - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> if captureOut - then do - errOutput <- takeMVar errMVar - outOutput <- takeMVar outMVar - return (outOutput, errOutput) - else return (S.empty, S.empty) - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - part <- getAttachmentPart ct fn - return $ addPart [part] mail - --- | Add an attachment from a file and construct a 'Part' --- with the specified content id in the Content-ID header. --- --- @since 0.4.12 -addAttachmentCid :: Text -- ^ content type - -> FilePath -- ^ file name - -> Text -- ^ content ID - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = - getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = getAttachmentPartBS ct fn content - in addPart [part] mail - --- | @since 0.4.12 -addAttachmentBSCid :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Text -- ^ content ID - -> Mail -> Mail -addAttachmentBSCid ct fn content cid mail = - let part = addHeader $ getAttachmentPartBS ct fn content - in addPart [part] mail - where - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -getAttachmentPartBS :: Text - -> Text - -> L.ByteString - -> Part -getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content - -getAttachmentPart :: Text -> FilePath -> IO Part -getAttachmentPart ct fn = do - content <- L.readFile fn - return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 46 = QPCEscape - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index d00912f..c15ed62 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -5,12 +5,12 @@ module SendMail import Control.Arrow (left) import Control.Exception (SomeException, try) import Data.Either (isLeft) +import qualified Network.Mail.Mime as M import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (fromText, toLazyText) -import qualified MimeMail as M import Model.Mail (Mail (Mail)) -- cgit v1.2.3 From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 28 Nov 2017 09:11:19 +0100 Subject: Add search for payments --- README.md | 2 +- client/src/Component/Input.hs | 57 ++++++++++++++++++++-------- client/src/Icon.hs | 6 +++ client/src/View/Payment.hs | 26 +++++++++---- client/src/View/Payment/Header.hs | 25 +++++++++--- client/src/View/Payment/Pages.hs | 37 ++++++++++-------- client/src/View/Payment/Table.hs | 9 ++--- client/src/View/SignIn.hs | 2 +- common/src/Common/Message/Key.hs | 2 +- common/src/Common/Message/Translation.hs | 2 +- common/src/Common/Util/Text.hs | 8 +++- server/migrations/1.sql | 65 ++++++++++++++++++++++++++++++++ server/src/Design/Global.hs | 26 +++++++++++++ server/src/Design/Helper.hs | 29 -------------- server/src/Design/View/Header.hs | 8 ++-- server/src/Design/View/Payment/Header.hs | 34 +++++++++-------- server/src/Job/Model.hs | 14 ++++--- 17 files changed, 243 insertions(+), 109 deletions(-) create mode 100644 server/migrations/1.sql diff --git a/README.md b/README.md index e9762ea..aa60885 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ Start the environment with: Init the database with migration scripts: ```bash -sqlite3 database < src/migrations/x.sql +sqlite3 database < server/migrations/1.sql ``` Inside the tmux session, add some users with sqlite after the migration is done: diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 1923463..7eec7d0 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -4,13 +4,19 @@ module Component.Input , input ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:)) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~)) +import qualified Reflex.Dom as R + +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button +import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_placeHolder :: Text + { _inputIn_reset :: Event t a + , _inputIn_label :: Text } data InputOut t = InputOut @@ -19,13 +25,34 @@ data InputOut t = InputOut } input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = do - let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) - let value = fmap (const "") (_inputIn_reset inputIn) - textInput <- R.textInput $ R.def & R.attributes .~ placeHolder - & R.setValue .~ value - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_value = R._textInput_value textInput - , _inputOut_enter = enter - } +input inputIn = + R.divClass "textInput" $ do + rec + let resetValue = R.leftmost + [ fmap (const "") (_inputIn_reset inputIn) + , fmap (const "") (_buttonOut_clic reset) + ] + + attributes = R.ffor value (\v -> + if T.null v then M.empty else M.singleton "class" "filled") + + value = R._textInput_value textInput + + textInput <- R.textInput $ R.def + & R.attributes .~ attributes + & R.setValue .~ resetValue + + R.el "label" $ R.text (_inputIn_label inputIn) + + reset <- Button.button $ ButtonIn + { _buttonIn_class = R.constDyn "" + , _buttonIn_content = Icon.cross + , _buttonIn_waiting = R.never + } + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ InputOut + { _inputOut_value = value + , _inputOut_enter = enter + } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index e04e2a8..555d928 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,6 @@ module Icon ( clone + , cross , delete , edit , loading @@ -21,6 +22,11 @@ clone = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank +cross :: forall t m. MonadWidget t m => m () +cross = + svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank + delete :: forall t m. MonadWidget t m => m () delete = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 15892c4..8aa4d38 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -8,9 +8,10 @@ import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Frequency (..), Init (..), Payment (..)) +import Common.Util.Text as T -import View.Payment.Header (HeaderIn (..)) +import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages @@ -29,15 +30,26 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do rec - _ <- Header.widget $ HeaderIn + let init = _paymentIn_init paymentIn + + filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual) + + payments = fmap + (\s -> filter (filterPayment s) (_init_payments init)) + (_headerOut_search header) + + header <- Header.widget $ HeaderIn { _headerIn_init = init } + _ <- Table.widget $ TableIn { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pagesOut + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = payments } - pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments init + + pages <- Pages.widget $ PagesIn + { _pagesIn_payments = payments } + return $ PaymentOut {} - where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 3f2adc3..f64f11d 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -8,10 +8,11 @@ import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import qualified Data.List as L hiding (groupBy) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), @@ -21,7 +22,8 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..)) +import Component (ButtonIn (..), InputIn (..), + InputOut (..)) import qualified Component as Component import qualified Util.List as L @@ -29,16 +31,19 @@ data HeaderIn t = HeaderIn { _headerIn_init :: Init } -data HeaderOut = HeaderOut - { +data HeaderOut t = HeaderOut + { _headerOut_search :: Dynamic t Text } -widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut +widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do payerAndAdd incomes payments users currency + search <- searchLine infos payments users currency - return $ HeaderOut {} + return $ HeaderOut + { _headerOut_search = search + } where init = _headerIn_init headerIn incomes = _init_incomes init payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) @@ -98,3 +103,11 @@ infos payments users currency = . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) $ payments + +searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text) +searchLine = + R.divClass "searchLine" $ + _inputOut_value <$> (Component.input $ InputIn + { _inputIn_reset = R.never + , _inputIn_label = Msg.get Msg.Search_Name + }) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 81555ab..dfd92c0 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Frequency (..), Payment (..)) +import Common.Model (Payment (..)) import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component @@ -16,52 +16,57 @@ import qualified Component as Component import qualified Icon import qualified View.Payment.Constants as Constants -data PagesIn = PagesIn - { _pagesIn_payments :: [Payment] +data PagesIn t = PagesIn + { _pagesIn_payments :: Dynamic t [Payment] } data PagesOut t = PagesOut { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) +widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do R.divClass "pages" $ do rec currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] - firstPageClic <- pageButton (R.constDyn 0) (R.constDyn 1) Icon.doubleLeftBar + firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar - previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft - pageClic <- pageEvent <$> (R.simpleList (fmap (range maxPage) currentPage) $ \p -> - pageButton currentPage p (R.dynText $ fmap (T.pack . show) p)) + pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> + pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) - nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight + nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight - lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar + lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar return $ PagesOut { _pagesOut_currentPage = currentPage } - where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn - maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage + where maxPage = + R.ffor (_pagesIn_payments pagesIn) (\payments -> + ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage + ) + pageEvent = R.switchPromptlyDyn . fmap R.leftmost + noCurrentPage = R.constDyn Nothing + range :: Int -> Int -> [Int] -range maxPage currentPage = [start..end] +range currentPage maxPage = [start..end] where sidePages = 2 - start = max 1 (currentPage - sidePages) + start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) end = min maxPage (start + sidePages * 2) -pageButton :: forall t m. MonadWidget t m => Dynamic t Int -> Dynamic t Int -> m () -> m (Event t Int) +pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do clic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = do cp <- currentPage p <- page - if cp == p then "page current" else "page" + if cp == Just p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index d8093a5..0c3b769 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -12,8 +12,7 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Frequency (..), - Init (..), Payment (..), +import Common.Model (Category (..), Init (..), Payment (..), PaymentCategory (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -26,6 +25,7 @@ import qualified View.Payment.Constants as Constants data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int + , _tableIn_payments :: Dynamic t [Payment] } data TableOut = TableOut @@ -47,8 +47,8 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn currentPage = _tableIn_currentPage tableIn - payments = _init_payments init - paymentRange = fmap (getPaymentRange payments) currentPage + payments = _tableIn_payments tableIn + paymentRange = getPaymentRange <$> payments <*> currentPage R.simpleList paymentRange (paymentRow init) return $ TableOut {} @@ -58,7 +58,6 @@ getPaymentRange payments currentPage = . drop ((currentPage - 1) * Constants.paymentsPerPage) . reverse . L.sortOn _payment_date - . filter ((==) Punctual . _payment_frequency) $ payments paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 69596d8..be6b152 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -23,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index ad8a7f1..a6828d5 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -118,7 +118,7 @@ data Key = | SignIn_Button | SignIn_DisconnectSuccess | SignIn_EmailInvalid - | SignIn_EmailPlaceholder + | SignIn_EmailLabel | SignIn_EmailSendFail | SignIn_EmailSent | SignIn_LinkExpired diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 0a6084d..13ced15 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -517,7 +517,7 @@ m l SignIn_EmailInvalid = English -> "Your email is not valid." French -> "Votre courriel n’est pas valide." -m l SignIn_EmailPlaceholder = +m l SignIn_EmailLabel = case l of English -> "Email" French -> "Courriel" diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index 7e5c8c2..b49fc55 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,10 +1,16 @@ module Common.Util.Text - ( unaccent + ( search + , unaccent ) where import Data.Text (Text) import qualified Data.Text as T +search :: Text -> Text -> Bool +search s t = + (format s) `T.isInfixOf` (format t) + where format = T.toLower . unaccent + unaccent :: Text -> Text unaccent = T.map unaccentChar diff --git a/server/migrations/1.sql b/server/migrations/1.sql new file mode 100644 index 0000000..d7c300e --- /dev/null +++ b/server/migrations/1.sql @@ -0,0 +1,65 @@ +CREATE TABLE IF NOT EXISTS "user" ( + "id" INTEGER PRIMARY KEY, + "creation" TIMESTAMP NOT NULL, + "email" VARCHAR NOT NULL, + "name" VARCHAR NOT NULL, + CONSTRAINT "uniq_user_email" UNIQUE ("email"), + CONSTRAINT "uniq_user_name" UNIQUE ("name") +); + +CREATE TABLE IF NOT EXISTS "job" ( + "id" INTEGER PRIMARY KEY, + "kind" VARCHAR NOT NULL, + "last_execution" TIMESTAMP NULL, + "last_check" TIMESTAMP NULL, + CONSTRAINT "uniq_job_kind" UNIQUE ("kind") +); + +CREATE TABLE IF NOT EXISTS "sign_in"( + "id" INTEGER PRIMARY KEY, + "token" VARCHAR NOT NULL, + "creation" TIMESTAMP NOT NULL, + "email" VARCHAR NOT NULL, + "is_used" BOOLEAN NOT NULL, + CONSTRAINT "uniq_sign_in_token" UNIQUE ("token") +); + +CREATE TABLE IF NOT EXISTS "payment"( + "id" INTEGER PRIMARY KEY, + "user_id" INTEGER NOT NULL REFERENCES "user", + "name" VARCHAR NOT NULL, + "cost" INTEGER NOT NULL, + "date" DATE NOT NULL, + "frequency" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +CREATE TABLE IF NOT EXISTS "income"( + "id" INTEGER PRIMARY KEY, + "user_id" INTEGER NOT NULL REFERENCES "user", + "date" DATE NOT NULL, + "amount" INTEGERNOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +CREATE TABLE IF NOT EXISTS "category"( + "id" INTEGER PRIMARY KEY, + "name" VARCHAR NOT NULL, + "color" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +CREATE TABLE IF NOT EXISTS "payment_category"( + "id" INTEGER PRIMARY KEY, + "name" VARCHAR NOT NULL, + "category" INTEGER NOT NULL REFERENCES "category", + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + CONSTRAINT "uniq_payment_category_name" UNIQUE ("name") +); diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 34d772e..5e5035c 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -71,3 +71,29 @@ global = do ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten svg ? height (pct 100) + + button ? do + ".content" ? display flex + svg # ".loader" ? display none + + ".waiting" & do + ".content" ? do + display none + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 89f5958..6980c71 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,7 +1,6 @@ module Design.Helper ( clearFix , button - , waitable , input , centeredWithMargin , verticalCentering @@ -37,20 +36,6 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) - waitable - -waitable :: Css -waitable = do - ".content" ? display flex - svg # ".loader" ? display none - - ".waiting" & do - ".content" ? do - display none - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation input :: Double -> Css input h = do @@ -72,17 +57,3 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 904a2f5..97f1802 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -2,13 +2,12 @@ module Design.View.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import Clay -import Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Media as Media +import Design.Color as Color +import qualified Design.Media as Media design :: Css design = do @@ -56,7 +55,6 @@ design = do Media.tabletDesktop $ headerPadding ".signOut" ? do - Helper.waitable display flex svg ? do Media.tabletDesktop $ width (px 30) diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 36bc8d9..80c5436 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -50,22 +50,24 @@ design = do ".searchLine" ? do marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + button ? do + svg ? "path" ? ("fill" -: Color.toString Color.silver) + hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25)) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none ".infos" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index a5fa62b..1dd6c63 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -5,7 +5,6 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) import Data.Time.Clock (UTCTime, getCurrentTime) import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -24,15 +23,20 @@ data Job = Job getLastExecution :: Kind -> Query (Maybe UTCTime) getLastExecution jobKind = Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time + result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime] + return $ case result of + [Only time] -> Just time + _ -> Nothing ) actualizeLastExecution :: Kind -> UTCTime -> Query () actualizeLastExecution jobKind time = Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result + result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int] + let hasJob = case result of + [Only _] -> True + _ -> False + if hasJob then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) ) -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- README.md | 27 +++++++++--- application.conf | 1 + client/client.cabal | 1 - client/src/Component/Input.hs | 2 +- client/src/Icon.hs | 8 ++-- client/src/Util/Dom.hs | 19 +++++++++ client/src/View/Payment.hs | 7 +++- client/src/View/Payment/Constants.hs | 6 --- client/src/View/Payment/Pages.hs | 51 ++++++++++++++--------- client/src/View/Payment/Table.hs | 59 +++++++++++++++----------- client/src/View/SignIn.hs | 4 +- server/server.cabal | 2 - server/src/Conf.hs | 4 +- server/src/Controller/Index.hs | 77 ++++++++++++++++++++++++---------- server/src/Controller/Payment.hs | 2 +- server/src/Controller/SignIn.hs | 44 -------------------- server/src/Design/View/SignIn.hs | 2 +- server/src/Job/MonthlyPayment.hs | 2 +- server/src/Job/WeeklyReport.hs | 7 +--- server/src/Main.hs | 81 +++++++++++++----------------------- server/src/Model/Income.hs | 12 +----- server/src/Model/Init.hs | 2 +- server/src/Model/Mail.hs | 8 ++-- server/src/Model/Payment.hs | 41 +++++++----------- server/src/SendMail.hs | 39 +++++++++++++---- server/src/View/Mail/SignIn.hs | 2 +- server/src/View/Mail/WeeklyReport.hs | 32 +++++++++++--- server/src/View/Page.hs | 6 +-- stylish-haskell/default.nix | 44 -------------------- tools.nix | 11 ++--- 30 files changed, 302 insertions(+), 301 deletions(-) create mode 100644 client/src/Util/Dom.hs delete mode 100644 client/src/View/Payment/Constants.hs delete mode 100644 server/src/Controller/SignIn.hs delete mode 100644 stylish-haskell/default.nix diff --git a/README.md b/README.md index aa60885..34ae53e 100644 --- a/README.md +++ b/README.md @@ -58,10 +58,25 @@ See [application.conf](application.conf). TODO ---- -- move persistence methods to a module -- use another route to check the token and redirect to / -- migration diff (use flyway?) +### Interface -- Add payment balance in weekly report -- search by payment category and payment date -- Move up element ids security (editOwn is actually at db level) +- Search payments by frequency. +- Add a payment. + +#### Bonus + +- Adjust login design. +- smooth search. +- search payments by: + - category, + - date. + +### Code + +- R.def for custom components. +- Move up element ids security (editOwn is actually at db level). +- move persistence methods to a module. + +### Tooling + +- migration diff (use flyway?). diff --git a/application.conf b/application.conf index 49b81a7..021fa2a 100644 --- a/application.conf +++ b/application.conf @@ -4,5 +4,6 @@ currency = "€" signInExpiration = 5 minutes noReplyMail = "no-reply@mail.com" https = False +devMode = True importMaybe "local.conf" diff --git a/client/client.cabal b/client/client.cabal index fdf764e..02a7549 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -39,7 +39,6 @@ Executable client View.App View.Header View.Payment - View.Payment.Constants View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 7eec7d0..24aac22 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -45,7 +45,7 @@ input inputIn = R.el "label" $ R.text (_inputIn_label inputIn) reset <- Button.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "reset" , _buttonIn_content = Icon.cross , _buttonIn_waiting = R.never } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index 555d928..dae5e7f 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -29,8 +29,8 @@ cross = delete :: forall t m. MonadWidget t m => m () delete = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank doubleLeft :: forall t m. MonadWidget t m => m () doubleLeft = @@ -54,8 +54,8 @@ doubleRightBar = edit :: forall t m. MonadWidget t m => m () edit = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank loading :: forall t m. MonadWidget t m => m () loading = diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs new file mode 100644 index 0000000..f3e9c88 --- /dev/null +++ b/client/src/Util/Dom.hs @@ -0,0 +1,19 @@ +module Util.Dom + ( divVisibleIf + , divClassVisibleIf + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a +divVisibleIf cond content = divClassVisibleIf cond "" content + +divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a +divClassVisibleIf cond className content = + R.elDynAttr + "div" + (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) + content diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 8aa4d38..f4aaf5c 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -38,6 +38,8 @@ widget paymentIn = do (\s -> filter (filterPayment s) (_init_payments init)) (_headerOut_search header) + paymentsPerPage = 7 + header <- Header.widget $ HeaderIn { _headerIn_init = init } @@ -46,10 +48,13 @@ widget paymentIn = do { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages , _tableIn_payments = payments + , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_payments = payments + { _pagesIn_total = length <$> payments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header } return $ PaymentOut {} diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs deleted file mode 100644 index 028e328..0000000 --- a/client/src/View/Payment/Constants.hs +++ /dev/null @@ -1,6 +0,0 @@ -module View.Payment.Constants - ( paymentsPerPage - ) where - -paymentsPerPage :: Int -paymentsPerPage = 7 diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index dfd92c0..55ceb9f 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -4,20 +4,20 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment (..)) - -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon -import qualified View.Payment.Constants as Constants +import qualified Util.Dom as Dom data PagesIn t = PagesIn - { _pagesIn_payments :: Dynamic t [Payment] + { _pagesIn_total :: Dynamic t Int + , _pagesIn_perPage :: Int + , _pagesIn_reset :: Event t () } data PagesOut t = PagesOut @@ -26,9 +26,29 @@ data PagesOut t = PagesOut widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do + currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where + total = _pagesIn_total pagesIn + perPage = _pagesIn_perPage pagesIn + reset = _pagesIn_reset pagesIn + +pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) +pageButtons total perPage reset = do R.divClass "pages" $ do rec - currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] + currentPage <- R.holdDyn 1 . R.leftmost $ + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + , (const 1) <$> reset + ] firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -41,17 +61,10 @@ widget pagesIn = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return $ PagesOut - { _pagesOut_currentPage = currentPage - } - - where maxPage = - R.ffor (_pagesIn_payments pagesIn) (\payments -> - ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage - ) + return currentPage + where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) pageEvent = R.switchPromptlyDyn . fmap R.leftmost - noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0c3b769..a49be5c 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,28 +4,29 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format import qualified Icon -import qualified View.Payment.Constants as Constants +import qualified Util.Dom as Dom data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int , _tableIn_payments :: Dynamic t [Payment] + , _tableIn_perPage :: Int } data TableOut = TableOut @@ -34,7 +35,8 @@ data TableOut = TableOut widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - _ <- R.divClass "table" $ + R.divClass "table" $ do + R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name @@ -45,17 +47,24 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - let init = _tableIn_init tableIn - currentPage = _tableIn_currentPage tableIn - payments = _tableIn_payments tableIn - paymentRange = getPaymentRange <$> payments <*> currentPage - R.simpleList paymentRange (paymentRow init) + _ <- R.simpleList paymentRange (paymentRow init) + return () + + Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + R.text $ Msg.get Msg.Payment_Empty + return $ TableOut {} -getPaymentRange :: [Payment] -> Int -> [Payment] -getPaymentRange payments currentPage = - take Constants.paymentsPerPage - . drop ((currentPage - 1) * Constants.paymentsPerPage) + where + init = _tableIn_init tableIn + currentPage = _tableIn_currentPage tableIn + payments = _tableIn_payments tableIn + paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage + +getPaymentRange :: Int -> [Payment] -> Int -> [Payment] +getPaymentRange perPage payments currentPage = + take perPage + . drop ((currentPage - 1) * perPage) . reverse . L.sortOn _payment_date $ payments diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index be6b152..89be737 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -45,7 +45,7 @@ view result = ] button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "" + { _buttonIn_class = R.constDyn "validate" , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) , _buttonIn_waiting = waiting } @@ -57,7 +57,7 @@ view result = askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) askSignIn email = fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email + where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email getResult response = case R._xhrResponse_responseText response of Just key -> diff --git a/server/server.cabal b/server/server.cabal index 3715105..d1dbd50 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -36,7 +36,6 @@ Executable server , filepath , http-conduit , http-types - , lens , mime-mail , monad-logger , mtl @@ -61,7 +60,6 @@ Executable server Controller.Income Controller.Index Controller.Payment - Controller.SignIn Cookie Design.Color Design.Constants diff --git a/server/src/Conf.hs b/server/src/Conf.hs index 2422a93..ca19c8d 100644 --- a/server/src/Conf.hs +++ b/server/src/Conf.hs @@ -17,6 +17,7 @@ data Conf = Conf , currency :: Currency , noReplyMail :: Text , https :: Bool + , devMode :: Bool } deriving Show get :: FilePath -> IO Conf @@ -30,7 +31,8 @@ get path = do Conf.lookup "signInExpiration" conf <*> fmap Currency (Conf.lookup "currency" conf) <*> Conf.lookup "noReplyMail" conf <*> - Conf.lookup "https" conf + Conf.lookup "https" conf <*> + Conf.lookup "devMode" conf ) case conf of Left msg -> error (T.unpack msg) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f05ce6f..9a3e2b7 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,16 +1,23 @@ module Controller.Index ( get + , askSignIn + , trySignIn , signOut ) where import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Status (badRequest400, ok200) import Prelude hiding (error) -import Web.Scotty hiding (get) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (InitResult (..), User (..)) +import Common.Model (InitResult (..), SignIn (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg @@ -21,26 +28,52 @@ import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User import Secure (getUserFromToken) +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn import View.Page (page) -get :: Conf -> Maybe Text -> ActionM () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Msg.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult +get :: Conf -> ActionM () +get conf = do + initResult <- do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + S.html $ page initResult + +askSignIn :: Conf -> SignIn -> ActionM () +askSignIn conf (SignIn email) = + if Email.isValid (TE.encodeUtf8 email) + then do + maybeUser <- liftIO . Query.run $ User.get email + case maybeUser of + Just user -> do + token <- liftIO . Query.run $ SignIn.createSignInToken email + let url = T.concat [ + if Conf.https conf then "https://" else "http://", + Conf.hostname conf, + "/signIn/", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + +trySignIn :: Conf -> Text -> ActionM () +trySignIn conf token = do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + Right _ -> + S.redirect "/" validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -82,4 +115,4 @@ getLoggedUser = do liftIO . Query.run . getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 +signOut conf = LoginSession.delete conf >> S.status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c6c874a..f2af6c9 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -22,7 +22,7 @@ import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json + (liftIO . Query.run $ Payment.listActive) >>= json ) create :: CreatePayment -> ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs deleted file mode 100644 index cf92c9f..0000000 --- a/server/src/Controller/SignIn.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty - -import Common.Model (SignIn (..)) -import qualified Common.Msg as Msg - -import Conf (Conf) -import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn - -signIn :: Conf -> SignIn -> ActionM () -signIn conf (SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 4d4be7b..7f5f503 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -23,7 +23,7 @@ design = do width (pct 100) marginBottom (px 10) - button ? do + button # ".validate" ? do Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten display flex alignItems center diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index ca7e007..907be2b 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -12,7 +12,7 @@ import Util.Time (timeToDay) monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly + monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName now <- getCurrentTime actualDay <- timeToDay now let punctualPayments = map diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 74180df..38d88b5 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -19,10 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) + (,,) <$> Payment.listPunctual <*> Income.list <*> User.list + _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now diff --git a/server/src/Main.hs b/server/src/Main.hs index c8080dc..e298a06 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,83 +1,62 @@ -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) - -import qualified Data.Text.Lazy as LT import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static -import Web.Scotty - -import Common.Model (Frequency (..), Payment (..)) -import qualified Common.Model as CM +import qualified Web.Scotty as S import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import qualified Data.Time as Time import Job.Daemon (runDaemons) -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query -import qualified Model.User as UserM main :: IO () main = do conf <- Conf.get "application.conf" _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } - middleware . staticPolicy $ noDots >-> addBase "public" + S.scotty (Conf.port conf) $ do + S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } + S.middleware . staticPolicy $ noDots >-> addBase "public" - get "/exceedingPayer" $ do - time <- liftIO Time.getCurrentTime - (users, incomes, payments) <- liftIO . Query.run $ - liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let punctualPayments = filter ((==) Punctual . _payment_frequency) payments - exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments - text . LT.pack . show $ exceedingPayers + S.get "/" $ do + Index.get conf - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken + S.post "/askSignIn" $ do + S.jsonData >>= Index.askSignIn conf - post "/signIn" $ do - jsonData >>= SignIn.signIn conf + S.get "/signIn/:signInToken" $ do + signInToken <- S.param "signInToken" + Index.trySignIn conf signInToken - post "/signOut" $ + S.post "/signOut" $ Index.signOut conf - post "/payment" $ - jsonData >>= Payment.create + S.post "/payment" $ + S.jsonData >>= Payment.create - put "/payment" $ - jsonData >>= Payment.editOwn + S.put "/payment" $ + S.jsonData >>= Payment.editOwn - delete "/payment" $ do - paymentId <- param "id" + S.delete "/payment" $ do + paymentId <- S.param "id" Payment.deleteOwn paymentId - post "/income" $ - jsonData >>= Income.create + S.post "/income" $ + S.jsonData >>= Income.create - put "/income" $ - jsonData >>= Income.editOwn + S.put "/income" $ + S.jsonData >>= Income.editOwn - delete "/income" $ do - incomeId <- param "id" + S.delete "/income" $ do + incomeId <- S.param "id" Income.deleteOwn incomeId - post "/category" $ - jsonData >>= Category.create + S.post "/category" $ + S.jsonData >>= Category.create - put "/category" $ - jsonData >>= Category.edit + S.put "/category" $ + S.jsonData >>= Category.edit - delete "/category" $ do - categoryId <- param "id" + S.delete "/category" $ do + categoryId <- S.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/server/src/Model/Income.hs b/server/src/Model/Income.hs index a6174bc..4938e50 100644 --- a/server/src/Model/Income.hs +++ b/server/src/Model/Income.hs @@ -5,12 +5,11 @@ module Model.Income , create , editOwn , deleteOwn - , modifiedDuring ) where import Data.Maybe (listToMaybe) import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) @@ -87,12 +86,3 @@ deleteOwn user incomeId = Nothing -> return False ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Income] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" - (start, end, start, end, start, end) - ) diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs index be44c72..0a0ffc7 100644 --- a/server/src/Model/Init.hs +++ b/server/src/Model/Init.hs @@ -18,7 +18,7 @@ getInit user conf = Init <$> User.list <*> (return . _user_id $ user) <*> - Payment.list <*> + Payment.listActive <*> Income.list <*> Category.list <*> PaymentCategory.list <*> diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs index a19f9ae..780efcc 100644 --- a/server/src/Model/Mail.hs +++ b/server/src/Model/Mail.hs @@ -5,8 +5,8 @@ module Model.Mail import Data.Text (Text) data Mail = Mail - { from :: Text - , to :: [Text] - , subject :: Text - , plainBody :: Text + { from :: Text + , to :: [Text] + , subject :: Text + , body :: Text } deriving (Eq, Show) diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs index 33551e5..5b29409 100644 --- a/server/src/Model/Payment.hs +++ b/server/src/Model/Payment.hs @@ -3,19 +3,18 @@ module Model.Payment ( Payment(..) , find - , list - , listMonthly + , listActive + , listPunctual + , listActiveMonthlyOrderedByName , create , createMany , editOwn , deleteOwn - , modifiedDuring ) where import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only), @@ -66,14 +65,22 @@ find paymentId = SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) ) -list :: Query [Payment] -list = +listActive :: Query [Payment] +listActive = Query (\conn -> SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" ) -listMonthly :: Query [Payment] -listMonthly = +listPunctual :: Query [Payment] +listPunctual = + Query (\conn -> + SQLite.query + conn + (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") + (Only Punctual)) + +listActiveMonthlyOrderedByName :: Query [Payment] +listActiveMonthlyOrderedByName = Query (\conn -> SQLite.query conn @@ -83,8 +90,7 @@ listMonthly = , "WHERE deleted_at IS NULL AND frequency = ?" , "ORDER BY name DESC" ]) - (Only Monthly) - ) + (Only Monthly)) create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId create userId paymentName paymentCost paymentDate paymentFrequency = @@ -161,18 +167,3 @@ deleteOwn userId paymentId = Nothing -> return False ) - -modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] -modifiedDuring start end = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE (created_at >= ? AND created_at <= ?)" - , " OR (edited_at >= ? AND edited_at <= ?)" - , " OR (deleted_at >= ? AND deleted_at <= ?)" - ]) - (start, end, start, end, start, end) - ) diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index c15ed62..3b17a0a 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -9,18 +9,41 @@ import qualified Network.Mail.Mime as M import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (fromText, toLazyText) -import Model.Mail (Mail (Mail)) +import Conf (Conf) +import qualified Conf +import Model.Mail (Mail (..)) -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = do - result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) - if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) - else putStrLn "OK" - return result +sendMail :: Conf -> Mail -> IO (Either Text ()) +sendMail conf mail = + if Conf.devMode conf + then + do + T.putStrLn . mockMailMessage $ mail + return (Right ()) + else + do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else return () + return result + +mockMailMessage :: Mail -> Text +mockMailMessage mail = T.concat $ + [ "[MOCK MAIL] " + , subject mail + , " (from: " + , from mail + , ") (to: " + , T.intercalate ", " $ to mail + , ")" + , "\n" + , body mail + ] getMimeMail :: Mail -> M.Mail getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs index 22c3cb0..3c5469f 100644 --- a/server/src/View/Mail/SignIn.hs +++ b/server/src/View/Mail/SignIn.hs @@ -17,5 +17,5 @@ mail conf user url to = { M.from = Conf.noReplyMail conf , M.to = to , M.subject = Msg.get Msg.SignIn_MailTitle - , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url) + , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url) } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 4ad8b77..5418880 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -11,8 +11,8 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime) -import Common.Model (Income (..), Payment (..), User (..), - UserId) +import Common.Model (ExceedingPayer (..), Income (..), + Payment (..), User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -35,11 +35,31 @@ mail conf users payments incomes start end = , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) + , M.body = body conf users payments incomes start end } -body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text -body conf users paymentsByStatus incomesByStatus = +body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text +body conf users payments incomes start end = + T.intercalate "\n" $ + [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments) + , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes) + ] + +exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text +exceedingPayers conf time users incomes payments = + T.intercalate "\n" . map formatPayer $ payers + where + payers = CM.getExceedingPayers time users incomes payments + formatPayer p = T.concat + [ " * " + , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users + , " + " + , Format.price (Conf.currency conf) $ _exceedingPayer_amount p + , "\n" + ] + +operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +operations conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then Msg.get Msg.WeeklyReport_Empty @@ -96,5 +116,5 @@ section title items = T.concat [ title , "\n\n" - , T.unlines . map (" - " <>) $ items + , T.unlines . map (" * " <>) $ items ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 27b4f26..97b84fa 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -26,10 +26,10 @@ page initResult = meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" H.title (toHtml $ Msg.get Msg.App_Title) - script ! src "javascript/main.js" $ "" + script ! src "/javascript/main.js" $ "" jsonScript "init" initResult - link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" - link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign jsonScript :: Json.ToJSON a => Text -> a -> Html diff --git a/stylish-haskell/default.nix b/stylish-haskell/default.nix deleted file mode 100644 index bd73cf8..0000000 --- a/stylish-haskell/default.nix +++ /dev/null @@ -1,44 +0,0 @@ -{ HUnit, aeson, base, bytestring, containers, directory, fetchFromGitHub -, filepath, haskell-src-exts, mkDerivation, mtl, optparse-applicative, stdenv -, strict, stylish-haskell, syb, test-framework, test-framework-hunit, yaml -}: - -let regularDependencies = [ - aeson - base - bytestring - containers - directory - filepath - haskell-src-exts - mtl - syb - yaml - ]; -in mkDerivation { - pname = "stylish-haskell"; - version = "0.8.1.0"; - - src = fetchFromGitHub { - owner = "jaspervdj"; - repo = "stylish-haskell"; - rev = "dc3a73e82c19ff97a1544840dac8f7f4568b24bc"; - sha256 = "0kx9m3j9w2357ff5y651s9cdbjiyax9fksyf4rk8pzabc0dv6dpg"; - }; - - isLibrary = true; - isExecutable = true; - - libraryHaskellDepends = - regularDependencies; - - executableHaskellDepends = - regularDependencies ++ [ optparse-applicative strict stylish-haskell ]; - - testHaskellDepends = - regularDependencies ++ [ HUnit test-framework test-framework-hunit ]; - - homepage = "https://github.com/jaspervdj/stylish-haskell"; - description = "Simple Haskell code prettifier"; - license = stdenv.lib.licenses.bsd3; - } diff --git a/tools.nix b/tools.nix index f09ad13..8c7d91f 100644 --- a/tools.nix +++ b/tools.nix @@ -7,11 +7,12 @@ with import {}; { cabal-install tmux tmuxinator - (import ./stylish-haskell { - inherit mkDerivation aeson base bytestring containers directory filepath - fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict - optparse-applicative HUnit test-framework test-framework-hunit stdenv; - }) + stylish-haskell + # (import ./stylish-haskell { + # inherit mkDerivation aeson base bytestring containers directory filepath + # fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict + # optparse-applicative HUnit test-framework test-framework-hunit stdenv; + # }) ]; }; } -- cgit v1.2.3 From 17d6a05756479388c91bc2e50f721fcea8a82d38 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:36:23 +0100 Subject: Remove quotes around names in weekly report --- common/src/Common/Message/Translation.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 13ced15..5ea12ad 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -641,23 +641,23 @@ m l (WeeklyReport_IncomeEdited count) = m l (WeeklyReport_PayedFor name amount for at) = case l of - English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] + English -> T.concat [ name, " payed ", amount, " for “", for, "” at ", at ] + French -> T.concat [ name, " a payé ", amount, " concernant « ", for, " » le ", at ] m l (WeeklyReport_PayedForNot name amount for at) = case l of - English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] + English -> T.concat [ name, " didn’t pay ", amount, " for “", for, "” at ", at ] + French -> T.concat [ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] m l (WeeklyReport_PayedFrom name amount for) = case l of - English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] + English -> T.concat [ name, " is payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ name, " est payé ", amount, " net par mois à partir du ", for ] m l (WeeklyReport_PayedFromNot name amount for) = case l of - English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] + English -> T.concat [ name, " isn’t payed ", amount, " of net monthly income from ", for ] + French -> T.concat [ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] m l (WeeklyReport_PaymentsCreated count) = case l of -- cgit v1.2.3 From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001 From: Joris Date: Fri, 5 Jan 2018 14:45:47 +0100 Subject: Add modal component --- README.md | 5 +- client/client.cabal | 1 + client/src/Component.hs | 1 + client/src/Component/Button.hs | 4 +- client/src/Component/Modal.hs | 38 ++++++++++ client/src/View/Payment.hs | 18 ++--- client/src/View/Payment/Header.hs | 130 +++++++++++++++++++++-------------- common/src/Common/Model/Frequency.hs | 2 +- public/css/reset.css | 12 ---- server/server.cabal | 2 +- server/src/Design/Dialog.hs | 22 ------ server/src/Design/Global.hs | 16 ++--- server/src/Design/Modal.hs | 43 ++++++++++++ 13 files changed, 184 insertions(+), 110 deletions(-) create mode 100644 client/src/Component/Modal.hs delete mode 100644 server/src/Design/Dialog.hs create mode 100644 server/src/Design/Modal.hs diff --git a/README.md b/README.md index 34ae53e..ec8c139 100644 --- a/README.md +++ b/README.md @@ -60,8 +60,10 @@ TODO ### Interface -- Search payments by frequency. - Add a payment. +- Edit a payment. +- Delete a payment. +- Clone a payment. #### Bonus @@ -76,6 +78,7 @@ TODO - R.def for custom components. - Move up element ids security (editOwn is actually at db level). - move persistence methods to a module. +- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) ### Tooling diff --git a/client/client.cabal b/client/client.cabal index 02a7549..1064e7d 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -34,6 +34,7 @@ Executable client other-modules: Component.Button Component.Input + Component.Modal Icon Util.List View.App diff --git a/client/src/Component.hs b/client/src/Component.hs index 4c9541b..dea384e 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -2,3 +2,4 @@ module Component (module X) where import Component.Button as X import Component.Input as X +import Component.Modal as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 754b903..3ee9561 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,8 +1,8 @@ module Component.Button ( ButtonIn(..) - , buttonInDefault , ButtonOut(..) , button + , buttonInDefault ) where import qualified Data.Map as M @@ -19,7 +19,7 @@ data ButtonIn t m = ButtonIn , _buttonIn_waiting :: Event t Bool } -buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m +buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m buttonInDefault = ButtonIn { _buttonIn_class = R.constDyn "" , _buttonIn_content = R.blank diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs new file mode 100644 index 0000000..bfb5e02 --- /dev/null +++ b/client/src/Component/Modal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Component.Modal + ( ModalIn(..) + , ModalOut(..) + , modal + ) where + +import qualified Data.Map as M +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +data ModalIn t m = ModalIn + { _modalIn_show :: Event t () + , _modalIn_content :: m () + } + +data ModalOut = ModalOut {} + +modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut +modal modalIn = do + rec + showModal <- R.holdDyn False $ R.leftmost + [ True <$ _modalIn_show modalIn + , False <$ curtainClick + ] + + let attr = flip fmap showModal (\s -> M.fromList $ + [ ("style", if s then "display:block" else "display:none") + , ("class", "modal") + ]) + + curtainClick <- R.elDynAttr "div" attr $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank + R.divClass "content" $ _modalIn_content modalIn + return $ R.domEvent R.Click curtain + + return $ ModalOut {} diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f4aaf5c..42da8fb 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -8,8 +8,7 @@ import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Frequency (..), Init (..), Payment (..)) -import Common.Util.Text as T +import Common.Model (Init (..)) import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -31,13 +30,6 @@ widget paymentIn = do R.divClass "payment" $ do rec let init = _paymentIn_init paymentIn - - filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual) - - payments = fmap - (\s -> filter (filterPayment s) (_init_payments init)) - (_headerOut_search header) - paymentsPerPage = 7 header <- Header.widget $ HeaderIn @@ -47,14 +39,14 @@ widget paymentIn = do _ <- Table.widget $ TableIn { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = payments + , _tableIn_payments = _headerOut_searchPayments header , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> payments + { _pagesIn_total = length <$> _headerOut_searchPayments header , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header + , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header } - return $ PaymentOut {} + pure $ PaymentOut {} diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index f64f11d..a694136 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -7,23 +7,26 @@ module View.Payment.Header import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import qualified Data.List as L hiding (groupBy) +import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), Frequency (..), Income (..), Init (..), - Payment (..), User (..), UserId) + Payment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg +import qualified Common.Util.Text as T import qualified Common.View.Format as Format -import Component (ButtonIn (..), InputIn (..), - InputOut (..)) +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..), + ModalIn (..)) import qualified Component as Component import qualified Util.List as L @@ -32,23 +35,37 @@ data HeaderIn t = HeaderIn } data HeaderOut t = HeaderOut - { _headerOut_search :: Dynamic t Text + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchPayments :: Dynamic t [Payment] } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes payments users currency - search <- searchLine - infos payments users currency + payerAndAdd incomes punctualPayments users currency + (searchName, searchFrequency) <- searchLine + let searchPayments = getSearchPayments searchName searchFrequency payments + infos searchPayments users currency return $ HeaderOut - { _headerOut_search = search + { _headerOut_searchName = searchName + , _headerOut_searchPayments = searchPayments } - where init = _headerIn_init headerIn - incomes = _init_incomes init - payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) - users = _init_users init - currency = _init_currency init + where + init = _headerIn_init headerIn + incomes = _init_incomes init + payments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) payments + users = _init_users init + currency = _init_currency init + +getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + pure $ flip filter payments (\p -> + ( T.search n (_payment_name p) + && (_payment_frequency p == f) + )) payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () payerAndAdd incomes payments users currency = do @@ -65,49 +82,62 @@ payerAndAdd incomes payments users currency = do R.text "+ " R.text . Format.price currency $ _exceedingPayer_amount p ) - _ <- Component.button $ ButtonIn + addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never + }) + _ <- Component.modal $ ModalIn + { _modalIn_show = addPayment + , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement" } return () -infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m () +searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) +searchLine = do + R.divClass "searchLine" $ do + searchName <- _inputOut_value <$> (Component.input $ InputIn + { _inputIn_reset = R.never + , _inputIn_label = Msg.get Msg.Search_Name + }) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + searchFrequency <- R._dropdown_value <$> + R.dropdown Punctual (R.constDyn frequencies) R.def + + return (searchName, searchFrequency) + +infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () infos payments users currency = R.divClass "infos" $ do - R.elClass "span" "total" $ do - R.text . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - R.elClass "span" "partition" . R.text $ - T.intercalate ", " - . map (\(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) - ) - $ totalByUser - where paymentCount = length payments - total = sum . map _payment_cost $ payments - - totalByUser :: [(UserId, Int)] - totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ payments + R.elClass "span" "total" $ do + R.dynText $ do + ps <- payments + let paymentCount = length ps + total = sum . map _payment_cost $ ps + pure . Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency total) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text) -searchLine = - R.divClass "searchLine" $ - _inputOut_value <$> (Component.input $ InputIn - { _inputIn_reset = R.never - , _inputIn_label = Msg.get Msg.Search_Name - }) + R.elClass "span" "partition" . R.dynText $ do + ps <- payments + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ ps + pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/common/src/Common/Model/Frequency.hs b/common/src/Common/Model/Frequency.hs index ee502e8..48e75ea 100644 --- a/common/src/Common/Model/Frequency.hs +++ b/common/src/Common/Model/Frequency.hs @@ -8,7 +8,7 @@ import GHC.Generics (Generic) data Frequency = Punctual | Monthly - deriving (Eq, Read, Show, Generic) + deriving (Eq, Read, Show, Generic, Ord) instance FromJSON Frequency instance ToJSON Frequency diff --git a/public/css/reset.css b/public/css/reset.css index 42f3b8c..2eecc94 100644 --- a/public/css/reset.css +++ b/public/css/reset.css @@ -56,17 +56,5 @@ 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/server/server.cabal b/server/server.cabal index d1dbd50..ada7040 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -63,12 +63,12 @@ Executable server Cookie Design.Color Design.Constants - Design.Dialog Design.Errors Design.Form Design.Global Design.Helper Design.Media + Design.Modal Design.Tooltip Design.View.Header Design.View.Payment diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs deleted file mode 100644 index 034a8b1..0000000 --- a/server/src/Design/Dialog.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 5e5035c..4da4ffb 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -3,19 +3,17 @@ module Design.Global ) where import Clay - import Data.Text.Lazy (Text) -import qualified Design.Dialog as Dialog -import qualified Design.Errors as Errors -import qualified Design.Form as Form -import qualified Design.Tooltip as Tooltip -import qualified Design.Views as Views - import qualified Design.Color as Color import qualified Design.Constants as Constants +import qualified Design.Errors as Errors +import qualified Design.Form as Form import qualified Design.Helper as Helper import qualified Design.Media as Media +import qualified Design.Modal as Modal +import qualified Design.Tooltip as Tooltip +import qualified Design.Views as Views globalDesign :: Text globalDesign = renderWith compact [] global @@ -23,7 +21,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design - ".dialog" ? Dialog.design + ".modal" ? Modal.design ".tooltip" ? Tooltip.design Views.design Form.design @@ -84,6 +82,8 @@ global = do rotateKeyframes rotateAnimation + select ? cursor pointer + rotateAnimation :: Css rotateAnimation = do animationName "rotate" diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs new file mode 100644 index 0000000..2612257 --- /dev/null +++ b/server/src/Design/Modal.hs @@ -0,0 +1,43 @@ +module Design.Modal + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +design :: Css +design = do + + ".curtain" ? do + position fixed + cursor pointer + top (px 0) + left (px 0) + width (pct 100) + height (pct 100) + backgroundColor (rgba 0 0 0 0.5) + zIndex 1000 + opacity 1 + transition "all" (sec 0.2) ease (sec 0) + + ".content" ? do + minWidth (px 270) + position fixed + top (pct 25) + left (pct 50) + "transform" -: "translate(-50%, -25%)" + zIndex 1000 + backgroundColor white + sym padding (px 20) + sym borderRadius (px 5) + boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + + ".paymentModal" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentModal" <> ".deleteIncomeModal" ? do + h1 ? marginBottom (em 1.5) -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- .tmuxinator.yml | 12 ++- README.md | 2 +- client/client.cabal | 7 ++ client/src/Component.hs | 2 + client/src/Component/Button.hs | 41 +++++--- client/src/Component/Form.hs | 12 +++ client/src/Component/Input.hs | 27 +++-- client/src/Component/Modal.hs | 24 +++-- client/src/Component/Select.hs | 32 ++++++ client/src/Main.hs | 4 +- client/src/Util/Ajax.hs | 20 ++++ client/src/Util/WaitFor.hs | 18 ++++ client/src/View/App.hs | 8 +- client/src/View/Header.hs | 13 ++- client/src/View/Payment/Add.hs | 104 ++++++++++++++++++ client/src/View/Payment/Delete.hs | 51 +++++++++ client/src/View/Payment/Header.hs | 33 +++--- client/src/View/Payment/Pages.hs | 2 + client/src/View/Payment/Table.hs | 48 ++++++--- client/src/View/SignIn.hs | 98 ++++++++--------- common/common.cabal | 1 + common/src/Common/Model/CreatePayment.hs | 3 +- common/src/Common/Model/InitResult.hs | 3 +- common/src/Common/Util/Time.hs | 26 +++++ server/server.cabal | 15 +-- server/src/Controller/Category.hs | 30 +++--- server/src/Controller/Income.hs | 8 +- server/src/Controller/Index.hs | 18 ++-- server/src/Controller/Payment.hs | 40 +++---- server/src/Design/Form.hs | 12 ++- server/src/Design/Modal.hs | 8 +- server/src/Design/View/Payment.hs | 2 + server/src/Design/View/Payment/Add.hs | 32 ++++++ server/src/Design/View/Payment/Header.hs | 9 +- server/src/Job/MonthlyPayment.hs | 16 +-- server/src/Job/WeeklyReport.hs | 8 +- server/src/Model/Category.hs | 78 -------------- server/src/Model/Frequency.hs | 20 ---- server/src/Model/Income.hs | 88 ---------------- server/src/Model/IncomeResource.hs | 15 +++ server/src/Model/Init.hs | 25 ----- server/src/Model/Payment.hs | 169 ------------------------------ server/src/Model/PaymentCategory.hs | 61 ----------- server/src/Model/PaymentResource.hs | 15 +++ server/src/Model/User.hs | 48 --------- server/src/Persistence/Category.hs | 79 ++++++++++++++ server/src/Persistence/Frequency.hs | 23 ++++ server/src/Persistence/Income.hs | 88 ++++++++++++++++ server/src/Persistence/Init.hs | 25 +++++ server/src/Persistence/Payment.hs | 169 ++++++++++++++++++++++++++++++ server/src/Persistence/PaymentCategory.hs | 66 ++++++++++++ server/src/Persistence/User.hs | 37 +++++++ server/src/Secure.hs | 4 +- server/src/SendMail.hs | 1 + server/src/Util/Time.hs | 17 ++- server/src/View/Mail/WeeklyReport.hs | 55 +++++----- 56 files changed, 1126 insertions(+), 746 deletions(-) create mode 100644 client/src/Component/Form.hs create mode 100644 client/src/Component/Select.hs create mode 100644 client/src/Util/Ajax.hs create mode 100644 client/src/Util/WaitFor.hs create mode 100644 client/src/View/Payment/Add.hs create mode 100644 client/src/View/Payment/Delete.hs create mode 100644 common/src/Common/Util/Time.hs create mode 100644 server/src/Design/View/Payment/Add.hs delete mode 100644 server/src/Model/Category.hs delete mode 100644 server/src/Model/Frequency.hs delete mode 100644 server/src/Model/Income.hs create mode 100644 server/src/Model/IncomeResource.hs delete mode 100644 server/src/Model/Init.hs delete mode 100644 server/src/Model/Payment.hs delete mode 100644 server/src/Model/PaymentCategory.hs create mode 100644 server/src/Model/PaymentResource.hs delete mode 100644 server/src/Model/User.hs create mode 100644 server/src/Persistence/Category.hs create mode 100644 server/src/Persistence/Frequency.hs create mode 100644 server/src/Persistence/Income.hs create mode 100644 server/src/Persistence/Init.hs create mode 100644 server/src/Persistence/Payment.hs create mode 100644 server/src/Persistence/PaymentCategory.hs create mode 100644 server/src/Persistence/User.hs diff --git a/.tmuxinator.yml b/.tmuxinator.yml index 48b5add..1576496 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -1,11 +1,13 @@ name: sharedCost windows: - - main: - layout: 3747,239x59,0,0{144x59,0,0,0,94x59,145,0[94x30,145,0,1,94x28,145,31,2]} + - console: + - clear + - app: panes: - - # Empty - - make clean-client watch-client - - make clean-server watch-server + - client: + - make clean-client watch-client + - server: + - make clean-server watch-server - db: - sqlite3 database diff --git a/README.md b/README.md index ec8c139..8a141e5 100644 --- a/README.md +++ b/README.md @@ -75,7 +75,7 @@ TODO ### Code -- R.def for custom components. +- modal as body child https://stackoverflow.com/questions/33711392/what-is-the-proper-way-in-reflex-dom-to-handle-a-modal-dialog - Move up element ids security (editOwn is actually at db level). - move persistence methods to a module. - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) diff --git a/client/client.cabal b/client/client.cabal index 1064e7d..0aec05f 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -33,13 +33,20 @@ Executable client other-modules: Component.Button + Component.Form Component.Input Component.Modal + Component.Select Icon + Util.Ajax + Util.Dom Util.List + Util.WaitFor View.App View.Header View.Payment + View.Payment.Add + View.Payment.Delete View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component.hs b/client/src/Component.hs index dea384e..7b87a75 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -1,5 +1,7 @@ module Component (module X) where import Component.Button as X +import Component.Form as X import Component.Input as X import Component.Modal as X +import Component.Select as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 3ee9561..bf604f1 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -2,10 +2,11 @@ module Component.Button ( ButtonIn(..) , ButtonOut(..) , button - , buttonInDefault + , defaultButtonIn ) where import qualified Data.Map as M +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -14,22 +15,36 @@ import qualified Reflex.Dom as R import qualified Icon data ButtonIn t m = ButtonIn - { _buttonIn_class :: Dynamic t Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool + { _buttonIn_class :: Dynamic t Text + , _buttonIn_content :: m () + , _buttonIn_waiting :: Event t Bool + , _buttonIn_tabIndex :: Maybe Int + , _buttonIn_submit :: Bool } -buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m -buttonInDefault = ButtonIn - { _buttonIn_class = R.constDyn "" - , _buttonIn_content = R.blank - , _buttonIn_waiting = R.never +defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m +defaultButtonIn content = ButtonIn + { _buttonIn_class = R.constDyn "" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False } +-- defaultButtonIn :: MonadWidget t m => ButtonIn t m +-- defaultButtonIn = ButtonIn +-- { _buttonIn_class = R.constDyn "" +-- , _buttonIn_content = R.blank +-- , _buttonIn_waiting = R.never +-- , _buttonIn_tabIndex = Nothing +-- , _buttonIn_submit = False +-- } + data ButtonOut t = ButtonOut { _buttonOut_clic :: Event t () } + button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn @@ -37,9 +52,11 @@ button buttonIn = do let attr = do buttonClass <- _buttonIn_class buttonIn waiting <- dynWaiting - return $ if waiting - then M.fromList [("type", "button"), ("class", T.intercalate " " [ buttonClass, "waiting" ])] - else M.fromList [("type", "button"), ("class", buttonClass)] + return . M.fromList . catMaybes $ + [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button") + , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn + , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ]) + ] (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs new file mode 100644 index 0000000..0a89c6e --- /dev/null +++ b/client/src/Component/Form.hs @@ -0,0 +1,12 @@ +module Component.Form + ( form + ) where + +import qualified Data.Map as M +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +form :: forall t m a. (MonadWidget t m) => m a -> m a +form content = + R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ + content diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 24aac22..92f8ec9 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -2,12 +2,14 @@ module Component.Input ( InputIn(..) , InputOut(..) , input + , defaultInputIn ) where import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~)) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&), + (.~)) import qualified Reflex.Dom as R import Component.Button (ButtonIn (..), ButtonOut (..)) @@ -15,8 +17,16 @@ import qualified Component.Button as Button import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_label :: Text + { _inputIn_reset :: Event t a + , _inputIn_label :: Text + , _inputIn_initialValue :: Text + } + +defaultInputIn :: (Reflex t) => InputIn t a b +defaultInputIn = InputIn + { _inputIn_reset = R.never + , _inputIn_label = "" + , _inputIn_initialValue = "" } data InputOut t = InputOut @@ -41,14 +51,15 @@ input inputIn = textInput <- R.textInput $ R.def & R.attributes .~ attributes & R.setValue .~ resetValue + & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) R.el "label" $ R.text (_inputIn_label inputIn) - reset <- Button.button $ ButtonIn - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_content = Icon.cross - , _buttonIn_waiting = R.never - } + reset <- Button.button $ + (Button.defaultButtonIn Icon.cross) + { _buttonIn_class = R.constDyn "reset" + , _buttonIn_tabIndex = Just (-1) + } let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index bfb5e02..1d70c90 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -10,18 +10,22 @@ import qualified Data.Map as M import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R -data ModalIn t m = ModalIn +data ModalIn t m a = ModalIn { _modalIn_show :: Event t () - , _modalIn_content :: m () + , _modalIn_hide :: Event t () + , _modalIn_content :: m a } -data ModalOut = ModalOut {} +data ModalOut a = ModalOut + { _modalOut_content :: a + } -modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut +modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) modal modalIn = do rec showModal <- R.holdDyn False $ R.leftmost [ True <$ _modalIn_show modalIn + , False <$ _modalIn_hide modalIn , False <$ curtainClick ] @@ -30,9 +34,11 @@ modal modalIn = do , ("class", "modal") ]) - curtainClick <- R.elDynAttr "div" attr $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank - R.divClass "content" $ _modalIn_content modalIn - return $ R.domEvent R.Click curtain + (curtainClick, content) <- R.elDynAttr "div" attr $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank + cont <- R.divClass "modalContent" $ _modalIn_content modalIn + return (R.domEvent R.Click curtain, cont) - return $ ModalOut {} + return $ ModalOut + { _modalOut_content = content + } diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs new file mode 100644 index 0000000..876548e --- /dev/null +++ b/client/src/Component/Select.hs @@ -0,0 +1,32 @@ +module Component.Select + ( SelectIn(..) + , SelectOut(..) + , select + ) where + +import Data.Map (Map) +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +data (Reflex t) => SelectIn t a = SelectIn + { _selectIn_label :: Text + , _selectIn_initialValue :: a + , _selectIn_values :: Dynamic t (Map a Text) + } + +data SelectOut t a = SelectOut + { _selectOut_value :: Dynamic t a + } + +select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a) +select selectIn = + R.divClass "selectInput" $ do + R.el "label" $ R.text (_selectIn_label selectIn) + + value <- R._dropdown_value <$> + R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def + + return SelectOut + { _selectOut_value = value + } diff --git a/client/src/Main.hs b/client/src/Main.hs index d55eefe..6c048c6 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -13,7 +13,7 @@ import JSDOM.Types (HTMLElement (..), JSM) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import Common.Model (InitResult (InitEmpty)) +import Common.Model (InitResult (InitError)) import qualified Common.Msg as Msg import qualified View.App as App @@ -37,4 +37,4 @@ readInit = do _ -> return initParseError - where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError) + where initParseError = InitError $ Msg.get Msg.SignIn_ParseError diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs new file mode 100644 index 0000000..1e8e4c7 --- /dev/null +++ b/client/src/Util/Ajax.hs @@ -0,0 +1,20 @@ +module Util.Ajax + ( post + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text)) +post url input = + fmap getResult <$> R.performRequestAsync xhrRequest + where xhrRequest = R.postJson url <$> input + getResult response = + case R._xhrResponse_responseText response of + Just responseText -> + if R._xhrResponse_status response == 200 + then Right responseText + else Left responseText + _ -> Left "NoKey" diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs new file mode 100644 index 0000000..0175c95 --- /dev/null +++ b/client/src/Util/WaitFor.hs @@ -0,0 +1,18 @@ +module Util.WaitFor + ( waitFor + ) where + +import Data.Time (NominalDiffTime) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +waitFor + :: forall t m a b. MonadWidget t m + => (Event t a -> m (Event t b)) + -> Event t () + -> Dynamic t a + -> m (Event t b, Event t Bool) +waitFor op start input = do + result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime) + let waiting = R.leftmost [ const True <$> start , const False <$> result ] + return (result, waiting) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 64ca303..9aa6c57 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -29,10 +29,12 @@ widget initResult = { _paymentIn_init = initSuccess } return () - InitEmpty result -> - SignIn.view result + InitEmpty -> + SignIn.view SignIn.EmptyMessage + InitError error -> + SignIn.view (SignIn.ErrorMessage error) - signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess) + signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 4c74383..8f1fb78 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -13,9 +13,8 @@ import qualified Reflex.Dom as R import Common.Model (Init (..), InitResult (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg - +import qualified Component as Component import Component.Button (ButtonIn (..)) -import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec - signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = R.constDyn "signOut item" - , Component._buttonIn_content = Icon.signOut - , Component._buttonIn_waiting = waiting - } + signOut <- Component.button $ + (Component.defaultButtonIn Icon.signOut) + { _buttonIn_class = R.constDyn "signOut item" + , _buttonIn_waiting = waiting + } let signOutClic = Component._buttonOut_clic signOut waiting = R.leftmost [ fmap (const True) signOutClic diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs new file mode 100644 index 0000000..2eaec0f --- /dev/null +++ b/client/src/View/Payment/Add.hs @@ -0,0 +1,104 @@ +module View.Payment.Add + ( view + , AddIn(..) + , AddOut(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.View.Format as Format +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +data AddIn = AddIn + { _addIn_categories :: [Category] + } + +data AddOut t = AddOut + { _addOut_cancel :: Event t () + } + +view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view addIn = do + R.divClass "add" $ do + R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add + + R.divClass "addContent" $ do + name <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + + cost <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + + currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + + date <- _inputOut_value <$> (Component.input $ + Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = Format.shortDay currentDay + }) + + frequency <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Frequency + , _selectIn_initialValue = Punctual + , _selectIn_values = R.constDyn frequencies + }) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = 0 + , _selectIn_values = R.constDyn categories + }) + + let payment = CreatePayment + <$> name + <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost + <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date + <*> category + <*> frequency + + cancel <- R.divClass "buttons" $ do + rec + validate <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (_, waiting) <- Util.waitFor + (Ajax.post "/payment") + validate + payment + + Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return AddOut + { _addOut_cancel = cancel + } + + where + frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> + (_category_id c, _category_name c) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs new file mode 100644 index 0000000..a1be16d --- /dev/null +++ b/client/src/View/Payment/Delete.hs @@ -0,0 +1,51 @@ +module View.Payment.Delete + ( view + , DeleteIn(..) + , DeleteOut(..) + ) where + +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +-- import qualified Util.Ajax as Ajax +-- import qualified Util.WaitFor as Util + +data DeleteIn = DeleteIn + {} + +data DeleteOut t = DeleteOut + { _deleteOut_cancel :: Event t () + } + +view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t) +view _ = + R.divClass "delete" $ do + R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm + + R.divClass "deleteContent" $ do + + cancel <- R.divClass "buttons" $ do + rec + _ <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_submit = True + }) + + -- (_, waiting) <- Util.waitFor + -- (Ajax.post "/payment") + -- validate + -- payment + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return cancel + + return DeleteOut + { _deleteOut_cancel = cancel + } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index a694136..d01dec6 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -16,9 +16,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Currency, ExceedingPayer (..), - Frequency (..), Income (..), Init (..), - Payment (..), User (..)) +import Common.Model (Category, Currency, + ExceedingPayer (..), Frequency (..), + Income (..), Init (..), Payment (..), + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -26,9 +27,11 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..)) + ModalIn (..), ModalOut (..)) import qualified Component as Component import qualified Util.List as L +import View.Payment.Add (AddIn (..), AddOut (..)) +import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn { _headerIn_init :: Init @@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users currency + payerAndAdd incomes punctualPayments users categories currency (searchName, searchFrequency) <- searchLine let searchPayments = getSearchPayments searchName searchFrequency payments infos searchPayments users currency @@ -56,6 +59,7 @@ widget headerIn = payments = _init_payments init punctualPayments = filter ((==) Punctual . _payment_frequency) payments users = _init_users init + categories = _init_categories init currency = _init_currency init getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] @@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do n <- name f <- frequency pure $ flip filter payments (\p -> - ( T.search n (_payment_name p) + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) && (_payment_frequency p == f) )) -payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m () -payerAndAdd incomes payments users currency = do +payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m () +payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do R.divClass "exceedingPayers" $ @@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False }) - _ <- Component.modal $ ModalIn - { _modalIn_show = addPayment - , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement" - } + rec + modalOut <- Component.modal $ ModalIn + { _modalIn_show = addPayment + , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut + , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + } return () searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) @@ -99,6 +107,7 @@ searchLine = do searchName <- _inputOut_value <$> (Component.input $ InputIn { _inputIn_reset = R.never , _inputIn_label = Msg.get Msg.Search_Name + , _inputIn_initialValue = "" }) let frequencies = M.fromList diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 55ceb9f..d14b640 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -82,5 +82,7 @@ pageButton currentPage page content = do if cp == Just p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index a49be5c..23d7225 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,23 +4,28 @@ module View.Payment.Table , TableOut(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.Util.Text as T +import qualified Common.View.Format as Format +import Component (ButtonIn (..), ButtonOut (..), + ModalIn (..), ModalOut (..)) +import qualified Component as Component +import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) +import qualified View.Payment.Delete as Delete import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Dom as Dom data TableIn t = TableIn { _tableIn_init :: Init @@ -105,8 +110,17 @@ paymentRow init payment = M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] R.elDynAttr "div" modifyAttrs $ R.el "button" $ Icon.edit - R.elDynAttr "div" modifyAttrs $ - R.el "button" $ Icon.delete + deletePayment <- R.elDynAttr "div" modifyAttrs $ + _buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn Icon.delete) + { _buttonIn_class = R.constDyn "deletePayment" }) + rec + modalOut <- Component.modal $ ModalIn + { _modalIn_show = deletePayment + , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_content = Delete.view (DeleteIn {}) + } + return () findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 89be737..912aea2 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,11 +1,10 @@ module View.SignIn - ( view + ( SignInMessage (..) + , view ) where import qualified Data.Either as Either -import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time (NominalDiffTime) import Prelude hiding (error) import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -16,62 +15,47 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component - -view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () -view result = - R.divClass "signIn" $ do - rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_label = Msg.get Msg.SignIn_EmailLabel - } - - let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button - - dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ - [ fmap (const True) userWantsEmailValidation - , fmap (const False) signInResult - ] - - uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail - - let validatedEmail = R.tagPromptlyDyn - (_inputOut_value input) - (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) - - let waiting = R.leftmost - [ fmap (const True) validatedEmail - , fmap (const False) signInResult - ] - - button <- Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "validate" - , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button) - , _buttonIn_waiting = waiting - } - - signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) - - showSignInResult result signInResult - -askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) -askSignIn email = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email - getResult response = - case R._xhrResponse_responseText response of - Just key -> - if R._xhrResponse_status response == 200 then Right key else Left key - _ -> Left "NoKey" - -showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () -showSignInResult result signInResult = do - _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult +import qualified Util.Ajax as Ajax +import qualified Util.WaitFor as Util + +data SignInMessage = + SuccessMessage Text + | ErrorMessage Text + | EmptyMessage + +view :: forall t m. MonadWidget t m => SignInMessage -> m () +view signInMessage = + R.divClass "signIn" $ + Component.form $ do + rec + input <- Component.input $ InputIn + { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_initialValue = "" + } + + button <- Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) + { _buttonIn_class = R.constDyn "validate" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + } + + (signInResult, waiting) <- Util.waitFor + (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (_buttonOut_clic button) + (_inputOut_value input) + + showSignInResult signInMessage signInResult + +showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m () +showSignInResult signInMessage signInResult = do + _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + where showInitResult (SuccessMessage success) = showSuccess success + showInitResult (ErrorMessage error) = showError error + showInitResult EmptyMessage = R.blank showResult (Left error) = showError error showResult (Right success) = showSuccess success diff --git a/common/common.cabal b/common/common.cabal index 7eadb49..6e5c8fb 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,6 +29,7 @@ Library Common.Model Common.Msg Common.Util.Text + Common.Util.Time Common.View.Format other-modules: diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index 8e2ab73..cd0b01d 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -2,7 +2,7 @@ module Common.Model.CreatePayment ( CreatePayment(..) ) where -import Data.Aeson (FromJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import Data.Time.Calendar (Day) import GHC.Generics (Generic) @@ -19,3 +19,4 @@ data CreatePayment = CreatePayment } deriving (Show, Generic) instance FromJSON CreatePayment +instance ToJSON CreatePayment diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs index 542e6c7..f4c08a9 100644 --- a/common/src/Common/Model/InitResult.hs +++ b/common/src/Common/Model/InitResult.hs @@ -10,7 +10,8 @@ import Common.Model.Init (Init) data InitResult = InitSuccess Init - | InitEmpty (Either Text (Maybe Text)) + | InitError Text + | InitEmpty deriving (Show, Generic) instance FromJSON InitResult diff --git a/common/src/Common/Util/Time.hs b/common/src/Common/Util/Time.hs new file mode 100644 index 0000000..9ab7ab5 --- /dev/null +++ b/common/src/Common/Util/Time.hs @@ -0,0 +1,26 @@ +module Common.Util.Time + ( timeToDay + , parseDay + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import qualified Data.Time as Time +import Data.Time.Calendar (Day) +import Data.Time.LocalTime +import qualified Text.Read as T + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time + +parseDay :: Text -> Maybe Day +parseDay str = do + (d, m, y) <- + case T.splitOn str "/" of + [d, m, y] -> Just (d, m, y) + _ -> Nothing + d' <- T.readMaybe . T.unpack $ d + m' <- T.readMaybe . T.unpack $ m + y' <- T.readMaybe . T.unpack $ y + return $ Time.fromGregorian y' m' d' diff --git a/server/server.cabal b/server/server.cabal index ada7040..2bfd18d 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -72,6 +72,7 @@ Executable server Design.Tooltip Design.View.Header Design.View.Payment + Design.View.Payment.Add Design.View.Payment.Header Design.View.Payment.Pages Design.View.Payment.Table @@ -87,17 +88,17 @@ Executable server Job.WeeklyReport Json LoginSession - Model.Category - Model.Frequency - Model.Income - Model.Init Model.Mail - Model.Payment - Model.PaymentCategory Model.Query Model.SignIn Model.UUID - Model.User + Persistence.Category + Persistence.Frequency + Persistence.Income + Persistence.Init + Persistence.Payment + Persistence.PaymentCategory + Persistence.User Resource Secure SendMail diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 5565b43..37b8357 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -4,31 +4,31 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty hiding (delete) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) -import qualified Common.Msg as Msg +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) +import qualified Common.Msg as Msg -import Json (jsonId) -import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure create :: CreateCategory -> ActionM () create (CreateCategory name color) = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Category.create name color) >>= jsonId + (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId ) edit :: EditCategory -> ActionM () edit (EditCategory categoryId name color) = Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color + updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color if updated then status ok200 else status badRequest400 @@ -38,9 +38,9 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId + paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId if null paymentCategories - then Category.delete categoryId + then CategoryPersistence.delete categoryId else return False if deleted then diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 19f0cfc..3f623e5 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -14,20 +14,20 @@ import Common.Model (CreateIncome (..), EditIncome (..), import qualified Common.Msg as Msg import Json (jsonId) -import qualified Model.Income as Income import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence import qualified Secure create :: CreateIncome -> ActionM () create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId + (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId ) editOwn :: EditIncome -> ActionM () editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount + updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -36,7 +36,7 @@ editOwn (EditIncome incomeId date amount) = deleteOwn :: IncomeId -> ActionM () deleteOwn incomeId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId + deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId if deleted then status ok200 diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 9a3e2b7..f942540 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -23,11 +23,11 @@ import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession -import Model.Init (getInit) import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) +import qualified Persistence.Init as InitPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn @@ -39,16 +39,16 @@ get conf = do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return . InitEmpty . Right $ Nothing + return InitEmpty Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf + liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf S.html $ page initResult askSignIn :: Conf -> SignIn -> ActionM () askSignIn conf (SignIn email) = if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.get email + maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do token <- liftIO . Query.run $ SignIn.createSignInToken email @@ -71,7 +71,7 @@ trySignIn conf token = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + S.html $ page (InitError $ Msg.get errorKey) Right _ -> S.redirect "/" @@ -100,7 +100,7 @@ validateSignIn conf textToken = do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn + UserPersistence.get . SignIn.email $ signIn return $ case mbUser of Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user @@ -112,7 +112,7 @@ getLoggedUser = do Nothing -> return Nothing Just token -> do - liftIO . Query.run . getUserFromToken $ token + liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index f2af6c9..e1936f0 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -5,54 +5,54 @@ module Controller.Payment , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (badRequest400, ok200) +import Control.Monad.IO.Class (liftIO) +import qualified Network.HTTP.Types.Status as Status import Web.Scotty -import Common.Model (CreatePayment (..), - EditPayment (..), PaymentId, - User (..)) +import Common.Model (CreatePayment (..), + EditPayment (..), PaymentId, + User (..)) -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import qualified Json +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.listActive) >>= json + (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) create :: CreatePayment -> ActionM () create (CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId + PaymentCategoryPersistence.save name category + PaymentPersistence.create (_user_id user) name cost date frequency + ) >>= Json.jsonId ) editOwn :: EditPayment -> ActionM () editOwn (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency + edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited - then PaymentCategory.save name category >> return () + then PaymentCategoryPersistence.save name category >> return () else return () return edited if updated - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId + deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId if deleted - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index be0e74f..0385cb4 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -53,8 +53,10 @@ design = do right (px 0) top (px 27) zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" + svg ? "path" ? + ("fill" -: Color.toString Color.silver) + hover & svg ? "path" ? + ("fill" -: Color.toString (Color.silver -. 25)) (input # ".filled" |+ label) <> (input # focus |+ label) ? do top (px 0) @@ -108,18 +110,18 @@ design = do fontWeight bold ".selectInput" ? do + marginBottom (em 1) label ? do display block marginBottom (px 10) fontSize (pct 80) select ? do + width (pct 100) 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) + option ? sym2 padding (px 5) (px 8) ".error" & do select ? borderColor Color.chestnutRose ".errorMessage" ? do diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 2612257..ce427c0 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -9,19 +9,18 @@ import Clay design :: Css design = do - ".curtain" ? do + ".modalCurtain" ? do position fixed - cursor pointer top (px 0) left (px 0) width (pct 100) height (pct 100) - backgroundColor (rgba 0 0 0 0.5) + backgroundColor (rgba 0 0 0 0.7) zIndex 1000 opacity 1 transition "all" (sec 0.2) ease (sec 0) - ".content" ? do + ".modalContent" ? do minWidth (px 270) position fixed top (pct 25) @@ -29,7 +28,6 @@ design = do "transform" -: "translate(-50%, -25%)" zIndex 1000 backgroundColor white - sym padding (px 20) sym borderRadius (px 5) boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 0d59fa0..2102ff8 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,6 +4,7 @@ module Design.View.Payment import Clay +import qualified Design.View.Payment.Add as Add import qualified Design.View.Payment.Header as Header import qualified Design.View.Payment.Pages as Pages import qualified Design.View.Payment.Table as Table @@ -11,5 +12,6 @@ import qualified Design.View.Payment.Table as Table design :: Css design = do ".header" ? Header.design + ".add" ? Add.design ".table" ? Table.design ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs new file mode 100644 index 0000000..199ad36 --- /dev/null +++ b/server/src/Design/View/Payment/Add.hs @@ -0,0 +1,32 @@ +module Design.View.Payment.Add + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".addHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".addContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 80c5436..0cb5b5d 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -6,8 +6,6 @@ import Data.Monoid ((<>)) import Clay -import Design.Constants - import qualified Design.Color as Color import qualified Design.Constants as Constants import qualified Design.Helper as Helper @@ -17,8 +15,8 @@ design :: Css design = do Media.desktop $ marginBottom (em 3) Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) ".payerAndAdd" ? do Media.tabletDesktop $ display flex @@ -55,9 +53,6 @@ design = do ".textInput" ? do display inlineBlock marginBottom (px 0) - button ? do - svg ? "path" ? ("fill" -: Color.toString Color.silver) - hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25)) Media.tabletDesktop $ marginRight (px 30) Media.mobile $ do diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs index 907be2b..dfbe8b4 100644 --- a/server/src/Job/MonthlyPayment.hs +++ b/server/src/Job/MonthlyPayment.hs @@ -2,19 +2,19 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) -import Common.Model (Frequency (..), Payment (..)) +import Common.Model (Frequency (..), Payment (..)) +import qualified Common.Util.Time as Time -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import Util.Time (timeToDay) +import qualified Model.Query as Query +import qualified Persistence.Payment as PaymentPersistence monthlyPayment :: Maybe UTCTime -> IO UTCTime monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName + monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName now <- getCurrentTime - actualDay <- timeToDay now + actualDay <- Time.timeToDay now let punctualPayments = map (\p -> p { _payment_frequency = Punctual @@ -22,5 +22,5 @@ monthlyPayment _ = do , _payment_createdAt = now }) monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) + _ <- Query.run (PaymentPersistence.createMany punctualPayments) return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 38d88b5..203c4e8 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -5,10 +5,10 @@ module Job.WeeklyReport import Data.Time.Clock (UTCTime, getCurrentTime) import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment import qualified Model.Query as Query -import qualified Model.User as User +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified SendMail import qualified View.Mail.WeeklyReport as WeeklyReport @@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> Payment.listPunctual <*> Income.list <*> User.list + (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs deleted file mode 100644 index ee406bc..0000000 --- a/server/src/Model/Category.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category - ( list - , create - , edit - , delete - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (Category (..), CategoryId) - -import Model.Query (Query (Query)) - -instance FromRow Category where - fromRow = Category <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Category] -list = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" - ) - -create :: Text -> Text -> Query CategoryId -create categoryName categoryColor = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn - ) - -edit :: CategoryId -> Text -> Text -> Query Bool -edit categoryId categoryName categoryColor = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) - return True - else - return False - ) - -delete :: CategoryId -> Query Bool -delete categoryId = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) - return True - else - return False - ) diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs deleted file mode 100644 index c29cf37..0000000 --- a/server/src/Model/Frequency.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where - -import qualified Data.Text as T -import Database.SQLite.Simple (SQLData (SQLText)) -import Database.SQLite.Simple.FromField (FromField (fromField), - fieldData) -import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) -import Database.SQLite.Simple.ToField (ToField (toField)) - -import Common.Model (Frequency) - -instance FromField Frequency where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Frequency) - _ -> Errors [error "SQLText field required for frequency"] - -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs deleted file mode 100644 index 4938e50..0000000 --- a/server/src/Model/Income.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income - ( list - , create - , editOwn - , deleteOwn - ) where - -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (Income (..), IncomeId, User (..), - UserId) - -import Model.Query (Query (Query)) -import Resource (Resource, resourceCreatedAt, - resourceDeletedAt, resourceEditedAt) - -instance Resource Income where - resourceCreatedAt = _income_createdAt - resourceEditedAt = _income_editedAt - resourceDeletedAt = _income_deletedAt - -instance FromRow Income where - fromRow = Income <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [Income] -list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") - -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn - ) - -editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool -editOwn incomeUserId incomeId incomeDate incomeAmount = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False - ) diff --git a/server/src/Model/IncomeResource.hs b/server/src/Model/IncomeResource.hs new file mode 100644 index 0000000..6ab5f18 --- /dev/null +++ b/server/src/Model/IncomeResource.hs @@ -0,0 +1,15 @@ +module Model.IncomeResource + ( IncomeResource(..) + ) where + +import Common.Model (Income (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype IncomeResource = IncomeResource Income + +instance Resource IncomeResource where + resourceCreatedAt (IncomeResource i) = _income_createdAt i + resourceEditedAt (IncomeResource i) = _income_editedAt i + resourceDeletedAt (IncomeResource i) = _income_deletedAt i diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs deleted file mode 100644 index 0a0ffc7..0000000 --- a/server/src/Model/Init.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Model.Init - ( getInit - ) where - -import Common.Model (Init (Init), User (..)) - -import Conf (Conf) -import qualified Conf -import qualified Model.Category as Category -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import Model.Query (Query) -import qualified Model.User as User - -getInit :: User -> Conf -> Query Init -getInit user conf = - Init <$> - User.list <*> - (return . _user_id $ user) <*> - Payment.listActive <*> - Income.list <*> - Category.list <*> - PaymentCategory.list <*> - (return . Conf.currency $ conf) diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs deleted file mode 100644 index 5b29409..0000000 --- a/server/src/Model/Payment.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment - ( Payment(..) - , find - , listActive - , listPunctual - , listActiveMonthlyOrderedByName - , create - , createMany - , editOwn - , deleteOwn - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only), - ToRow) -import qualified Database.SQLite.Simple as SQLite -import Database.SQLite.Simple.ToField (ToField (toField)) -import Prelude hiding (id) - -import Common.Model (Frequency (..), Payment (..), - PaymentId, UserId) - -import Model.Frequency () -import Model.Query (Query (Query)) -import Resource (Resource, resourceCreatedAt, - resourceDeletedAt, - resourceEditedAt) - -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt - -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -instance ToRow Payment where - toRow p = - [ toField (_payment_user p) - , toField (_payment_name p) - , toField (_payment_cost p) - , toField (_payment_date p) - , toField (_payment_frequency p) - , toField (_payment_createdAt p) - ] - -find :: PaymentId -> Query (Maybe Payment) -find paymentId = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - ) - -listActive :: Query [Payment] -listActive = - Query (\conn -> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" - ) - -listPunctual :: Query [Payment] -listPunctual = - Query (\conn -> - SQLite.query - conn - (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") - (Only Punctual)) - -listActiveMonthlyOrderedByName :: Query [Payment] -listActiveMonthlyOrderedByName = - Query (\conn -> - SQLite.query - conn - (SQLite.Query $ T.intercalate " " - [ "SELECT *" - , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" - , "ORDER BY name DESC" - ]) - (Only Monthly)) - -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False - ) diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs deleted file mode 100644 index c60c1a2..0000000 --- a/server/src/Model/PaymentCategory.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory - ( list - , listByCategory - , save - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory (..)) -import qualified Common.Util.Text as T - -import Model.Query (Query (Query)) - -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [PaymentCategory] -list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query () -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) - ) - where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower diff --git a/server/src/Model/PaymentResource.hs b/server/src/Model/PaymentResource.hs new file mode 100644 index 0000000..1ea978c --- /dev/null +++ b/server/src/Model/PaymentResource.hs @@ -0,0 +1,15 @@ +module Model.PaymentResource + ( PaymentResource(..) + ) where + +import Common.Model (Payment (..)) + +import Resource (Resource, resourceCreatedAt, resourceDeletedAt, + resourceEditedAt) + +newtype PaymentResource = PaymentResource Payment + +instance Resource PaymentResource where + resourceCreatedAt (PaymentResource p) = _payment_createdAt p + resourceEditedAt (PaymentResource p) = _payment_editedAt p + resourceDeletedAt (PaymentResource p) = _payment_deletedAt p diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs deleted file mode 100644 index 8dc1fc8..0000000 --- a/server/src/Model/User.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.User - ( list - , get - , create - , delete - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Common.Model (User (..), UserId) - -import Model.Query (Query (Query)) - -instance FromRow User where - fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field - -list :: Query [User] -list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") - -get :: Text -> Query (Maybe User) -get userEmail = - Query (\conn -> listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) - ) - -create :: Text -> Text -> Query UserId -create userEmail userName = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" - (now, userEmail, userName) - SQLite.lastInsertRowId conn - ) - -delete :: Text -> Query () -delete userEmail = - Query (\conn -> - SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) - ) diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs new file mode 100644 index 0000000..2afe5db --- /dev/null +++ b/server/src/Persistence/Category.hs @@ -0,0 +1,79 @@ +module Persistence.Category + ( list + , create + , edit + , delete + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Category (..), CategoryId) + +import Model.Query (Query (Query)) + +newtype Row = Row Category + +instance FromRow Row where + fromRow = Row <$> (Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [Category] +list = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query CategoryId +create categoryName categoryColor = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" + (categoryName, categoryColor, now) + SQLite.lastInsertRowId conn + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit categoryId categoryName categoryColor = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" + (now, categoryName, categoryColor, categoryId) + return True + else + return False + ) + +delete :: CategoryId -> Query Bool +delete categoryId = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + return True + else + return False + ) diff --git a/server/src/Persistence/Frequency.hs b/server/src/Persistence/Frequency.hs new file mode 100644 index 0000000..edaa844 --- /dev/null +++ b/server/src/Persistence/Frequency.hs @@ -0,0 +1,23 @@ +module Persistence.Frequency + ( FrequencyField(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +import Common.Model (Frequency) + +newtype FrequencyField = FrequencyField Frequency + +instance FromField FrequencyField where + fromField field = + case fieldData field of + SQLText text -> Ok (FrequencyField (read (T.unpack text) :: Frequency)) + _ -> Errors [error "SQLText field required for frequency"] + +instance ToField FrequencyField where + toField (FrequencyField f) = SQLText . T.pack . show $ f diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs new file mode 100644 index 0000000..a863f85 --- /dev/null +++ b/server/src/Persistence/Income.hs @@ -0,0 +1,88 @@ +module Persistence.Income + ( list + , create + , editOwn + , deleteOwn + ) where + +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Income (..), IncomeId, User (..), + UserId) + +import Model.Query (Query (Query)) + +newtype Row = Row Income + +instance FromRow Row where + fromRow = Row <$> (Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [Income] +list = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" + ) + +create :: UserId -> Day -> Int -> Query IncomeId +create incomeUserId incomeDate incomeAmount = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" + (incomeUserId, incomeDate, incomeAmount, now) + SQLite.lastInsertRowId conn + ) + +editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool +editOwn incomeUserId incomeId incomeDate incomeAmount = + Query (\conn -> do + mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> + SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == incomeUserId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" + (now, incomeDate, incomeAmount, incomeId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: User -> IncomeId -> Query Bool +deleteOwn user incomeId = + Query (\conn -> do + mbIncome <- + fmap (\(Row i) -> i) . listToMaybe <$> + SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == _user_id user + then do + now <- getCurrentTime + SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) + return True + else + return False + Nothing -> + return False + ) diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs new file mode 100644 index 0000000..74d9172 --- /dev/null +++ b/server/src/Persistence/Init.hs @@ -0,0 +1,25 @@ +module Persistence.Init + ( getInit + ) where + +import Common.Model (Init (Init), User (..)) + +import Conf (Conf) +import qualified Conf +import Model.Query (Query) +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import qualified Persistence.User as UserPersistence + +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + UserPersistence.list <*> + (return . _user_id $ user) <*> + PaymentPersistence.listActive <*> + IncomePersistence.list <*> + CategoryPersistence.list <*> + PaymentCategoryPersistence.list <*> + (return . Conf.currency $ conf) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs new file mode 100644 index 0000000..32600d7 --- /dev/null +++ b/server/src/Persistence/Payment.hs @@ -0,0 +1,169 @@ +module Persistence.Payment + ( Payment(..) + , find + , listActive + , listPunctual + , listActiveMonthlyOrderedByName + , create + , createMany + , editOwn + , deleteOwn + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only), + ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id) + +import Common.Model (Frequency (..), Payment (..), + PaymentId, UserId) + +import Model.Query (Query (Query)) +import Persistence.Frequency (FrequencyField (..)) + +newtype Row = Row Payment + +instance FromRow Row where + fromRow = Row <$> (Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +newtype InsertRow = InsertRow Payment + +instance ToRow InsertRow where + toRow (InsertRow p) = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (FrequencyField (_payment_frequency p)) + , toField (_payment_createdAt p) + ] + +find :: PaymentId -> Query (Maybe Payment) +find paymentId = + Query (\conn -> do + fmap (\(Row p) -> p) . listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + ) + +listActive :: Query [Payment] +listActive = + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + ) + +listPunctual :: Query [Payment] +listPunctual = + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.query + conn + (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") + (Only (FrequencyField Punctual)) + ) + +listActiveMonthlyOrderedByName :: Query [Payment] +listActiveMonthlyOrderedByName = + Query (\conn -> do + map (\(Row p) -> p) <$> + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) + (Only (FrequencyField Monthly)) + ) + +create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId +create userId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) + SQLite.lastInsertRowId conn + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (map InsertRow payments) + ) + +editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) + (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: UserId -> PaymentId -> Query Bool +deleteOwn userId paymentId = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just (Row payment) -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE payment SET deleted_at = ? WHERE id = ?" + (now, paymentId) + return True + else + return False + Nothing -> + return False + ) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs new file mode 100644 index 0000000..1e377b1 --- /dev/null +++ b/server/src/Persistence/PaymentCategory.hs @@ -0,0 +1,66 @@ +module Persistence.PaymentCategory + ( list + , listByCategory + , save + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (CategoryId, PaymentCategory (..)) +import qualified Common.Util.Text as T + +import Model.Query (Query (Query)) + +newtype Row = Row PaymentCategory + +instance FromRow Row where + fromRow = Row <$> (PaymentCategory <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [PaymentCategory] +list = + Query (\conn -> do + map (\(Row pc) -> pc) <$> + SQLite.query_ conn "SELECT * from payment_category" + ) + +listByCategory :: CategoryId -> Query [PaymentCategory] +listByCategory cat = + Query (\conn -> do + map (\(Row pc) -> pc) <$> + SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) + ) + +save :: Text -> CategoryId -> Query () +save newName categoryId = + Query (\conn -> do + now <- getCurrentTime + hasPaymentCategory <- isJust <$> listToMaybe <$> + (SQLite.query + conn + "SELECT * FROM payment_category WHERE name = ?" + (Only (formatPaymentName newName)) :: IO [Row]) + if hasPaymentCategory + then + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formatPaymentName newName) + else do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formatPaymentName newName, categoryId, now) + ) + where + formatPaymentName :: Text -> Text + formatPaymentName = T.unaccent . T.toLower diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs new file mode 100644 index 0000000..4ec2dcf --- /dev/null +++ b/server/src/Persistence/User.hs @@ -0,0 +1,37 @@ +module Persistence.User + ( list + , get + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (User (..)) + +import Model.Query (Query (Query)) + +newtype Row = Row User + +instance FromRow Row where + fromRow = Row <$> (User <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [User] +list = + Query (\conn -> do + map (\(Row u) -> u) <$> + SQLite.query_ conn "SELECT * from user ORDER BY creation DESC" + ) + +get :: Text -> Query (Maybe User) +get userEmail = + Query (\conn -> do + fmap (\(Row u) -> u) . listToMaybe <$> + SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + ) diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 6e5b998..4fb2333 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -16,7 +16,7 @@ import qualified LoginSession import Model.Query (Query) import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Model.User as User +import qualified Persistence.User as UserPersistence loggedAction :: (User -> ActionM ()) -> ActionM () loggedAction action = do @@ -39,6 +39,6 @@ getUserFromToken token = do mbSignIn <- SignIn.getSignIn token case mbSignIn of Just signIn -> - User.get (SignIn.email signIn) + UserPersistence.get (SignIn.email signIn) Nothing -> return Nothing diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs index 3b17a0a..13d4072 100644 --- a/server/src/SendMail.hs +++ b/server/src/SendMail.hs @@ -43,6 +43,7 @@ mockMailMessage mail = T.concat $ , ")" , "\n" , body mail + , "\n" ] getMimeMail :: Mail -> M.Mail diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs index 3e0856d..4a29fcc 100644 --- a/server/src/Util/Time.hs +++ b/server/src/Util/Time.hs @@ -1,25 +1,22 @@ module Util.Time ( belongToCurrentMonth , belongToCurrentWeek - , timeToDay ) where -import Data.Time.Calendar +import Data.Time.Calendar (toGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime + +import qualified Common.Util.Time as Time belongToCurrentMonth :: UTCTime -> IO Bool belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + (timeYear, timeMonth, _) <- toGregorian <$> Time.timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= Time.timeToDay) return (actualYear == timeYear && actualMonth == timeMonth) belongToCurrentWeek :: UTCTime -> IO Bool belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + (timeYear, timeWeek, _) <- toWeekDate <$> Time.timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= Time.timeToDay) return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 5418880..7e88d98 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -2,28 +2,28 @@ module View.Mail.WeeklyReport ( mail ) where -import Data.List (sortOn) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (UTCTime) +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) -import Common.Model (ExceedingPayer (..), Income (..), - Payment (..), User (..), UserId) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (ExceedingPayer (..), Income (..), + Payment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Income () -import Model.Mail (Mail (Mail)) -import qualified Model.Mail as M -import Model.Payment () -import Resource (Status (..), groupByStatus, statuses) +import Conf (Conf) +import qualified Conf as Conf +import Model.IncomeResource (IncomeResource (..)) +import Model.Mail (Mail (Mail)) +import qualified Model.Mail as M +import Model.PaymentResource (PaymentResource (..)) +import Resource (Status (..), groupByStatus, statuses) mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = @@ -42,8 +42,11 @@ body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text body conf users payments incomes start end = T.intercalate "\n" $ [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments) - , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes) + , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] + where + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text exceedingPayers conf time users incomes payments = @@ -58,7 +61,7 @@ exceedingPayers conf time users incomes payments = , "\n" ] -operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text operations conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then @@ -69,7 +72,7 @@ operations conf users paymentsByStatus incomesByStatus = , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses ] -paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text +paymentSection :: Status -> Conf -> [User] -> [PaymentResource] -> Text paymentSection status conf users payments = section sectionTitle sectionItems where count = length payments @@ -77,7 +80,7 @@ paymentSection status conf users payments = Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count - sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments + sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = @@ -89,7 +92,7 @@ payedFor status conf users payment = for = _payment_name payment at = Format.longDay $ _payment_date payment -incomeSection :: Status -> Conf -> [User] -> [Income] -> Text +incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text incomeSection status conf users incomes = section sectionTitle sectionItems where count = length incomes @@ -97,7 +100,7 @@ incomeSection status conf users incomes = Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count - sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = -- cgit v1.2.3 From df83b634006c699cfa1e921bf74ce951a906a62f Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Jun 2018 22:02:00 +0200 Subject: Use date input type --- client/src/Component/Button.hs | 10 ---------- client/src/Component/Input.hs | 38 +++++++++++++++++++++++++------------- client/src/View/Payment/Add.hs | 8 +++++--- client/src/View/Payment/Header.hs | 6 ++---- client/src/View/SignIn.hs | 2 ++ tools.nix | 5 ----- 6 files changed, 34 insertions(+), 35 deletions(-) diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index bf604f1..46c0afa 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -31,20 +31,10 @@ defaultButtonIn content = ButtonIn , _buttonIn_submit = False } --- defaultButtonIn :: MonadWidget t m => ButtonIn t m --- defaultButtonIn = ButtonIn --- { _buttonIn_class = R.constDyn "" --- , _buttonIn_content = R.blank --- , _buttonIn_waiting = R.never --- , _buttonIn_tabIndex = Nothing --- , _buttonIn_submit = False --- } - data ButtonOut t = ButtonOut { _buttonOut_clic :: Event t () } - button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) button buttonIn = do dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 92f8ec9..c1eb4e8 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -17,16 +17,20 @@ import qualified Component.Button as Button import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_label :: Text - , _inputIn_initialValue :: Text + { _inputIn_reset :: Event t a + , _inputIn_hasResetButton :: Bool + , _inputIn_label :: Text + , _inputIn_initialValue :: Text + , _inputIn_inputType :: Text } defaultInputIn :: (Reflex t) => InputIn t a b defaultInputIn = InputIn - { _inputIn_reset = R.never - , _inputIn_label = "" - , _inputIn_initialValue = "" + { _inputIn_reset = R.never + , _inputIn_hasResetButton = True + , _inputIn_label = "" + , _inputIn_initialValue = "" + , _inputIn_inputType = "text" } data InputOut t = InputOut @@ -40,11 +44,13 @@ input inputIn = rec let resetValue = R.leftmost [ fmap (const "") (_inputIn_reset inputIn) - , fmap (const "") (_buttonOut_clic reset) + , fmap (const "") resetClic ] attributes = R.ffor value (\v -> - if T.null v then M.empty else M.singleton "class" "filled") + if T.null v && _inputIn_inputType inputIn /= "date" + then M.empty + else M.singleton "class" "filled") value = R._textInput_value textInput @@ -52,14 +58,20 @@ input inputIn = & R.attributes .~ attributes & R.setValue .~ resetValue & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) + & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) R.el "label" $ R.text (_inputIn_label inputIn) - reset <- Button.button $ - (Button.defaultButtonIn Icon.cross) - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_tabIndex = Just (-1) - } + resetClic <- + if _inputIn_hasResetButton inputIn + then + _buttonOut_clic <$> (Button.button $ + (Button.defaultButtonIn Icon.cross) + { _buttonIn_class = R.constDyn "reset" + , _buttonIn_tabIndex = Just (-1) + }) + else + return R.never let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 2eaec0f..5ff09dd 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -8,6 +8,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import qualified Data.Maybe as Maybe import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -17,7 +18,6 @@ import Common.Model (Category (..), CreatePayment (..), Frequency (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time -import qualified Common.View.Format as Format import Component (ButtonIn (..), InputIn (..), InputOut (..), SelectIn (..), SelectOut (..)) @@ -49,8 +49,10 @@ view addIn = do date <- _inputOut_value <$> (Component.input $ Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_initialValue = Format.shortDay currentDay + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False }) frequency <- _selectOut_value <$> (Component.select $ SelectIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index d01dec6..fd46c25 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -104,10 +104,8 @@ payerAndAdd incomes payments users categories currency = do searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) searchLine = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input $ InputIn - { _inputIn_reset = R.never - , _inputIn_label = Msg.get Msg.Search_Name - , _inputIn_initialValue = "" + searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Search_Name }) let frequencies = M.fromList diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 912aea2..21d0fcc 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -30,8 +30,10 @@ view signInMessage = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult + , _inputIn_hasResetButton = True , _inputIn_label = Msg.get Msg.SignIn_EmailLabel , _inputIn_initialValue = "" + , _inputIn_inputType = "text" } button <- Component.button $ diff --git a/tools.nix b/tools.nix index 8c7d91f..5fd5129 100644 --- a/tools.nix +++ b/tools.nix @@ -8,11 +8,6 @@ with import {}; { tmux tmuxinator stylish-haskell - # (import ./stylish-haskell { - # inherit mkDerivation aeson base bytestring containers directory filepath - # fetchFromGitHub haskell-src-exts mtl syb yaml stylish-haskell strict - # optparse-applicative HUnit test-framework test-framework-hunit stdenv; - # }) ]; }; } -- cgit v1.2.3 From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Oct 2018 17:57:58 +0100 Subject: Delete payment --- .tmuxinator.yml | 4 +- README.md | 2 - client/client.cabal | 6 ++- client/src/Component/Form.hs | 2 +- client/src/Component/Modal.hs | 33 ++++++++++------ client/src/Component/Select.hs | 2 +- client/src/Util/Ajax.hs | 67 ++++++++++++++++++++++++-------- client/src/Util/Dom.hs | 36 ++++++++++++++--- client/src/View/Payment/Add.hs | 6 +-- client/src/View/Payment/Delete.hs | 40 +++++++++++-------- client/src/View/Payment/Header.hs | 4 +- client/src/View/Payment/Table.hs | 2 +- client/src/View/SignIn.hs | 6 +-- common/common.cabal | 6 +-- common/src/Common/Message/Key.hs | 4 +- common/src/Common/Message/Translation.hs | 12 +++--- common/src/Common/Model/CreatePayment.hs | 14 ++++++- default.nix | 4 +- server/server.cabal | 5 ++- server/src/Controller/Payment.hs | 17 +++++--- server/src/Design/Modal.hs | 9 ++++- server/src/Design/View/Payment.hs | 2 - server/src/Design/View/Payment/Delete.hs | 32 +++++++++++++++ server/src/Main.hs | 6 +-- server/src/Validation.hs | 23 ----------- server/src/Validation/Atomic.hs | 32 +++++++++++++++ server/src/Validation/CreatePayment.hs | 25 ++++++++++++ 27 files changed, 285 insertions(+), 116 deletions(-) create mode 100644 server/src/Design/View/Payment/Delete.hs delete mode 100644 server/src/Validation.hs create mode 100644 server/src/Validation/Atomic.hs create mode 100644 server/src/Validation/CreatePayment.hs diff --git a/.tmuxinator.yml b/.tmuxinator.yml index 1576496..2d52bb4 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -6,8 +6,8 @@ windows: - app: panes: - client: - - make clean-client watch-client + - make watch-client - server: - - make clean-server watch-server + - make watch-server - db: - sqlite3 database diff --git a/README.md b/README.md index 8a141e5..620dae6 100644 --- a/README.md +++ b/README.md @@ -75,9 +75,7 @@ TODO ### Code -- modal as body child https://stackoverflow.com/questions/33711392/what-is-the-proper-way-in-reflex-dom-to-handle-a-modal-dialog - Move up element ids security (editOwn is actually at db level). -- move persistence methods to a module. - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) ### Tooling diff --git a/client/client.cabal b/client/client.cabal index 0aec05f..26ad2ec 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -10,7 +10,7 @@ Cabal-version: >=1.10 Executable client Main-Is: Main.hs - Ghc-options: -Wall -Werror + -- Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 @@ -22,10 +22,12 @@ Executable client Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , bytestring , common , containers + , data-default + , ghcjs-dom-jsffi , jsaddle-dom , reflex-dom , text diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs index 0a89c6e..6ea02fa 100644 --- a/client/src/Component/Form.hs +++ b/client/src/Component/Form.hs @@ -6,7 +6,7 @@ import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -form :: forall t m a. (MonadWidget t m) => m a -> m a +form :: forall t m a. MonadWidget t m => m a -> m a form content = R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ content diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 1d70c90..72091c9 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,14 +1,19 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Component.Modal ( ModalIn(..) , ModalOut(..) , modal ) where -import qualified Data.Map as M -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified GHCJS.DOM.Node as Node +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R + +import qualified Util.Dom as Dom data ModalIn t m a = ModalIn { _modalIn_show :: Event t () @@ -29,16 +34,22 @@ modal modalIn = do , False <$ curtainClick ] - let attr = flip fmap showModal (\s -> M.fromList $ - [ ("style", if s then "display:block" else "display:none") - , ("class", "modal") - ]) - - (curtainClick, content) <- R.elDynAttr "div" attr $ do + (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank cont <- R.divClass "modalContent" $ _modalIn_content modalIn return (R.domEvent R.Click curtain, cont) + body <- Dom.getBody + let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn) + R.performEvent_ $ void `fmap` moveBackdrop + return $ ModalOut { _modalOut_content = content } + +getAttributes :: Bool -> LM.Map Text Text +getAttributes show = + M.fromList $ + [ ("style", if show then "display:block" else "display:none") + , ("class", "modal") + ] diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 876548e..17a4958 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -19,7 +19,7 @@ data SelectOut t a = SelectOut { _selectOut_value :: Dynamic t a } -select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a) +select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a) select selectIn = R.divClass "selectInput" $ do R.el "label" $ R.text (_selectIn_label selectIn) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 1e8e4c7..14675df 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,20 +1,55 @@ module Util.Ajax - ( post + ( postJson + , delete ) where -import Data.Aeson (ToJSON) -import Data.Text (Text) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Aeson (ToJSON) +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, + XhrRequest, XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R -post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text)) -post url input = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = R.postJson url <$> input - getResult response = - case R._xhrResponse_responseText response of - Just responseText -> - if R._xhrResponse_status response == 200 - then Right responseText - else Left responseText - _ -> Left "NoKey" +postJson + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text Text)) +postJson url input = + fmap getResult <$> + R.performRequestAsync (R.postJson url <$> input) + +delete + :: forall t m. MonadWidget t m + => Dynamic t Text + -> Event t () + -> m (Event t (Either Text Text)) +delete url fire = + fmap getResult <$> + R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + +getResult :: XhrResponse -> Either Text Text +getResult response = + case R._xhrResponse_responseText response of + Just responseText -> + if R._xhrResponse_status response == 200 + then Right responseText + else Left responseText + _ -> Left "NoKey" + +request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a +request method url sendData = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = sendData + } + in + R.xhrRequest method url config diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs index f3e9c88..55b8521 100644 --- a/client/src/Util/Dom.hs +++ b/client/src/Util/Dom.hs @@ -1,12 +1,31 @@ module Util.Dom - ( divVisibleIf + ( divIfDyn + , divIfEvent + , divVisibleIf , divClassVisibleIf + , getBody ) where -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.Document as Document +import qualified GHCJS.DOM.HTMLCollection as HTMLCollection +import GHCJS.DOM.Types (Element) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a) +divIfDyn cond = divIfEvent (R.updated cond) + +divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) +divIfEvent cond empty content = + R.widgetHold empty (flip fmap cond (\show -> + if show + then + content + else + empty)) divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a divVisibleIf cond content = divClassVisibleIf cond "" content @@ -17,3 +36,10 @@ divClassVisibleIf cond className content = "div" (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) content + +getBody :: forall t m. MonadWidget t m => m Element +getBody = do + document <- Dom.currentDocumentUnchecked + nodelist <- Document.getElementsByTagName document ("body" :: String) + Just body <- nodelist `HTMLCollection.item` 0 + return body diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 5ff09dd..8b1b56e 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -23,7 +23,7 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data AddIn = AddIn { _addIn_categories :: [Category] @@ -83,8 +83,8 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- Util.waitFor - (Ajax.post "/payment") + (_, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") validate payment diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index a1be16d..03cf267 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,24 +4,27 @@ module View.Payment.Delete , DeleteOut(..) ) where -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R - -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component --- import qualified Util.Ajax as Ajax --- import qualified Util.WaitFor as Util - -data DeleteIn = DeleteIn - {} +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model.Payment (PaymentId) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +-- import qualified Util.WaitFor as WaitFor + +data DeleteIn t = DeleteIn + { _deleteIn_id :: Dynamic t PaymentId + } data DeleteOut t = DeleteOut { _deleteOut_cancel :: Event t () } -view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t) -view _ = +view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) +view deleteIn = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm @@ -29,14 +32,19 @@ view _ = cancel <- R.divClass "buttons" $ do rec - _ <- Component._buttonOut_clic <$> (Component.button $ + confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_submit = True }) - -- (_, waiting) <- Util.waitFor - -- (Ajax.post "/payment") + let url = flip fmap (_deleteIn_id deleteIn) (\id -> + T.concat ["/payment/", T.pack . show $ id] + ) + Ajax.delete url confirm + + -- (_, waiting) <- WaitFor.waitFor + -- (Ajax.delete "/payment") -- validate -- payment diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index fd46c25..be7f6d5 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -86,7 +86,7 @@ payerAndAdd incomes payments users categories currency = do R.text "+ " R.text . Format.price currency $ _exceedingPayer_amount p ) - addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn + addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never @@ -95,7 +95,7 @@ payerAndAdd incomes payments users categories currency = do }) rec modalOut <- Component.modal $ ModalIn - { _modalIn_show = addPayment + { _modalIn_show = addPaymentClic , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 23d7225..13cedda 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -118,7 +118,7 @@ paymentRow init payment = modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Delete.view (DeleteIn {}) + , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } return () diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 21d0fcc..24e5be0 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -16,7 +16,7 @@ import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -43,8 +43,8 @@ view signInMessage = , _buttonIn_submit = True } - (signInResult, waiting) <- Util.waitFor - (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (signInResult, waiting) <- WaitFor.waitFor + (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) (_buttonOut_clic button) (_inputOut_value input) diff --git a/common/common.cabal b/common/common.cabal index 6e5c8fb..151326a 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -21,12 +21,14 @@ Library Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , text , time Exposed-modules: Common.Model + Common.Model.CreatePayment + Common.Model.Payment Common.Msg Common.Util.Text Common.Util.Time @@ -39,7 +41,6 @@ Library Common.Model.Category Common.Model.CreateCategory Common.Model.CreateIncome - Common.Model.CreatePayment Common.Model.Currency Common.Model.EditCategory Common.Model.EditIncome @@ -49,7 +50,6 @@ Library Common.Model.Init Common.Model.InitResult Common.Model.Payer - Common.Model.Payment Common.Model.PaymentCategory Common.Model.SignIn Common.Model.User diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index a6828d5..6e5f246 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -38,8 +38,8 @@ data Key = | Error_SignOut | Form_AlreadyExists - | Form_CostMustNotBeNull - | Form_Empty + | Form_NonEmpty + | Form_NonNullNumber | Form_GreaterIntThan Int | Form_InvalidCategory | Form_InvalidColor diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 5ea12ad..70eb978 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -157,16 +157,16 @@ m l Form_AlreadyExists = English -> "Dupplicate field" French -> "Doublon" -m l Form_CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l Form_Empty = +m l Form_NonEmpty = case l of English -> "Required field" French -> "Champ requis" +m l Form_NonNullNumber = + case l of + English -> "Number must not be null" + French -> "Le nombre ne doit pas être nul" + m l (Form_GreaterIntThan number) = case l of English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index cd0b01d..c61423c 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -1,5 +1,6 @@ module Common.Model.CreatePayment - ( CreatePayment(..) + ( CreatePaymentError(..) + , CreatePayment(..) ) where import Data.Aeson (FromJSON, ToJSON) @@ -10,6 +11,17 @@ import GHC.Generics (Generic) import Common.Model.Category (CategoryId) import Common.Model.Frequency (Frequency) +data CreatePaymentError = CreatePaymentError + { _createPaymentError_name :: Maybe Text + , _createPaymentError_cost :: Maybe Text + , _createPaymentError_date :: Maybe Text + , _createPaymentError_category :: Maybe Text + , _createPaymentError_frequency :: Maybe Text + } deriving (Show, Generic) + +instance FromJSON CreatePaymentError +instance ToJSON CreatePaymentError + data CreatePayment = CreatePayment { _createPayment_name :: Text , _createPayment_cost :: Int diff --git a/default.nix b/default.nix index 15dfdae..657de1b 100644 --- a/default.nix +++ b/default.nix @@ -6,9 +6,9 @@ let repo = "reflex-platform"; rev = "504b0344dfa6d03e4c89cf70ab9792b0a1fa021b"; sha256 = "01hvdwc6bw48falpha5kaq4p7w98hc804kkwrayipb5ld1snchpz"; + # rev = "a457c21ceb32ea27f66f3fae930e5d8bf7ec768d"; + # sha256 = "0drzvma2q809b6hafdlq4k23mnlbmy8ny5qz140ya76zizbq34vs"; }) {}; - - buildInputs = [ pkgs.noDemon ]; in reflex-platform.project ({ pkgs, ... }: { packages = { diff --git a/server/server.cabal b/server/server.cabal index 2bfd18d..2c6bef1 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -21,7 +21,7 @@ Executable server Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , base64-bytestring , blaze-builder , blaze-html @@ -103,7 +103,8 @@ Executable server Secure SendMail Util.Time - Validation + Validation.Atomic + Validation.CreatePayment View.Mail.SignIn View.Mail.WeeklyReport View.Page diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e1936f0..4edbf6a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -18,6 +18,7 @@ import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +import qualified Validation.CreatePayment as CreatePaymentValidation list :: ActionM () list = @@ -26,12 +27,18 @@ list = ) create :: CreatePayment -> ActionM () -create (CreatePayment name cost date category frequency) = +create createPayment@(CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + case CreatePaymentValidation.validate createPayment of + Nothing -> + (liftIO . Query.run $ do + PaymentCategoryPersistence.save name category + PaymentPersistence.create (_user_id user) name cost date frequency + ) >>= Json.jsonId + Just validationError -> + do + status Status.badRequest400 + json validationError ) editOwn :: EditPayment -> ActionM () diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index ce427c0..2677fd8 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -2,9 +2,11 @@ module Design.Modal ( design ) where -import Data.Monoid ((<>)) - import Clay +import Data.Monoid ((<>)) + +import qualified Design.View.Payment.Add as Add +import qualified Design.View.Payment.Delete as Delete design :: Css design = do @@ -31,6 +33,9 @@ design = do sym borderRadius (px 5) boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + ".add" ? Add.design + ".delete" ? Delete.design + ".paymentModal" & do ".radioGroup" ? ".title" ? display none ".selectInput" ? do diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 2102ff8..0d59fa0 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,7 +4,6 @@ module Design.View.Payment import Clay -import qualified Design.View.Payment.Add as Add import qualified Design.View.Payment.Header as Header import qualified Design.View.Payment.Pages as Pages import qualified Design.View.Payment.Table as Table @@ -12,6 +11,5 @@ import qualified Design.View.Payment.Table as Table design :: Css design = do ".header" ? Header.design - ".add" ? Add.design ".table" ? Table.design ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs new file mode 100644 index 0000000..5597f5b --- /dev/null +++ b/server/src/Design/View/Payment/Delete.hs @@ -0,0 +1,32 @@ +module Design.View.Payment.Delete + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".deleteHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".deleteContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten diff --git a/server/src/Main.hs b/server/src/Main.hs index e298a06..745071c 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -37,7 +37,7 @@ main = do S.put "/payment" $ S.jsonData >>= Payment.editOwn - S.delete "/payment" $ do + S.delete "/payment/:id" $ do paymentId <- S.param "id" Payment.deleteOwn paymentId @@ -47,7 +47,7 @@ main = do S.put "/income" $ S.jsonData >>= Income.editOwn - S.delete "/income" $ do + S.delete "/income/:id" $ do incomeId <- S.param "id" Income.deleteOwn incomeId @@ -57,6 +57,6 @@ main = do S.put "/category" $ S.jsonData >>= Category.edit - S.delete "/category" $ do + S.delete "/category/:id" $ do categoryId <- S.param "id" Category.delete categoryId diff --git a/server/src/Validation.hs b/server/src/Validation.hs deleted file mode 100644 index fd739cd..0000000 --- a/server/src/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs new file mode 100644 index 0000000..d15ad49 --- /dev/null +++ b/server/src/Validation/Atomic.hs @@ -0,0 +1,32 @@ +module Validation.Atomic + ( nonEmpty + , nonNullNumber + -- , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import qualified Common.Msg as Msg + +nonEmpty :: Text -> Maybe Text +nonEmpty str = + if T.null str + then Just $ Msg.get Msg.Form_NonEmpty + else Nothing + +nonNullNumber :: Int -> Maybe Text +nonNullNumber n = + if n == 0 + then Just $ Msg.get Msg.Form_NonNullNumber + else Nothing + +-- number :: (Int -> Bool) -> Text -> Maybe Int +-- number numberForm str = +-- case reads (T.unpack str) :: [(Int, String)] of +-- (num, _) : _ -> +-- if numberForm num +-- then Just num +-- else Nothing +-- _ -> +-- Nothing diff --git a/server/src/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs new file mode 100644 index 0000000..fbcdb7c --- /dev/null +++ b/server/src/Validation/CreatePayment.hs @@ -0,0 +1,25 @@ +module Validation.CreatePayment + ( validate + ) where + +import Data.Maybe (catMaybes) + +import Common.Model.CreatePayment (CreatePayment (..), + CreatePaymentError (..)) +import qualified Validation.Atomic as Atomic + +validate :: CreatePayment -> Maybe CreatePaymentError +validate p = + if not . null . catMaybes $ [ nameError, costError ] + then Just createPaymentError + else Nothing + where + nameError = Atomic.nonEmpty . _createPayment_name $ p + costError = Atomic.nonNullNumber . _createPayment_cost $ p + createPaymentError = CreatePaymentError + { _createPaymentError_name = nameError + , _createPaymentError_cost = costError + , _createPaymentError_date = Nothing + , _createPaymentError_category = Nothing + , _createPaymentError_frequency = Nothing + } -- cgit v1.2.3 From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 18:04:58 +0100 Subject: Update table when adding or removing a payment --- client/src/Component/Input.hs | 20 +++++----- client/src/Component/Modal.hs | 66 +++++++++++++++++++++----------- client/src/Component/Select.hs | 10 ++++- client/src/Icon.hs | 2 +- client/src/Main.hs | 5 ++- client/src/Util/Ajax.hs | 40 ++++++++++++-------- client/src/Util/Either.hs | 7 ++++ client/src/View/Payment.hs | 61 ++++++++++++++++++++++++++---- client/src/View/Payment/Add.hs | 39 ++++++++++++------- client/src/View/Payment/Delete.hs | 13 +++++-- client/src/View/Payment/Header.hs | 79 +++++++++++++++++++++++---------------- client/src/View/Payment/Pages.hs | 2 +- client/src/View/Payment/Table.hs | 29 ++++++++------ client/src/View/SignIn.hs | 10 ++--- common/common.cabal | 2 +- common/src/Common/Util/Time.hs | 6 +-- server/src/Controller/Payment.hs | 4 +- server/src/Design/Global.hs | 2 + server/src/Persistence/Payment.hs | 21 ++++++++--- 19 files changed, 278 insertions(+), 140 deletions(-) create mode 100644 client/src/Util/Either.hs diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index c1eb4e8..57018a6 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -16,18 +16,16 @@ import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified Icon -data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_hasResetButton :: Bool +data InputIn = InputIn + { _inputIn_hasResetButton :: Bool , _inputIn_label :: Text , _inputIn_initialValue :: Text , _inputIn_inputType :: Text } -defaultInputIn :: (Reflex t) => InputIn t a b +defaultInputIn :: InputIn defaultInputIn = InputIn - { _inputIn_reset = R.never - , _inputIn_hasResetButton = True + { _inputIn_hasResetButton = True , _inputIn_label = "" , _inputIn_initialValue = "" , _inputIn_inputType = "text" @@ -38,12 +36,16 @@ data InputOut t = InputOut , _inputOut_enter :: Event t () } -input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = +input + :: forall t m a b. MonadWidget t m + => InputIn + -> Event t a -- reset + -> m (InputOut t) +input inputIn reset = R.divClass "textInput" $ do rec let resetValue = R.leftmost - [ fmap (const "") (_inputIn_reset inputIn) + [ fmap (const "") reset , fmap (const "") resetClic ] diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 72091c9..b86fee0 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -4,16 +4,18 @@ module Component.Modal , modal ) where -import Control.Monad (void) -import qualified Data.Map as M -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import qualified GHCJS.DOM.Node as Node -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R -import qualified Reflex.Dom.Class as R +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified GHCJS.DOM.Element as Element +import qualified GHCJS.DOM.Node as Node +import JSDOM.Types (JSString) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R -import qualified Util.Dom as Dom +import qualified Util.Dom as Dom data ModalIn t m a = ModalIn { _modalIn_show :: Event t () @@ -28,20 +30,21 @@ data ModalOut a = ModalOut modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) modal modalIn = do rec - showModal <- R.holdDyn False $ R.leftmost - [ True <$ _modalIn_show modalIn - , False <$ _modalIn_hide modalIn - , False <$ curtainClick - ] + let showEvent = R.leftmost + [ True <$ _modalIn_show modalIn + , False <$ _modalIn_hide modalIn + , False <$ curtainClick + ] - (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank - cont <- R.divClass "modalContent" $ _modalIn_content modalIn - return (R.domEvent R.Click curtain, cont) + showModal <- R.holdDyn False showEvent - body <- Dom.getBody - let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn) - R.performEvent_ $ void `fmap` moveBackdrop + (elem, (curtainClick, content)) <- + R.buildElement "div" (getAttributes <$> showModal) $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank + cont <- R.divClass "modalContent" $ _modalIn_content modalIn + return (R.domEvent R.Click curtain, cont) + + performShowEffects showEvent elem return $ ModalOut { _modalOut_content = content @@ -53,3 +56,24 @@ getAttributes show = [ ("style", if show then "display:block" else "display:none") , ("class", "modal") ] + +performShowEffects + :: forall t m a. MonadWidget t m + => Event t Bool + -> Element.Element + -> m () +performShowEffects showEvent elem = do + body <- Dom.getBody + + let showEffects = + flip fmap showEvent (\show -> do + if show + then + do + Node.appendChild body elem + Element.setClassName body ("modal" :: JSString) + else + Element.setClassName body ("" :: JSString) + ) + + R.performEvent_ $ void `fmap` showEffects diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 17a4958..7cb6726 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -6,13 +6,14 @@ module Component.Select import Data.Map (Map) import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R data (Reflex t) => SelectIn t a = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a , _selectIn_values :: Dynamic t (Map a Text) + , _selectIn_reset :: Event t () } data SelectOut t a = SelectOut @@ -24,8 +25,13 @@ select selectIn = R.divClass "selectInput" $ do R.el "label" $ R.text (_selectIn_label selectIn) + let initialValue = _selectIn_initialValue selectIn + value <- R._dropdown_value <$> - R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) return SelectOut { _selectOut_value = value diff --git a/client/src/Icon.hs b/client/src/Icon.hs index dae5e7f..1a45933 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -59,7 +59,7 @@ edit = loading :: forall t m. MonadWidget t m => m () loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank signOut :: forall t m. MonadWidget t m => m () diff --git a/client/src/Main.hs b/client/src/Main.hs index 6c048c6..d6f89cd 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -9,7 +9,8 @@ import qualified Data.Text.Encoding as T import qualified JSDOM as Dom import qualified JSDOM.Generated.HTMLElement as Dom import qualified JSDOM.Generated.NonElementParentNode as Dom -import JSDOM.Types (HTMLElement (..), JSM) +import JSDOM.Types (HTMLElement (..), JSM, + JSString) import qualified JSDOM.Types as Dom import Prelude hiding (error, init) @@ -26,7 +27,7 @@ main = do readInit :: JSM InitResult readInit = do document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document ("init" :: Dom.JSString) + initNode <- Dom.getElementById document ("init" :: JSString) case initNode of Just node -> do diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 14675df..0d76638 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -3,32 +3,42 @@ module Util.Ajax , delete ) where -import Data.Aeson (ToJSON) -import Data.Default (def) -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, - XhrRequest, XhrRequestConfig (..), XhrResponse, - XhrResponseHeaders (..)) -import qualified Reflex.Dom as R +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, + XhrRequest, XhrRequestConfig (..), + XhrResponse, XhrResponseHeaders (..)) +import qualified Reflex.Dom as R postJson - :: forall t m a. (MonadWidget t m, ToJSON a) + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a - -> m (Event t (Either Text Text)) + -> m (Event t (Either Text b)) postJson url input = - fmap getResult <$> + fmap getJsonResult <$> R.performRequestAsync (R.postJson url <$> input) delete - :: forall t m. MonadWidget t m + :: forall t m a. (MonadWidget t m) => Dynamic t Text -> Event t () -> m (Event t (Either Text Text)) -delete url fire = - fmap getResult <$> - R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) +delete url fire = do + response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + return $ fmap getResult response + +getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a +getJsonResult response = + case getResult response of + Left l -> Left l + Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r) getResult :: XhrResponse -> Either Text Text getResult response = diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs new file mode 100644 index 0000000..2910d95 --- /dev/null +++ b/client/src/Util/Either.hs @@ -0,0 +1,7 @@ +module Util.Either + ( eitherToMaybe + ) where + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 42da8fb..5245e72 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -4,17 +4,20 @@ module View.Payment , PaymentOut(..) ) where +import Data.Text (Text) +import qualified Data.Text as T import Prelude hiding (init) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Init (..)) - +import Common.Model (Frequency, Init (..), Payment (..), + PaymentId) +import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..)) +import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -32,21 +35,63 @@ widget paymentIn = do let init = _paymentIn_init paymentIn paymentsPerPage = 7 + payments <- getPayments + (_init_payments init) + (_headerOut_addedPayment header) + (_tableOut_deletedPayment table) + + let searchPayments = + getSearchPayments + (_headerOut_searchName header) + (_headerOut_searchFrequency header) + payments + header <- Header.widget $ HeaderIn { _headerIn_init = init + , _headerIn_searchPayments = searchPayments } - _ <- Table.widget $ TableIn + table <- Table.widget $ TableIn { _tableIn_init = init , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = _headerOut_searchPayments header + , _tableIn_payments = searchPayments , _tableIn_perPage = paymentsPerPage } pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> _headerOut_searchPayments header + { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header + , _pagesIn_reset = R.leftmost $ + [ fmap (const ()) . R.updated . _headerOut_searchName $ header + , fmap (const ()) . _headerOut_addedPayment $ header + ] } pure $ PaymentOut {} + +getPayments + :: forall t m. MonadWidget t m + => [Payment] + -> Event t Payment + -> Event t PaymentId + -> m (Dynamic t [Payment]) +getPayments initPayments addedPayment deletedPayment = + R.foldDyn id initPayments $ R.leftmost + [ flip fmap addedPayment (:) + , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + ] + +getSearchPayments + :: forall t. Reflex t + => Dynamic t Text + -> Dynamic t Frequency + -> Dynamic t [Payment] + -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + ps <- payments + pure $ flip filter ps (\p -> + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) + && (_payment_frequency p == f) + )) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 8b1b56e..602f7f3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -10,12 +10,12 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget) +import Reflex.Dom (Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import Component (ButtonIn (..), InputIn (..), @@ -23,48 +23,56 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data AddIn = AddIn +data AddIn t = AddIn { _addIn_categories :: [Category] + , _addIn_show :: Event t () } data AddOut t = AddOut - { _addOut_cancel :: Event t () + { _addOut_cancel :: Event t () + , _addOut_addedPayment :: Event t Payment } -view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t) +view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) view addIn = do R.divClass "add" $ do R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add R.divClass "addContent" $ do - name <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + name <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + (_addIn_show addIn)) - cost <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + (_addIn_show addIn)) currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay - date <- _inputOut_value <$> (Component.input $ - Component.defaultInputIn + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False }) + (_addIn_show addIn)) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = _addIn_show addIn }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = 0 , _selectIn_values = R.constDyn categories + , _selectIn_reset = _addIn_show addIn }) let payment = CreatePayment @@ -74,7 +82,7 @@ view addIn = do <*> category <*> frequency - cancel <- R.divClass "buttons" $ do + (addedPayment, cancel) <- R.divClass "buttons" $ do rec validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -83,17 +91,20 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- WaitFor.waitFor + (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") validate payment - Component._buttonOut_clic <$> (Component.button $ + cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return AddOut { _addOut_cancel = cancel + , _addOut_addedPayment = addedPayment } where diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 03cf267..330ef9f 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,6 +4,7 @@ module View.Payment.Delete , DeleteOut(..) ) where +import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R @@ -13,6 +14,7 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil -- import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn @@ -20,7 +22,8 @@ data DeleteIn t = DeleteIn } data DeleteOut t = DeleteOut - { _deleteOut_cancel :: Event t () + { _deleteOut_cancel :: Event t () + , _deleteOut_validate :: Event t PaymentId } view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) @@ -30,7 +33,7 @@ view deleteIn = R.divClass "deleteContent" $ do - cancel <- R.divClass "buttons" $ do + (deletedPayment, cancel) <- R.divClass "buttons" $ do rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -41,7 +44,8 @@ view deleteIn = let url = flip fmap (_deleteIn_id deleteIn) (\id -> T.concat ["/payment/", T.pack . show $ id] ) - Ajax.delete url confirm + + result <- Ajax.delete url confirm -- (_, waiting) <- WaitFor.waitFor -- (Ajax.delete "/payment") @@ -52,8 +56,9 @@ view deleteIn = (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) - return cancel + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return DeleteOut { _deleteOut_cancel = cancel + , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index be7f6d5..653df5e 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -13,7 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Category, Currency, @@ -22,7 +22,6 @@ import Common.Model (Category, Currency, User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg -import qualified Common.Util.Text as T import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), @@ -34,44 +33,47 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] } data HeaderOut t = HeaderOut - { _headerOut_searchName :: Dynamic t Text - , _headerOut_searchPayments :: Dynamic t [Payment] + { _headerOut_searchName :: Dynamic t Text + , _headerOut_searchFrequency :: Dynamic t Frequency + , _headerOut_addedPayment :: Event t Payment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - payerAndAdd incomes punctualPayments users categories currency - (searchName, searchFrequency) <- searchLine - let searchPayments = getSearchPayments searchName searchFrequency payments - infos searchPayments users currency + addedPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addedPayment + (searchName, searchFrequency) <- searchLine resetSearchName + + infos (_headerIn_searchPayments headerIn) users currency + return $ HeaderOut { _headerOut_searchName = searchName - , _headerOut_searchPayments = searchPayments + , _headerOut_searchFrequency = searchFrequency + , _headerOut_addedPayment = addedPayment } where init = _headerIn_init headerIn incomes = _init_incomes init - payments = _init_payments init - punctualPayments = filter ((==) Punctual . _payment_frequency) payments + initPayments = _init_payments init + punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments users = _init_users init categories = _init_categories init currency = _init_currency init -getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - pure $ flip filter payments (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) - -payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m () +payerAndAdd + :: forall t m. MonadWidget t m + => [Income] + -> [Payment] + -> [User] + -> [Category] + -> Currency + -> m (Event t Payment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -94,19 +96,28 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- Component.modal $ ModalIn + modalOut <- fmap _modalOut_content . Component.modal $ ModalIn { _modalIn_show = addPaymentClic - , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } + , _modalIn_hide = R.leftmost $ + [ _addOut_cancel modalOut + , fmap (const ()) . _addOut_addedPayment $ modalOut + ] + , _modalIn_content = Add.view $ AddIn + { _addIn_categories = categories + , _addIn_show = addPaymentClic + } } - return () + return (_addOut_addedPayment modalOut) -searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency) -searchLine = do +searchLine + :: forall t m. MonadWidget t m + => Event t () + -> m (Dynamic t Text, Dynamic t Frequency) +searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Search_Name - }) + searchName <- _inputOut_value <$> (Component.input + ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) + reset) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) @@ -118,7 +129,11 @@ searchLine = do return (searchName, searchFrequency) -infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m () +infos + :: forall t m. MonadWidget t m + => Dynamic t [Payment] + -> [User] + -> Currency -> m () infos payments users currency = R.divClass "infos" $ do diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index d14b640..57d67ac 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -64,7 +64,7 @@ pageButtons total perPage reset = do return currentPage where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switchPromptlyDyn . fmap R.leftmost + pageEvent = R.switch . R.current . fmap R.leftmost noCurrentPage = R.constDyn Nothing range :: Int -> Int -> [Int] diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 13cedda..ba16bf5 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -9,11 +9,12 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) + PaymentCategory (..), PaymentId, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.Util.Text as T @@ -34,15 +35,15 @@ data TableIn t = TableIn , _tableIn_perPage :: Int } -data TableOut = TableOut - { +data TableOut t = TableOut + { _tableOut_deletedPayment :: Event t PaymentId } -widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut +widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - R.divClass "lines" $ do + deletedPayment <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -52,13 +53,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - _ <- R.simpleList paymentRange (paymentRow init) - return () + (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty - return $ TableOut {} + return $ TableOut + { _tableOut_deletedPayment = deletedPayment + } where init = _tableIn_init tableIn @@ -74,7 +76,7 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) paymentRow init payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment @@ -117,10 +119,13 @@ paymentRow init payment = rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment - , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut + , _modalIn_hide = R.leftmost $ + [ _deleteOut_cancel . _modalOut_content $ modalOut + , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut + ] , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } - return () + return (_deleteOut_validate . _modalOut_content $ modalOut) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 24e5be0..7f53299 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -28,13 +28,9 @@ view signInMessage = R.divClass "signIn" $ Component.form $ do rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_hasResetButton = True - , _inputIn_label = Msg.get Msg.SignIn_EmailLabel - , _inputIn_initialValue = "" - , _inputIn_inputType = "text" - } + input <- (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) + (R.ffilter Either.isRight signInResult)) button <- Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) diff --git a/common/common.cabal b/common/common.cabal index 151326a..78f2927 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,6 +29,7 @@ Library Common.Model Common.Model.CreatePayment Common.Model.Payment + Common.Model.User Common.Msg Common.Util.Text Common.Util.Time @@ -52,4 +53,3 @@ Library Common.Model.Payer Common.Model.PaymentCategory Common.Model.SignIn - Common.Model.User diff --git a/common/src/Common/Util/Time.hs b/common/src/Common/Util/Time.hs index 9ab7ab5..6240720 100644 --- a/common/src/Common/Util/Time.hs +++ b/common/src/Common/Util/Time.hs @@ -16,9 +16,9 @@ timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time parseDay :: Text -> Maybe Day parseDay str = do - (d, m, y) <- - case T.splitOn str "/" of - [d, m, y] -> Just (d, m, y) + (y, m, d) <- + case T.splitOn "-" str of + [y, m, d] -> Just (y, m, d) _ -> Nothing d' <- T.readMaybe . T.unpack $ d m' <- T.readMaybe . T.unpack $ m diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 4edbf6a..fb7fcb2 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -12,8 +12,6 @@ import Web.Scotty import Common.Model (CreatePayment (..), EditPayment (..), PaymentId, User (..)) - -import qualified Json import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -34,7 +32,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do PaymentCategoryPersistence.save name category PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + ) >>= json Just validationError -> do status Status.badRequest400 diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 4da4ffb..de8dd61 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -29,6 +29,8 @@ global = do body ? do minWidth (px 320) fontFamily ["Cantarell"] [sansSerif] + ".modal" & + overflowY hidden Media.tablet $ do fontSize (px 15) button ? fontSize (px 15) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 32600d7..272cd39 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -92,18 +92,29 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = +create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment +create userId name cost date frequency = Query (\conn -> do - now <- getCurrentTime + time <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?)" ]) - (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) - SQLite.lastInsertRowId conn + (userId, name, cost, date, FrequencyField frequency, time) + paymentId <- SQLite.lastInsertRowId conn + return $ Payment + { _payment_id = paymentId + , _payment_user = userId + , _payment_name = name + , _payment_cost = cost + , _payment_date = date + , _payment_frequency = frequency + , _payment_createdAt = time + , _payment_editedAt = Nothing + , _payment_deletedAt = Nothing + } ) createMany :: [Payment] -> Query () -- cgit v1.2.3 From 8a28f608d8e08fba4bbe54b46804d261686c3c03 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 20:33:17 +0100 Subject: Upgrade reflex-platform --- .ghc.environment.x86_64-linux-8.4.3 | 157 ++++++++++++++++++++++++++++++++++++ Makefile | 4 +- README.md | 4 +- client/src/Util/Ajax.hs | 2 +- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment/Header.hs | 1 + default.nix | 6 +- server/server.cabal | 3 + server/src/Design/Modal.hs | 2 +- server/src/Design/Views.hs | 2 +- tools.nix | 4 +- 11 files changed, 173 insertions(+), 14 deletions(-) create mode 100644 .ghc.environment.x86_64-linux-8.4.3 diff --git a/.ghc.environment.x86_64-linux-8.4.3 b/.ghc.environment.x86_64-linux-8.4.3 new file mode 100644 index 0000000..7d3e48e --- /dev/null +++ b/.ghc.environment.x86_64-linux-8.4.3 @@ -0,0 +1,157 @@ +-- This is a GHC environment file written by cabal. This means you can +-- run ghc or ghci and get the environment of the project as a whole. +-- But you still need to use cabal repl $target to get the environment +-- of specific components (libs, exes, tests etc) because each one can +-- have its own source dirs, cpp flags etc. +-- +clear-package-db +global-package-db +package-db /home/joris/.cabal/store/ghc-8.4.3/package.db +package-db dist-server/packagedb/ghc-8.4.3 +package-id common-0.0.1-inplace +package-id aeson-1.3.1.1-Lq3qt0bucT8Ce9ru8xJuCI +package-id attoparsec-0.13.2.2-ATx7nMcxk3nBRIyNYmGqiS +package-id array-0.5.2.0 +package-id base-4.11.1.0 +package-id rts +package-id ghc-prim-0.5.2.0 +package-id integer-gmp-1.0.2.0 +package-id bytestring-0.10.8.2 +package-id deepseq-1.4.3.0 +package-id containers-0.5.11.0 +package-id scientific-0.3.6.2-CQmXpomPvoD3ixE02xGLRK +package-id integer-logarithms-1.0.2.1-KTtq4CBpjpvEUZ9qRz5Dnw +package-id text-1.2.3.0 +package-id binary-0.8.5.1 +package-id hashable-1.2.7.0-3tjvi3NV6rN9wchx0YHnZD +package-id primitive-0.6.3.0-DaZpcxwJp2TGn8ITSgfI4C +package-id transformers-0.5.5.0 +package-id base-compat-0.10.4-9FtFg9E90S5CFRyvxjUaaZ +package-id unix-2.7.2.2 +package-id time-1.8.0.2 +package-id dlist-0.8.0.4-EWVGGTJvTTW8quLYK9yz9r +package-id tagged-0.8.5-4YetGW889ApC8am7APN51M +package-id template-haskell-2.13.0.0 +package-id ghc-boot-th-8.4.3 +package-id pretty-1.1.3.6 +package-id transformers-compat-0.6.2-EZ0ZvADLUlc4V8RuKaJX5W +package-id th-abstraction-0.2.8.0-Ct896m4STpK8GA15Cl5y88 +package-id time-locale-compat-0.1.1.5-KqeVbnHNo2M7DUvscbLCec +package-id unordered-containers-0.2.9.0-5IJJnkQI2ZvDdhI29XIpGM +package-id uuid-types-1.0.3-8w4UPTs1JS8B9G14pA0XAT +package-id random-1.1-9LLJAJa4iQFLJiLXBOBXBV +package-id vector-0.12.0.1-4awQG9XUvVEBfJgKGHBhOb +package-id base64-bytestring-1.0.0.1-5trcv0VH0VU6H0uIZkhZ3k +package-id blaze-builder-0.4.1.0-5wTyfrZhdBm5HR5E6AoC8q +package-id blaze-html-0.9.1.1-2WuVUrAVuLu82r7EJau7GP +package-id blaze-markup-0.8.2.1-5q61W3qlhuHHgHlyBxVWdI +package-id clay-0.13.1-8XtTo244BlHJ5E7LTRpxDO +package-id mtl-2.2.2 +package-id clientsession-0.9.1.2-Kp1X4vuJeaaJGosy9Go9AT +package-id cereal-0.5.7.0-1u6PhbqJMrKHERqJJagiCb +package-id directory-1.3.1.5 +package-id filepath-1.4.2 +package-id crypto-api-0.13.3-9IodYT3eNDPBQONIDwB97L +package-id entropy-0.4.1.1-FmBdJKRG6hQDsYzBhT7c6v +package-id skein-1.0.9.4-KqWA7IwIzMC5B1u6Q3OfIC +package-id cprng-aes-0.6.1-63etvHRpER8EeGrwwFmDBf +package-id byteable-0.1.1-APABKKN6nDlC3QxQBw4YlY +package-id crypto-random-0.0.9-8Tu8ZbKJeNNKNdtsawKUJP +package-id securemem-0.1.10-47zZUPlFQPlLT2d3byocKS +package-id memory-0.14.16-GTCi0eCrvrnI3inLDBWVMK +package-id basement-0.0.8-8QjArDsw3GWCcbHE5iqtz3 +package-id foundation-0.0.21-2XnEGrFO7ZkKqT4yFq3WNW +package-id cipher-aes-0.2.11-JuxqKjUdElsKUllS45vrnr +package-id crypto-cipher-types-0.0.9-Iu6qf1HOoNxJnMNZvefoYo +package-id setenv-0.1.1.3-H1xmIqlPy4yIDquO6eJhBl +package-id config-manager-0.3.0.1-ErZESEYU0J61ILS0rVvaqp +package-id parsec-3.1.13.0 +package-id cookie-0.4.4-CbgKffgfVXL7ehGVl03UQt +package-id data-default-class-0.1.2.0-2kYzERBLX3wJoPfj7mwVvW +package-id email-validate-2.3.2.6-5cF9aOuvvJ3B7vRZe3M5wS +package-id http-conduit-2.3.2-9qWpTkSiT7OIggksuiU0NL +package-id resourcet-1.2.1-VQ4XM4cYxr16gqpSEgCOy +package-id exceptions-0.10.0-D5kcCq3onNJ8Xd3zaVEIaB +package-id stm-2.4.5.0 +package-id unliftio-core-0.1.2.0-900TPot3SR34dceIcVaslS +package-id conduit-1.3.0.3-Ag2soCkulYh4LXK7KSKXoI +package-id mono-traversable-1.0.9.0-ClemTK6PNuCEdKAFXMoJbR +package-id split-0.2.3.3-EmQETEsKhhCBcRcdyKMbme +package-id vector-algorithms-0.7.0.4-LTeQMW2mffA77UAhZhdPqK +package-id conduit-extra-1.3.0-IvU7g6gaQD229U2EMYtyRt +package-id async-2.2.1-9Pc6MzjEaIMLKHdFpoYFYT +package-id network-2.6.3.6-2g6VId0Xlc85XRtUcfQj0T +package-id process-1.6.3.0 +package-id streaming-commons-0.2.1.0-EohdSCkYJCzJ8j6F5uKOLe +package-id zlib-0.6.2-FP80mWgJNoyCiVcPtw6kKj +package-id typed-process-0.2.3.0-3tpgRagpzJP7pjiSyDz0nm +package-id http-types-0.12.1-GrpELT1BwSZHH8qr3E2SOs +package-id case-insensitive-1.2.0.11-JyXkkg6pL0XjfMAnCwmax +package-id http-client-0.5.13.1-9cMLZOykl2HLT4rQDGR74b +package-id mime-types-0.1.0.8-LKKvOy4Qa71IxJa0ssc0G3 +package-id network-uri-2.6.1.0-58iE8XZUuHG29WOa1Wcd6B +package-id http-client-tls-0.3.5.3-Ijx3BXTqwcWHk6zAxUfVZC +package-id connection-0.2.8-KsXaNBvRY6SEBsRXaIsNph +package-id socks-0.5.6-E2UdBGsYbPg15P7ufoQudW +package-id tls-1.4.1-86xaCnbqM9j4gcJwKoy8kL +package-id cryptonite-0.25-GgyZs9E1viv2owjaLxA3vq +package-id asn1-types-0.3.2-D5pV0M5JoITIzfbcuQzEgZ +package-id hourglass-0.2.12-3UpIPqczZGGFB8xo4AtO7k +package-id asn1-encoding-0.9.5-GlFjXiAJ16sE0dEqFJUiZm +package-id x509-1.7.3-6xPfCnkvwZA7yWmuNY705r +package-id pem-0.2.4-KNeFq9SFLwqKj6C5ugBM0P +package-id asn1-parse-0.9.4-GPR0gL1pKKm7p8d8kand6q +package-id x509-store-1.6.6-IqoEuOPiJVoFoe5dvQdGI +package-id x509-validation-1.6.10-BPP7TLcoO4h8axlCTrfvOz +package-id x509-system-1.6.6-GHbFvQ8bgRK7oqdcOEJZc9 +package-id mime-mail-0.4.14-F6ySGbdVER65wtqCqWqOl3 +package-id monad-logger-0.3.29-6bZsQD4SE1xLoctmBqiUHU +package-id fast-logger-2.4.11-GgPMTheucOf1lpGoClAZZ9 +package-id auto-update-0.1.4-7k5Okr80TfS9UGlvnbDZr0 +package-id easy-file-0.2.2-4l2xgq1xN4PHgDPMu188oI +package-id unix-time-0.3.8-5bbDZ3NgOpv6wzZECQszPQ +package-id old-time-1.1.0.3-2H7uVRdRD4GDRLoYt56mwc +package-id old-locale-1.0.0.7-26K7wLFR2jK44UeOklvTCh +package-id lifted-base-0.2.3.12-8egLh9Bh3xRGu9ioodnJbr +package-id transformers-base-0.4.5.2-15Q5KM4EiRA3cyTs4bqRMY +package-id base-orphans-0.7-53B8vWYZ549FoHd6pWzX45 +package-id monad-control-1.0.2.3-YxLr8wGYVF1whrb88JCVF +package-id monad-loops-0.4.3-4dVf0xJrZft7wNMs79AFwP +package-id stm-chans-3.0.0.4-1zxsnYr1r3u2n2uZuqSuqq +package-id scotty-0.11.2-Aakq2WpJ8g59uR4UgaFkV2 +package-id fail-4.9.0.0-BAHmj60kS5K7NVhhKpm9J5 +package-id nats-1.1.2-1IJUekZt6ps5IWVCKMBPeK +package-id regex-compat-0.95.1-GpayP5pCY7oFkOLgNVrkag +package-id regex-base-0.93.2-98bD2PeVUkV8MO804tnXmq +package-id regex-posix-0.95.2-FLMmMz75XIwP5t3X8eXe +package-id wai-3.2.1.2-tyzSRIN6w83qZ0VQLCWbw +package-id vault-0.3.1.2-1TB2YirTMicAuuTDRwE6kX +package-id semigroups-0.18.5-E4FVMc5VZAG98u64romz5 +package-id wai-extra-3.0.24.2-AvTLVrqVXmKA5VMHa9boEF +package-id wai-logger-2.3.2-FDfZC2RZ3dFAtwJUbKFuvA +package-id byteorder-1.0.4-JGHrMy8StI888DOmmSVbRy +package-id ansi-terminal-0.8.0.4-JygoK7BZB5m4K6OxT2muhl +package-id colour-2.3.4-C3PVIHDZkyCIpOJGl3M0hE +package-id void-0.7.2-AeUlTizrscF7IT5YtjodSF +package-id stringsearch-0.3.6.6-6DZU68MAKlcJFBtzhQCsgS +package-id word8-0.1.3-K7c7pnNichCC0T510LrMTC +package-id unix-compat-0.5.1-IZ2l0C7CE13FdrCF8rJfBj +package-id iproute-1.7.5-sGroOlpubcDgMr0Wr8rcw +package-id appar-0.1.4-J5mdtVuytVIKFPXD2MXW4E +package-id warp-3.2.23-2pmcK8CzflY6enLxynQiQ +package-id bsb-http-chunked-0.0.0.3-E7NwspJN6SxIKqIRCJ80gO +package-id bytestring-builder-0.10.8.1.0-79xKWk2yKAy2kdzRqfwsUV +package-id http2-1.6.3-17wK0i2oRMq6bDCOjAuG6e +package-id psqueues-0.2.7.0-61W4WPtGYUOI5ei0j8xe3i +package-id simple-sendfile-0.2.27-2TzFC62eMnEJApcSMGU0P6 +package-id http-date-0.0.8-H1gAnhnvIOqv1hADs2y4c +package-id sqlite-simple-0.4.16.0-1X7hKRWKO0T3XyEgQEMkzU +package-id blaze-textual-0.2.1.0-DyWVSpyf0gV3fMlgELHYIq +package-id direct-sqlite-2.3.24-IIklpzBOtgwBoWbRSy0dek +package-id Only-0.1-ESoRmRbP5ByJm8IsgOJKc0 +package-id uuid-1.3.13-F6NIzx4IcRFHIkFHCKpKxt +package-id cryptohash-sha1-0.11.100.1-8iUWTKIak4F2397EhPbMrb +package-id cryptohash-md5-0.11.100.1-GxTbFNHFy9d4RJgBkoQPg7 +package-id network-info-0.2.0.10-Jad1urRPRS69Kkzc04cakY +package-id wai-middleware-static-0.8.2-FLTnHo5pQAg9J9aQ1NGcN0 +package-id expiring-cache-map-0.0.6.1-7nOabKJZiSQ8IBqNWYOW5A diff --git a/Makefile b/Makefile index ac939fc..31d9a62 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ build-client-inside: @cabal --project-file=cabal-client.project --builddir=dist-client new-build all cp-client: - @cp dist-client/build/x86_64-linux/ghcjs-0.2.1/client-0.0.1/c/client/build/client/client.jsexe/all.js public/javascript/main.js + @cp dist-client/build/x86_64-linux/ghcjs-*/client-*/*/client/build/client/client.jsexe/all.js public/javascript/main.js watch-client: @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" @@ -45,7 +45,7 @@ build-server-inside: run-server: @(fuser -k 3000/tcp &>/dev/null) || : - @./dist-server/build/x86_64-linux/ghc-8.0.2/server-0.0.1/c/server/build/server/server + @./dist-server/build/x86_64-linux/ghc-*/server-0.0.1/*/server/build/server/server watch-server: @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" diff --git a/README.md b/README.md index 620dae6..9e10234 100644 --- a/README.md +++ b/README.md @@ -60,9 +60,9 @@ TODO ### Interface -- Add a payment. +- Add payment error handling. +- Delete payment waitFor. - Edit a payment. -- Delete a payment. - Clone a payment. #### Bonus diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 0d76638..7b65c52 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -31,7 +31,7 @@ delete -> Event t () -> m (Event t (Either Text Text)) delete url fire = do - response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) return $ fmap getResult response getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 0175c95..7d5e7c5 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -13,6 +13,6 @@ waitFor -> Dynamic t a -> m (Event t b, Event t Bool) waitFor op start input = do - result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime) + result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime) let waiting = R.leftmost [ const True <$> start , const False <$> result ] return (result, waiting) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 653df5e..6fbaecf 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -11,6 +11,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import qualified Data.Time as Time import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) diff --git a/default.nix b/default.nix index 657de1b..e34d5bc 100644 --- a/default.nix +++ b/default.nix @@ -4,10 +4,8 @@ let reflex-platform = import (pkgs.fetchFromGitHub { owner = "reflex-frp"; repo = "reflex-platform"; - rev = "504b0344dfa6d03e4c89cf70ab9792b0a1fa021b"; - sha256 = "01hvdwc6bw48falpha5kaq4p7w98hc804kkwrayipb5ld1snchpz"; - # rev = "a457c21ceb32ea27f66f3fae930e5d8bf7ec768d"; - # sha256 = "0drzvma2q809b6hafdlq4k23mnlbmy8ny5qz140ya76zizbq34vs"; + rev = "7e002c573a3d7d3224eb2154ae55fc898e67d211"; + sha256 = "1adhzvw32zahybwd6hn1fmqm0ky2x252mshscgq2g1qlks915436"; }) {}; in reflex-platform.project ({ pkgs, ... }: { diff --git a/server/server.cabal b/server/server.cabal index 2c6bef1..644f57a 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -73,6 +73,7 @@ Executable server Design.View.Header Design.View.Payment Design.View.Payment.Add + Design.View.Payment.Delete Design.View.Payment.Header Design.View.Payment.Pages Design.View.Payment.Table @@ -88,7 +89,9 @@ Executable server Job.WeeklyReport Json LoginSession + Model.IncomeResource Model.Mail + Model.PaymentResource Model.Query Model.SignIn Model.UUID diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 2677fd8..914c011 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -31,7 +31,7 @@ design = do zIndex 1000 backgroundColor white sym borderRadius (px 5) - boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) ".add" ? Add.design ".delete" ? Delete.design diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index a73a1fa..b9e3cf8 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -43,5 +43,5 @@ design = do ".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) + boxShadow . pure . bsColor (rgba 0 0 0 0.3) $ shadowWithBlur (px 2) (px 2) (px 5) color Color.white diff --git a/tools.nix b/tools.nix index 5fd5129..9a506c7 100644 --- a/tools.nix +++ b/tools.nix @@ -1,13 +1,13 @@ with import {}; { env = stdenv.mkDerivation { name = "tools"; - buildInputs = with pkgs; with nodePackages; with haskellPackages; [ + buildInputs = with pkgs; with nodePackages; [ nodemon sqlite cabal-install tmux tmuxinator - stylish-haskell + haskellPackages.stylish-haskell ]; }; } -- cgit v1.2.3 From b5244184920b4d7a8d64eada2eca21e9a6ea2df9 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 20:44:12 +0100 Subject: Use waitfor with delete confirm button --- client/src/Util/WaitFor.hs | 9 ++++----- client/src/View/Payment/Add.hs | 3 +-- client/src/View/Payment/Delete.hs | 12 +++++------- client/src/View/SignIn.hs | 3 +-- 4 files changed, 11 insertions(+), 16 deletions(-) diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 7d5e7c5..46882aa 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -9,10 +9,9 @@ import qualified Reflex.Dom as R waitFor :: forall t m a b. MonadWidget t m => (Event t a -> m (Event t b)) - -> Event t () - -> Dynamic t a + -> Event t a -> m (Event t b, Event t Bool) -waitFor op start input = do - result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime) - let waiting = R.leftmost [ const True <$> start , const False <$> result ] +waitFor op input = do + result <- op input >>= R.debounce (0.2 :: NominalDiffTime) + let waiting = R.leftmost [ const True <$> input , const False <$> result ] return (result, waiting) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 602f7f3..1864e76 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -93,8 +93,7 @@ view addIn = do (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - validate - payment + (R.tag (R.current payment) validate) cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 330ef9f..81c7c57 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -15,7 +15,7 @@ import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil --- import qualified Util.WaitFor as WaitFor +import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn { _deleteIn_id :: Dynamic t PaymentId @@ -39,18 +39,16 @@ view deleteIn = (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_submit = True + , _buttonIn_waiting = waiting }) let url = flip fmap (_deleteIn_id deleteIn) (\id -> T.concat ["/payment/", T.pack . show $ id] ) - result <- Ajax.delete url confirm - - -- (_, waiting) <- WaitFor.waitFor - -- (Ajax.delete "/payment") - -- validate - -- payment + (result, waiting) <- WaitFor.waitFor + (Ajax.delete url) + confirm cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 7f53299..428997e 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -41,8 +41,7 @@ view signInMessage = (signInResult, waiting) <- WaitFor.waitFor (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (_buttonOut_clic button) - (_inputOut_value input) + (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) showSignInResult signInMessage signInResult -- cgit v1.2.3 From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 31 Oct 2018 19:03:19 +0100 Subject: Various fixes --- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment/Add.hs | 115 ++++++++++++++++++++------------------- server/src/Controller/Index.hs | 3 +- server/src/Design/Global.hs | 14 +++-- server/src/Design/Helper.hs | 13 +---- server/src/Design/View/SignIn.hs | 6 -- 6 files changed, 72 insertions(+), 81 deletions(-) diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 46882aa..02edff5 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -12,6 +12,6 @@ waitFor -> Event t a -> m (Event t b, Event t Bool) waitFor op input = do - result <- op input >>= R.debounce (0.2 :: NominalDiffTime) + result <- op input >>= R.debounce (0.5 :: NominalDiffTime) let waiting = R.leftmost [ const True <$> input , const False <$> result ] return (result, waiting) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 1864e76..061eeeb 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -42,64 +42,65 @@ view addIn = do R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add R.divClass "addContent" $ do - name <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) - (_addIn_show addIn)) - - cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) - (_addIn_show addIn)) - - currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay - - date <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False + rec + name <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) + (const () <$ addedPayment)) + + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) + (const () <$ addedPayment)) + + currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + }) + (const () <$ addedPayment)) + + frequency <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Frequency + , _selectIn_initialValue = Punctual + , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = _addIn_show addIn }) - (_addIn_show addIn)) - - frequency <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Frequency - , _selectIn_initialValue = Punctual - , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = _addIn_show addIn - }) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = 0 - , _selectIn_values = R.constDyn categories - , _selectIn_reset = _addIn_show addIn - }) - - let payment = CreatePayment - <$> name - <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost - <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date - <*> category - <*> frequency - - (addedPayment, cancel) <- R.divClass "buttons" $ do - rec - validate <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (result, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") - (R.tag (R.current payment) validate) - - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = 0 + , _selectIn_values = R.constDyn categories + , _selectIn_reset = _addIn_show addIn + }) + + let payment = CreatePayment + <$> name + <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost + <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date + <*> category + <*> frequency + + (addedPayment, cancel) <- R.divClass "buttons" $ do + rec + validate <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (result, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") + (R.tag (R.current payment) validate) + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return AddOut { _addOut_cancel = cancel diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f942540..0b276d3 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -6,6 +6,7 @@ module Controller.Index ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -60,7 +61,7 @@ askSignIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent + Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail Nothing -> textKey badRequest400 Msg.Secure_Unauthorized else textKey badRequest400 Msg.SignIn_EmailInvalid diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index de8dd61..ba4ccb7 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -73,14 +73,20 @@ global = do svg ? height (pct 100) button ? do - ".content" ? display flex - svg # ".loader" ? display none + position relative + + ".content" ? do + display flex + + svg # ".loader" ? do + opacity 0 + position absolute ".waiting" & do ".content" ? do - display none + opacity 0 svg # ".loader" ? do - display block + opacity 1 rotateKeyframes rotateAnimation diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 6980c71..e586d56 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,16 +1,14 @@ module Design.Helper ( clearFix , button - , input , centeredWithMargin , verticalCentering ) where import Prelude hiding (span) -import Clay hiding (button, input) +import Clay hiding (button) -import Design.Color as Color import Design.Constants clearFix :: Css @@ -37,15 +35,6 @@ button backgroundCol textCol h focusOp = do hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) -input :: Double -> Css -input h = do - height (px h) - padding (px 10) (px 10) (px 10) (px 10) - borderRadius radius radius radius radius - border solid (px 1) Color.dustyGray - focus & borderColor Color.silver - verticalAlign middle - centeredWithMargin :: Css centeredWithMargin = do width (pct blockPercentWidth) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 7f5f503..2138676 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -17,12 +17,6 @@ design = do marginLeft auto marginRight auto - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - button # ".validate" ? do Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten display flex -- cgit v1.2.3 From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- .ghc.environment.x86_64-linux-8.4.3 | 157 ------- .gitignore | 1 + .tmuxinator.yml | 5 +- README.md | 1 + client/client.cabal | 8 +- client/src/Component/Input.hs | 114 ++++-- client/src/Component/Modal.hs | 19 +- client/src/Component/Select.hs | 61 ++- client/src/Util/Validation.hs | 37 ++ client/src/View/App.hs | 3 +- client/src/View/Payment.hs | 2 +- client/src/View/Payment/Add.hs | 127 +++--- client/src/View/Payment/Header.hs | 16 +- client/src/View/Payment/Pages.hs | 2 +- client/src/View/SignIn.hs | 48 ++- common/common.cabal | 12 +- common/src/Common/Message/Key.hs | 1 + common/src/Common/Message/Translation.hs | 9 +- common/src/Common/Model.hs | 3 +- common/src/Common/Model/Email.hs | 12 + common/src/Common/Model/SignIn.hs | 14 - common/src/Common/Model/SignInForm.hs | 14 + common/src/Common/Util/Validation.hs | 13 + common/src/Common/Validation/Atomic.hs | 47 +++ common/src/Common/Validation/Payment.hs | 21 + common/src/Common/Validation/SignIn.hs | 19 + default.nix | 9 +- server/server.cabal | 5 +- server/src/Controller/Index.hs | 26 +- server/src/Design/Form.hs | 10 +- server/src/Design/Global.hs | 59 ++- server/src/Design/Modal.hs | 2 +- server/src/Design/View/Header.hs | 2 + server/src/Design/View/Payment/Add.hs | 7 +- server/src/Design/View/Payment/Delete.hs | 3 + server/src/Validation/Atomic.hs | 2 +- server/src/View/Page.hs | 3 + validation/LICENSE | 674 +++++++++++++++++++++++++++++++ validation/Setup.hs | 2 + validation/validation.cabal | 23 ++ 40 files changed, 1243 insertions(+), 350 deletions(-) delete mode 100644 .ghc.environment.x86_64-linux-8.4.3 create mode 100644 client/src/Util/Validation.hs create mode 100644 common/src/Common/Model/Email.hs delete mode 100644 common/src/Common/Model/SignIn.hs create mode 100644 common/src/Common/Model/SignInForm.hs create mode 100644 common/src/Common/Util/Validation.hs create mode 100644 common/src/Common/Validation/Atomic.hs create mode 100644 common/src/Common/Validation/Payment.hs create mode 100644 common/src/Common/Validation/SignIn.hs create mode 100644 validation/LICENSE create mode 100644 validation/Setup.hs create mode 100644 validation/validation.cabal diff --git a/.ghc.environment.x86_64-linux-8.4.3 b/.ghc.environment.x86_64-linux-8.4.3 deleted file mode 100644 index 7d3e48e..0000000 --- a/.ghc.environment.x86_64-linux-8.4.3 +++ /dev/null @@ -1,157 +0,0 @@ --- This is a GHC environment file written by cabal. This means you can --- run ghc or ghci and get the environment of the project as a whole. --- But you still need to use cabal repl $target to get the environment --- of specific components (libs, exes, tests etc) because each one can --- have its own source dirs, cpp flags etc. --- -clear-package-db -global-package-db -package-db /home/joris/.cabal/store/ghc-8.4.3/package.db -package-db dist-server/packagedb/ghc-8.4.3 -package-id common-0.0.1-inplace -package-id aeson-1.3.1.1-Lq3qt0bucT8Ce9ru8xJuCI -package-id attoparsec-0.13.2.2-ATx7nMcxk3nBRIyNYmGqiS -package-id array-0.5.2.0 -package-id base-4.11.1.0 -package-id rts -package-id ghc-prim-0.5.2.0 -package-id integer-gmp-1.0.2.0 -package-id bytestring-0.10.8.2 -package-id deepseq-1.4.3.0 -package-id containers-0.5.11.0 -package-id scientific-0.3.6.2-CQmXpomPvoD3ixE02xGLRK -package-id integer-logarithms-1.0.2.1-KTtq4CBpjpvEUZ9qRz5Dnw -package-id text-1.2.3.0 -package-id binary-0.8.5.1 -package-id hashable-1.2.7.0-3tjvi3NV6rN9wchx0YHnZD -package-id primitive-0.6.3.0-DaZpcxwJp2TGn8ITSgfI4C -package-id transformers-0.5.5.0 -package-id base-compat-0.10.4-9FtFg9E90S5CFRyvxjUaaZ -package-id unix-2.7.2.2 -package-id time-1.8.0.2 -package-id dlist-0.8.0.4-EWVGGTJvTTW8quLYK9yz9r -package-id tagged-0.8.5-4YetGW889ApC8am7APN51M -package-id template-haskell-2.13.0.0 -package-id ghc-boot-th-8.4.3 -package-id pretty-1.1.3.6 -package-id transformers-compat-0.6.2-EZ0ZvADLUlc4V8RuKaJX5W -package-id th-abstraction-0.2.8.0-Ct896m4STpK8GA15Cl5y88 -package-id time-locale-compat-0.1.1.5-KqeVbnHNo2M7DUvscbLCec -package-id unordered-containers-0.2.9.0-5IJJnkQI2ZvDdhI29XIpGM -package-id uuid-types-1.0.3-8w4UPTs1JS8B9G14pA0XAT -package-id random-1.1-9LLJAJa4iQFLJiLXBOBXBV -package-id vector-0.12.0.1-4awQG9XUvVEBfJgKGHBhOb -package-id base64-bytestring-1.0.0.1-5trcv0VH0VU6H0uIZkhZ3k -package-id blaze-builder-0.4.1.0-5wTyfrZhdBm5HR5E6AoC8q -package-id blaze-html-0.9.1.1-2WuVUrAVuLu82r7EJau7GP -package-id blaze-markup-0.8.2.1-5q61W3qlhuHHgHlyBxVWdI -package-id clay-0.13.1-8XtTo244BlHJ5E7LTRpxDO -package-id mtl-2.2.2 -package-id clientsession-0.9.1.2-Kp1X4vuJeaaJGosy9Go9AT -package-id cereal-0.5.7.0-1u6PhbqJMrKHERqJJagiCb -package-id directory-1.3.1.5 -package-id filepath-1.4.2 -package-id crypto-api-0.13.3-9IodYT3eNDPBQONIDwB97L -package-id entropy-0.4.1.1-FmBdJKRG6hQDsYzBhT7c6v -package-id skein-1.0.9.4-KqWA7IwIzMC5B1u6Q3OfIC -package-id cprng-aes-0.6.1-63etvHRpER8EeGrwwFmDBf -package-id byteable-0.1.1-APABKKN6nDlC3QxQBw4YlY -package-id crypto-random-0.0.9-8Tu8ZbKJeNNKNdtsawKUJP -package-id securemem-0.1.10-47zZUPlFQPlLT2d3byocKS -package-id memory-0.14.16-GTCi0eCrvrnI3inLDBWVMK -package-id basement-0.0.8-8QjArDsw3GWCcbHE5iqtz3 -package-id foundation-0.0.21-2XnEGrFO7ZkKqT4yFq3WNW -package-id cipher-aes-0.2.11-JuxqKjUdElsKUllS45vrnr -package-id crypto-cipher-types-0.0.9-Iu6qf1HOoNxJnMNZvefoYo -package-id setenv-0.1.1.3-H1xmIqlPy4yIDquO6eJhBl -package-id config-manager-0.3.0.1-ErZESEYU0J61ILS0rVvaqp -package-id parsec-3.1.13.0 -package-id cookie-0.4.4-CbgKffgfVXL7ehGVl03UQt -package-id data-default-class-0.1.2.0-2kYzERBLX3wJoPfj7mwVvW -package-id email-validate-2.3.2.6-5cF9aOuvvJ3B7vRZe3M5wS -package-id http-conduit-2.3.2-9qWpTkSiT7OIggksuiU0NL -package-id resourcet-1.2.1-VQ4XM4cYxr16gqpSEgCOy -package-id exceptions-0.10.0-D5kcCq3onNJ8Xd3zaVEIaB -package-id stm-2.4.5.0 -package-id unliftio-core-0.1.2.0-900TPot3SR34dceIcVaslS -package-id conduit-1.3.0.3-Ag2soCkulYh4LXK7KSKXoI -package-id mono-traversable-1.0.9.0-ClemTK6PNuCEdKAFXMoJbR -package-id split-0.2.3.3-EmQETEsKhhCBcRcdyKMbme -package-id vector-algorithms-0.7.0.4-LTeQMW2mffA77UAhZhdPqK -package-id conduit-extra-1.3.0-IvU7g6gaQD229U2EMYtyRt -package-id async-2.2.1-9Pc6MzjEaIMLKHdFpoYFYT -package-id network-2.6.3.6-2g6VId0Xlc85XRtUcfQj0T -package-id process-1.6.3.0 -package-id streaming-commons-0.2.1.0-EohdSCkYJCzJ8j6F5uKOLe -package-id zlib-0.6.2-FP80mWgJNoyCiVcPtw6kKj -package-id typed-process-0.2.3.0-3tpgRagpzJP7pjiSyDz0nm -package-id http-types-0.12.1-GrpELT1BwSZHH8qr3E2SOs -package-id case-insensitive-1.2.0.11-JyXkkg6pL0XjfMAnCwmax -package-id http-client-0.5.13.1-9cMLZOykl2HLT4rQDGR74b -package-id mime-types-0.1.0.8-LKKvOy4Qa71IxJa0ssc0G3 -package-id network-uri-2.6.1.0-58iE8XZUuHG29WOa1Wcd6B -package-id http-client-tls-0.3.5.3-Ijx3BXTqwcWHk6zAxUfVZC -package-id connection-0.2.8-KsXaNBvRY6SEBsRXaIsNph -package-id socks-0.5.6-E2UdBGsYbPg15P7ufoQudW -package-id tls-1.4.1-86xaCnbqM9j4gcJwKoy8kL -package-id cryptonite-0.25-GgyZs9E1viv2owjaLxA3vq -package-id asn1-types-0.3.2-D5pV0M5JoITIzfbcuQzEgZ -package-id hourglass-0.2.12-3UpIPqczZGGFB8xo4AtO7k -package-id asn1-encoding-0.9.5-GlFjXiAJ16sE0dEqFJUiZm -package-id x509-1.7.3-6xPfCnkvwZA7yWmuNY705r -package-id pem-0.2.4-KNeFq9SFLwqKj6C5ugBM0P -package-id asn1-parse-0.9.4-GPR0gL1pKKm7p8d8kand6q -package-id x509-store-1.6.6-IqoEuOPiJVoFoe5dvQdGI -package-id x509-validation-1.6.10-BPP7TLcoO4h8axlCTrfvOz -package-id x509-system-1.6.6-GHbFvQ8bgRK7oqdcOEJZc9 -package-id mime-mail-0.4.14-F6ySGbdVER65wtqCqWqOl3 -package-id monad-logger-0.3.29-6bZsQD4SE1xLoctmBqiUHU -package-id fast-logger-2.4.11-GgPMTheucOf1lpGoClAZZ9 -package-id auto-update-0.1.4-7k5Okr80TfS9UGlvnbDZr0 -package-id easy-file-0.2.2-4l2xgq1xN4PHgDPMu188oI -package-id unix-time-0.3.8-5bbDZ3NgOpv6wzZECQszPQ -package-id old-time-1.1.0.3-2H7uVRdRD4GDRLoYt56mwc -package-id old-locale-1.0.0.7-26K7wLFR2jK44UeOklvTCh -package-id lifted-base-0.2.3.12-8egLh9Bh3xRGu9ioodnJbr -package-id transformers-base-0.4.5.2-15Q5KM4EiRA3cyTs4bqRMY -package-id base-orphans-0.7-53B8vWYZ549FoHd6pWzX45 -package-id monad-control-1.0.2.3-YxLr8wGYVF1whrb88JCVF -package-id monad-loops-0.4.3-4dVf0xJrZft7wNMs79AFwP -package-id stm-chans-3.0.0.4-1zxsnYr1r3u2n2uZuqSuqq -package-id scotty-0.11.2-Aakq2WpJ8g59uR4UgaFkV2 -package-id fail-4.9.0.0-BAHmj60kS5K7NVhhKpm9J5 -package-id nats-1.1.2-1IJUekZt6ps5IWVCKMBPeK -package-id regex-compat-0.95.1-GpayP5pCY7oFkOLgNVrkag -package-id regex-base-0.93.2-98bD2PeVUkV8MO804tnXmq -package-id regex-posix-0.95.2-FLMmMz75XIwP5t3X8eXe -package-id wai-3.2.1.2-tyzSRIN6w83qZ0VQLCWbw -package-id vault-0.3.1.2-1TB2YirTMicAuuTDRwE6kX -package-id semigroups-0.18.5-E4FVMc5VZAG98u64romz5 -package-id wai-extra-3.0.24.2-AvTLVrqVXmKA5VMHa9boEF -package-id wai-logger-2.3.2-FDfZC2RZ3dFAtwJUbKFuvA -package-id byteorder-1.0.4-JGHrMy8StI888DOmmSVbRy -package-id ansi-terminal-0.8.0.4-JygoK7BZB5m4K6OxT2muhl -package-id colour-2.3.4-C3PVIHDZkyCIpOJGl3M0hE -package-id void-0.7.2-AeUlTizrscF7IT5YtjodSF -package-id stringsearch-0.3.6.6-6DZU68MAKlcJFBtzhQCsgS -package-id word8-0.1.3-K7c7pnNichCC0T510LrMTC -package-id unix-compat-0.5.1-IZ2l0C7CE13FdrCF8rJfBj -package-id iproute-1.7.5-sGroOlpubcDgMr0Wr8rcw -package-id appar-0.1.4-J5mdtVuytVIKFPXD2MXW4E -package-id warp-3.2.23-2pmcK8CzflY6enLxynQiQ -package-id bsb-http-chunked-0.0.0.3-E7NwspJN6SxIKqIRCJ80gO -package-id bytestring-builder-0.10.8.1.0-79xKWk2yKAy2kdzRqfwsUV -package-id http2-1.6.3-17wK0i2oRMq6bDCOjAuG6e -package-id psqueues-0.2.7.0-61W4WPtGYUOI5ei0j8xe3i -package-id simple-sendfile-0.2.27-2TzFC62eMnEJApcSMGU0P6 -package-id http-date-0.0.8-H1gAnhnvIOqv1hADs2y4c -package-id sqlite-simple-0.4.16.0-1X7hKRWKO0T3XyEgQEMkzU -package-id blaze-textual-0.2.1.0-DyWVSpyf0gV3fMlgELHYIq -package-id direct-sqlite-2.3.24-IIklpzBOtgwBoWbRSy0dek -package-id Only-0.1-ESoRmRbP5ByJm8IsgOJKc0 -package-id uuid-1.3.13-F6NIzx4IcRFHIkFHCKpKxt -package-id cryptohash-sha1-0.11.100.1-8iUWTKIak4F2397EhPbMrb -package-id cryptohash-md5-0.11.100.1-GxTbFNHFy9d4RJgBkoQPg7 -package-id network-info-0.2.0.10-Jad1urRPRS69Kkzc04cakY -package-id wai-middleware-static-0.8.2-FLTnHo5pQAg9J9aQ1NGcN0 -package-id expiring-cache-map-0.0.6.1-7nOabKJZiSQ8IBqNWYOW5A diff --git a/.gitignore b/.gitignore index d8cc83e..19d08a2 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ public/javascript/main.js result-client result-server sessionKey +.ghc.environment.* diff --git a/.tmuxinator.yml b/.tmuxinator.yml index 2d52bb4..2a765c0 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -1,13 +1,14 @@ name: sharedCost +startup_window: app windows: - console: - clear - app: panes: - - client: - - make watch-client - server: - make watch-server + - client: + - make watch-client - db: - sqlite3 database diff --git a/README.md b/README.md index 9e10234..83a172c 100644 --- a/README.md +++ b/README.md @@ -60,6 +60,7 @@ TODO ### Interface +- Add loader in the initial html page, that is showed before the JS code is running - Add payment error handling. - Delete payment waitFor. - Edit a payment. diff --git a/client/client.cabal b/client/client.cabal index 26ad2ec..af71f2d 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -21,8 +21,8 @@ Executable client RecursiveDo Build-depends: - aeson - , base >=4.9 && <5 + aeson + , base >= 4.11 && < 5 , bytestring , common , containers @@ -32,8 +32,10 @@ Executable client , reflex-dom , text , time + , validation other-modules: + Component Component.Button Component.Form Component.Input @@ -42,7 +44,9 @@ Executable client Icon Util.Ajax Util.Dom + Util.Either Util.List + Util.Validation Util.WaitFor View.App View.Header diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 57018a6..67f97c0 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -5,59 +5,91 @@ module Component.Input , defaultInputIn ) where -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, (&), - (.~)) -import qualified Reflex.Dom as R - -import Component.Button (ButtonIn (..), ButtonOut (..)) -import qualified Component.Button as Button +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, + (&), (.~)) +import qualified Reflex.Dom as R + +import qualified Common.Util.Validation as ValidationUtil +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button import qualified Icon -data InputIn = InputIn +data InputIn a = InputIn { _inputIn_hasResetButton :: Bool , _inputIn_label :: Text , _inputIn_initialValue :: Text , _inputIn_inputType :: Text + , _inputIn_validation :: Text -> Validation Text a } -defaultInputIn :: InputIn +defaultInputIn :: InputIn Text defaultInputIn = InputIn { _inputIn_hasResetButton = True , _inputIn_label = "" , _inputIn_initialValue = "" , _inputIn_inputType = "text" + , _inputIn_validation = V.Success } -data InputOut t = InputOut - { _inputOut_value :: Dynamic t Text +data InputOut t a = InputOut + { _inputOut_raw :: Dynamic t Text + , _inputOut_value :: Dynamic t (Maybe (Validation Text a)) , _inputOut_enter :: Event t () } input :: forall t m a b. MonadWidget t m - => InputIn - -> Event t a -- reset - -> m (InputOut t) -input inputIn reset = - R.divClass "textInput" $ do - rec - let resetValue = R.leftmost - [ fmap (const "") reset - , fmap (const "") resetClic - ] - - attributes = R.ffor value (\v -> - if T.null v && _inputIn_inputType inputIn /= "date" - then M.empty - else M.singleton "class" "filled") - - value = R._textInput_value textInput + => InputIn a + -> Event t Text -- reset + -> Event t b -- validate + -> m (InputOut t a) +input inputIn reset validate = do + rec + let resetValue = R.leftmost + [ R.traceEvent "reset" reset + , fmap (const "") resetClic + ] + + inputAttr = R.ffor value (\v -> + if T.null v && _inputIn_inputType inputIn /= "date" + then M.empty + else M.singleton "class" "filled") + + value = R._textInput_value textInput + + containerAttr = R.ffor validatedValue (\v -> + M.singleton "class" $ T.intercalate " " + [ "textInput" + , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else "" + ]) + + -- Clear validation errors after reset + delayedReset <- R.delay (0.1 :: NominalDiffTime) reset + + validatedValue <- R.holdDyn Nothing $ R.attachWith + (\v (clearValidation, validateEmpty) -> + if clearValidation + then Nothing + else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v))) + (R.current value) + (R.leftmost + [ const (False, True) <$> resetClic + , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) + , const (False, False) <$> validate + , const (True, False) <$> R.traceEvent "delayedReset" delayedReset + ]) + + (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do textInput <- R.textInput $ R.def - & R.attributes .~ attributes + & R.attributes .~ inputAttr & R.setValue .~ resetValue & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) @@ -75,9 +107,19 @@ input inputIn reset = else return R.never - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + R.divClass "errorMessage" $ + R.dynText . fmap validationError $ validatedValue + + return (textInput, resetClic) + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ InputOut + { _inputOut_raw = value + , _inputOut_value = validatedValue + , _inputOut_enter = enter + } - return $ InputOut - { _inputOut_value = value - , _inputOut_enter = enter - } +validationError :: Maybe (Validation Text a) -> Text +validationError (Just (Failure e)) = e +validationError _ = "" diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index b86fee0..d7943a9 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -23,11 +23,12 @@ data ModalIn t m a = ModalIn , _modalIn_content :: m a } -data ModalOut a = ModalOut +data ModalOut t a = ModalOut { _modalOut_content :: a + , _modalOut_hide :: Event t () } -modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a) +modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) modal modalIn = do rec let showEvent = R.leftmost @@ -48,6 +49,7 @@ modal modalIn = do return $ ModalOut { _modalOut_content = content + , _modalOut_hide = curtainClick } getAttributes :: Bool -> LM.Map Text Text @@ -67,12 +69,13 @@ performShowEffects showEvent elem = do let showEffects = flip fmap showEvent (\show -> do - if show - then - do - Node.appendChild body elem - Element.setClassName body ("modal" :: JSString) - else + if show then + do + Node.appendChild body elem + Element.setClassName body ("modal" :: JSString) + else + do + Node.removeChild body elem Element.setClassName body ("" :: JSString) ) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 7cb6726..9f671d3 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -5,34 +5,65 @@ module Component.Select ) where import Data.Map (Map) +import qualified Data.Map as M import Data.Text (Text) +import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -data (Reflex t) => SelectIn t a = SelectIn +import qualified Common.Msg as Msg + +data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a , _selectIn_values :: Dynamic t (Map a Text) - , _selectIn_reset :: Event t () + , _selectIn_reset :: Event t b + , _selectIn_isValid :: a -> Bool + , _selectIn_validate :: Event t c } data SelectOut t a = SelectOut { _selectOut_value :: Dynamic t a } -select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a) -select selectIn = - R.divClass "selectInput" $ do - R.el "label" $ R.text (_selectIn_label selectIn) +select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) +select selectIn = do + rec + let containerAttr = R.ffor hasError (\e -> + M.singleton "class" $ T.intercalate " " + [ "selectInput" + , if e then "error" else "" + ]) + + hasError <- R.holdDyn False $ R.attachWith + (\v clearError -> not clearError && not (_selectIn_isValid selectIn v)) + (R.current value) + (R.leftmost + [ const False <$> _selectIn_validate selectIn + , const True <$> _selectIn_reset selectIn + ]) + + value <- R.elDynAttr "div" containerAttr $ do + R.el "label" $ R.text (_selectIn_label selectIn) + + let initialValue = _selectIn_initialValue selectIn + + value <- R._dropdown_value <$> + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + + errorMessage <- R.holdDyn "" $ R.attachWith + (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") + (R.current value) + (_selectIn_validate selectIn) - let initialValue = _selectIn_initialValue selectIn + R.divClass "errorMessage" . R.dynText $ + R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "") - value <- R._dropdown_value <$> - R.dropdown - initialValue - (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + return value - return SelectOut - { _selectOut_value = value - } + return SelectOut + { _selectOut_value = value + } diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs new file mode 100644 index 0000000..e2a3dcb --- /dev/null +++ b/client/src/Util/Validation.hs @@ -0,0 +1,37 @@ +module Util.Validation + ( fireValidation + , fireMaybe + , nelError + ) where + +import Control.Monad (join) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL +import Data.Text (Text) +import Data.Validation (Validation (Failure, Success)) +import qualified Data.Validation as Validation +import Reflex.Dom (Dynamic, Event, Reflex) +import qualified Reflex.Dom as R + +nelError :: Validation a b -> Validation (NonEmpty a) b +nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success + +fireValidation + :: forall t a b c. Reflex t + => Dynamic t (Maybe (Validation a b)) + -> Event t c + -> Event t b +fireValidation value validate = + R.fmapMaybe + (join . fmap (Validation.validation (const Nothing) Just)) + (R.tag (R.current value) validate) + +fireMaybe + :: forall t a b. Reflex t + => Dynamic t (Maybe a) + -> Event t b + -> Event t a +fireMaybe value validate = + R.fmapMaybe + id + (R.tag (R.current value) validate) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 9aa6c57..6435297 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -16,7 +16,8 @@ import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = - R.mainWidget $ do + R.mainWidget $ R.divClass "app" $ do + headerOut <- Header.view $ HeaderIn { _headerIn_initResult = initResult } diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 5245e72..007471d 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -30,7 +30,7 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do - R.divClass "payment" $ do + R.elClass "main" "payment" $ do rec let init = _paymentIn_init paymentIn paymentsPerPage = 7 diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 061eeeb..62b26a3 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,31 +4,34 @@ module View.Payment.Add , AddOut(..) ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import qualified Data.Text as T -import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Time -import Reflex.Dom (Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R -import qualified Text.Read as T - -import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data AddIn t = AddIn { _addIn_categories :: [Category] - , _addIn_show :: Event t () + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -43,48 +46,84 @@ view addIn = do R.divClass "addContent" $ do rec + let reset = R.leftmost + [ const "" <$> cancel + , const "" <$> addedPayment + , const "" <$> _addIn_cancel addIn + ] + name <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_validation = PaymentValidation.name + }) + reset + validate) cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost }) - (const () <$ addedPayment)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_validation = PaymentValidation.cost + }) + reset + validate) - currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + currentDay <- do + d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay + , _inputIn_initialValue = currentDay , _inputIn_inputType = "date" , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date }) - (const () <$ addedPayment)) + (const currentDay <$> reset) + validate) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = const True + , _selectIn_validate = validate }) category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = 0 + , _selectIn_initialValue = -1 , _selectIn_values = R.constDyn categories - , _selectIn_reset = _addIn_show addIn + , _selectIn_reset = reset + , _selectIn_isValid = \id -> id /= -1 + , _selectIn_validate = validate }) - let payment = CreatePayment - <$> name - <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost - <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date - <*> category - <*> frequency - - (addedPayment, cancel) <- R.divClass "buttons" $ do + let payment = do + n <- name + c <- cost + d <- date + cat <- category + f <- frequency + pure $ do + n' <- n + c' <- c + d' <- d + pure $ CreatePayment + <$> ValidationUtil.nelError n' + <*> ValidationUtil.nelError c' + <*> ValidationUtil.nelError d' + <*> ValidationUtil.nelError (V.Success cat) + <*> ValidationUtil.nelError (V.Success f) + + (addedPayment, cancel, validate) <- R.divClass "buttons" $ do rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + validate <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" @@ -94,13 +133,9 @@ view addIn = do (result, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - (R.tag (R.current payment) validate) - - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) + return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) return AddOut { _addOut_cancel = cancel diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 6fbaecf..56441eb 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -97,18 +97,19 @@ payerAndAdd incomes payments users categories currency = do , _buttonIn_submit = False }) rec - modalOut <- fmap _modalOut_content . Component.modal $ ModalIn + modalOut <- Component.modal $ ModalIn { _modalIn_show = addPaymentClic , _modalIn_hide = R.leftmost $ - [ _addOut_cancel modalOut - , fmap (const ()) . _addOut_addedPayment $ modalOut + [ _addOut_cancel addOut + , fmap (const ()) . _addOut_addedPayment $ addOut ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories - , _addIn_show = addPaymentClic + , _addIn_cancel = _modalOut_hide modalOut } } - return (_addOut_addedPayment modalOut) + let addOut = _modalOut_content modalOut + return (_addOut_addedPayment addOut) searchLine :: forall t m. MonadWidget t m @@ -116,9 +117,10 @@ searchLine -> m (Dynamic t Text, Dynamic t Frequency) searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_value <$> (Component.input + searchName <- _inputOut_raw <$> (Component.input ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) - reset) + (const "" <$> reset) + R.never) let frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 57d67ac..cbe7b50 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -47,7 +47,7 @@ pageButtons total perPage reset = do , pageClic , nextPageClic , lastPageClic - , (const 1) <$> reset + , 1 <$ reset ] firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 428997e..6fbf6d6 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -3,20 +3,24 @@ module View.SignIn , view ) where -import qualified Data.Either as Either -import Data.Text (Text) -import Prelude hiding (error) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Data.Validation (Validation) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (SignIn (SignIn)) -import qualified Common.Msg as Msg +import Common.Model (SignInForm (SignInForm)) +import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation -import Component (ButtonIn (..), ButtonOut (..), InputIn (..), - InputOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as WaitFor +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -29,19 +33,27 @@ view signInMessage = Component.form $ do rec input <- (Component.input - (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel }) - (R.ffilter Either.isRight signInResult)) + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.SignIn_EmailLabel + , _inputIn_validation = SignInValidation.email + }) + (const "" <$> R.ffilter Either.isRight signInResult) + validate) - button <- Component.button $ + validate <- _buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) { _buttonIn_class = R.constDyn "validate" , _buttonIn_waiting = waiting , _buttonIn_submit = True - } + }) + + let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) - (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button)) + (Ajax.postJson "/askSignIn") + (ValidationUtil.fireMaybe + ((\f -> const f <$> SignInValidation.signIn f) <$> form) + validate) showSignInResult signInMessage signInResult diff --git a/common/common.cabal b/common/common.cabal index 78f2927..9881c64 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -20,19 +20,26 @@ Library OverloadedStrings Build-depends: - aeson - , base >=4.9 && <5 + aeson + , base >= 4.11 && < 5 , text , time + , validation Exposed-modules: Common.Model Common.Model.CreatePayment + Common.Model.Email Common.Model.Payment + Common.Model.SignInForm Common.Model.User Common.Msg Common.Util.Text Common.Util.Time + Common.Util.Validation + Common.Validation.Atomic + Common.Validation.Payment + Common.Validation.SignIn Common.View.Format other-modules: @@ -52,4 +59,3 @@ Library Common.Model.InitResult Common.Model.Payer Common.Model.PaymentCategory - Common.Model.SignIn diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 6e5f246..4acba93 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -39,6 +39,7 @@ data Key = | Form_AlreadyExists | Form_NonEmpty + | Form_MinChars Int | Form_NonNullNumber | Form_GreaterIntThan Int | Form_InvalidCategory diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 70eb978..e95fa74 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -162,6 +162,11 @@ m l Form_NonEmpty = English -> "Required field" French -> "Champ requis" +m l (Form_MinChars number) = + case l of + English -> T.concat [ "This field must contains at least ", T.pack . show $ number, " characters" ] + French -> T.concat [ "Ce champ doit contenir au moins ", T.pack . show $ number, " caractères" ] + m l Form_NonNullNumber = case l of English -> "Number must not be null" @@ -184,8 +189,8 @@ m l Form_InvalidColor = m l Form_InvalidDate = case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" + English -> "DD/MM/YYYY required" + French -> "JJ/MM/AAAA requis" m l Form_InvalidInt = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index cb38b2f..b0e0491 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -8,6 +8,7 @@ import Common.Model.Currency as X import Common.Model.EditCategory as X import Common.Model.EditIncome as X import Common.Model.EditPayment as X +import Common.Model.Email as X import Common.Model.Frequency as X import Common.Model.Income as X import Common.Model.Init as X @@ -15,5 +16,5 @@ import Common.Model.InitResult as X import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X -import Common.Model.SignIn as X +import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/Email.hs b/common/src/Common/Model/Email.hs new file mode 100644 index 0000000..e938f83 --- /dev/null +++ b/common/src/Common/Model/Email.hs @@ -0,0 +1,12 @@ +module Common.Model.Email + ( Email(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Email = Email Text deriving (Show, Generic) + +instance FromJSON Email +instance ToJSON Email diff --git a/common/src/Common/Model/SignIn.hs b/common/src/Common/Model/SignIn.hs deleted file mode 100644 index bfd7fbc..0000000 --- a/common/src/Common/Model/SignIn.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Common.Model.SignIn - ( SignIn(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data SignIn = SignIn - { _signIn_email :: Text - } deriving (Show, Generic) - -instance FromJSON SignIn -instance ToJSON SignIn diff --git a/common/src/Common/Model/SignInForm.hs b/common/src/Common/Model/SignInForm.hs new file mode 100644 index 0000000..2b8c955 --- /dev/null +++ b/common/src/Common/Model/SignInForm.hs @@ -0,0 +1,14 @@ +module Common.Model.SignInForm + ( SignInForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data SignInForm = SignInForm + { _signIn_email :: Text + } deriving (Show, Generic) + +instance FromJSON SignInForm +instance ToJSON SignInForm diff --git a/common/src/Common/Util/Validation.hs b/common/src/Common/Util/Validation.hs new file mode 100644 index 0000000..f195d95 --- /dev/null +++ b/common/src/Common/Util/Validation.hs @@ -0,0 +1,13 @@ +module Common.Util.Validation + ( isSuccess + , isFailure + ) where + +import Data.Validation (Validation (Failure, Success)) + +isSuccess :: forall a b. Validation a b -> Bool +isSuccess (Failure _) = False +isSuccess (Success _) = True + +isFailure :: forall a b. Validation a b -> Bool +isFailure = not . isSuccess diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs new file mode 100644 index 0000000..3516668 --- /dev/null +++ b/common/src/Common/Validation/Atomic.hs @@ -0,0 +1,47 @@ +module Common.Validation.Atomic + ( nonEmpty + , minLength + , number + , nonNullNumber + , day + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V +import qualified Text.Read as T + +import qualified Common.Msg as Msg +import qualified Common.Util.Time as Time + +minLength :: Int -> Text -> Validation Text Text +minLength l = + V.validate + (Msg.get (Msg.Form_MinChars l)) + (\t -> if T.length t >= l then Just t else Nothing) + +nonEmpty :: Text -> Validation Text Text +nonEmpty = + V.validate + (Msg.get Msg.Form_NonEmpty) + (\t -> if (not . T.null $ t) then Just t else Nothing) + +number :: Text -> Validation Text Int +number input = + case (T.readMaybe . T.unpack $ input) of + Just n -> V.Success n + _ -> V.Failure (Msg.get Msg.Form_InvalidInt) + +nonNullNumber :: Int -> Validation Text Int +nonNullNumber = + V.validate + (Msg.get Msg.Form_NonNullNumber) + (\n -> if n /= 0 then Just n else Nothing) + +day :: Text -> Validation Text Day +day str = + case Time.parseDay str of + Just d -> V.Success d + Nothing -> V.Failure $ Msg.get Msg.Form_InvalidDate diff --git a/common/src/Common/Validation/Payment.hs b/common/src/Common/Validation/Payment.hs new file mode 100644 index 0000000..b6c1d30 --- /dev/null +++ b/common/src/Common/Validation/Payment.hs @@ -0,0 +1,21 @@ +module Common.Validation.Payment + ( name + , cost + , date + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as Validation + +import qualified Common.Validation.Atomic as Atomic + +name :: Text -> Validation Text Text +name = Atomic.nonEmpty + +cost :: Text -> Validation Text Int +cost input = Validation.bindValidation (Atomic.number input) Atomic.nonNullNumber + +date :: Text -> Validation Text Day +date = Atomic.day diff --git a/common/src/Common/Validation/SignIn.hs b/common/src/Common/Validation/SignIn.hs new file mode 100644 index 0000000..18ceb44 --- /dev/null +++ b/common/src/Common/Validation/SignIn.hs @@ -0,0 +1,19 @@ +module Common.Validation.SignIn + ( signIn + , email + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model.Email (Email (..)) +import Common.Model.SignInForm (SignInForm (..)) +import qualified Common.Validation.Atomic as Atomic +import qualified Data.Validation as Validation + +signIn :: SignInForm -> Maybe Email +signIn (SignInForm str) = + Validation.validation (const Nothing) Just . email $ str + +email :: Text -> Validation Text Email +email = fmap Email . Atomic.minLength 5 diff --git a/default.nix b/default.nix index e34d5bc..977af02 100644 --- a/default.nix +++ b/default.nix @@ -4,19 +4,20 @@ let reflex-platform = import (pkgs.fetchFromGitHub { owner = "reflex-frp"; repo = "reflex-platform"; - rev = "7e002c573a3d7d3224eb2154ae55fc898e67d211"; - sha256 = "1adhzvw32zahybwd6hn1fmqm0ky2x252mshscgq2g1qlks915436"; + rev = "51e02339704b7502e63bccf10a72fa4dda744b17"; + sha256 = "1mkimidf755968xzbm3z222xgpdvgg6xmmrfppv1hw0rap5w53iw"; }) {}; in reflex-platform.project ({ pkgs, ... }: { packages = { + validation = ./validation; common = ./common; server = ./server; client = ./client; }; shells = { - ghc = [ "common" "server" ]; - ghcjs = [ "common" "client" ]; + ghc = [ "validation" "common" "server" ]; + ghcjs = [ "validation" "common" "client" ]; }; }) diff --git a/server/server.cabal b/server/server.cabal index 644f57a..d6c4a9b 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -20,8 +20,8 @@ Executable server OverloadedStrings Build-depends: - aeson - , base >=4.9 && <5 + aeson + , base >= 4.11 && < 5 , base64-bytestring , blaze-builder , blaze-html @@ -32,7 +32,6 @@ Executable server , config-manager , containers , cookie - , email-validate , filepath , http-conduit , http-types diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 0b276d3..fbda527 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -9,18 +9,18 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (badRequest400, ok200) +import qualified Network.HTTP.Types.Status as Status import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (InitResult (..), SignIn (..), - User (..)) +import Common.Model (Email (..), InitResult (..), + SignInForm (..), User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession @@ -30,7 +30,6 @@ import qualified Persistence.Init as InitPersistence import qualified Persistence.User as UserPersistence import qualified Secure import qualified SendMail -import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn import View.Page (page) @@ -45,10 +44,12 @@ get conf = do liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf S.html $ page initResult -askSignIn :: Conf -> SignIn -> ActionM () -askSignIn conf (SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do +askSignIn :: Conf -> SignInForm -> ActionM () +askSignIn conf form = + case SignInValidation.signIn form of + Nothing -> + textKey Status.badRequest400 Msg.SignIn_EmailInvalid + Just (Email email) -> do maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do @@ -62,9 +63,8 @@ askSignIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid + Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) trySignIn :: Conf -> Text -> ActionM () @@ -116,4 +116,4 @@ getLoggedUser = do liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> S.status ok200 +signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 0385cb4..31a2127 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -22,7 +22,7 @@ design = do ".textInput" ? do position relative - marginBottom (em 1.5) + marginBottom (em 2) paddingTop (px inputTop) marginTop (px (-10)) @@ -46,7 +46,7 @@ design = do position absolute top (px inputTop) left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) + transition "all" (sec 0.2) easeInOut (sec 0) button ? do position absolute @@ -110,11 +110,13 @@ design = do fontWeight bold ".selectInput" ? do - marginBottom (em 1) + marginBottom (em 2) + label ? do display block marginBottom (px 10) fontSize (pct 80) + select ? do width (pct 100) backgroundColor Color.white @@ -122,6 +124,8 @@ design = do sym borderRadius (px 3) sym2 padding (px 5) (px 8) option ? sym2 padding (px 5) (px 8) + focus & backgroundColor Color.wildSand + ".error" & do select ? borderColor Color.chestnutRose ".errorMessage" ? do diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index ba4ccb7..66e9f47 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -3,6 +3,7 @@ module Design.Global ) where import Clay +import Clay.Color as C import Data.Text.Lazy (Text) import qualified Design.Color as Color @@ -26,8 +27,16 @@ global = do Views.design Form.design + spinKeyframes + appearKeyframe + + html ? do + height (pct 100) + body ? do + position relative minWidth (px 320) + height (pct 100) fontFamily ["Cantarell"] [sansSerif] ".modal" & overflowY hidden @@ -40,6 +49,28 @@ global = do button ? fontSize (px 14) input ? fontSize (px 14) + ".app" ? do + appearAnimation + + ".spinner" ? do + display flex + alignItems center + justifyContent center + width (pct 100) + height (pct 100) + paddingBottom (pct 10) + + before & do + display block + content (stringContent "") + width (px 50) + height (px 50) + border solid (px 3) (C.setA 0.3 Color.chestnutRose) + sym borderRadius (pct 50) + borderTopColor Color.chestnutRose + spinKeyframes + spinAnimation + a ? cursor pointer input ? fontSize inherit @@ -87,21 +118,31 @@ global = do opacity 0 svg # ".loader" ? do opacity 1 - rotateKeyframes - rotateAnimation + spinAnimation select ? cursor pointer -rotateAnimation :: Css -rotateAnimation = do +spinAnimation :: Css +spinAnimation = do animationName "rotate" animationDuration (sec 1) - animationTimingFunction easeOut + animationTimingFunction easeInOut animationIterationCount infinite -rotateKeyframes :: Css -rotateKeyframes = keyframes +spinKeyframes :: Css +spinKeyframes = keyframes "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") + [ (100, "transform" -: "rotate(360deg)") + ] + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") ] diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 914c011..9c016b9 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -23,7 +23,7 @@ design = do transition "all" (sec 0.2) ease (sec 0) ".modalContent" ? do - minWidth (px 270) + minWidth (px 300) position fixed top (pct 25) left (pct 50) diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 97f1802..2422686 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -56,6 +56,8 @@ design = do ".signOut" ? do display flex + justifyContent center + alignItems center svg ? do Media.tabletDesktop $ width (px 30) Media.mobile $ width (px 20) diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs index 199ad36..5ecae7a 100644 --- a/server/src/Design/View/Payment/Add.hs +++ b/server/src/Design/View/Payment/Add.hs @@ -14,12 +14,12 @@ design = do backgroundColor Color.chestnutRose fontSize (px 18) color Color.white - sym padding (px 20) + sym2 padding (px 20) (px 30) textAlign (alignSide sideCenter) borderRadius (px 5) (px 5) (px 0) (px 0) ".addContent" ? do - sym padding (px 20) + sym2 padding (px 20) (px 30) ".buttons" ? do display flex @@ -30,3 +30,6 @@ design = do Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten ".undo" ? Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs index 5597f5b..f3d7e3f 100644 --- a/server/src/Design/View/Payment/Delete.hs +++ b/server/src/Design/View/Payment/Delete.hs @@ -30,3 +30,6 @@ design = do Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten ".undo" ? Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs index d15ad49..7a7351a 100644 --- a/server/src/Validation/Atomic.hs +++ b/server/src/Validation/Atomic.hs @@ -19,7 +19,7 @@ nonNullNumber :: Int -> Maybe Text nonNullNumber n = if n == 0 then Just $ Msg.get Msg.Form_NonNullNumber - else Nothing + else Nothing -- number :: (Int -> Bool) -> Text -> Maybe Int -- number numberForm str = diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 97b84fa..f47c544 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -31,6 +31,9 @@ page initResult = link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign + H.body $ do + H.div ! A.class_ "spinner" $ "" + jsonScript :: Json.ToJSON a => Text -> a -> Html jsonScript scriptId json = diff --git a/validation/LICENSE b/validation/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/validation/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/validation/Setup.hs b/validation/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/validation/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/validation/validation.cabal b/validation/validation.cabal new file mode 100644 index 0000000..6e2458b --- /dev/null +++ b/validation/validation.cabal @@ -0,0 +1,23 @@ +name: validation +version: 1 +license: BSD3 +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge , Queensland Functional Programming Lab +synopsis: A data-type like Either but with an accumulating Applicative +category: Data +cabal-version: >= 1.10 +build-type: Simple + +library + Default-Language: Haskell2010 + Build-Depends: + base >= 4.5 && < 5 + , deepseq >= 1.2 && < 1.5 + , semigroups >= 0.8 && < 1 + , semigroupoids >= 5 && < 6 + , bifunctors >= 5.1 && < 6 + , lens >= 4 && < 5 + Ghc-Options: -Wall + Hs-Source-Dirs: src + Exposed-Modules: Data.Validation -- cgit v1.2.3 From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Aug 2019 21:53:30 +0200 Subject: Use updated payment categories from payment add in payment’s table --- README.md | 20 ++++++------- client/src/Component/Input.hs | 4 +-- client/src/View/Payment.hs | 30 ++++++++++++++----- client/src/View/Payment/Add.hs | 22 ++++++++------ client/src/View/Payment/Header.hs | 22 +++++++------- client/src/View/Payment/Table.hs | 31 +++++++++++--------- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/CreatedPayment.hs | 17 +++++++++++ server/src/Controller/Payment.hs | 6 ++-- server/src/Persistence/PaymentCategory.hs | 48 ++++++++++++++++++++----------- 11 files changed, 130 insertions(+), 72 deletions(-) create mode 100644 common/src/Common/Model/CreatedPayment.hs diff --git a/README.md b/README.md index 83a172c..a102f87 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,4 @@ -Shared Cost -=========== +# Shared Cost Share costs with a group of people: @@ -8,8 +7,7 @@ Share costs with a group of people: - Statistics by month, - Weekly activity sent by email. -Getting started ---------------- +## Getting started Install nix: @@ -43,20 +41,22 @@ Later, stop the environment with: ./make stop ``` -Dist ----- +## Dist ``` make dist ``` -Configuration -------------- +## Configuration See [application.conf](application.conf). -TODO ----- +## Documentation + +- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html) +- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html) + +## TODO ### Interface diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 67f97c0..d679f9b 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -53,7 +53,7 @@ input input inputIn reset validate = do rec let resetValue = R.leftmost - [ R.traceEvent "reset" reset + [ reset , fmap (const "") resetClic ] @@ -83,7 +83,7 @@ input inputIn reset validate = do [ const (False, True) <$> resetClic , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) , const (False, False) <$> validate - , const (True, False) <$> R.traceEvent "delayedReset" delayedReset + , const (True, False) <$> delayedReset ]) (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 007471d..f614936 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -10,7 +10,8 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Frequency, Init (..), Payment (..), +import Common.Model (CreatedPayment (..), Frequency, Init (..), + Payment (..), PaymentCategory (..), PaymentId) import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) @@ -37,8 +38,12 @@ widget paymentIn = do payments <- getPayments (_init_payments init) - (_headerOut_addedPayment header) - (_tableOut_deletedPayment table) + (_createdPayment_payment <$> _headerOut_addPayment header) + (_tableOut_deletePayment table) + + paymentCategories <- getPaymentCategories + (_init_paymentCategories init) + (_createdPayment_paymentCategory <$> _headerOut_addPayment header) let searchPayments = getSearchPayments @@ -56,6 +61,7 @@ widget paymentIn = do , _tableIn_currentPage = _pagesOut_currentPage pages , _tableIn_payments = searchPayments , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories } pages <- Pages.widget $ PagesIn @@ -63,7 +69,7 @@ widget paymentIn = do , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ [ fmap (const ()) . R.updated . _headerOut_searchName $ header - , fmap (const ()) . _headerOut_addedPayment $ header + , fmap (const ()) . _headerOut_addPayment $ header ] } @@ -75,10 +81,20 @@ getPayments -> Event t Payment -> Event t PaymentId -> m (Dynamic t [Payment]) -getPayments initPayments addedPayment deletedPayment = +getPayments initPayments addPayment deletePayment = R.foldDyn id initPayments $ R.leftmost - [ flip fmap addedPayment (:) - , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + [ (:) <$> addPayment + , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + ] + +getPaymentCategories + :: forall t m. MonadWidget t m + => [PaymentCategory] + -> Event t PaymentCategory + -> m (Dynamic t [PaymentCategory]) +getPaymentCategories initPaymentCategories addPaymentCategory = + R.foldDyn id initPaymentCategories $ R.leftmost + [ (:) <$> addPaymentCategory ] getSearchPayments diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 62b26a3..2970394 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -16,7 +16,8 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..)) + CreatedPayment (..), Frequency (..), + Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation @@ -35,8 +36,9 @@ data AddIn t = AddIn } data AddOut t = AddOut - { _addOut_cancel :: Event t () - , _addOut_addedPayment :: Event t Payment + { _addOut_cancel :: Event t () + , _addOut_addPayment :: Event t CreatedPayment + , _addOut_addPaymentCategory :: Event t PaymentCategory } view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) @@ -48,7 +50,7 @@ view addIn = do rec let reset = R.leftmost [ const "" <$> cancel - , const "" <$> addedPayment + , const "" <$> addPayment , const "" <$> _addIn_cancel addIn ] @@ -68,8 +70,10 @@ view addIn = do reset validate) + now <- liftIO Time.getCurrentTime + currentDay <- do - d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay + d <- liftIO $ Time.timeToDay now return . T.pack . Calendar.showGregorian $ d date <- _inputOut_value <$> (Component.input @@ -118,7 +122,7 @@ view addIn = do <*> ValidationUtil.nelError (V.Success cat) <*> ValidationUtil.nelError (V.Success f) - (addedPayment, cancel, validate) <- R.divClass "buttons" $ do + (addPayment, cancel, validate) <- R.divClass "buttons" $ do rec cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) @@ -131,15 +135,15 @@ view addIn = do , _buttonIn_submit = True }) - (result, waiting) <- WaitFor.waitFor + (addPayment, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") (ValidationUtil.fireValidation payment validate) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate) + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate) return AddOut { _addOut_cancel = cancel - , _addOut_addedPayment = addedPayment + , _addOut_addPayment = addPayment } where diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 56441eb..c49b284 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -17,10 +17,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Init (..), Payment (..), - User (..)) +import Common.Model (Category, CreatedPayment (..), + Currency, ExceedingPayer (..), + Frequency (..), Income (..), Init (..), + Payment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -41,14 +41,14 @@ data HeaderIn t = HeaderIn data HeaderOut t = HeaderOut { _headerOut_searchName :: Dynamic t Text , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addedPayment :: Event t Payment + , _headerOut_addPayment :: Event t CreatedPayment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addedPayment <- payerAndAdd incomes punctualPayments users categories currency - let resetSearchName = fmap (const ()) $ addedPayment + addPayment <- payerAndAdd incomes punctualPayments users categories currency + let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName infos (_headerIn_searchPayments headerIn) users currency @@ -56,7 +56,7 @@ widget headerIn = return $ HeaderOut { _headerOut_searchName = searchName , _headerOut_searchFrequency = searchFrequency - , _headerOut_addedPayment = addedPayment + , _headerOut_addPayment = addPayment } where init = _headerIn_init headerIn @@ -74,7 +74,7 @@ payerAndAdd -> [User] -> [Category] -> Currency - -> m (Event t Payment) + -> m (Event t CreatedPayment) payerAndAdd incomes payments users categories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -101,7 +101,7 @@ payerAndAdd incomes payments users categories currency = do { _modalIn_show = addPaymentClic , _modalIn_hide = R.leftmost $ [ _addOut_cancel addOut - , fmap (const ()) . _addOut_addedPayment $ addOut + , fmap (const ()) . _addOut_addPayment $ addOut ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories @@ -109,7 +109,7 @@ payerAndAdd incomes payments users categories currency = do } } let addOut = _modalOut_content modalOut - return (_addOut_addedPayment addOut) + return (_addOut_addPayment addOut) searchLine :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index ba16bf5..6432274 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -29,21 +29,22 @@ import qualified Icon import qualified Util.Dom as Dom data TableIn t = TableIn - { _tableIn_init :: Init - , _tableIn_currentPage :: Dynamic t Int - , _tableIn_payments :: Dynamic t [Payment] - , _tableIn_perPage :: Int + { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int + , _tableIn_payments :: Dynamic t [Payment] + , _tableIn_perPage :: Int + , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] } data TableOut t = TableOut - { _tableOut_deletedPayment :: Event t PaymentId + { _tableOut_deletePayment :: Event t PaymentId } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - deletedPayment <- R.divClass "lines" $ do + deletePayment <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -53,13 +54,14 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init)) + (R.switch . R.current . fmap R.leftmost) <$> + (R.simpleList paymentRange (paymentRow init paymentCategories)) Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut - { _tableOut_deletedPayment = deletedPayment + { _tableOut_deletePayment = deletePayment } where @@ -67,6 +69,7 @@ widget tableIn = do currentPage = _tableIn_currentPage tableIn payments = _tableIn_payments tableIn paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage + paymentCategories = _tableIn_paymentCategories tableIn getPaymentRange :: Int -> [Payment] -> Int -> [Payment] getPaymentRange perPage payments currentPage = @@ -76,8 +79,8 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId) -paymentRow init payment = +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId) +paymentRow init paymentCategories payment = R.divClass "row" $ do R.divClass "cell name" . R.dynText . fmap _payment_name $ payment R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment @@ -88,10 +91,10 @@ paymentRow init payment = Just u -> _user_name u _ -> "" - let category = flip fmap payment $ \p -> findCategory - (_init_categories init) - (_init_paymentCategories init) - (_payment_name p) + let category = do + p <- payment + pcs <- paymentCategories + return $ findCategory (_init_categories init) pcs (_payment_name p) R.divClass "cell category" $ do let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of Just c -> M.fromList diff --git a/common/common.cabal b/common/common.cabal index 9881c64..b7e0416 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,6 +29,7 @@ Library Exposed-modules: Common.Model Common.Model.CreatePayment + Common.Model.CreatedPayment Common.Model.Email Common.Model.Payment Common.Model.SignInForm diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index b0e0491..64db890 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -2,6 +2,7 @@ module Common.Model (module X) where import Common.Model.Category as X import Common.Model.CreateCategory as X +import Common.Model.CreatedPayment as X import Common.Model.CreateIncome as X import Common.Model.CreatePayment as X import Common.Model.Currency as X diff --git a/common/src/Common/Model/CreatedPayment.hs b/common/src/Common/Model/CreatedPayment.hs new file mode 100644 index 0000000..c1bba29 --- /dev/null +++ b/common/src/Common/Model/CreatedPayment.hs @@ -0,0 +1,17 @@ +module Common.Model.CreatedPayment + ( CreatedPayment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) + +data CreatedPayment = CreatedPayment + { _createdPayment_payment :: Payment + , _createdPayment_paymentCategory :: PaymentCategory + } deriving (Show, Generic) + +instance FromJSON CreatedPayment +instance ToJSON CreatedPayment diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index fb7fcb2..e82fd49 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -10,6 +10,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty import Common.Model (CreatePayment (..), + CreatedPayment (..), EditPayment (..), PaymentId, User (..)) import qualified Model.Query as Query @@ -30,8 +31,9 @@ create createPayment@(CreatePayment name cost date category frequency) = case CreatePaymentValidation.validate createPayment of Nothing -> (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency + pc <- PaymentCategoryPersistence.save name category + p <- PaymentPersistence.create (_user_id user) name cost date frequency + return $ CreatedPayment p pc ) >>= json Just validationError -> do diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 1e377b1..1cfd702 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -4,7 +4,7 @@ module Persistence.PaymentCategory , save ) where -import Data.Maybe (isJust, listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -40,27 +40,41 @@ listByCategory cat = SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) ) -save :: Text -> CategoryId -> Query () +save :: Text -> CategoryId -> Query PaymentCategory save newName categoryId = Query (\conn -> do now <- getCurrentTime - hasPaymentCategory <- isJust <$> listToMaybe <$> + paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [Row]) - if hasPaymentCategory - then - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formatPaymentName newName) - else do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formatPaymentName newName, categoryId, now) + (Only formattedNewName)) + case paymentCategory of + Just pc -> + do + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formattedNewName) + return $ PaymentCategory + (_paymentCategory_id pc) + formattedNewName + categoryId + (_paymentCategory_createdAt pc) + (Just now) + Nothing -> + do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formattedNewName, categoryId, now) + paymentCategoryId <- SQLite.lastInsertRowId conn + return $ PaymentCategory + paymentCategoryId + formattedNewName + categoryId + now + Nothing ) where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower + formattedNewName = T.unaccent . T.toLower $ newName -- cgit v1.2.3 From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 7 Aug 2019 21:27:59 +0200 Subject: Update category according to payment in add overlay --- README.md | 24 ++++++++++--- client/src/Component/Select.hs | 8 ++++- client/src/Util/Validation.hs | 9 +++-- client/src/View/Payment.hs | 1 + client/src/View/Payment/Add.hs | 33 ++++++++++++++---- client/src/View/Payment/Delete.hs | 9 ++--- client/src/View/Payment/Header.hs | 15 +++++--- client/src/View/Payment/Table.hs | 57 ++++++++++++++++++++++--------- common/src/Common/Util/Text.hs | 9 ++--- server/src/Persistence/PaymentCategory.hs | 3 +- 10 files changed, 123 insertions(+), 45 deletions(-) diff --git a/README.md b/README.md index a102f87..39b5135 100644 --- a/README.md +++ b/README.md @@ -58,16 +58,32 @@ See [application.conf](application.conf). ## TODO -### Interface +### Payment view -- Add loader in the initial html page, that is showed before the JS code is running -- Add payment error handling. -- Delete payment waitFor. +- I should not be able to delete payment of another person +- When removing / modifying a payment, remove the payment category if there is no other payment with the same name +- Use dynamic payments in exceeding payers computation +- Check monthly payment functions - Edit a payment. - Clone a payment. +### Income view + +… + +### Category view + +… + +### Stat view + +… + #### Bonus +- HTTP error message +- Use only one loader +- Login with email and password - Adjust login design. - smooth search. - search payments by: diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 9f671d3..43a8a6e 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -16,6 +16,7 @@ import qualified Common.Msg as Msg data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text , _selectIn_initialValue :: a + , _selectIn_value :: Event t a , _selectIn_values :: Dynamic t (Map a Text) , _selectIn_reset :: Event t b , _selectIn_isValid :: a -> Bool @@ -48,11 +49,16 @@ select selectIn = do let initialValue = _selectIn_initialValue selectIn + let setValue = R.leftmost + [ const initialValue <$> (_selectIn_reset selectIn) + , _selectIn_value selectIn + ] + value <- R._dropdown_value <$> R.dropdown initialValue (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) }) + (R.def { R._dropdownConfig_setValue = setValue }) errorMessage <- R.holdDyn "" $ R.attachWith (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index e2a3dcb..fc13f36 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -1,7 +1,8 @@ module Util.Validation - ( fireValidation + ( nelError + , toMaybe + , fireValidation , fireMaybe - , nelError ) where import Control.Monad (join) @@ -16,6 +17,10 @@ import qualified Reflex.Dom as R nelError :: Validation a b -> Validation (NonEmpty a) b nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success +toMaybe :: Validation a b -> Maybe b +toMaybe (Success s) = Just s +toMaybe (Failure _) = Nothing + fireValidation :: forall t a b c. Reflex t => Dynamic t (Maybe (Validation a b)) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f614936..05eedab 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -54,6 +54,7 @@ widget paymentIn = do header <- Header.widget $ HeaderIn { _headerIn_init = init , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories } table <- Table.widget $ TableIn diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 2970394..d023613 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -4,21 +4,26 @@ module View.Payment.Add , AddOut(..) ) where +import Control.Monad (join) import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L import qualified Data.Map as M import qualified Data.Maybe as Maybe +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time import qualified Data.Validation as V -import Reflex.Dom (Event, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import qualified Text.Read as T -import Common.Model (Category (..), CreatePayment (..), +import Common.Model (Category (..), CategoryId, + CreatePayment (..), CreatedPayment (..), Frequency (..), Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Text as Text import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation import Component (ButtonIn (..), InputIn (..), @@ -31,8 +36,9 @@ import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor data AddIn t = AddIn - { _addIn_categories :: [Category] - , _addIn_cancel :: Event t () + { _addIn_categories :: [Category] + , _addIn_paymentCategories :: Dynamic t [PaymentCategory] + , _addIn_cancel :: Event t () } data AddOut t = AddOut @@ -54,13 +60,13 @@ view addIn = do , const "" <$> _addIn_cancel addIn ] - name <- _inputOut_value <$> (Component.input + name <- Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name , _inputIn_validation = PaymentValidation.name }) reset - validate) + validate cost <- _inputOut_value <$> (Component.input (Component.defaultInputIn @@ -90,15 +96,22 @@ view addIn = do frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency , _selectIn_initialValue = Punctual + , _selectIn_value = R.never , _selectIn_values = R.constDyn frequencies , _selectIn_reset = reset , _selectIn_isValid = const True , _selectIn_validate = validate }) + let setCategory = + R.fmapMaybe id + . R.updated + $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn) + category <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Category , _selectIn_initialValue = -1 + , _selectIn_value = setCategory , _selectIn_values = R.constDyn categories , _selectIn_reset = reset , _selectIn_isValid = \id -> id /= -1 @@ -106,7 +119,7 @@ view addIn = do }) let payment = do - n <- name + n <- _inputOut_value name c <- cost d <- date cat <- category @@ -154,3 +167,9 @@ view addIn = do categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> (_category_id c, _category_name c) + + +findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId +findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 81c7c57..4aa10f3 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -34,6 +34,11 @@ view deleteIn = R.divClass "deleteContent" $ do (deletedPayment, cancel) <- R.divClass "buttons" $ do + + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + rec confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) @@ -50,10 +55,6 @@ view deleteIn = (Ajax.delete url) confirm - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) return DeleteOut diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index c49b284..5cc362a 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -20,7 +20,8 @@ import qualified Reflex.Dom as R import Common.Model (Category, CreatedPayment (..), Currency, ExceedingPayer (..), Frequency (..), Income (..), Init (..), - Payment (..), User (..)) + Payment (..), PaymentCategory, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -34,8 +35,9 @@ import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_searchPayments :: Dynamic t [Payment] + { _headerIn_init :: Init + , _headerIn_searchPayments :: Dynamic t [Payment] + , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] } data HeaderOut t = HeaderOut @@ -47,7 +49,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes punctualPayments users categories currency + addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName @@ -66,6 +68,7 @@ widget headerIn = users = _init_users init categories = _init_categories init currency = _init_currency init + paymentCategories = _headerIn_paymentCategories headerIn payerAndAdd :: forall t m. MonadWidget t m @@ -73,9 +76,10 @@ payerAndAdd -> [Payment] -> [User] -> [Category] + -> Dynamic t [PaymentCategory] -> Currency -> m (Event t CreatedPayment) -payerAndAdd incomes payments users categories currency = do +payerAndAdd incomes payments users categories paymentCategories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do R.divClass "exceedingPayers" $ @@ -105,6 +109,7 @@ payerAndAdd incomes payments users categories currency = do ] , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories + , _addIn_paymentCategories = paymentCategories , _addIn_cancel = _modalOut_hide modalOut } } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 6432274..cdc4bb3 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -26,7 +26,7 @@ import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) import qualified View.Payment.Delete as Delete import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Dom as DomUtil data TableIn t = TableIn { _tableIn_init :: Init @@ -57,7 +57,7 @@ widget tableIn = do (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init paymentCategories)) - Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut @@ -79,13 +79,24 @@ getPaymentRange perPage payments currentPage = . L.sortOn _payment_date $ payments -paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId) +paymentRow + :: forall t m. MonadWidget t m + => Init + -> Dynamic t [PaymentCategory] + -> Dynamic t Payment + -> m (Event t PaymentId) paymentRow init paymentCategories payment = R.divClass "row" $ do - R.divClass "cell name" . R.dynText . fmap _payment_name $ payment - R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment - let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) + R.divClass "cell name" $ + R.dynText $ fmap _payment_name payment + + R.divClass "cell cost" $ + R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment + + let user = R.ffor payment (\p -> + CM.findUser (_payment_user p) (_init_users init)) + R.divClass "cell user" $ R.dynText $ flip fmap user $ \mbUser -> case mbUser of Just u -> _user_name u @@ -95,13 +106,16 @@ paymentRow init paymentCategories payment = p <- payment pcs <- paymentCategories return $ findCategory (_init_categories init) pcs (_payment_name p) + R.divClass "cell category" $ do + let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of Just c -> M.fromList [ ("class", "tag") , ("style", T.concat [ "background-color: ", _category_color c ]) ] Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of Just c -> _category_name c @@ -110,15 +124,26 @@ paymentRow init paymentCategories payment = R.divClass "cell date" $ do R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - R.divClass "cell button" . R.el "button" $ Icon.clone - let modifyAttrs = flip fmap payment $ \p -> - M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] - R.elDynAttr "div" modifyAttrs $ - R.el "button" $ Icon.edit - deletePayment <- R.elDynAttr "div" modifyAttrs $ - _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" }) + + R.divClass "cell button" $ + R.el "button" Icon.clone + + let isFromCurrentUser = + R.ffor + payment + (\p -> _payment_user p == _init_currentUser init) + + R.divClass "cell button" $ + DomUtil.divVisibleIf isFromCurrentUser $ + R.el "button" Icon.edit + + deletePayment <- + R.divClass "cell button" $ + DomUtil.divVisibleIf isFromCurrentUser $ + _buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn Icon.delete) + { _buttonIn_class = R.constDyn "deletePayment" }) + rec modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment @@ -133,6 +158,6 @@ paymentRow init paymentCategories payment = findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do paymentCategory <- L.find - ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) + ((== T.formatSearch paymentName) . _paymentCategory_name) paymentCategories L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index b49fc55..d7f1db4 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,15 +1,16 @@ module Common.Util.Text ( search - , unaccent + , formatSearch ) where import Data.Text (Text) import qualified Data.Text as T search :: Text -> Text -> Bool -search s t = - (format s) `T.isInfixOf` (format t) - where format = T.toLower . unaccent +search s t = (formatSearch s) `T.isInfixOf` (formatSearch t) + +formatSearch :: Text -> Text +formatSearch = T.toLower . unaccent unaccent :: Text -> Text unaccent = T.map unaccentChar diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 1cfd702..5fd035a 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -6,7 +6,6 @@ module Persistence.PaymentCategory import qualified Data.Maybe as Maybe import Data.Text (Text) -import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -77,4 +76,4 @@ save newName categoryId = Nothing ) where - formattedNewName = T.unaccent . T.toLower $ newName + formattedNewName = T.formatSearch newName -- cgit v1.2.3 From 7c77e52faa71e43324087903c905f9d493b1dfb7 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 8 Aug 2019 21:28:22 +0200 Subject: Finish payment add modal --- README.md | 11 +++-- client/src/Component/Input.hs | 69 +++++++++++++++++++++----------- client/src/Component/Select.hs | 54 ++++++++++++++----------- client/src/Util/Validation.hs | 9 ++++- client/src/View/Payment.hs | 1 + client/src/View/Payment/Add.hs | 36 ++++++++--------- client/src/View/Payment/Header.hs | 34 ++++++++++------ common/src/Common/Message/Translation.hs | 4 +- 8 files changed, 128 insertions(+), 90 deletions(-) diff --git a/README.md b/README.md index 39b5135..39dd428 100644 --- a/README.md +++ b/README.md @@ -60,10 +60,9 @@ See [application.conf](application.conf). ### Payment view -- I should not be able to delete payment of another person -- When removing / modifying a payment, remove the payment category if there is no other payment with the same name -- Use dynamic payments in exceeding payers computation -- Check monthly payment functions +- When removing / modifying a payment, remove the payment category if there is + no other payment with the same name +- Check monthly payment UX - Edit a payment. - Clone a payment. @@ -84,17 +83,17 @@ See [application.conf](application.conf). - HTTP error message - Use only one loader - Login with email and password -- Adjust login design. -- smooth search. - search payments by: - category, - date. ### Code +- Add tests about exceedingPayers - Move up element ids security (editOwn is actually at db level). - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) ### Tooling +- use Obelisk - migration diff (use flyway?). diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index d679f9b..abdc51c 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -40,7 +40,7 @@ defaultInputIn = InputIn data InputOut t a = InputOut { _inputOut_raw :: Dynamic t Text - , _inputOut_value :: Dynamic t (Maybe (Validation Text a)) + , _inputOut_value :: Dynamic t (Validation Text a) , _inputOut_enter :: Event t () } @@ -64,27 +64,14 @@ input inputIn reset validate = do value = R._textInput_value textInput - containerAttr = R.ffor validatedValue (\v -> + containerAttr = R.ffor inputError (\e -> M.singleton "class" $ T.intercalate " " [ "textInput" - , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else "" + , if Maybe.isJust e then "error" else "" ]) - -- Clear validation errors after reset - delayedReset <- R.delay (0.1 :: NominalDiffTime) reset - - validatedValue <- R.holdDyn Nothing $ R.attachWith - (\v (clearValidation, validateEmpty) -> - if clearValidation - then Nothing - else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v))) - (R.current value) - (R.leftmost - [ const (False, True) <$> resetClic - , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput) - , const (False, False) <$> validate - , const (True, False) <$> delayedReset - ]) + let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v)) + inputError <- getInputError valueWithValidation validate (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do @@ -108,7 +95,7 @@ input inputIn reset validate = do return R.never R.divClass "errorMessage" $ - R.dynText . fmap validationError $ validatedValue + R.dynText . fmap (Maybe.fromMaybe "") $ inputError return (textInput, resetClic) @@ -116,10 +103,46 @@ input inputIn reset validate = do return $ InputOut { _inputOut_raw = value - , _inputOut_value = validatedValue + , _inputOut_value = fmap snd valueWithValidation , _inputOut_enter = enter } -validationError :: Maybe (Validation Text a) -> Text -validationError (Just (Failure e)) = e -validationError _ = "" +getInputError + :: forall t m a b c. MonadWidget t m + => Dynamic t (Text, Validation Text a) + -> Event t c + -> m (Dynamic t (Maybe Text)) +getInputError validatedValue validate = do + let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue + errorEvent = R.updated errorDynamic + delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent + fmap (fmap fst) $ R.foldDyn + (\event (err, hasBeenResetted) -> + case event of + ModifiedEvent t -> + (Nothing, T.null t) + + ValidateEvent e -> + (e, False) + + DelayEvent e -> + if hasBeenResetted then + (Nothing, False) + else + (e, False) + ) + (Nothing, False) + (R.leftmost + [ fmap (\(t, _) -> ModifiedEvent t) errorEvent + , fmap (\(_, e) -> DelayEvent e) delayedError + , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate + ]) + +validationError :: (Validation Text a) -> Maybe Text +validationError (Failure e) = Just e +validationError _ = Nothing + +data InputEvent + = ModifiedEvent Text + | DelayEvent (Maybe Text) + | ValidateEvent (Maybe Text) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 43a8a6e..01ed37a 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -4,14 +4,17 @@ module Component.Select , select ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Validation (Validation (Failure, Success)) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R -import qualified Common.Msg as Msg +import qualified Common.Msg as Msg +import qualified Util.Validation as ValidationUtil data (Reflex t) => SelectIn t a b c = SelectIn { _selectIn_label :: Text @@ -24,25 +27,33 @@ data (Reflex t) => SelectIn t a b c = SelectIn } data SelectOut t a = SelectOut - { _selectOut_value :: Dynamic t a + { _selectOut_value :: Dynamic t (Validation Text a) } select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) select selectIn = do rec - let containerAttr = R.ffor hasError (\e -> + let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " [ "selectInput" - , if e then "error" else "" + , if Maybe.isJust e then "error" else "" ]) - hasError <- R.holdDyn False $ R.attachWith - (\v clearError -> not clearError && not (_selectIn_isValid selectIn v)) - (R.current value) - (R.leftmost - [ const False <$> _selectIn_validate selectIn - , const True <$> _selectIn_reset selectIn - ]) + validatedValue = + R.ffor value (\v -> + if _selectIn_isValid selectIn v then + Success v + else + Failure (Msg.get Msg.Form_NonEmpty)) + + maybeError = + fmap ValidationUtil.maybeError validatedValue + + showedError <- R.holdDyn Nothing $ R.leftmost + [ const Nothing <$> _selectIn_reset selectIn + , R.updated maybeError + , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) + ] value <- R.elDynAttr "div" containerAttr $ do R.el "label" $ R.text (_selectIn_label selectIn) @@ -60,16 +71,11 @@ select selectIn = do (_selectIn_values selectIn) (R.def { R._dropdownConfig_setValue = setValue }) - errorMessage <- R.holdDyn "" $ R.attachWith - (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!") - (R.current value) - (_selectIn_validate selectIn) - R.divClass "errorMessage" . R.dynText $ - R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "") + R.ffor showedError (Maybe.fromMaybe "") return value return SelectOut - { _selectOut_value = value + { _selectOut_value = validatedValue } diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index fc13f36..f9545a4 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -1,6 +1,7 @@ module Util.Validation ( nelError , toMaybe + , maybeError , fireValidation , fireMaybe ) where @@ -21,14 +22,18 @@ toMaybe :: Validation a b -> Maybe b toMaybe (Success s) = Just s toMaybe (Failure _) = Nothing +maybeError :: Validation a b -> Maybe a +maybeError (Success _) = Nothing +maybeError (Failure e) = Just e + fireValidation :: forall t a b c. Reflex t - => Dynamic t (Maybe (Validation a b)) + => Dynamic t (Validation a b) -> Event t c -> Event t b fireValidation value validate = R.fmapMaybe - (join . fmap (Validation.validation (const Nothing) Just)) + (Validation.validation (const Nothing) Just) (R.tag (R.current value) validate) fireMaybe diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 05eedab..ae20079 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -53,6 +53,7 @@ widget paymentIn = do header <- Header.widget $ HeaderIn { _headerIn_init = init + , _headerIn_payments = payments , _headerIn_searchPayments = searchPayments , _headerIn_paymentCategories = paymentCategories } diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index d023613..e0772f7 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -66,7 +66,7 @@ view addIn = do , _inputIn_validation = PaymentValidation.name }) reset - validate + confirm cost <- _inputOut_value <$> (Component.input (Component.defaultInputIn @@ -74,7 +74,7 @@ view addIn = do , _inputIn_validation = PaymentValidation.cost }) reset - validate) + confirm) now <- liftIO Time.getCurrentTime @@ -91,7 +91,7 @@ view addIn = do , _inputIn_validation = PaymentValidation.date }) (const currentDay <$> reset) - validate) + confirm) frequency <- _selectOut_value <$> (Component.select $ SelectIn { _selectIn_label = Msg.get Msg.Payment_Frequency @@ -100,7 +100,7 @@ view addIn = do , _selectIn_values = R.constDyn frequencies , _selectIn_reset = reset , _selectIn_isValid = const True - , _selectIn_validate = validate + , _selectIn_validate = confirm }) let setCategory = @@ -115,7 +115,7 @@ view addIn = do , _selectIn_values = R.constDyn categories , _selectIn_reset = reset , _selectIn_isValid = \id -> id /= -1 - , _selectIn_validate = validate + , _selectIn_validate = confirm }) let payment = do @@ -124,24 +124,20 @@ view addIn = do d <- date cat <- category f <- frequency - pure $ do - n' <- n - c' <- c - d' <- d - pure $ CreatePayment - <$> ValidationUtil.nelError n' - <*> ValidationUtil.nelError c' - <*> ValidationUtil.nelError d' - <*> ValidationUtil.nelError (V.Success cat) - <*> ValidationUtil.nelError (V.Success f) - - (addPayment, cancel, validate) <- R.divClass "buttons" $ do + return (CreatePayment + <$> ValidationUtil.nelError n + <*> ValidationUtil.nelError c + <*> ValidationUtil.nelError d + <*> ValidationUtil.nelError cat + <*> ValidationUtil.nelError f) + + (addPayment, cancel, confirm) <- R.divClass "buttons" $ do rec cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) { _buttonIn_class = R.constDyn "undo" }) - validate <- Component._buttonOut_clic <$> (Component.button $ + confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_waiting = waiting @@ -150,9 +146,9 @@ view addIn = do (addPayment, waiting) <- WaitFor.waitFor (Ajax.postJson "/payment") - (ValidationUtil.fireValidation payment validate) + (ValidationUtil.fireValidation payment confirm) - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate) + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) return AddOut { _addOut_cancel = cancel diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 5cc362a..73517f0 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -36,6 +36,7 @@ import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn { _headerIn_init :: Init + , _headerIn_payments :: Dynamic t [Payment] , _headerIn_searchPayments :: Dynamic t [Payment] , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] } @@ -49,7 +50,7 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency + addPayment <- payerAndAdd incomes payments users categories paymentCategories currency let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName @@ -64,7 +65,7 @@ widget headerIn = init = _headerIn_init headerIn incomes = _init_incomes init initPayments = _init_payments init - punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments + payments = _headerIn_payments headerIn users = _init_users init categories = _init_categories init currency = _init_currency init @@ -73,7 +74,7 @@ widget headerIn = payerAndAdd :: forall t m. MonadWidget t m => [Income] - -> [Payment] + -> Dynamic t [Payment] -> [User] -> [Category] -> Dynamic t [PaymentCategory] @@ -82,17 +83,23 @@ payerAndAdd payerAndAdd incomes payments users categories paymentCategories currency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do + + let exceedingPayers = + R.ffor payments $ \ps -> + CM.getExceedingPayers time users incomes $ + filter ((==) Punctual . _payment_frequency) ps + R.divClass "exceedingPayers" $ - forM_ - (CM.getExceedingPayers time users incomes payments) - (\p -> - R.elClass "span" "exceedingPayer" $ do - R.elClass "span" "userName" $ - R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users - R.elClass "span" "amount" $ do - R.text "+ " - R.text . Format.price currency $ _exceedingPayer_amount p - ) + R.simpleList exceedingPayers $ \exceedingPayer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.dynText . R.ffor exceedingPayer $ \ep -> + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users + R.elClass "span" "amount" $ do + R.text "+ " + R.dynText . R.ffor exceedingPayer $ \ep -> + Format.price currency $ _exceedingPayer_amount ep + addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add @@ -100,6 +107,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do , _buttonIn_tabIndex = Nothing , _buttonIn_submit = False }) + rec modalOut <- Component.modal $ ModalIn { _modalIn_show = addPaymentClic diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index e95fa74..4eb0523 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -189,8 +189,8 @@ m l Form_InvalidColor = m l Form_InvalidDate = case l of - English -> "DD/MM/YYYY required" - French -> "JJ/MM/AAAA requis" + English -> "Date required" + French -> "Date requise" m l Form_InvalidInt = case l of -- cgit v1.2.3 From 3943c50d5320f7137bd5acec4485dd56a2aa52b3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 09:59:22 +0200 Subject: Debounce payments search --- client/src/View/Payment.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index ae20079..915cc18 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -6,6 +6,7 @@ module View.Payment import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R @@ -47,10 +48,16 @@ widget paymentIn = do let searchPayments = getSearchPayments - (_headerOut_searchName header) + debouncedSearchName (_headerOut_searchFrequency header) payments + debouncedSearchNameEvt <- + R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header) + + debouncedSearchName <- + R.holdDyn "" debouncedSearchNameEvt + header <- Header.widget $ HeaderIn { _headerIn_init = init , _headerIn_payments = payments @@ -70,8 +77,8 @@ widget paymentIn = do { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ - [ fmap (const ()) . R.updated . _headerOut_searchName $ header - , fmap (const ()) . _headerOut_addPayment $ header + [ const () <$> debouncedSearchNameEvt + , const () <$> _headerOut_addPayment header ] } -- cgit v1.2.3 From fb8f0fe577e28dae69903413b761da50586e0099 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 14:53:41 +0200 Subject: Remove payment category if unused after a payment is deleted --- README.md | 11 ++++--- client/src/View/Payment.hs | 49 +++++++++++++++++++++---------- client/src/View/Payment/Add.hs | 3 +- client/src/View/Payment/Delete.hs | 35 +++++++++++----------- client/src/View/Payment/Table.hs | 12 ++++---- common/src/Common/Message/Key.hs | 1 - common/src/Common/Message/Translation.hs | 5 ---- server/migrations/2.sql | 23 +++++++++++++++ server/src/Controller/Income.hs | 33 ++++++++------------- server/src/Controller/Payment.hs | 37 ++++++++++++++--------- server/src/Main.hs | 8 ++--- server/src/Persistence/Income.hs | 34 ++++++++------------- server/src/Persistence/Payment.hs | 34 +++++++-------------- server/src/Persistence/PaymentCategory.hs | 14 +++++++-- 14 files changed, 163 insertions(+), 136 deletions(-) create mode 100644 server/migrations/2.sql diff --git a/README.md b/README.md index 39dd428..dbffc41 100644 --- a/README.md +++ b/README.md @@ -60,10 +60,9 @@ See [application.conf](application.conf). ### Payment view -- When removing / modifying a payment, remove the payment category if there is - no other payment with the same name - Check monthly payment UX - Edit a payment. +- Possibly remove payment category after payment edit - Clone a payment. ### Income view @@ -89,11 +88,15 @@ See [application.conf](application.conf). ### Code +- Move the CSS out from the index page - Add tests about exceedingPayers -- Move up element ids security (editOwn is actually at db level). - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) +### DB + +- Add DB indexes + ### Tooling -- use Obelisk +- deploy command - migration diff (use flyway?). diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 915cc18..46ab642 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -45,18 +45,14 @@ widget paymentIn = do paymentCategories <- getPaymentCategories (_init_paymentCategories init) (_createdPayment_paymentCategory <$> _headerOut_addPayment header) + payments + (_tableOut_deletePayment table) - let searchPayments = - getSearchPayments - debouncedSearchName - (_headerOut_searchFrequency header) - payments - - debouncedSearchNameEvt <- - R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header) + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) - debouncedSearchName <- - R.holdDyn "" debouncedSearchNameEvt + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments header <- Header.widget $ HeaderIn { _headerIn_init = init @@ -77,34 +73,57 @@ widget paymentIn = do { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ - [ const () <$> debouncedSearchNameEvt + [ const () <$> searchNameEvent , const () <$> _headerOut_addPayment header ] } pure $ PaymentOut {} +debounceSearchName + :: forall t m. MonadWidget t m + => Dynamic t Text + -> m (Event t Text, Dynamic t Text) +debounceSearchName searchName = do + event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) + dynamic <- R.holdDyn "" event + return (event, dynamic) + getPayments :: forall t m. MonadWidget t m => [Payment] -> Event t Payment - -> Event t PaymentId + -> Event t Payment -> m (Dynamic t [Payment]) getPayments initPayments addPayment deletePayment = R.foldDyn id initPayments $ R.leftmost [ (:) <$> addPayment - , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id)) + , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) ] getPaymentCategories :: forall t m. MonadWidget t m => [PaymentCategory] - -> Event t PaymentCategory + -> Event t PaymentCategory -- add payment category + -> Dynamic t [Payment] -- payments + -> Event t Payment -- delete payment -> m (Dynamic t [PaymentCategory]) -getPaymentCategories initPaymentCategories addPaymentCategory = +getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment = R.foldDyn id initPaymentCategories $ R.leftmost [ (:) <$> addPaymentCategory + , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) ] + where + deletePaymentName = + R.attachWithMaybe + (\ps p -> + if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then + Nothing + else + Just (_payment_name p)) + (R.current payments) + deletePayment + lowerName = T.toLower . _payment_name getSearchPayments :: forall t. Reflex t diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index e0772f7..bd10e5a 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -23,7 +23,6 @@ import Common.Model (Category (..), CategoryId, CreatedPayment (..), Frequency (..), Payment (..), PaymentCategory (..)) import qualified Common.Msg as Msg -import qualified Common.Util.Text as Text import qualified Common.Util.Time as Time import qualified Common.Validation.Payment as PaymentValidation import Component (ButtonIn (..), InputIn (..), @@ -168,4 +167,4 @@ view addIn = do findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = fmap _paymentCategory_category - . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name) + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 4aa10f3..65ce660 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,26 +4,26 @@ module View.Payment.Delete , DeleteOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model.Payment (PaymentId) -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment (..)) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor data DeleteIn t = DeleteIn - { _deleteIn_id :: Dynamic t PaymentId + { _deleteIn_payment :: Dynamic t Payment } data DeleteOut t = DeleteOut { _deleteOut_cancel :: Event t () - , _deleteOut_validate :: Event t PaymentId + , _deleteOut_validate :: Event t Payment } view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) @@ -47,8 +47,9 @@ view deleteIn = , _buttonIn_waiting = waiting }) - let url = flip fmap (_deleteIn_id deleteIn) (\id -> - T.concat ["/payment/", T.pack . show $ id] + let url = + R.ffor (_deleteIn_payment deleteIn) (\id -> + T.concat ["/payment/", T.pack . show $ _payment_id id] ) (result, waiting) <- WaitFor.waitFor @@ -59,5 +60,5 @@ view deleteIn = return DeleteOut { _deleteOut_cancel = cancel - , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment + , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index cdc4bb3..b09f30f 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,11 +13,9 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), PaymentId, - User (..)) + PaymentCategory (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg -import qualified Common.Util.Text as T import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), ModalIn (..), ModalOut (..)) @@ -37,7 +35,7 @@ data TableIn t = TableIn } data TableOut t = TableOut - { _tableOut_deletePayment :: Event t PaymentId + { _tableOut_deletePayment :: Event t Payment } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) @@ -84,7 +82,7 @@ paymentRow => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment - -> m (Event t PaymentId) + -> m (Event t Payment) paymentRow init paymentCategories payment = R.divClass "row" $ do @@ -151,13 +149,13 @@ paymentRow init paymentCategories payment = [ _deleteOut_cancel . _modalOut_content $ modalOut , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut ] - , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) + , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment }) } return (_deleteOut_validate . _modalOut_content $ modalOut) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do paymentCategory <- L.find - ((== T.formatSearch paymentName) . _paymentCategory_name) + ((== T.toLower paymentName) . _paymentCategory_name) paymentCategories L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 4acba93..e460d3e 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -64,7 +64,6 @@ data Key = | Income_Edit | Income_Empty | Income_MonthlyNet - | Income_NotDeleted | Income_Title | Month_January diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 4eb0523..6b9e7be 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -277,11 +277,6 @@ m l Income_MonthlyNet = English -> "Net monthly incomes" French -> "Revenus mensuels nets" -m l Income_NotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n’a pas pu être supprimé." - m l Income_Title = case l of English -> "Income" diff --git a/server/migrations/2.sql b/server/migrations/2.sql new file mode 100644 index 0000000..1c829ec --- /dev/null +++ b/server/migrations/2.sql @@ -0,0 +1,23 @@ +-- Add payment categories with accents from payment with accents + +INSERT INTO + payment_category (name, category, created_at) +SELECT + DISTINCT lower(payment.name), payment_category.category, datetime('now') +FROM + payment +INNER JOIN + payment_category +ON + replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(payment.name), 'é', 'e'), 'è', 'e'), 'à', 'a'), 'û', 'u'), 'â', 'a'), 'ê', 'e'), 'â', 'a'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ë', 'e') = payment_category.name +WHERE + payment.name +IN + (SELECT DISTINCT payment.name FROM payment WHERE lower(payment.name) NOT IN (SELECT payment_category.name FROM payment_category) AND payment.deleted_at IS NULL); + +-- Remove unused payment categories + +DELETE FROM + payment_category +WHERE + name NOT IN (SELECT DISTINCT lower(name) FROM payment); diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 3f623e5..ed58ac8 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,17 +1,15 @@ module Controller.Income ( create - , editOwn - , deleteOwn + , edit + , delete ) where import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty hiding (delete) import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) -import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Query as Query @@ -24,23 +22,18 @@ create (CreateIncome date amount) = (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId ) -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = +edit :: EditIncome -> ActionM () +edit (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount + updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount if updated - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = +delete :: IncomeId -> ActionM () +delete incomeId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted + _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId + status Status.ok200 ) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e82fd49..3d857be 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,18 +1,18 @@ module Controller.Payment ( list , create - , editOwn - , deleteOwn + , edit + , delete ) where import Control.Monad.IO.Class (liftIO) import qualified Network.HTTP.Types.Status as Status -import Web.Scotty +import Web.Scotty hiding (delete) import Common.Model (CreatePayment (..), CreatedPayment (..), - EditPayment (..), PaymentId, - User (..)) + EditPayment (..), Payment (..), + PaymentId, User (..)) import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -41,11 +41,11 @@ create createPayment@(CreatePayment name cost date category frequency) = json validationError ) -editOwn :: EditPayment -> ActionM () -editOwn (EditPayment paymentId name cost date category frequency) = +edit :: EditPayment -> ActionM () +edit (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency + edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategoryPersistence.save name category >> return () else return () @@ -55,11 +55,20 @@ editOwn (EditPayment paymentId name cost date category frequency) = else status Status.badRequest400 ) -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = +delete :: PaymentId -> ActionM () +delete paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId - if deleted - then status Status.ok200 - else status Status.badRequest400 + deleted <- liftIO . Query.run $ do + payment <- PaymentPersistence.find paymentId + case payment of + Just p | _payment_user p == _user_id user -> do + PaymentPersistence.delete (_user_id user) paymentId + PaymentCategoryPersistence.deleteIfUnused (_payment_name p) + return True + _ -> + return False + if deleted then + status Status.ok200 + else + status Status.badRequest400 ) diff --git a/server/src/Main.hs b/server/src/Main.hs index 745071c..0ccf5e2 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -35,21 +35,21 @@ main = do S.jsonData >>= Payment.create S.put "/payment" $ - S.jsonData >>= Payment.editOwn + S.jsonData >>= Payment.edit S.delete "/payment/:id" $ do paymentId <- S.param "id" - Payment.deleteOwn paymentId + Payment.delete paymentId S.post "/income" $ S.jsonData >>= Income.create S.put "/income" $ - S.jsonData >>= Income.editOwn + S.jsonData >>= Income.edit S.delete "/income/:id" $ do incomeId <- S.param "id" - Income.deleteOwn incomeId + Income.delete incomeId S.post "/category" $ S.jsonData >>= Category.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index a863f85..cee9892 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,8 +1,8 @@ module Persistence.Income ( list , create - , editOwn - , deleteOwn + , edit + , delete ) where import Data.Maybe (listToMaybe) @@ -12,7 +12,7 @@ import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) -import Common.Model (Income (..), IncomeId, User (..), +import Common.Model (Income (..), IncomeId, PaymentId, UserId) import Model.Query (Query (Query)) @@ -47,8 +47,8 @@ create incomeUserId incomeDate incomeAmount = SQLite.lastInsertRowId conn ) -editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool -editOwn incomeUserId incomeId incomeDate incomeAmount = +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool +edit incomeUserId incomeId incomeDate incomeAmount = Query (\conn -> do mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) @@ -68,21 +68,11 @@ editOwn incomeUserId incomeId incomeDate incomeAmount = return False ) -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- - fmap (\(Row i) -> i) . listToMaybe <$> - SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False +delete :: UserId -> PaymentId -> Query () +delete userId paymentId = + Query (\conn -> + SQLite.execute + conn + "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" + (paymentId, userId) ) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 272cd39..3d8f129 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -6,8 +6,8 @@ module Persistence.Payment , listActiveMonthlyOrderedByName , create , createMany - , editOwn - , deleteOwn + , edit + , delete ) where import Data.Maybe (listToMaybe) @@ -129,8 +129,8 @@ createMany payments = (map InsertRow payments) ) -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +edit userId paymentId paymentName paymentCost paymentDate paymentFrequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) @@ -158,23 +158,11 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = return False ) -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just (Row payment) -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False +delete :: UserId -> PaymentId -> Query () +delete userId paymentId = + Query (\conn -> + SQLite.execute + conn + "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" + (paymentId, userId) ) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 5fd035a..7dc363c 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -2,16 +2,17 @@ module Persistence.PaymentCategory ( list , listByCategory , save + , deleteIfUnused ) where import qualified Data.Maybe as Maybe import Data.Text (Text) +import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite import Common.Model (CategoryId, PaymentCategory (..)) -import qualified Common.Util.Text as T import Model.Query (Query (Query)) @@ -76,4 +77,13 @@ save newName categoryId = Nothing ) where - formattedNewName = T.formatSearch newName + formattedNewName = T.toLower newName + +deleteIfUnused :: Text -> Query () +deleteIfUnused name = + Query (\conn -> + SQLite.execute + conn + "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)" + (name, name) + ) >> return () -- cgit v1.2.3 From 234b5b29361734656dc780148309962f932d9907 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 15:07:11 +0200 Subject: Use select component in payment search line --- README.md | 1 + client/src/Component/Select.hs | 6 ++++-- client/src/View/Payment/Header.hs | 15 ++++++++++++--- server/src/Design/View/Payment/Header.hs | 6 ++---- 4 files changed, 19 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index dbffc41..9f9b64b 100644 --- a/README.md +++ b/README.md @@ -88,6 +88,7 @@ See [application.conf](application.conf). ### Code +- Use BEM style - Move the CSS out from the index page - Add tests about exceedingPayers - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 01ed37a..cf62f26 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -27,7 +27,8 @@ data (Reflex t) => SelectIn t a b c = SelectIn } data SelectOut t a = SelectOut - { _selectOut_value :: Dynamic t (Validation Text a) + { _selectOut_raw :: Dynamic t a + , _selectOut_value :: Dynamic t (Validation Text a) } select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) @@ -77,5 +78,6 @@ select selectIn = do return value return SelectOut - { _selectOut_value = validatedValue + { _selectOut_raw = value + , _selectOut_value = validatedValue } diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 73517f0..7a85493 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -28,7 +28,8 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..), ModalOut (..)) + ModalIn (..), ModalOut (..), + SelectIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.List as L import View.Payment.Add (AddIn (..), AddOut (..)) @@ -140,8 +141,16 @@ searchLine reset = do , (Monthly, Msg.get Msg.Payment_MonthlyMale) ] - searchFrequency <- R._dropdown_value <$> - R.dropdown Punctual (R.constDyn frequencies) R.def + searchFrequency <- _selectOut_raw <$> (Component.select $ + SelectIn + { _selectIn_label = "" + , _selectIn_initialValue = Punctual + , _selectIn_value = R.never + , _selectIn_values = R.constDyn frequencies + , _selectIn_reset = R.never + , _selectIn_isValid = const True + , _selectIn_validate = R.never + }) return (searchName, searchFrequency) diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 0cb5b5d..9111374 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -59,10 +59,8 @@ design = do marginBottom (em 1) width (pct 100) - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock ".infos" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) -- cgit v1.2.3 From c5c54722f4736108c8418c9865f81f05a6db560d Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 15:29:56 +0200 Subject: Fix payment add frequency to the one selected in the page --- README.md | 1 - client/src/View/Payment/Add.hs | 15 +++------------ client/src/View/Payment/Header.hs | 23 +++++++++++++++++------ 3 files changed, 20 insertions(+), 19 deletions(-) diff --git a/README.md b/README.md index 9f9b64b..dfa417f 100644 --- a/README.md +++ b/README.md @@ -60,7 +60,6 @@ See [application.conf](application.conf). ### Payment view -- Check monthly payment UX - Edit a payment. - Possibly remove payment category after payment edit - Clone a payment. diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index bd10e5a..d2d2dc4 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -37,6 +37,7 @@ import qualified Util.WaitFor as WaitFor data AddIn t = AddIn { _addIn_categories :: [Category] , _addIn_paymentCategories :: Dynamic t [PaymentCategory] + , _addIn_frequency :: Dynamic t Frequency , _addIn_cancel :: Event t () } @@ -92,16 +93,6 @@ view addIn = do (const currentDay <$> reset) confirm) - frequency <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Frequency - , _selectIn_initialValue = Punctual - , _selectIn_value = R.never - , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = reset - , _selectIn_isValid = const True - , _selectIn_validate = confirm - }) - let setCategory = R.fmapMaybe id . R.updated @@ -122,13 +113,13 @@ view addIn = do c <- cost d <- date cat <- category - f <- frequency + f <- _addIn_frequency addIn return (CreatePayment <$> ValidationUtil.nelError n <*> ValidationUtil.nelError c <*> ValidationUtil.nelError d <*> ValidationUtil.nelError cat - <*> ValidationUtil.nelError f) + <*> V.Success f) (addPayment, cancel, confirm) <- R.divClass "buttons" $ do rec diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 7a85493..fa21731 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -51,11 +51,20 @@ data HeaderOut t = HeaderOut widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do - addPayment <- payerAndAdd incomes payments users categories paymentCategories currency - let resetSearchName = fmap (const ()) $ addPayment - (searchName, searchFrequency) <- searchLine resetSearchName - - infos (_headerIn_searchPayments headerIn) users currency + rec + addPayment <- + payerAndAdd + incomes + payments + users + categories + paymentCategories + currency + searchFrequency + let resetSearchName = fmap (const ()) $ addPayment + (searchName, searchFrequency) <- searchLine resetSearchName + + infos (_headerIn_searchPayments headerIn) users currency return $ HeaderOut { _headerOut_searchName = searchName @@ -80,8 +89,9 @@ payerAndAdd -> [Category] -> Dynamic t [PaymentCategory] -> Currency + -> Dynamic t Frequency -> m (Event t CreatedPayment) -payerAndAdd incomes payments users categories paymentCategories currency = do +payerAndAdd incomes payments users categories paymentCategories currency frequency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -119,6 +129,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories , _addIn_paymentCategories = paymentCategories + , _addIn_frequency = frequency , _addIn_cancel = _modalOut_hide modalOut } } -- cgit v1.2.3 From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 21:31:27 +0200 Subject: Add smooth transitions to modal show and hide --- .stylish-haskell.yaml | 1 + README.md | 5 ++- client/client.cabal | 1 + client/src/Component/Modal.hs | 79 ++++++++++++++++++++++++++------------- client/src/Component/Select.hs | 4 +- client/src/Util/WaitFor.hs | 2 +- client/src/View/Payment.hs | 4 +- client/src/View/Payment/Add.hs | 8 ++-- client/src/View/Payment/Header.hs | 2 +- client/src/View/SignIn.hs | 4 +- common/common.cabal | 1 + server/server.cabal | 1 + server/src/Design/Form.hs | 33 +--------------- server/src/Design/Global.hs | 7 ++-- server/src/Design/Modal.hs | 39 +++++++++++++++---- 15 files changed, 108 insertions(+), 83 deletions(-) diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index a3f992d..034ace0 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -27,6 +27,7 @@ newline: native language_extensions: - ExistentialQuantification + - LambdaCase - MultiParamTypeClasses - OverloadedStrings - RecursiveDo diff --git a/README.md b/README.md index dfa417f..19309f5 100644 --- a/README.md +++ b/README.md @@ -60,9 +60,10 @@ See [application.conf](application.conf). ### Payment view -- Edit a payment. +- Edit a payment - Possibly remove payment category after payment edit -- Clone a payment. +- Clone a payment +- Add icon tooltip ### Income view diff --git a/client/client.cabal b/client/client.cabal index af71f2d..ce3c059 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -16,6 +16,7 @@ Executable client Default-extensions: ExistentialQuantification + LambdaCase MultiParamTypeClasses OverloadedStrings RecursiveDo diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index d7943a9..fac417e 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -8,6 +8,8 @@ import Control.Monad (void) import qualified Data.Map as M import qualified Data.Map.Lazy as LM import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) import qualified GHCJS.DOM.Element as Element import qualified GHCJS.DOM.Node as Node import JSDOM.Types (JSString) @@ -31,52 +33,75 @@ data ModalOut t a = ModalOut modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) modal modalIn = do rec - let showEvent = R.leftmost - [ True <$ _modalIn_show modalIn - , False <$ _modalIn_hide modalIn - , False <$ curtainClick - ] + let show = Show <$ (_modalIn_show modalIn) - showModal <- R.holdDyn False showEvent + startHiding = + R.attachWithMaybe + (\a _ -> if a then Just StartHiding else Nothing) + (R.current canBeHidden) + (R.leftmost [ _modalIn_hide modalIn, curtainClick ]) + + canBeHidden <- + R.holdDyn True $ R.leftmost + [ False <$ startHiding + , True <$ endHiding + ] + + endHiding <- + R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding) + + let action = + R.leftmost [ show, startHiding, endHiding ] + + modalClass <- + R.holdDyn "" (fmap getModalClass action) (elem, (curtainClick, content)) <- - R.buildElement "div" (getAttributes <$> showModal) $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank - cont <- R.divClass "modalContent" $ _modalIn_content modalIn - return (R.domEvent R.Click curtain, cont) + R.buildElement "div" (fmap getAttributes modalClass) $ do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank + content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn + return (R.domEvent R.Click curtain, content) - performShowEffects showEvent elem + performShowEffects action elem return $ ModalOut { _modalOut_content = content , _modalOut_hide = curtainClick } -getAttributes :: Bool -> LM.Map Text Text -getAttributes show = - M.fromList $ - [ ("style", if show then "display:block" else "display:none") - , ("class", "modal") - ] +getAttributes :: Text -> LM.Map Text Text +getAttributes modalClass = + M.singleton "class" $ + T.intercalate " " [ "g-Modal", modalClass] performShowEffects :: forall t m a. MonadWidget t m - => Event t Bool + => Event t Action -> Element.Element -> m () performShowEffects showEvent elem = do body <- Dom.getBody let showEffects = - flip fmap showEvent (\show -> do - if show then - do - Node.appendChild body elem - Element.setClassName body ("modal" :: JSString) - else - do - Node.removeChild body elem - Element.setClassName body ("" :: JSString) + flip fmap showEvent (\case + Show -> do + Node.appendChild body elem + Element.setClassName body ("g-Body--Modal" :: JSString) + StartHiding -> + return () + EndHiding -> do + Node.removeChild body elem + Element.setClassName body ("" :: JSString) ) R.performEvent_ $ void `fmap` showEffects + +data Action + = Show + | StartHiding + | EndHiding + +getModalClass :: Action -> Text +getModalClass Show = "g-Modal--Show" +getModalClass StartHiding = "g-Modal--Hiding" +getModalClass _ = "" diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index cf62f26..9a37afc 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -51,7 +51,7 @@ select selectIn = do fmap ValidationUtil.maybeError validatedValue showedError <- R.holdDyn Nothing $ R.leftmost - [ const Nothing <$> _selectIn_reset selectIn + [ Nothing <$ _selectIn_reset selectIn , R.updated maybeError , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) ] @@ -62,7 +62,7 @@ select selectIn = do let initialValue = _selectIn_initialValue selectIn let setValue = R.leftmost - [ const initialValue <$> (_selectIn_reset selectIn) + [ initialValue <$ (_selectIn_reset selectIn) , _selectIn_value selectIn ] diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs index 02edff5..fe7b733 100644 --- a/client/src/Util/WaitFor.hs +++ b/client/src/Util/WaitFor.hs @@ -13,5 +13,5 @@ waitFor -> m (Event t b, Event t Bool) waitFor op input = do result <- op input >>= R.debounce (0.5 :: NominalDiffTime) - let waiting = R.leftmost [ const True <$> input , const False <$> result ] + let waiting = R.leftmost [ True <$ input , False <$ result ] return (result, waiting) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 46ab642..f363b06 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -73,8 +73,8 @@ widget paymentIn = do { _pagesIn_total = length <$> searchPayments , _pagesIn_perPage = paymentsPerPage , _pagesIn_reset = R.leftmost $ - [ const () <$> searchNameEvent - , const () <$> _headerOut_addPayment header + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header ] } diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index d2d2dc4..69e29a7 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -55,9 +55,9 @@ view addIn = do R.divClass "addContent" $ do rec let reset = R.leftmost - [ const "" <$> cancel - , const "" <$> addPayment - , const "" <$> _addIn_cancel addIn + [ "" <$ cancel + , "" <$ addPayment + , "" <$ _addIn_cancel addIn ] name <- Component.input @@ -90,7 +90,7 @@ view addIn = do , _inputIn_hasResetButton = False , _inputIn_validation = PaymentValidation.date }) - (const currentDay <$> reset) + (currentDay <$ reset) confirm) let setCategory = diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index fa21731..1bdee8d 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -144,7 +144,7 @@ searchLine reset = do R.divClass "searchLine" $ do searchName <- _inputOut_raw <$> (Component.input ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) - (const "" <$> reset) + ("" <$ reset) R.never) let frequencies = M.fromList diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 6fbf6d6..f8b985f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -37,7 +37,7 @@ view signInMessage = { _inputIn_label = Msg.get Msg.SignIn_EmailLabel , _inputIn_validation = SignInValidation.email }) - (const "" <$> R.ffilter Either.isRight signInResult) + ("" <$ R.ffilter Either.isRight signInResult) validate) validate <- _buttonOut_clic <$> (Component.button $ @@ -52,7 +52,7 @@ view signInMessage = (signInResult, waiting) <- WaitFor.waitFor (Ajax.postJson "/askSignIn") (ValidationUtil.fireMaybe - ((\f -> const f <$> SignInValidation.signIn f) <$> form) + ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) showSignInResult signInMessage signInResult diff --git a/common/common.cabal b/common/common.cabal index b7e0416..0edd8e2 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -16,6 +16,7 @@ Library Default-extensions: DeriveGeneric ExistentialQuantification + LambdaCase MultiParamTypeClasses OverloadedStrings diff --git a/server/server.cabal b/server/server.cabal index d6c4a9b..3bc8e42 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -16,6 +16,7 @@ Executable server Default-extensions: ExistentialQuantification + LambdaCase MultiParamTypeClasses OverloadedStrings diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 31a2127..0f236f7 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -14,7 +14,6 @@ design = do let inputHeight = 30 let inputTop = 22 let inputPaddingBottom = 3 - let inputZIndex = 1 label ? do cursor pointer @@ -29,9 +28,9 @@ design = do input ? do width (pct 100) position relative - zIndex inputZIndex backgroundColor transparent paddingBottom (px inputPaddingBottom) + paddingRight (px 14) -- Space for the delete icon borderStyle none borderBottom solid (px 1) Color.dustyGray marginBottom (px 5) @@ -52,7 +51,6 @@ design = do position absolute right (px 0) top (px 27) - zIndex inputZIndex svg ? "path" ? ("fill" -: Color.toString Color.silver) hover & svg ? "path" ? @@ -80,35 +78,6 @@ design = do borderColor transparent backgroundColor transparent - ".radioGroup" ? do - position relative - marginBottom (em 2) - - ".title" ? do - color Color.silver - marginBottom (em 0.8) - - ".radioInputs" ? do - display flex - "justify-content" -: "center" - - ".radioInput:not(:last-child)::after" ? do - content (stringContent "/") - marginLeft (px 10) - marginRight (px 10) - - input ? do - opacity 0 - width (px 30) - margin (px 0) (px (-15)) (px 0) (px (-15)) - - "input:focus + label" ? do - textDecoration underline - - "input:checked + label" ? do - color Color.chestnutRose - fontWeight bold - ".selectInput" ? do marginBottom (em 2) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 66e9f47..24d999f 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -22,7 +22,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design - ".modal" ? Modal.design + Modal.design ".tooltip" ? Tooltip.design Views.design Form.design @@ -33,13 +33,14 @@ global = do html ? do height (pct 100) + "g-Body--Modal" ? + overflowY hidden + body ? do position relative minWidth (px 320) height (pct 100) fontFamily ["Cantarell"] [sansSerif] - ".modal" & - overflowY hidden Media.tablet $ do fontSize (px 15) button ? fontSize (px 15) diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 9c016b9..dce2ef9 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -11,24 +11,37 @@ import qualified Design.View.Payment.Delete as Delete design :: Css design = do - ".modalCurtain" ? do + appearKeyframe + + ".g-Modal" ? do + appearAnimation + transition "all" (sec 0.2) ease (sec 0) + display none + opacity 0 + + ".g-Modal--Show" & do + display block + opacity 1 + + ".g-Modal--Hiding" & do + display block + + ".g-Modal__Curtain" ? do position fixed top (px 0) left (px 0) width (pct 100) height (pct 100) - backgroundColor (rgba 0 0 0 0.7) - zIndex 1000 - opacity 1 - transition "all" (sec 0.2) ease (sec 0) + backgroundColor (rgba 0 0 0 0.6) + zIndex 1 - ".modalContent" ? do + ".g-Modal__Content" ? do minWidth (px 300) position fixed top (pct 25) left (pct 50) "transform" -: "translate(-50%, -25%)" - zIndex 1000 + zIndex 1 backgroundColor white sym borderRadius (px 5) boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) @@ -44,3 +57,15 @@ design = do ".deletePaymentModal" <> ".deleteIncomeModal" ? do h1 ? marginBottom (em 1.5) + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.15) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] -- cgit v1.2.3 From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 11 Aug 2019 22:40:09 +0200 Subject: Add payment clone --- README.md | 13 ++- client/client.cabal | 5 +- client/src/Component/Modal.hs | 63 +++++----- client/src/Util/Dom.hs | 45 ------- client/src/Util/Reflex.hs | 52 +++++++++ client/src/View/Payment.hs | 14 ++- client/src/View/Payment/Add.hs | 187 +++++++----------------------- client/src/View/Payment/Clone.hs | 60 ++++++++++ client/src/View/Payment/Delete.hs | 57 +++++---- client/src/View/Payment/Edit.hs | 55 +++++++++ client/src/View/Payment/Form.hs | 165 ++++++++++++++++++++++++++ client/src/View/Payment/Header.hs | 39 +++---- client/src/View/Payment/Pages.hs | 14 +-- client/src/View/Payment/Table.hs | 109 ++++++++++++----- common/common.cabal | 2 +- common/src/Common/Model.hs | 2 +- common/src/Common/Model/CreatedPayment.hs | 17 --- common/src/Common/Model/EditPayment.hs | 3 +- common/src/Common/Model/SavedPayment.hs | 17 +++ server/server.cabal | 1 + server/src/Controller/Payment.hs | 29 +++-- server/src/Design/Modal.hs | 4 +- server/src/Design/View/Payment/Form.hs | 35 ++++++ server/src/Persistence/Payment.hs | 66 +++++++---- 24 files changed, 678 insertions(+), 376 deletions(-) delete mode 100644 client/src/Util/Dom.hs create mode 100644 client/src/Util/Reflex.hs create mode 100644 client/src/View/Payment/Clone.hs create mode 100644 client/src/View/Payment/Edit.hs create mode 100644 client/src/View/Payment/Form.hs delete mode 100644 common/src/Common/Model/CreatedPayment.hs create mode 100644 common/src/Common/Model/SavedPayment.hs create mode 100644 server/src/Design/View/Payment/Form.hs diff --git a/README.md b/README.md index 19309f5..bc9e98c 100644 --- a/README.md +++ b/README.md @@ -58,12 +58,16 @@ See [application.conf](application.conf). ## TODO +### Fix + +- When clicking on an input label, focus to the input + ### Payment view - Edit a payment -- Possibly remove payment category after payment edit -- Clone a payment -- Add icon tooltip +- Possibly remove payment category after payment edit (frontend) +- Remove old validation, use client validation on the backend +- Add icon tooltip ? ### Income view @@ -88,6 +92,7 @@ See [application.conf](application.conf). ### Code +- remove client warning messages - Use BEM style - Move the CSS out from the index page - Add tests about exceedingPayers @@ -101,3 +106,5 @@ See [application.conf](application.conf). - deploy command - migration diff (use flyway?). +- utiliser ghcid +- set up fast deploy diff --git a/client/client.cabal b/client/client.cabal index ce3c059..5fc20ae 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -44,16 +44,19 @@ Executable client Component.Select Icon Util.Ajax - Util.Dom Util.Either Util.List + Util.Reflex Util.Validation Util.WaitFor View.App View.Header View.Payment View.Payment.Add + View.Payment.Clone View.Payment.Delete + View.Payment.Edit + View.Payment.Form View.Payment.Header View.Payment.Pages View.Payment.Table diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index fac417e..96c2679 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,7 +1,7 @@ module Component.Modal - ( ModalIn(..) - , ModalOut(..) - , modal + ( Input(..) + , Content + , view ) where import Control.Monad (void) @@ -17,29 +17,26 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import qualified Reflex.Dom.Class as R -import qualified Util.Dom as Dom +import qualified Util.Reflex as ReflexUtil -data ModalIn t m a = ModalIn - { _modalIn_show :: Event t () - , _modalIn_hide :: Event t () - , _modalIn_content :: m a - } +-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) +type Content t m a = Event t () -> m (Event t (), Event t a) -data ModalOut t a = ModalOut - { _modalOut_content :: a - , _modalOut_hide :: Event t () +data Input t m a = Input + { _input_show :: Event t () + , _input_content :: Content t m a } -modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a) -modal modalIn = do +view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a) +view input = do rec - let show = Show <$ (_modalIn_show modalIn) + let show = Show <$ (_input_show input) startHiding = R.attachWithMaybe (\a _ -> if a then Just StartHiding else Nothing) (R.current canBeHidden) - (R.leftmost [ _modalIn_hide modalIn, curtainClick ]) + (R.leftmost [ hide, curtainClick ]) canBeHidden <- R.holdDyn True $ R.leftmost @@ -56,18 +53,25 @@ modal modalIn = do modalClass <- R.holdDyn "" (fmap getModalClass action) - (elem, (curtainClick, content)) <- - R.buildElement "div" (fmap getAttributes modalClass) $ do - (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank - content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn - return (R.domEvent R.Click curtain, content) + (elem, dyn) <- + R.buildElement "div" (getAttributes <$> modalClass) $ + ReflexUtil.visibleIfEvent + (isVisible <$> action) + (R.blank >> return (R.never, R.never, R.never)) + (do + (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank + let curtainClick = R.domEvent R.Click curtain + (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick) + return (curtainClick, hide, content)) + - performShowEffects action elem + performShowEffects action elem - return $ ModalOut - { _modalOut_content = content - , _modalOut_hide = curtainClick - } + let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn + let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn + let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn + + return content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = @@ -80,7 +84,7 @@ performShowEffects -> Element.Element -> m () performShowEffects showEvent elem = do - body <- Dom.getBody + body <- ReflexUtil.getBody let showEffects = flip fmap showEvent (\case @@ -105,3 +109,8 @@ getModalClass :: Action -> Text getModalClass Show = "g-Modal--Show" getModalClass StartHiding = "g-Modal--Hiding" getModalClass _ = "" + +isVisible :: Action -> Bool +isVisible Show = True +isVisible StartHiding = True +isVisible EndHiding = False diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs deleted file mode 100644 index 55b8521..0000000 --- a/client/src/Util/Dom.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Util.Dom - ( divIfDyn - , divIfEvent - , divVisibleIf - , divClassVisibleIf - , getBody - ) where - -import qualified Data.Map as M -import Data.Text (Text) -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.Document as Document -import qualified GHCJS.DOM.HTMLCollection as HTMLCollection -import GHCJS.DOM.Types (Element) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a) -divIfDyn cond = divIfEvent (R.updated cond) - -divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) -divIfEvent cond empty content = - R.widgetHold empty (flip fmap cond (\show -> - if show - then - content - else - empty)) - -divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -divVisibleIf cond content = divClassVisibleIf cond "" content - -divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a -divClassVisibleIf cond className content = - R.elDynAttr - "div" - (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) - content - -getBody :: forall t m. MonadWidget t m => m Element -getBody = do - document <- Dom.currentDocumentUnchecked - nodelist <- Document.getElementsByTagName document ("body" :: String) - Just body <- nodelist `HTMLCollection.item` 0 - return body diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs new file mode 100644 index 0000000..c14feeb --- /dev/null +++ b/client/src/Util/Reflex.hs @@ -0,0 +1,52 @@ +module Util.Reflex + ( visibleIfDyn + , visibleIfEvent + , divVisibleIf + , divClassVisibleIf + , flatten + , getBody + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.Document as Document +import qualified GHCJS.DOM.HTMLCollection as HTMLCollection +import GHCJS.DOM.Types (Element) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a) +visibleIfDyn cond empty content = + R.dyn $ R.ffor cond $ \case + True -> content + False -> empty + +visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) +visibleIfEvent cond empty content = + R.widgetHold empty $ + R.ffor cond $ \case + True -> content + False -> empty + +divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a +divVisibleIf cond content = divClassVisibleIf cond "" content + +divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a +divClassVisibleIf cond className content = + R.elDynAttr + "div" + (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) + content + +flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a) +flatten e = do + dyn <- R.holdDyn R.never e + return $ R.switchDyn dyn + +getBody :: forall t m. MonadWidget t m => m Element +getBody = do + document <- Dom.currentDocumentUnchecked + nodelist <- Document.getElementsByTagName document ("body" :: String) + Just body <- nodelist `HTMLCollection.item` 0 + return body diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f363b06..ab83447 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -11,9 +11,9 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (CreatedPayment (..), Frequency, Init (..), - Payment (..), PaymentCategory (..), - PaymentId) +import Common.Model (Frequency, Init (..), Payment (..), + PaymentCategory (..), PaymentId, + SavedPayment (..)) import qualified Common.Util.Text as T import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -36,15 +36,19 @@ widget paymentIn = do rec let init = _paymentIn_init paymentIn paymentsPerPage = 7 + savedPayments = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] payments <- getPayments (_init_payments init) - (_createdPayment_payment <$> _headerOut_addPayment header) + (_savedPayment_payment <$> savedPayments) (_tableOut_deletePayment table) paymentCategories <- getPaymentCategories (_init_paymentCategories init) - (_createdPayment_paymentCategory <$> _headerOut_addPayment header) + (_savedPayment_paymentCategory <$> savedPayments) payments (_tableOut_deletePayment table) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 69e29a7..88806bc 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -1,161 +1,54 @@ module View.Payment.Add ( view - , AddIn(..) - , AddOut(..) + , Input(..) ) where import Control.Monad (join) import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Time -import qualified Data.Validation as V -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import qualified Text.Read as T -import Common.Model (Category (..), CategoryId, - CreatePayment (..), - CreatedPayment (..), Frequency (..), - Payment (..), PaymentCategory (..)) +import Common.Model (Category (..), CreatePayment (..), + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) import qualified Common.Msg as Msg -import qualified Common.Util.Time as Time +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.Validation as ValidationUtil -import qualified Util.WaitFor as WaitFor - -data AddIn t = AddIn - { _addIn_categories :: [Category] - , _addIn_paymentCategories :: Dynamic t [PaymentCategory] - , _addIn_frequency :: Dynamic t Frequency - , _addIn_cancel :: Event t () - } - -data AddOut t = AddOut - { _addOut_cancel :: Event t () - , _addOut_addPayment :: Event t CreatedPayment - , _addOut_addPaymentCategory :: Event t PaymentCategory +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_frequency :: Dynamic t Frequency } -view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t) -view addIn = do - R.divClass "add" $ do - R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add - - R.divClass "addContent" $ do - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addPayment - , "" <$ _addIn_cancel addIn - ] - - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_validation = PaymentValidation.name - }) - reset - confirm - - cost <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_validation = PaymentValidation.cost - }) - reset - confirm) - - now <- liftIO Time.getCurrentTime - - currentDay <- do - d <- liftIO $ Time.timeToDay now - return . T.pack . Calendar.showGregorian $ d - - date <- _inputOut_value <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = currentDay - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date - }) - (currentDay <$ reset) - confirm) - - let setCategory = - R.fmapMaybe id - . R.updated - $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = -1 - , _selectIn_value = setCategory - , _selectIn_values = R.constDyn categories - , _selectIn_reset = reset - , _selectIn_isValid = \id -> id /= -1 - , _selectIn_validate = confirm - }) - - let payment = do - n <- _inputOut_value name - c <- cost - d <- date - cat <- category - f <- _addIn_frequency addIn - return (CreatePayment - <$> ValidationUtil.nelError n - <*> ValidationUtil.nelError c - <*> ValidationUtil.nelError d - <*> ValidationUtil.nelError cat - <*> V.Success f) - - (addPayment, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addPayment, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") - (ValidationUtil.fireValidation payment confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) - - return AddOut - { _addOut_cancel = cancel - , _addOut_addPayment = addPayment - } - - where - frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - categories = M.fromList . flip map (_addIn_categories addIn) $ \c -> - (_category_id c, _category_name c) - - -findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId -findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + frequency <- _input_frequency input + return $ Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_Add + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = "" + , Form._input_cost = "" + , Form._input_date = currentDay + , Form._input_category = -1 + , Form._input_frequency = frequency + , Form._input_mkPayload = CreatePayment + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return (hide, addPayment) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs new file mode 100644 index 0000000..5624f6c --- /dev/null +++ b/client/src/View/Payment/Clone.hs @@ -0,0 +1,60 @@ +module View.Payment.Clone + ( Input(..) + , view + ) where + +import qualified Control.Monad as Monad +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, + CreatePayment (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Payment as PaymentValidation +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_show :: Event t () + , _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_payment :: Dynamic t Payment + , _input_category :: Dynamic t CategoryId + } + +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + payment <- _input_payment input + category <- _input_category input + return . Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = _payment_name payment + , Form._input_cost = T.pack . show . _payment_cost $ payment + , Form._input_date = currentDay + , Form._input_category = category + , Form._input_frequency = _payment_frequency payment + , Form._input_mkPayload = CreatePayment + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return $ + ( hide + , clonePayment + ) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 65ce660..e7e319e 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -1,39 +1,34 @@ module View.Payment.Delete - ( view - , DeleteIn(..) - , DeleteOut(..) + ( Input(..) + , view ) where -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data DeleteIn t = DeleteIn - { _deleteIn_payment :: Dynamic t Payment - } - -data DeleteOut t = DeleteOut - { _deleteOut_cancel :: Event t () - , _deleteOut_validate :: Event t Payment +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment (..)) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data Input t = Input + { _input_payment :: Dynamic t Payment } -view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) -view deleteIn = +view :: forall t m. MonadWidget t m => (Input t) -> Modal.Content t m Payment +view input _ = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm R.divClass "deleteContent" $ do - (deletedPayment, cancel) <- R.divClass "buttons" $ do + (confirm, cancel) <- R.divClass "buttons" $ do cancel <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) @@ -48,7 +43,7 @@ view deleteIn = }) let url = - R.ffor (_deleteIn_payment deleteIn) (\id -> + R.ffor (_input_payment input) (\id -> T.concat ["/payment/", T.pack . show $ _payment_id id] ) @@ -58,7 +53,7 @@ view deleteIn = return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) - return DeleteOut - { _deleteOut_cancel = cancel - , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment - } + return $ + ( R.leftmost [ cancel, () <$ confirm ] + , R.tag (R.current $ _input_payment input) confirm + ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs new file mode 100644 index 0000000..5020e57 --- /dev/null +++ b/client/src/View/Payment/Edit.hs @@ -0,0 +1,55 @@ +module View.Payment.Edit + ( Input(..) + , view + ) where + +import qualified Control.Monad as Monad +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, + EditPayment (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Validation.Payment as PaymentValidation +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form + +data Input t = Input + { _input_show :: Event t () + , _input_categories :: [Category] + , _input_paymentCategories :: Dynamic t [PaymentCategory] + , _input_payment :: Dynamic t Payment + , _input_category :: Dynamic t CategoryId + } + +view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view input cancel = do + + formOutput <- R.dyn $ do + paymentCategories <- _input_paymentCategories input + payment <- _input_payment input + category <- _input_category input + return . Form.view $ Form.Input + { Form._input_cancel = cancel + , Form._input_headerLabel = Msg.get Msg.Payment_EditLong + , Form._input_categories = _input_categories input + , Form._input_paymentCategories = paymentCategories + , Form._input_name = _payment_name payment + , Form._input_cost = T.pack . show . _payment_cost $ payment + , Form._input_date = _payment_date payment + , Form._input_category = category + , Form._input_frequency = _payment_frequency payment + , Form._input_mkPayload = EditPayment (_payment_id payment) + } + + hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) + editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + + return $ + ( hide + , editPayment + ) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs new file mode 100644 index 0000000..ba54957 --- /dev/null +++ b/client/src/View/Payment/Form.hs @@ -0,0 +1,165 @@ +module View.Payment.Form + ( view + , Input(..) + , Output(..) + ) where + +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadHold, + MonadWidget, Reflex) +import qualified Reflex.Dom as R +import qualified Text.Read as T + +import Common.Model (Category (..), CategoryId, + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Validation.Payment as PaymentValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..), SelectIn (..), + SelectOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data Input t p = Input + { _input_cancel :: Event t () + , _input_headerLabel :: Text + , _input_categories :: [Category] + , _input_paymentCategories :: [PaymentCategory] + , _input_name :: Text + , _input_cost :: Text + , _input_date :: Day + , _input_category :: CategoryId + , _input_frequency :: Frequency + , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + } + +data Output t = Output + { _output_hide :: Event t () + , _output_addPayment :: Event t SavedPayment + } + +view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t) +view input = do + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_input_headerLabel input) + + R.divClass "formContent" $ do + rec + let reset = R.leftmost + [ "" <$ cancel + , "" <$ addPayment + , "" <$ _input_cancel input + ] + + name <- Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_initialValue = _input_name input + , _inputIn_validation = PaymentValidation.name + }) + (_input_name input <$ reset) + confirm + + cost <- _inputOut_value <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = _input_cost input + , _inputIn_validation = PaymentValidation.cost + }) + (_input_cost input <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _input_date $ input + + date <- _inputOut_value <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date + }) + (initialDate <$ reset) + confirm) + + let setCategory = + R.fmapMaybe id . R.updated $ + R.ffor (_inputOut_raw name) $ \name -> + findCategory name (_input_paymentCategories input) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = _input_category input + , _selectIn_value = setCategory + , _selectIn_values = R.constDyn categories + , _selectIn_reset = _input_category input <$ reset + , _selectIn_isValid = (/= -1) + , _selectIn_validate = confirm + }) + + let payment = do + n <- _inputOut_value name + c <- cost + d <- date + cat <- category + return ((_input_mkPayload input) + <$> ValidationUtil.nelError n + <*> ValidationUtil.nelError c + <*> ValidationUtil.nelError d + <*> ValidationUtil.nelError cat + <*> V.Success (_input_frequency input)) + + (addPayment, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + confirm <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (addPayment, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") + (ValidationUtil.fireValidation payment confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) + + return Output + { _output_hide = R.leftmost [ cancel, () <$ addPayment ] + , _output_addPayment = addPayment + } + + where + frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + categories = M.fromList . flip map (_input_categories input) $ \c -> + (_category_id c, _category_name c) + + +findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId +findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 1bdee8d..7281195 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -17,10 +17,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Category, CreatedPayment (..), - Currency, ExceedingPayer (..), - Frequency (..), Income (..), Init (..), - Payment (..), PaymentCategory, +import Common.Model (Category, Currency, + ExceedingPayer (..), Frequency (..), + Income (..), Init (..), Payment (..), + PaymentCategory, SavedPayment (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -28,11 +28,10 @@ import qualified Common.View.Format as Format import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..), - ModalIn (..), ModalOut (..), SelectIn (..), SelectOut (..)) import qualified Component as Component +import qualified Component.Modal as Modal import qualified Util.List as L -import View.Payment.Add (AddIn (..), AddOut (..)) import qualified View.Payment.Add as Add data HeaderIn t = HeaderIn @@ -45,7 +44,7 @@ data HeaderIn t = HeaderIn data HeaderOut t = HeaderOut { _headerOut_searchName :: Dynamic t Text , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addPayment :: Event t CreatedPayment + , _headerOut_addPayment :: Event t SavedPayment } widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) @@ -90,7 +89,7 @@ payerAndAdd -> Dynamic t [PaymentCategory] -> Currency -> Dynamic t Frequency - -> m (Event t CreatedPayment) + -> m (Event t SavedPayment) payerAndAdd incomes payments users categories paymentCategories currency frequency = do time <- liftIO Time.getCurrentTime R.divClass "payerAndAdd" $ do @@ -119,22 +118,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen , _buttonIn_submit = False }) - rec - modalOut <- Component.modal $ ModalIn - { _modalIn_show = addPaymentClic - , _modalIn_hide = R.leftmost $ - [ _addOut_cancel addOut - , fmap (const ()) . _addOut_addPayment $ addOut - ] - , _modalIn_content = Add.view $ AddIn - { _addIn_categories = categories - , _addIn_paymentCategories = paymentCategories - , _addIn_frequency = frequency - , _addIn_cancel = _modalOut_hide modalOut - } - } - let addOut = _modalOut_content modalOut - return (_addOut_addPayment addOut) + Modal.view $ Modal.Input + { Modal._input_show = addPaymentClic + , Modal._input_content = Add.view $ Add.Input + { Add._input_categories = categories + , Add._input_paymentCategories = paymentCategories + , Add._input_frequency = frequency + } + } searchLine :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index cbe7b50..9247143 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -4,15 +4,15 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon -import qualified Util.Dom as Dom +import qualified Util.Reflex as ReflexUtil data PagesIn t = PagesIn { _pagesIn_total :: Dynamic t Int @@ -26,7 +26,7 @@ data PagesOut t = PagesOut widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do - currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset return $ PagesOut { _pagesOut_currentPage = currentPage diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index b09f30f..f2b8870 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -6,25 +6,32 @@ module View.Payment.Table import qualified Data.List as L import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Init (..), Payment (..), - PaymentCategory (..), User (..)) +import Common.Model (Category (..), Frequency (Punctual), + Init (..), Payment (..), + PaymentCategory (..), SavedPayment, + User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..), ButtonOut (..), - ModalIn (..), ModalOut (..)) +import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component -import View.Payment.Delete (DeleteIn (..), DeleteOut (..)) +import qualified Component.Modal as Modal +import qualified View.Payment.Clone as Clone import qualified View.Payment.Delete as Delete +import qualified View.Payment.Edit as Edit import qualified Icon -import qualified Util.Dom as DomUtil +import qualified Util.Reflex as ReflexUtil + +-- TODO: remove +import Debug.Trace (trace) data TableIn t = TableIn { _tableIn_init :: Init @@ -32,17 +39,19 @@ data TableIn t = TableIn , _tableIn_payments :: Dynamic t [Payment] , _tableIn_perPage :: Int , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] + , _tableIn_categories :: [Category] } data TableOut t = TableOut - { _tableOut_deletePayment :: Event t Payment + { _tableOut_addPayment :: Event t SavedPayment + , _tableOut_deletePayment :: Event t Payment } widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - deletePayment <- R.divClass "lines" $ do + (addPayment, deletePayment) <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -52,14 +61,21 @@ widget tableIn = do R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - (R.switch . R.current . fmap R.leftmost) <$> + + result <- (R.simpleList paymentRange (paymentRow init paymentCategories)) - DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ + return $ + ( R.switch . R.current . fmap (R.leftmost . map fst) $ result + , R.switch . R.current . fmap (R.leftmost . map snd) $ result + ) + + ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty return $ TableOut - { _tableOut_deletePayment = deletePayment + { _tableOut_addPayment = addPayment + , _tableOut_deletePayment = deletePayment } where @@ -82,7 +98,7 @@ paymentRow => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment - -> m (Event t Payment) + -> m (Event t SavedPayment, Event t Payment) paymentRow init paymentCategories payment = R.divClass "row" $ do @@ -115,7 +131,7 @@ paymentRow init paymentCategories payment = Nothing -> M.singleton "display" "none" R.elDynAttr "span" attrs $ - R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of + R.dynText $ R.ffor category $ \case Just c -> _category_name c _ -> "" @@ -123,35 +139,68 @@ paymentRow init paymentCategories payment = R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - R.divClass "cell button" $ - R.el "button" Icon.clone + let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category + + clonePayment <- + R.divClass "cell button" $ + _buttonOut_clic <$> (Component.button $ + Component.defaultButtonIn Icon.clone) + + paymentCloned <- + Modal.view $ Modal.Input + { Modal._input_show = clonePayment + , Modal._input_content = + Clone.view $ Clone.Input + { Clone._input_show = clonePayment + , Clone._input_categories = _init_categories init + , Clone._input_paymentCategories = paymentCategories + , Clone._input_payment = payment + , Clone._input_category = categoryId + } + } let isFromCurrentUser = R.ffor payment (\p -> _payment_user p == _init_currentUser init) - R.divClass "cell button" $ - DomUtil.divVisibleIf isFromCurrentUser $ - R.el "button" Icon.edit + editPayment <- + R.divClass "cell button" $ + ReflexUtil.divVisibleIf isFromCurrentUser $ + _buttonOut_clic <$> (Component.button $ + Component.defaultButtonIn Icon.edit) + + paymentEdited <- + Modal.view $ Modal.Input + { Modal._input_show = editPayment + , Modal._input_content = + Edit.view $ Edit.Input + { Edit._input_show = editPayment + , Edit._input_categories = _init_categories init + , Edit._input_paymentCategories = paymentCategories + , Edit._input_payment = payment + , Edit._input_category = categoryId + } + } deletePayment <- R.divClass "cell button" $ - DomUtil.divVisibleIf isFromCurrentUser $ + ReflexUtil.divVisibleIf isFromCurrentUser $ _buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" }) - - rec - modalOut <- Component.modal $ ModalIn - { _modalIn_show = deletePayment - , _modalIn_hide = R.leftmost $ - [ _deleteOut_cancel . _modalOut_content $ modalOut - , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut - ] - , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment }) + { _buttonIn_class = R.constDyn "deletePayment" + }) + + paymentDeleted <- + Modal.view $ Modal.Input + { Modal._input_show = deletePayment + , Modal._input_content = + Delete.view $ Delete.Input + { Delete._input_payment = payment + } } - return (_deleteOut_validate . _modalOut_content $ modalOut) + + return $ (paymentCloned, paymentDeleted) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/common/common.cabal b/common/common.cabal index 0edd8e2..a454270 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -30,9 +30,9 @@ Library Exposed-modules: Common.Model Common.Model.CreatePayment - Common.Model.CreatedPayment Common.Model.Email Common.Model.Payment + Common.Model.SavedPayment Common.Model.SignInForm Common.Model.User Common.Msg diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 64db890..1abc3e3 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -2,7 +2,6 @@ module Common.Model (module X) where import Common.Model.Category as X import Common.Model.CreateCategory as X -import Common.Model.CreatedPayment as X import Common.Model.CreateIncome as X import Common.Model.CreatePayment as X import Common.Model.Currency as X @@ -17,5 +16,6 @@ import Common.Model.InitResult as X import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X +import Common.Model.SavedPayment as X import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/CreatedPayment.hs b/common/src/Common/Model/CreatedPayment.hs deleted file mode 100644 index c1bba29..0000000 --- a/common/src/Common/Model/CreatedPayment.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Common.Model.CreatedPayment - ( CreatedPayment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) - -data CreatedPayment = CreatedPayment - { _createdPayment_payment :: Payment - , _createdPayment_paymentCategory :: PaymentCategory - } deriving (Show, Generic) - -instance FromJSON CreatedPayment -instance ToJSON CreatedPayment diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs index d2c223f..8860b84 100644 --- a/common/src/Common/Model/EditPayment.hs +++ b/common/src/Common/Model/EditPayment.hs @@ -2,7 +2,7 @@ module Common.Model.EditPayment ( EditPayment(..) ) where -import Data.Aeson (FromJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import Data.Time.Calendar (Day) import GHC.Generics (Generic) @@ -21,3 +21,4 @@ data EditPayment = EditPayment } deriving (Show, Generic) instance FromJSON EditPayment +instance ToJSON EditPayment diff --git a/common/src/Common/Model/SavedPayment.hs b/common/src/Common/Model/SavedPayment.hs new file mode 100644 index 0000000..f45c479 --- /dev/null +++ b/common/src/Common/Model/SavedPayment.hs @@ -0,0 +1,17 @@ +module Common.Model.SavedPayment + ( SavedPayment(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) + +data SavedPayment = SavedPayment + { _savedPayment_payment :: Payment + , _savedPayment_paymentCategory :: PaymentCategory + } deriving (Show, Generic) + +instance FromJSON SavedPayment +instance ToJSON SavedPayment diff --git a/server/server.cabal b/server/server.cabal index 3bc8e42..3c1c770 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -74,6 +74,7 @@ Executable server Design.View.Payment Design.View.Payment.Add Design.View.Payment.Delete + Design.View.Payment.Form Design.View.Payment.Header Design.View.Payment.Pages Design.View.Payment.Table diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 3d857be..c700240 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -10,9 +10,9 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreatePayment (..), - CreatedPayment (..), EditPayment (..), Payment (..), - PaymentId, User (..)) + PaymentId, SavedPayment (..), + User (..)) import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -33,7 +33,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do pc <- PaymentCategoryPersistence.save name category p <- PaymentPersistence.create (_user_id user) name cost date frequency - return $ CreatedPayment p pc + return $ SavedPayment p pc ) >>= json Just validationError -> do @@ -44,15 +44,20 @@ create createPayment@(CreatePayment name cost date category frequency) = edit :: EditPayment -> ActionM () edit (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ do - edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - _ <- if edited - then PaymentCategoryPersistence.save name category >> return () - else return () - return edited - if updated - then status Status.ok200 - else status Status.badRequest400 + result <- liftIO . Query.run $ do + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency + case editedPayment of + Just p -> do + pc <- PaymentCategoryPersistence.save name category + PaymentCategoryPersistence.deleteIfUnused name + return $ Just (p, pc) + Nothing -> + return Nothing + case result of + Just (p, pc) -> + json $ SavedPayment p pc + Nothing -> + status Status.badRequest400 ) delete :: PaymentId -> ActionM () diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index dce2ef9..4020eb0 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -7,6 +7,7 @@ import Data.Monoid ((<>)) import qualified Design.View.Payment.Add as Add import qualified Design.View.Payment.Delete as Delete +import qualified Design.View.Payment.Form as Form design :: Css design = do @@ -14,9 +15,9 @@ design = do appearKeyframe ".g-Modal" ? do + display none appearAnimation transition "all" (sec 0.2) ease (sec 0) - display none opacity 0 ".g-Modal--Show" & do @@ -47,6 +48,7 @@ design = do boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) ".add" ? Add.design + ".form" ? Form.design ".delete" ? Delete.design ".paymentModal" & do diff --git a/server/src/Design/View/Payment/Form.hs b/server/src/Design/View/Payment/Form.hs new file mode 100644 index 0000000..aada12b --- /dev/null +++ b/server/src/Design/View/Payment/Form.hs @@ -0,0 +1,35 @@ +module Design.View.Payment.Form + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".formHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym2 padding (px 20) (px 30) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".formContent" ? do + sym2 padding (px 20) (px 30) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 3d8f129..b3f2b2e 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -129,33 +129,53 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -edit userId paymentId paymentName paymentCost paymentDate paymentFrequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment) +edit userId paymentId name cost date frequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + SQLite.query + conn + "SELECT * FROM payment WHERE id = ? and userId = ?" + (paymentId, userId) case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId) - return True - else - return False + Just payment -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE" + , " payment" + , "SET" + , " edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE" + , " id = ?" + , " AND user_id = ?" + ]) + ( now + , name + , cost + , date + , FrequencyField frequency + , paymentId + , userId + ) + return . Just $ Payment + { _payment_id = paymentId + , _payment_user = userId + , _payment_name = name + , _payment_cost = cost + , _payment_date = date + , _payment_frequency = frequency + , _payment_createdAt = _payment_createdAt payment + , _payment_editedAt = Just now + , _payment_deletedAt = Nothing + } Nothing -> - return False + return Nothing ) delete :: UserId -> PaymentId -> Query () -- cgit v1.2.3 From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:28:54 +0200 Subject: Make payment edition to work on the frontend --- ISSUES.md | 51 +++++++++++++++++++++++++ README.md | 53 +------------------------- client/src/Util/Ajax.hs | 63 ++++++++++++++++++++++--------- client/src/View/Payment.hs | 38 +++++++++++++------ client/src/View/Payment/Add.hs | 1 + client/src/View/Payment/Clone.hs | 1 + client/src/View/Payment/Edit.hs | 1 + client/src/View/Payment/Form.hs | 19 +++++++--- client/src/View/Payment/Table.hs | 13 ++++--- server/src/Controller/Payment.hs | 6 +-- server/src/Persistence/Payment.hs | 6 +-- server/src/Persistence/PaymentCategory.hs | 2 +- 12 files changed, 157 insertions(+), 97 deletions(-) create mode 100644 ISSUES.md diff --git a/ISSUES.md b/ISSUES.md new file mode 100644 index 0000000..9ee077d --- /dev/null +++ b/ISSUES.md @@ -0,0 +1,51 @@ +# Fix + +- When clicking on an input label, focus to the input + +# Payment view + +- Remove unused payment category after payment edit on frontend +- Remove old validation, use client validation on the backend +- Add icon tooltip ? +- auto focus on first input when payment modal is open + +# Income view + +… + +# Category view + +… + +# Stat view + +… + +# Features + +- HTTP error message +- Use only one loader +- Login with email and password +- search payments by: + - category, + - date. + +# Code + +- remove client warning messages +- Use BEM style +- Move the CSS out from the index page +- Test exceedingPayers +- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) + +# DB + +- Add DB indexes + +# Tooling + +- deploy command +- migration diff (use flyway?). +- use ghcid +- set up fast deploy +- pin nixpkgs diff --git a/README.md b/README.md index bc9e98c..6e1c675 100644 --- a/README.md +++ b/README.md @@ -56,55 +56,6 @@ See [application.conf](application.conf). - [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html) - [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html) -## TODO +## Issues -### Fix - -- When clicking on an input label, focus to the input - -### Payment view - -- Edit a payment -- Possibly remove payment category after payment edit (frontend) -- Remove old validation, use client validation on the backend -- Add icon tooltip ? - -### Income view - -… - -### Category view - -… - -### Stat view - -… - -#### Bonus - -- HTTP error message -- Use only one loader -- Login with email and password -- search payments by: - - category, - - date. - -### Code - -- remove client warning messages -- Use BEM style -- Move the CSS out from the index page -- Add tests about exceedingPayers -- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) - -### DB - -- Add DB indexes - -### Tooling - -- deploy command -- migration diff (use flyway?). -- utiliser ghcid -- set up fast deploy +See [ISSUES.md](ISSUES.md). diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 7b65c52..a4f6a74 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,20 +1,24 @@ module Util.Ajax ( postJson + , putJson , delete ) where -import Control.Arrow (left) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as Aeson -import Data.Default (def) -import qualified Data.Map.Lazy as LM -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, - XhrRequest, XhrRequestConfig (..), - XhrResponse, XhrResponseHeaders (..)) -import qualified Reflex.Dom as R +import Control.Arrow (left) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Reflex.Dom (Dynamic, Event, IsXhrPayload, + MonadWidget, XhrRequest, + XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R postJson :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) @@ -23,7 +27,16 @@ postJson -> m (Event t (Either Text b)) postJson url input = fmap getJsonResult <$> - R.performRequestAsync (R.postJson url <$> input) + R.performRequestAsync (jsonRequest "POST" url <$> input) + +putJson + :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) + => Text + -> Event t a + -> m (Event t (Either Text b)) +putJson url input = + fmap getJsonResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) delete :: forall t m a. (MonadWidget t m) @@ -31,8 +44,9 @@ delete -> Event t () -> m (Event t (Either Text Text)) delete url fire = do - response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) - return $ fmap getResult response + fmap getResult <$> + (R.performRequestAsync $ + R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a getJsonResult response = @@ -50,7 +64,22 @@ getResult response = _ -> Left "NoKey" request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a -request method url sendData = +request method url payload = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = payload + } + in + R.xhrRequest method url config + +jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString +jsonRequest method url payload = let config = XhrRequestConfig { _xhrRequestConfig_headers = def @@ -59,7 +88,7 @@ request method url sendData = , _xhrRequestConfig_responseType = def , _xhrRequestConfig_responseHeaders = def , _xhrRequestConfig_withCredentials = False - , _xhrRequestConfig_sendData = sendData + , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload } in R.xhrRequest method url config diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index ab83447..f2a5071 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -35,21 +35,25 @@ widget paymentIn = do R.elClass "main" "payment" $ do rec let init = _paymentIn_init paymentIn + paymentsPerPage = 7 - savedPayments = R.leftmost + + addPayment = R.leftmost [ _headerOut_addPayment header , _tableOut_addPayment table ] - payments <- getPayments + payments <- reducePayments (_init_payments init) - (_savedPayment_payment <$> savedPayments) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) (_tableOut_deletePayment table) - paymentCategories <- getPaymentCategories + paymentCategories <- reducePaymentCategories (_init_paymentCategories init) - (_savedPayment_paymentCategory <$> savedPayments) payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) (_tableOut_deletePayment table) (searchNameEvent, searchName) <- @@ -93,28 +97,38 @@ debounceSearchName searchName = do dynamic <- R.holdDyn "" event return (event, dynamic) -getPayments +reducePayments :: forall t m. MonadWidget t m => [Payment] - -> Event t Payment - -> Event t Payment + -> Event t Payment -- add payment + -> Event t Payment -- edit payment + -> Event t Payment -- delete payment -> m (Dynamic t [Payment]) -getPayments initPayments addPayment deletePayment = +reducePayments initPayments addPayment editPayment deletePayment = R.foldDyn id initPayments $ R.leftmost [ (:) <$> addPayment + , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) ] -getPaymentCategories +reducePaymentCategories :: forall t m. MonadWidget t m => [PaymentCategory] - -> Event t PaymentCategory -- add payment category -> Dynamic t [Payment] -- payments + -> Event t PaymentCategory -- add payment category + -> Event t PaymentCategory -- edit payment category -> Event t Payment -- delete payment -> m (Dynamic t [PaymentCategory]) -getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment = +reducePaymentCategories + initPaymentCategories + payments + addPaymentCategory + editPaymentCategory + deletePayment + = R.foldDyn id initPaymentCategories $ R.leftmost [ (:) <$> addPaymentCategory + , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) ] where diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 88806bc..e83dba9 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -46,6 +46,7 @@ view input cancel = do , Form._input_category = -1 , Form._input_frequency = frequency , Form._input_mkPayload = CreatePayment + , Form._input_httpMethod = Form.Post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 5624f6c..922e89c 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -49,6 +49,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = CreatePayment + , Form._input_httpMethod = Form.Post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 5020e57..9c11af0 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -44,6 +44,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = EditPayment (_payment_id payment) + , Form._input_httpMethod = Form.Put } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index ba54957..9889638 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,6 +1,7 @@ module View.Payment.Form ( view , Input(..) + , HttpMethod(..) , Output(..) ) where @@ -46,8 +47,11 @@ data Input t p = Input , _input_category :: CategoryId , _input_frequency :: Frequency , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + , _input_httpMethod :: HttpMethod } +data HttpMethod = Put | Post + data Output t = Output { _output_hide :: Event t () , _output_addPayment :: Event t SavedPayment @@ -139,7 +143,7 @@ view input = do }) (addPayment, waiting) <- WaitFor.waitFor - (Ajax.postJson "/payment") + (ajax "/payment") (ValidationUtil.fireValidation payment confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) @@ -150,14 +154,19 @@ view input = do } where - frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] + frequencies = + M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] categories = M.fromList . flip map (_input_categories input) $ \c -> (_category_id c, _category_name c) + ajax = + case _input_httpMethod input of + Post -> Ajax.postJson + Put -> Ajax.putJson findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f2b8870..40bc864 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -44,6 +44,7 @@ data TableIn t = TableIn data TableOut t = TableOut { _tableOut_addPayment :: Event t SavedPayment + , _tableOut_editPayment :: Event t SavedPayment , _tableOut_deletePayment :: Event t Payment } @@ -51,7 +52,7 @@ widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) widget tableIn = do R.divClass "table" $ do - (addPayment, deletePayment) <- R.divClass "lines" $ do + (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost @@ -66,8 +67,9 @@ widget tableIn = do (R.simpleList paymentRange (paymentRow init paymentCategories)) return $ - ( R.switch . R.current . fmap (R.leftmost . map fst) $ result - , R.switch . R.current . fmap (R.leftmost . map snd) $ result + ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result + , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result + , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result ) ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ @@ -75,6 +77,7 @@ widget tableIn = do return $ TableOut { _tableOut_addPayment = addPayment + , _tableOut_editPayment = editPayment , _tableOut_deletePayment = deletePayment } @@ -98,7 +101,7 @@ paymentRow => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment - -> m (Event t SavedPayment, Event t Payment) + -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) paymentRow init paymentCategories payment = R.divClass "row" $ do @@ -200,7 +203,7 @@ paymentRow init paymentCategories payment = } } - return $ (paymentCloned, paymentDeleted) + return $ (paymentCloned, paymentEdited, paymentDeleted) findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c700240..38c1c19 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -47,10 +47,10 @@ edit (EditPayment paymentId name cost date category frequency) = result <- liftIO . Query.run $ do editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency case editedPayment of - Just p -> do + Just (old, new) -> do pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused name - return $ Just (p, pc) + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return $ Just (new, pc) Nothing -> return Nothing case result of diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index b3f2b2e..bcd7eb8 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -129,13 +129,13 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment) +edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment)) edit userId paymentId name cost date frequency = Query (\conn -> do mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> SQLite.query conn - "SELECT * FROM payment WHERE id = ? and userId = ?" + "SELECT * FROM payment WHERE id = ? and user_id = ?" (paymentId, userId) case mbPayment of Just payment -> do @@ -163,7 +163,7 @@ edit userId paymentId name cost date frequency = , paymentId , userId ) - return . Just $ Payment + return . Just . (,) payment $ Payment { _payment_id = paymentId , _payment_user = userId , _payment_name = name diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs index 7dc363c..46be7f5 100644 --- a/server/src/Persistence/PaymentCategory.hs +++ b/server/src/Persistence/PaymentCategory.hs @@ -84,6 +84,6 @@ deleteIfUnused name = Query (\conn -> SQLite.execute conn - "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)" + "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)" (name, name) ) >> return () -- cgit v1.2.3 From 2cbd43c3a0f0640776a4e7c7425b3210d2e6632b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:41:17 +0200 Subject: Make input label clickable again --- ISSUES.md | 4 ---- client/src/Component/Input.hs | 16 ++++++++++------ client/src/Component/Select.hs | 16 +++++++++------- server/src/Design/Form.hs | 13 ++++++------- 4 files changed, 25 insertions(+), 24 deletions(-) diff --git a/ISSUES.md b/ISSUES.md index 9ee077d..f61d0b4 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,7 +1,3 @@ -# Fix - -- When clicking on an input label, focus to the input - # Payment view - Remove unused payment category after payment edit on frontend diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index abdc51c..0c84754 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -75,13 +75,17 @@ input inputIn reset validate = do (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do - textInput <- R.textInput $ R.def - & R.attributes .~ inputAttr - & R.setValue .~ resetValue - & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) - & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) + textInput <- R.el "label" $ do + textInput <- R.textInput $ R.def + & R.attributes .~ inputAttr + & R.setValue .~ resetValue + & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) + & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) - R.el "label" $ R.text (_inputIn_label inputIn) + R.divClass "label" $ + R.text (_inputIn_label inputIn) + + return textInput resetClic <- if _inputIn_hasResetButton inputIn diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 9a37afc..5980ed2 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -57,8 +57,6 @@ select selectIn = do ] value <- R.elDynAttr "div" containerAttr $ do - R.el "label" $ R.text (_selectIn_label selectIn) - let initialValue = _selectIn_initialValue selectIn let setValue = R.leftmost @@ -66,11 +64,15 @@ select selectIn = do , _selectIn_value selectIn ] - value <- R._dropdown_value <$> - R.dropdown - initialValue - (_selectIn_values selectIn) - (R.def { R._dropdownConfig_setValue = setValue }) + value <- R.el "label" $ do + R.divClass "label" $ + R.text (_selectIn_label selectIn) + + R._dropdown_value <$> + R.dropdown + initialValue + (_selectIn_values selectIn) + (R.def { R._dropdownConfig_setValue = setValue }) R.divClass "errorMessage" . R.dynText $ R.ffor showedError (Maybe.fromMaybe "") diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 0f236f7..506343d 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -15,10 +15,6 @@ design = do let inputTop = 22 let inputPaddingBottom = 3 - label ? do - cursor pointer - color Color.silver - ".textInput" ? do position relative marginBottom (em 2) @@ -40,7 +36,9 @@ design = do borderWidth (px 2) paddingBottom (px $ inputPaddingBottom - 1) - label ? do + ".label" ? do + zIndex (-1) + color Color.silver lineHeight (px inputHeight) position absolute top (px inputTop) @@ -56,7 +54,7 @@ design = do hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25)) - (input # ".filled" |+ label) <> (input # focus |+ label) ? do + (input # ".filled" |+ ".label") <> (input # focus |+ ".label") ? do top (px 0) fontSize (pct 80) @@ -81,7 +79,8 @@ design = do ".selectInput" ? do marginBottom (em 2) - label ? do + ".label" ? do + color Color.silver display block marginBottom (px 10) fontSize (pct 80) -- cgit v1.2.3 From e5ac82f4808e974dec5f19fc6f059efaa5214022 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:46:03 +0200 Subject: Reorganize issues --- ISSUES.md | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/ISSUES.md b/ISSUES.md index f61d0b4..ba8d15f 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,30 +1,37 @@ -# Payment view +# MVP -- Remove unused payment category after payment edit on frontend -- Remove old validation, use client validation on the backend -- Add icon tooltip ? -- auto focus on first input when payment modal is open +- Implement routing -# Income view +## Payment view -… +- Remove old validation, use client validation on the backend -# Category view +## Income view -… +- Show the income table +- Add an income +- Edit an income +- Remove an income -# Stat view +## Category view -… +- Show the category table +- Add a category +- Edit a category +- Remove a category -# Features +# Additional features +- Remove unused payment category after payment edit on frontend +- Auto focus on first input when payment modal is open +- Add icon tooltip - HTTP error message - Use only one loader - Login with email and password -- search payments by: +- Search payments by: - category, - date. +- Show statistics. # Code -- cgit v1.2.3 From 7529a18ff0ac443e7f9764b5e2d0f57a5d3a850b Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 9 Oct 2019 23:16:00 +0200 Subject: Use common payment validation in the backend Remove deprecated backend validation --- ISSUES.md | 4 -- client/src/Component/Select.hs | 11 ++--- client/src/View/Payment/Add.hs | 35 +++++++------ client/src/View/Payment/Clone.hs | 35 +++++++------ client/src/View/Payment/Edit.hs | 27 +++++----- client/src/View/Payment/Form.hs | 12 ++--- client/src/View/Payment/Header.hs | 3 +- common/common.cabal | 4 +- common/src/Common/Model.hs | 38 +++++++-------- common/src/Common/Model/CreatePayment.hs | 34 ------------- common/src/Common/Model/CreatePaymentForm.hs | 21 ++++++++ common/src/Common/Model/EditPayment.hs | 24 --------- common/src/Common/Model/EditPaymentForm.hs | 23 +++++++++ common/src/Common/Validation/Payment.hs | 15 +++++- server/server.cabal | 7 ++- server/src/Controller/Helper.hs | 17 +++++++ server/src/Controller/Payment.hs | 73 +++++++++++++++------------- server/src/Model/CreatePayment.hs | 16 ++++++ server/src/Model/EditPayment.hs | 17 +++++++ server/src/Validation/Atomic.hs | 32 ------------ server/src/Validation/CreatePayment.hs | 25 ---------- server/src/Validation/Payment.hs | 33 +++++++++++++ 22 files changed, 264 insertions(+), 242 deletions(-) delete mode 100644 common/src/Common/Model/CreatePayment.hs create mode 100644 common/src/Common/Model/CreatePaymentForm.hs delete mode 100644 common/src/Common/Model/EditPayment.hs create mode 100644 common/src/Common/Model/EditPaymentForm.hs create mode 100644 server/src/Controller/Helper.hs create mode 100644 server/src/Model/CreatePayment.hs create mode 100644 server/src/Model/EditPayment.hs delete mode 100644 server/src/Validation/Atomic.hs delete mode 100644 server/src/Validation/CreatePayment.hs create mode 100644 server/src/Validation/Payment.hs diff --git a/ISSUES.md b/ISSUES.md index ba8d15f..1286596 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -2,10 +2,6 @@ - Implement routing -## Payment view - -- Remove old validation, use client validation on the backend - ## Income view - Show the income table diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 5980ed2..102f554 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -9,11 +9,10 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T -import Data.Validation (Validation (Failure, Success)) +import Data.Validation (Validation) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import qualified Common.Msg as Msg import qualified Util.Validation as ValidationUtil data (Reflex t) => SelectIn t a b c = SelectIn @@ -22,7 +21,7 @@ data (Reflex t) => SelectIn t a b c = SelectIn , _selectIn_value :: Event t a , _selectIn_values :: Dynamic t (Map a Text) , _selectIn_reset :: Event t b - , _selectIn_isValid :: a -> Bool + , _selectIn_isValid :: a -> Validation Text a , _selectIn_validate :: Event t c } @@ -41,11 +40,7 @@ select selectIn = do ]) validatedValue = - R.ffor value (\v -> - if _selectIn_isValid selectIn v then - Success v - else - Failure (Msg.get Msg.Form_NonEmpty)) + fmap (_selectIn_isValid selectIn) value maybeError = fmap ValidationUtil.maybeError validatedValue diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index e83dba9..28c0148 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -3,23 +3,22 @@ module View.Payment.Add , Input(..) ) where -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CreatePayment (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Common.Validation.Payment as PaymentValidation -import qualified Component.Modal as Modal -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form +import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CreatePaymentForm (..), + Frequency (..), Payment (..), + PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form data Input t = Input { _input_categories :: [Category] @@ -45,7 +44,7 @@ view input cancel = do , Form._input_date = currentDay , Form._input_category = -1 , Form._input_frequency = frequency - , Form._input_mkPayload = CreatePayment + , Form._input_mkPayload = CreatePaymentForm , Form._input_httpMethod = Form.Post } diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 922e89c..60694ca 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -3,23 +3,22 @@ module View.Payment.Clone , view ) where -import qualified Control.Monad as Monad -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - CreatePayment (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Common.Validation.Payment as PaymentValidation -import qualified Component.Modal as Modal -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form +import qualified Control.Monad as Monad +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Time.Clock as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form data Input t = Input { _input_show :: Event t () @@ -48,7 +47,7 @@ view input cancel = do , Form._input_date = currentDay , Form._input_category = category , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = CreatePayment + , Form._input_mkPayload = CreatePaymentForm , Form._input_httpMethod = Form.Post } diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 9c11af0..0361602 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -3,20 +3,19 @@ module View.Payment.Edit , view ) where -import qualified Control.Monad as Monad -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Control.Monad as Monad +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Category (..), CategoryId, - EditPayment (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Validation.Payment as PaymentValidation -import qualified Component.Modal as Modal -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form +import Common.Model (Category (..), CategoryId, + EditPaymentForm (..), Frequency (..), + Payment (..), PaymentCategory (..), + SavedPayment (..)) +import qualified Common.Msg as Msg +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Form as Form data Input t = Input { _input_show :: Event t () @@ -43,7 +42,7 @@ view input cancel = do , Form._input_date = _payment_date payment , Form._input_category = category , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = EditPayment (_payment_id payment) + , Form._input_mkPayload = EditPaymentForm (_payment_id payment) , Form._input_httpMethod = Form.Put } diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 9889638..187b64b 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -46,7 +46,7 @@ data Input t p = Input , _input_date :: Day , _input_category :: CategoryId , _input_frequency :: Frequency - , _input_mkPayload :: Text -> Int -> Day -> CategoryId -> Frequency -> p + , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> p , _input_httpMethod :: HttpMethod } @@ -80,7 +80,7 @@ view input = do (_input_name input <$ reset) confirm - cost <- _inputOut_value <$> (Component.input + cost <- _inputOut_raw <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost , _inputIn_initialValue = _input_cost input @@ -91,7 +91,7 @@ view input = do let initialDate = T.pack . Calendar.showGregorian . _input_date $ input - date <- _inputOut_value <$> (Component.input + date <- _inputOut_raw <$> (Component.input (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Date , _inputIn_initialValue = initialDate @@ -113,7 +113,7 @@ view input = do , _selectIn_value = setCategory , _selectIn_values = R.constDyn categories , _selectIn_reset = _input_category input <$ reset - , _selectIn_isValid = (/= -1) + , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) , _selectIn_validate = confirm }) @@ -124,8 +124,8 @@ view input = do cat <- category return ((_input_mkPayload input) <$> ValidationUtil.nelError n - <*> ValidationUtil.nelError c - <*> ValidationUtil.nelError d + <*> V.Success c + <*> V.Success d <*> ValidationUtil.nelError cat <*> V.Success (_input_frequency input)) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 7281195..6ed3b0e 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -13,6 +13,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time (NominalDiffTime) import qualified Data.Time as Time +import qualified Data.Validation as V import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R @@ -150,7 +151,7 @@ searchLine reset = do , _selectIn_value = R.never , _selectIn_values = R.constDyn frequencies , _selectIn_reset = R.never - , _selectIn_isValid = const True + , _selectIn_isValid = V.Success , _selectIn_validate = R.never }) diff --git a/common/common.cabal b/common/common.cabal index a454270..64a3b3e 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,7 +29,7 @@ Library Exposed-modules: Common.Model - Common.Model.CreatePayment + Common.Model.CreatePaymentForm Common.Model.Email Common.Model.Payment Common.Model.SavedPayment @@ -54,7 +54,7 @@ Library Common.Model.Currency Common.Model.EditCategory Common.Model.EditIncome - Common.Model.EditPayment + Common.Model.EditPaymentForm Common.Model.Frequency Common.Model.Income Common.Model.Init diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 1abc3e3..5b71a84 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -1,21 +1,21 @@ module Common.Model (module X) where -import Common.Model.Category as X -import Common.Model.CreateCategory as X -import Common.Model.CreateIncome as X -import Common.Model.CreatePayment as X -import Common.Model.Currency as X -import Common.Model.EditCategory as X -import Common.Model.EditIncome as X -import Common.Model.EditPayment as X -import Common.Model.Email as X -import Common.Model.Frequency as X -import Common.Model.Income as X -import Common.Model.Init as X -import Common.Model.InitResult as X -import Common.Model.Payer as X -import Common.Model.Payment as X -import Common.Model.PaymentCategory as X -import Common.Model.SavedPayment as X -import Common.Model.SignInForm as X -import Common.Model.User as X +import Common.Model.Category as X +import Common.Model.CreateCategory as X +import Common.Model.CreateIncome as X +import Common.Model.CreatePaymentForm as X +import Common.Model.Currency as X +import Common.Model.EditCategory as X +import Common.Model.EditIncome as X +import Common.Model.EditPaymentForm as X +import Common.Model.Email as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.Init as X +import Common.Model.InitResult as X +import Common.Model.Payer as X +import Common.Model.Payment as X +import Common.Model.PaymentCategory as X +import Common.Model.SavedPayment as X +import Common.Model.SignInForm as X +import Common.Model.User as X diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs deleted file mode 100644 index c61423c..0000000 --- a/common/src/Common/Model/CreatePayment.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Common.Model.CreatePayment - ( CreatePaymentError(..) - , CreatePayment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) - -data CreatePaymentError = CreatePaymentError - { _createPaymentError_name :: Maybe Text - , _createPaymentError_cost :: Maybe Text - , _createPaymentError_date :: Maybe Text - , _createPaymentError_category :: Maybe Text - , _createPaymentError_frequency :: Maybe Text - } deriving (Show, Generic) - -instance FromJSON CreatePaymentError -instance ToJSON CreatePaymentError - -data CreatePayment = CreatePayment - { _createPayment_name :: Text - , _createPayment_cost :: Int - , _createPayment_date :: Day - , _createPayment_category :: CategoryId - , _createPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment -instance ToJSON CreatePayment diff --git a/common/src/Common/Model/CreatePaymentForm.hs b/common/src/Common/Model/CreatePaymentForm.hs new file mode 100644 index 0000000..60c5423 --- /dev/null +++ b/common/src/Common/Model/CreatePaymentForm.hs @@ -0,0 +1,21 @@ +module Common.Model.CreatePaymentForm + ( CreatePaymentForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) + +data CreatePaymentForm = CreatePaymentForm + { _createPaymentForm_name :: Text + , _createPaymentForm_cost :: Text + , _createPaymentForm_date :: Text + , _createPaymentForm_category :: CategoryId + , _createPaymentForm_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON CreatePaymentForm +instance ToJSON CreatePaymentForm diff --git a/common/src/Common/Model/EditPayment.hs b/common/src/Common/Model/EditPayment.hs deleted file mode 100644 index 8860b84..0000000 --- a/common/src/Common/Model/EditPayment.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Common.Model.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) -import Common.Model.Payment (PaymentId) - -data EditPayment = EditPayment - { _editPayment_id :: PaymentId - , _editPayment_name :: Text - , _editPayment_cost :: Int - , _editPayment_date :: Day - , _editPayment_category :: CategoryId - , _editPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment -instance ToJSON EditPayment diff --git a/common/src/Common/Model/EditPaymentForm.hs b/common/src/Common/Model/EditPaymentForm.hs new file mode 100644 index 0000000..168c9ff --- /dev/null +++ b/common/src/Common/Model/EditPaymentForm.hs @@ -0,0 +1,23 @@ +module Common.Model.EditPaymentForm + ( EditPaymentForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.Frequency (Frequency) +import Common.Model.Payment (PaymentId) + +data EditPaymentForm = EditPaymentForm + { _editPaymentForm_id :: PaymentId + , _editPaymentForm_name :: Text + , _editPaymentForm_cost :: Text + , _editPaymentForm_date :: Text + , _editPaymentForm_category :: CategoryId + , _editPaymentForm_frequency :: Frequency + } deriving (Show, Generic) + +instance FromJSON EditPaymentForm +instance ToJSON EditPaymentForm diff --git a/common/src/Common/Validation/Payment.hs b/common/src/Common/Validation/Payment.hs index b6c1d30..1bb00ce 100644 --- a/common/src/Common/Validation/Payment.hs +++ b/common/src/Common/Validation/Payment.hs @@ -2,20 +2,31 @@ module Common.Validation.Payment ( name , cost , date + , category ) where import Data.Text (Text) import Data.Time.Calendar (Day) import Data.Validation (Validation) -import qualified Data.Validation as Validation +import qualified Data.Validation as V +import Common.Model (CategoryId) +import qualified Common.Msg as Msg import qualified Common.Validation.Atomic as Atomic + name :: Text -> Validation Text Text name = Atomic.nonEmpty cost :: Text -> Validation Text Int -cost input = Validation.bindValidation (Atomic.number input) Atomic.nonNullNumber +cost input = V.bindValidation (Atomic.number input) Atomic.nonNullNumber date :: Text -> Validation Text Day date = Atomic.day + +category :: [CategoryId] -> CategoryId -> Validation Text CategoryId +category cs c = + if elem c cs then + V.Success c + else + V.Failure $ Msg.get Msg.Form_InvalidCategory diff --git a/server/server.cabal b/server/server.cabal index 3c1c770..ea7ebed 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -50,6 +50,7 @@ Executable server , transformers , unordered-containers , uuid + , validation , wai , wai-extra , wai-middleware-static @@ -57,6 +58,7 @@ Executable server other-modules: Conf Controller.Category + Controller.Helper Controller.Income Controller.Index Controller.Payment @@ -90,6 +92,8 @@ Executable server Job.WeeklyReport Json LoginSession + Model.CreatePayment + Model.EditPayment Model.IncomeResource Model.Mail Model.PaymentResource @@ -107,8 +111,7 @@ Executable server Secure SendMail Util.Time - Validation.Atomic - Validation.CreatePayment + Validation.Payment View.Mail.SignIn View.Mail.WeeklyReport View.Page diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs new file mode 100644 index 0000000..fd0d2bb --- /dev/null +++ b/server/src/Controller/Helper.hs @@ -0,0 +1,17 @@ +module Controller.Helper + ( jsonOrBadRequest + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () +jsonOrBadRequest (Left message) = do + S.status Status.badRequest400 + S.text (LT.fromStrict message) +jsonOrBadRequest (Right a) = + S.json a diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 38c1c19..ba9d1ba 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -6,18 +6,25 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) +import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) -import Common.Model (CreatePayment (..), - EditPayment (..), Payment (..), - PaymentId, SavedPayment (..), - User (..)) +import Common.Model (Category (..), + CreatePaymentForm (..), + EditPaymentForm (..), + Payment (..), PaymentId, + SavedPayment (..), User (..)) +import qualified Common.Msg as Msg +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure -import qualified Validation.CreatePayment as CreatePaymentValidation +import qualified Validation.Payment as PaymentValidation list :: ActionM () list = @@ -25,39 +32,39 @@ list = (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) -create :: CreatePayment -> ActionM () -create createPayment@(CreatePayment name cost date category frequency) = +create :: CreatePaymentForm -> ActionM () +create form = Secure.loggedAction (\user -> - case CreatePaymentValidation.validate createPayment of - Nothing -> - (liftIO . Query.run $ do + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.list + case PaymentValidation.createPayment cs form of + Success (CreatePayment name cost date category frequency) -> do pc <- PaymentCategoryPersistence.save name category p <- PaymentPersistence.create (_user_id user) name cost date frequency - return $ SavedPayment p pc - ) >>= json - Just validationError -> - do - status Status.badRequest400 - json validationError + return . Right $ SavedPayment p pc + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) -edit :: EditPayment -> ActionM () -edit (EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - result <- liftIO . Query.run $ do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return $ Just (new, pc) - Nothing -> - return Nothing - case result of - Just (p, pc) -> - json $ SavedPayment p pc - Nothing -> - status Status.badRequest400 +edit :: EditPaymentForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.list + case PaymentValidation.editPayment cs form of + Success (EditPayment paymentId name cost date category frequency) -> do + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency + case editedPayment of + Just (old, new) -> do + pc <- PaymentCategoryPersistence.save name category + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return . Right $ SavedPayment new pc + Nothing -> + return . Left $ Msg.get Msg.Error_PaymentEdit + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) delete :: PaymentId -> ActionM () diff --git a/server/src/Model/CreatePayment.hs b/server/src/Model/CreatePayment.hs new file mode 100644 index 0000000..b25d2a4 --- /dev/null +++ b/server/src/Model/CreatePayment.hs @@ -0,0 +1,16 @@ +module Model.CreatePayment + ( CreatePayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency) + +data CreatePayment = CreatePayment + { _createPayment_name :: Text + , _createPayment_cost :: Int + , _createPayment_date :: Day + , _createPayment_category :: CategoryId + , _createPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Model/EditPayment.hs b/server/src/Model/EditPayment.hs new file mode 100644 index 0000000..ac4c906 --- /dev/null +++ b/server/src/Model/EditPayment.hs @@ -0,0 +1,17 @@ +module Model.EditPayment + ( EditPayment(..) + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) + +import Common.Model (CategoryId, Frequency, PaymentId) + +data EditPayment = EditPayment + { _editPayment_id :: PaymentId + , _editPayment_name :: Text + , _editPayment_cost :: Int + , _editPayment_date :: Day + , _editPayment_category :: CategoryId + , _editPayment_frequency :: Frequency + } deriving (Show) diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs deleted file mode 100644 index 7a7351a..0000000 --- a/server/src/Validation/Atomic.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Validation.Atomic - ( nonEmpty - , nonNullNumber - -- , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import qualified Common.Msg as Msg - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Just $ Msg.get Msg.Form_NonEmpty - else Nothing - -nonNullNumber :: Int -> Maybe Text -nonNullNumber n = - if n == 0 - then Just $ Msg.get Msg.Form_NonNullNumber - else Nothing - --- number :: (Int -> Bool) -> Text -> Maybe Int --- number numberForm str = --- case reads (T.unpack str) :: [(Int, String)] of --- (num, _) : _ -> --- if numberForm num --- then Just num --- else Nothing --- _ -> --- Nothing diff --git a/server/src/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs deleted file mode 100644 index fbcdb7c..0000000 --- a/server/src/Validation/CreatePayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Validation.CreatePayment - ( validate - ) where - -import Data.Maybe (catMaybes) - -import Common.Model.CreatePayment (CreatePayment (..), - CreatePaymentError (..)) -import qualified Validation.Atomic as Atomic - -validate :: CreatePayment -> Maybe CreatePaymentError -validate p = - if not . null . catMaybes $ [ nameError, costError ] - then Just createPaymentError - else Nothing - where - nameError = Atomic.nonEmpty . _createPayment_name $ p - costError = Atomic.nonNullNumber . _createPayment_cost $ p - createPaymentError = CreatePaymentError - { _createPaymentError_name = nameError - , _createPaymentError_cost = costError - , _createPaymentError_date = Nothing - , _createPaymentError_category = Nothing - , _createPaymentError_frequency = Nothing - } diff --git a/server/src/Validation/Payment.hs b/server/src/Validation/Payment.hs new file mode 100644 index 0000000..20e370e --- /dev/null +++ b/server/src/Validation/Payment.hs @@ -0,0 +1,33 @@ +module Validation.Payment + ( createPayment + , editPayment + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CategoryId, CreatePaymentForm (..), + EditPaymentForm (..)) +import qualified Common.Validation.Payment as PaymentValidation +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) + +createPayment :: [CategoryId] -> CreatePaymentForm -> Validation Text CreatePayment +createPayment categories form = + CreatePayment + <$> PaymentValidation.name (_createPaymentForm_name form) + <*> PaymentValidation.cost (_createPaymentForm_cost form) + <*> PaymentValidation.date (_createPaymentForm_date form) + <*> PaymentValidation.category categories (_createPaymentForm_category form) + <*> V.Success (_createPaymentForm_frequency form) + +editPayment :: [CategoryId] -> EditPaymentForm -> Validation Text EditPayment +editPayment categories form = + EditPayment + <$> V.Success (_editPaymentForm_id form) + <*> PaymentValidation.name (_editPaymentForm_name form) + <*> PaymentValidation.cost (_editPaymentForm_cost form) + <*> PaymentValidation.date (_editPaymentForm_date form) + <*> PaymentValidation.category categories (_editPaymentForm_category form) + <*> V.Success (_editPaymentForm_frequency form) -- cgit v1.2.3 From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- ISSUES.md | 9 +- Makefile | 4 +- README.md | 4 +- client/client.cabal | 12 ++ client/src/Component.hs | 1 + client/src/Component/Link.hs | 33 ++++ client/src/Model/Route.hs | 9 ++ client/src/Util/Css.hs | 9 ++ client/src/Util/Router.hs | 266 +++++++++++++++++++++++++++++++ client/src/View/App.hs | 87 +++++++--- client/src/View/Header.hs | 65 ++++++-- client/src/View/NotFound.hs | 20 +++ client/src/View/Payment.hs | 9 +- client/src/View/Payment/Delete.hs | 2 +- client/src/View/Payment/Form.hs | 2 +- client/src/View/SignIn.hs | 2 +- common/src/Common/Message/Key.hs | 3 + common/src/Common/Message/Translation.hs | 10 ++ server/server.cabal | 1 + server/src/Controller/Index.hs | 2 +- server/src/Design/View/Header.hs | 7 +- server/src/Design/View/NotFound.hs | 21 +++ server/src/Design/Views.hs | 21 +-- server/src/Main.hs | 36 +++-- 24 files changed, 550 insertions(+), 85 deletions(-) create mode 100644 client/src/Component/Link.hs create mode 100644 client/src/Model/Route.hs create mode 100644 client/src/Util/Css.hs create mode 100644 client/src/Util/Router.hs create mode 100644 client/src/View/NotFound.hs create mode 100644 server/src/Design/View/NotFound.hs diff --git a/ISSUES.md b/ISSUES.md index 1286596..b7d31c3 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,7 +1,3 @@ -# MVP - -- Implement routing - ## Income view - Show the income table @@ -16,6 +12,11 @@ - Edit a category - Remove a category +## Phone + +- Slow, consider native ? +- Fix sign-in responsiveness + # Additional features - Remove unused payment category after payment edit on frontend diff --git a/Makefile b/Makefile index 31d9a62..5c615b3 100644 --- a/Makefile +++ b/Makefile @@ -29,7 +29,7 @@ cp-client: @cp dist-client/build/x86_64-linux/ghcjs-*/client-*/*/client/build/client/client.jsexe/all.js public/javascript/main.js watch-client: - @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(clear && make build-client-inside && make cp-client) || true'" + @nix-shell -A shells.ghcjs --run "nodemon --delay 0.2 --watch client --watch common --ext hs --exec '(tput reset && make build-client-inside && make cp-client) || true'" # Server # ------ @@ -48,4 +48,4 @@ run-server: @./dist-server/build/x86_64-linux/ghc-*/server-0.0.1/*/server/build/server/server watch-server: - @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(clear && make build-server-inside && make run-server) || :'" + @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(tput reset && make build-server-inside && make run-server) || :'" diff --git a/README.md b/README.md index 6e1c675..7f8d8f3 100644 --- a/README.md +++ b/README.md @@ -53,8 +53,8 @@ See [application.conf](application.conf). ## Documentation -- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html) -- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html) +- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.4/docs/doc-index-All.html) +- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-core-0.5/docs/doc-index-All.html) ## Issues diff --git a/client/client.cabal b/client/client.cabal index 5fc20ae..55ba5e1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -35,22 +35,34 @@ Executable client , time , validation + -- Router + , ghcjs-base + , ghcjs-prim + , ghcjs-dom + , jsaddle + , lens + , uri-bytestring + other-modules: Component Component.Button Component.Form Component.Input + Component.Link Component.Modal Component.Select Icon Util.Ajax + Util.Css Util.Either Util.List Util.Reflex + Util.Router Util.Validation Util.WaitFor View.App View.Header + View.NotFound View.Payment View.Payment.Add View.Payment.Clone diff --git a/client/src/Component.hs b/client/src/Component.hs index 7b87a75..7e0b151 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -3,5 +3,6 @@ module Component (module X) where import Component.Button as X import Component.Form as X import Component.Input as X +import Component.Link as X import Component.Modal as X import Component.Select as X diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs new file mode 100644 index 0000000..7e8558b --- /dev/null +++ b/client/src/Component/Link.hs @@ -0,0 +1,33 @@ +module Component.Link + ( link + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () +link href inputAttrs content = + R.elDynAttr "a" attrs (R.text content) + where + + onclickHandler = + T.intercalate ";" + [ "history.pushState(0, '', event.target.href)" + , "dispatchEvent(new PopStateEvent('popstate', {cancelable: true, bubbles: true, view: window}))" + , "return false" + ] + + attrs = + R.ffor inputAttrs (\as -> + (M.union + (M.fromList + [ ("onclick", onclickHandler) + , ("href", href) + ] + ) + as) + ) diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs new file mode 100644 index 0000000..420fe05 --- /dev/null +++ b/client/src/Model/Route.hs @@ -0,0 +1,9 @@ +module Model.Route + ( Route(..) + ) where + +data Route + = RootRoute + | IncomeRoute + | NotFoundRoute + deriving (Eq, Show) diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs new file mode 100644 index 0000000..804b10f --- /dev/null +++ b/client/src/Util/Css.hs @@ -0,0 +1,9 @@ +module Util.Css + ( classes + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +classes :: [(Text, Bool)] -> Text +classes = T.unwords . map fst . filter snd diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs new file mode 100644 index 0000000..e9d0a1a --- /dev/null +++ b/client/src/Util/Router.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Util.Router ( + -- == High-level routers + route + , route' + , partialPathRoute + + -- = Low-level URL bar access + , getLoc + , getURI + , getUrlText + , uriOrigin + , URI + + -- = History movement + , goForward + , goBack + ) where + +------------------------------------------------------------------------------ +import Control.Lens ((&), (.~), (^.)) +import Control.Monad.Fix (MonadFix) +import qualified Data.ByteString.Char8 as BS +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHCJS.DOM (currentDocumentUnchecked, + currentWindowUnchecked) +import GHCJS.DOM.Document (createEvent) +import GHCJS.DOM.Event (initEvent) +import GHCJS.DOM.EventM (on) +import GHCJS.DOM.EventTarget (dispatchEvent_) +import GHCJS.DOM.History (History, back, forward, + pushState) +import GHCJS.DOM.Location (getHref) +import GHCJS.DOM.PopStateEvent +import GHCJS.DOM.Types (Location (..), + PopStateEvent (..)) +import GHCJS.DOM.Types (MonadJSM, uncheckedCastTo) +import qualified GHCJS.DOM.Types as DOM +import GHCJS.DOM.Window (getHistory, getLocation) +import GHCJS.DOM.WindowEventHandlers (popState) +import GHCJS.Foreign (isFunction) +import GHCJS.Marshal.Pure (pFromJSVal) +import Language.Javascript.JSaddle (JSM, Object (..), ghcjsPure, + liftJSM) +import qualified Language.Javascript.JSaddle as JS +import Reflex.Dom.Core hiding (EventName, Window) +import qualified URI.ByteString as U +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------- +-- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic +-- routing of a widget +-- These sources of URL-bar change will be reflected in the output URI +-- - Input events to 'route' +-- - Browser Forward/Back button clicks +-- - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls +-- - Any URL changes followed by a popState event +-- But external calls to pushState that don't manually fire a popState +-- won't be detected +route + :: forall t m. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m)) + => Event t T.Text + -> m (Dynamic t (U.URIRef U.Absolute)) +route pushTo = do + loc0 <- getURI + + _ <- performEvent $ ffor pushTo $ \t -> do + let newState = Just t + withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text) + liftJSM dispatchEvent' + + locUpdates <- getPopState + holdDyn loc0 locUpdates + +route' + :: forall t m a b. + ( MonadHold t m + , PostBuild t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => (URI -> a -> URI) + -> (URI -> b) + -> Event t a + -> m (Dynamic t b) +route' encode decode routeUpdate = do + rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates) + let urlUpdates = attachWith encode (current rUri) routeUpdate + return $ decode <$> rUri + + +------------------------------------------------------------------------------- +-- | Route a single page app according to the part of the path after +-- pathBase +partialPathRoute + :: forall t m. + ( MonadHold t m + , PostBuild t m + , DomBuilder t m + , TriggerEvent t m + , PerformEvent t m + , HasJSContext m + , HasJSContext (Performable m) + , MonadJSM m + , MonadJSM (Performable m) + , MonadFix m) + => T.Text -- ^ The path segments not related to SPA routing + -- (leading '/' will be added automaticaly) + -> Event t T.Text -- ^ Updates to the path segments used for routing + -- These values will be appended to the base path + -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing +partialPathRoute pathBase pathUpdates = do + route' (flip updateUrl) parseParts pathUpdates + where + + rootPathBase :: T.Text + rootPathBase = + if T.null pathBase then + "" + else + "/" <> cleanT pathBase + + toPath :: T.Text -> BS.ByteString + toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath + + updateUrl :: T.Text -> URI -> URI + updateUrl updateParts u = u & U.pathL .~ toPath updateParts + + parseParts :: URI -> [T.Text] + parseParts u = + maybe (error $ pfxErr u pathBase) + (T.splitOn "/" . T.decodeUtf8 . cleanB) . + BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $ + cleanB (u ^. U.pathL) + + cleanT = T.dropWhile (=='/') + cleanB = BS.dropWhile (== '/') + + +------------------------------------------------------------------------------- +uriOrigin :: U.URIRef U.Absolute -> T.Text +uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r' + where + r' = r { U.uriPath = mempty + , U.uriQuery = mempty + , U.uriFragment = mempty + } + + +------------------------------------------------------------------------------- +getPopState + :: forall t m. + ( MonadHold t m + , TriggerEvent t m + , MonadJSM m) => m (Event t URI) +getPopState = do + window <- currentWindowUnchecked + wrapDomEventMaybe window (`on` popState) $ do + loc <- getLocation window + locStr <- getHref loc + return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr) + + +------------------------------------------------------------------------------- +goForward :: (HasJSContext m, MonadJSM m) => m () +goForward = withHistory forward + + +------------------------------------------------------------------------------- +goBack :: (HasJSContext m, MonadJSM m) => m () +goBack = withHistory back + + +------------------------------------------------------------------------------- +withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a +withHistory act = do + w <- currentWindowUnchecked + h <- getHistory w + act h + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window +getLoc :: (HasJSContext m, MonadJSM m) => m Location +getLoc = do + win <- currentWindowUnchecked + loc <- getLocation win + return loc + + +------------------------------------------------------------------------------- +-- | (Unsafely) get the URL text of a window +getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text +getUrlText = getLoc >>= getHref + + +------------------------------------------------------------------------------- +type URI = U.URIRef U.Absolute + + +------------------------------------------------------------------------------- +getURI :: (HasJSContext m, MonadJSM m) => m URI +getURI = do + l <- getUrlText + return $ either (error "No parse of window location") id . + U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l + + +dispatchEvent' :: JSM () +dispatchEvent' = do + window <- currentWindowUnchecked + obj@(Object o) <- JS.create + JS.objSetPropertyByName obj ("cancelable" :: Text) True + JS.objSetPropertyByName obj ("bubbles" :: Text) True + JS.objSetPropertyByName obj ("view" :: Text) window + event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case + True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o + False -> do + doc <- currentDocumentUnchecked + event <- createEvent doc ("PopStateEvent" :: Text) + initEvent event ("popstate" :: Text) True True + JS.objSetPropertyByName obj ("view" :: Text) window + return $ uncheckedCastTo PopStateEvent event + + dispatchEvent_ window event + + +------------------------------------------------------------------------------- +hush :: Either e a -> Maybe a +hush (Right a) = Just a +hush _ = Nothing + + +------------------------------------------------------------------------------- +pfxErr :: URI -> T.Text -> String +pfxErr pn pathBase = + T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn) + <> ") without expected prefix (" <> pathBase <> ")" diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 6435297..d853c7e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,41 +2,84 @@ module View.App ( widget ) where -import Prelude hiding (error, init) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (InitResult (..)) -import qualified Common.Msg as Msg +import Common.Model (Init, InitResult (..)) +import qualified Common.Msg as Msg -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import Model.Route (Route (..)) +import qualified Util.Router as Router +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import qualified View.NotFound as NotFound +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = R.mainWidget $ R.divClass "app" $ do + route <- getRoute + headerOut <- Header.view $ HeaderIn { _headerIn_initResult = initResult + , _headerIn_isInitSuccess = + case initResult of + InitSuccess _ -> True + _ -> False + , _headerIn_route = route } - let signOut = Header._headerOut_signOut headerOut + let signOut = + Header._headerOut_signOut headerOut + + mainContent = + case initResult of + InitSuccess init -> + signedWidget init route + + InitEmpty -> + SignIn.view SignIn.EmptyMessage - initialContent = case initResult of - InitSuccess initSuccess -> do - _ <- Payment.widget $ PaymentIn - { _paymentIn_init = initSuccess - } - return () - InitEmpty -> - SignIn.view SignIn.EmptyMessage - InitError error -> - SignIn.view (SignIn.ErrorMessage error) + InitError error -> + SignIn.view (SignIn.ErrorMessage error) - signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) + signOutContent = + SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) - _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) + _ <- R.widgetHold (mainContent) (signOutContent <$ signOut) R.blank + +signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget init route = do + R.dyn . R.ffor route $ \case + RootRoute -> + Payment.widget $ PaymentIn + { _paymentIn_init = init + } + + IncomeRoute -> + R.el "div" $ R.text "Incomes" + + NotFoundRoute -> + NotFound.view + + return () + +getRoute :: MonadWidget t m => m (Dynamic t Route) +getRoute = do + r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never + return . R.ffor r $ \case + [""] -> + RootRoute + + ["income"] -> + IncomeRoute + + _ -> + NotFoundRoute diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 8f1fb78..9a4de89 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -4,40 +4,73 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Component as Component -import Component.Button (ButtonIn (..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import Component (ButtonIn (..)) +import qualified Component as Component import qualified Icon +import Model.Route (Route (..)) +import qualified Util.Css as CssUtil +import qualified Util.Reflex as ReflexUtil -data HeaderIn = HeaderIn - { _headerIn_initResult :: InitResult +data HeaderIn t = HeaderIn + { _headerIn_initResult :: InitResult + , _headerIn_isInitSuccess :: Bool + , _headerIn_route :: Dynamic t Route } data HeaderOut t = HeaderOut { _headerOut_signOut :: Event t () } -view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) +view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t) view headerIn = R.el "header" $ do R.divClass "title" $ R.text $ Msg.get Msg.App_Title - signOut <- nameSignOut $ _headerIn_initResult headerIn + signOut <- R.el "div" $ do + rec + showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut) + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn) + signOut <- nameSignOut $ _headerIn_initResult headerIn + return signOut return $ HeaderOut { _headerOut_signOut = signOut } +links :: forall t m. MonadWidget t m => Dynamic t Route -> m () +links route = do + Component.link + "/" + (R.ffor route (attrs RootRoute)) + (Msg.get Msg.Payment_Title) + + Component.link + "/income" + (R.ffor route (attrs IncomeRoute)) + (Msg.get Msg.Income_Title) + + where + attrs linkRoute currentRoute = + M.singleton "class" $ + CssUtil.classes + [ ("item", True) + , ("current", linkRoute == currentRoute) + ] + nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) nameSignOut initResult = case initResult of (InitSuccess init) -> do @@ -76,5 +109,5 @@ signOutButton = do where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) askSignOut signOut = fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut + where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut getResult = (== 200) . R._xhrResponse_status diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs new file mode 100644 index 0000000..1d4e477 --- /dev/null +++ b/client/src/View/NotFound.hs @@ -0,0 +1,20 @@ +module View.NotFound + ( view + ) where + +import qualified Data.Map as M +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component as Component + +view :: forall t m. MonadWidget t m => m () +view = + R.divClass "notfound" $ do + R.text (Msg.get Msg.NotFound_Message) + + Component.link + "/" + (R.constDyn $ M.singleton "class" "link") + (Msg.get Msg.NotFound_LinkMessage) diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index f2a5071..1072a5e 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,7 +1,6 @@ module View.Payment ( widget , PaymentIn(..) - , PaymentOut(..) ) where import Data.Text (Text) @@ -26,11 +25,7 @@ data PaymentIn = PaymentIn { _paymentIn_init :: Init } -data PaymentOut = PaymentOut - { - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut +widget :: forall t m. MonadWidget t m => PaymentIn -> m () widget paymentIn = do R.elClass "main" "payment" $ do rec @@ -86,7 +81,7 @@ widget paymentIn = do ] } - pure $ PaymentOut {} + pure () debounceSearchName :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index e7e319e..521c1a7 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -44,7 +44,7 @@ view input _ = let url = R.ffor (_input_payment input) (\id -> - T.concat ["/payment/", T.pack . show $ _payment_id id] + T.concat ["/api/payment/", T.pack . show $ _payment_id id] ) (result, waiting) <- WaitFor.waitFor diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 187b64b..7819836 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -143,7 +143,7 @@ view input = do }) (addPayment, waiting) <- WaitFor.waitFor - (ajax "/payment") + (ajax "/api/payment") (ValidationUtil.fireValidation payment confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index f8b985f..8c248bd 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/askSignIn") + (Ajax.postJson "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index e460d3e..c2fde58 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -150,3 +150,6 @@ data Key = | WeeklyReport_PaymentDeleted Int | WeeklyReport_PaymentEdited Int | WeeklyReport_Title + + | NotFound_Message + | NotFound_LinkMessage diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 6b9e7be..3173561 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -693,3 +693,13 @@ m l WeeklyReport_Title = case l of English -> "Weekly report" French -> "Rapport hebdomadaire" + +m l NotFound_Message = + case l of + English -> "There is nothing here!" + French -> "Vous vous êtes perdu." + +m l NotFound_LinkMessage = + case l of + English -> "Go back to the home page." + French -> "Retour à l’accueil." diff --git a/server/server.cabal b/server/server.cabal index ea7ebed..75af442 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -73,6 +73,7 @@ Executable server Design.Modal Design.Tooltip Design.View.Header + Design.View.NotFound Design.View.Payment Design.View.Payment.Add Design.View.Payment.Delete diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index fbda527..5ebe921 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -57,7 +57,7 @@ askSignIn conf form = let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, - "/signIn/", + "/api/signIn/", token ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 2422686..59e0e51 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -40,8 +40,11 @@ design = do ".current" & backgroundColor (Color.chestnutRose -. 20) Media.mobile $ fontSize (px 13) - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + (".item" # hover) <> (".item" # focus) ? + backgroundColor (Color.chestnutRose +. 10) + + (".item.current" # hover) <> (".item.current" # focus) ? + backgroundColor (Color.chestnutRose -. 10) ".nameSignOut" ? do display flex diff --git a/server/src/Design/View/NotFound.hs b/server/src/Design/View/NotFound.hs new file mode 100644 index 0000000..150c6fc --- /dev/null +++ b/server/src/Design/View/NotFound.hs @@ -0,0 +1,21 @@ +module Design.View.NotFound + ( design + ) where + +import Clay +import Prelude hiding (rem) + +import qualified Design.Color as Color + +design :: Css +design = do + + marginLeft (rem 3) + + ".link" ? do + display block + marginTop (rem 1) + color Color.chestnutRose + textDecoration underline + hover & + color (Color.chestnutRose +. 15) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index b9e3cf8..bf39cff 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,16 +4,16 @@ module Design.Views import Clay -import qualified Design.View.Header as Header -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table design :: Css design = do @@ -21,6 +21,7 @@ design = do ".payment" ? Payment.design ".signIn" ? SignIn.design ".stat" ? Stat.design + ".notfound" ? NotFound.design Table.design ".withMargin" ? do diff --git a/server/src/Main.hs b/server/src/Main.hs index 0ccf5e2..e3dad9e 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -15,48 +15,52 @@ main = do conf <- Conf.get "application.conf" _ <- runDaemons conf S.scotty (Conf.port conf) $ do - S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress } - S.middleware . staticPolicy $ noDots >-> addBase "public" - S.get "/" $ do - Index.get conf + S.middleware $ + W.gzip $ W.def { W.gzipFiles = GzipCompress } + + S.middleware . staticPolicy $ + noDots >-> addBase "public" - S.post "/askSignIn" $ do + S.post "/api/askSignIn" $ S.jsonData >>= Index.askSignIn conf - S.get "/signIn/:signInToken" $ do + S.get "/api/signIn/:signInToken" $ do signInToken <- S.param "signInToken" Index.trySignIn conf signInToken - S.post "/signOut" $ + S.post "/api/signOut" $ Index.signOut conf - S.post "/payment" $ + S.post "/api/payment" $ S.jsonData >>= Payment.create - S.put "/payment" $ + S.put "/api/payment" $ S.jsonData >>= Payment.edit - S.delete "/payment/:id" $ do + S.delete "/api/payment/:id" $ do paymentId <- S.param "id" Payment.delete paymentId - S.post "/income" $ + S.post "/api/income" $ S.jsonData >>= Income.create - S.put "/income" $ + S.put "/api/income" $ S.jsonData >>= Income.edit - S.delete "/income/:id" $ do + S.delete "/api/income/:id" $ do incomeId <- S.param "id" Income.delete incomeId - S.post "/category" $ + S.post "/api/category" $ S.jsonData >>= Category.create - S.put "/category" $ + S.put "/api/category" $ S.jsonData >>= Category.edit - S.delete "/category/:id" $ do + S.delete "/api/category/:id" $ do categoryId <- S.param "id" Category.delete categoryId + + S.notFound $ + Index.get conf -- cgit v1.2.3 From 6dfc1c166db387a60630eff980e330518601df5b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 13 Oct 2019 20:58:45 +0200 Subject: Fix sign in responsiveness --- ISSUES.md | 3 +-- server/src/Design/Global.hs | 6 +++--- server/src/Design/View/SignIn.hs | 4 +++- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/ISSUES.md b/ISSUES.md index b7d31c3..92e9052 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -12,10 +12,9 @@ - Edit a category - Remove a category -## Phone +## Mobile - Slow, consider native ? -- Fix sign-in responsiveness # Additional features diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 24d999f..5b8f2dc 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -111,14 +111,14 @@ global = do display flex svg # ".loader" ? do - opacity 0 + display none position absolute ".waiting" & do ".content" ? do - opacity 0 + display none svg # ".loader" ? do - opacity 1 + display block spinAnimation select ? cursor pointer diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index 2138676..a39276e 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -4,6 +4,7 @@ module Design.View.SignIn import Clay import Data.Monoid ((<>)) +import Prelude hiding (rem) import qualified Design.Color as Color import qualified Design.Constants as Constants @@ -12,7 +13,8 @@ import qualified Design.Helper as Helper design :: Css design = do let inputHeight = 50 - width (px 500) + maxWidth (px 550) + sym2 padding (rem 0) (rem 2) marginTop (px 100) marginLeft auto marginRight auto -- cgit v1.2.3 From 04c59f08f100ba6a0658d1f2b357f7d8b1e14218 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 13 Oct 2019 22:38:35 +0200 Subject: Show income table --- ISSUES.md | 4 +- client/client.cabal | 4 +- client/src/Component.hs | 1 + client/src/Component/Table.hs | 38 ++++++++ client/src/View/App.hs | 40 ++++---- client/src/View/Income/Income.hs | 68 ++++++++++++++ client/src/View/Payment.hs | 154 ------------------------------- client/src/View/Payment/Payment.hs | 154 +++++++++++++++++++++++++++++++ client/src/View/Payment/Table.hs | 3 - common/src/Common/Message/Key.hs | 1 + common/src/Common/Message/Translation.hs | 9 +- 11 files changed, 297 insertions(+), 179 deletions(-) create mode 100644 client/src/Component/Table.hs create mode 100644 client/src/View/Income/Income.hs delete mode 100644 client/src/View/Payment.hs create mode 100644 client/src/View/Payment/Payment.hs diff --git a/ISSUES.md b/ISSUES.md index 92e9052..fbbcc87 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,7 +1,8 @@ ## Income view -- Show the income table +- Show the income header - Add an income +- Clone an income - Edit an income - Remove an income @@ -9,6 +10,7 @@ - Show the category table - Add a category +- Clone a category - Edit a category - Remove a category diff --git a/client/client.cabal b/client/client.cabal index 55ba5e1..f8fe1e1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -50,6 +50,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.Table Component.Select Icon Util.Ajax @@ -62,8 +63,8 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Income View.NotFound - View.Payment View.Payment.Add View.Payment.Clone View.Payment.Delete @@ -71,5 +72,6 @@ Executable client View.Payment.Form View.Payment.Header View.Payment.Pages + View.Payment.Payment View.Payment.Table View.SignIn diff --git a/client/src/Component.hs b/client/src/Component.hs index 7e0b151..97c250e 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -6,3 +6,4 @@ import Component.Input as X import Component.Link as X import Component.Modal as X import Component.Select as X +import Component.Table as X diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs new file mode 100644 index 0000000..a77a18d --- /dev/null +++ b/client/src/Component/Table.hs @@ -0,0 +1,38 @@ +module Component.Table + ( table + , TableIn(..) + , TableOut(..) + ) where + +import Data.Text (Text) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +data TableIn h r t = TableIn + { _tableIn_headerLabel :: h -> Text + , _tableIn_rows :: Dynamic t [r] + , _tableIn_cell :: h -> r -> Text + } + +data TableOut = TableOut + {} + +table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) +table tableIn = do + R.divClass "table" $ do + + R.divClass "lines" $ do + R.divClass "header" $ do + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" . R.text $ + _tableIn_headerLabel tableIn header + + R.simpleList (_tableIn_rows tableIn) $ \r -> + R.divClass "row" $ + flip mapM_ [minBound..] $ \h -> + R.divClass "cell name" $ + R.dynText $ + R.ffor r (_tableIn_cell tableIn h) + + return $ TableOut + {} diff --git a/client/src/View/App.hs b/client/src/View/App.hs index d853c7e..3292336 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,24 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init, InitResult (..)) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import View.Header (HeaderIn (..)) -import qualified View.Header as Header -import qualified View.NotFound as NotFound -import View.Payment (PaymentIn (..)) -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init, InitResult (..)) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Income.Income (IncomeIn (..)) +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import View.Payment.Payment (PaymentIn (..)) +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -59,12 +61,14 @@ signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> - Payment.widget $ PaymentIn + Payment.view $ PaymentIn { _paymentIn_init = init } IncomeRoute -> - R.el "div" $ R.text "Incomes" + Income.view $ IncomeIn + { _incomeIn_init = init + } NotFoundRoute -> NotFound.view diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs new file mode 100644 index 0000000..5e9ce1d --- /dev/null +++ b/client/src/View/Income/Income.hs @@ -0,0 +1,68 @@ +module View.Income.Income + ( view + , IncomeIn(..) + ) where + +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) +import qualified Component + +data IncomeIn = IncomeIn + { _incomeIn_init :: Init + } + +view :: forall t m. MonadWidget t m => IncomeIn -> m () +view incomeIn = + R.elClass "main" "income" $ do + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + Component.table $ TableIn + { _tableIn_headerLabel = headerLabel + , _tableIn_rows = + R.constDyn + . reverse + . L.sortOn _income_date + . _init_incomes + . _incomeIn_init + $ incomeIn + , _tableIn_cell = cell (_incomeIn_init incomeIn) + } + return () + +data Header + = UserHeader + | AmountHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel UserHeader = Msg.get Msg.Income_Name +headerLabel DateHeader = Msg.get Msg.Income_Date +headerLabel AmountHeader = Msg.get Msg.Income_Amount + +cell :: Init -> Header -> Income -> Text +cell init header income = + case header of + UserHeader -> + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + + DateHeader -> + Format.longDay . _income_date $ income + + AmountHeader -> + Format.price (_init_currency init) . _income_amount $ income diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs deleted file mode 100644 index 1072a5e..0000000 --- a/client/src/View/Payment.hs +++ /dev/null @@ -1,154 +0,0 @@ -module View.Payment - ( widget - , PaymentIn(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Frequency, Init (..), Payment (..), - PaymentCategory (..), PaymentId, - SavedPayment (..)) -import qualified Common.Util.Text as T -import View.Payment.Header (HeaderIn (..), HeaderOut (..)) -import qualified View.Payment.Header as Header -import View.Payment.Pages (PagesIn (..), PagesOut (..)) -import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..), TableOut (..)) -import qualified View.Payment.Table as Table - -data PaymentIn = PaymentIn - { _paymentIn_init :: Init - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m () -widget paymentIn = do - R.elClass "main" "payment" $ do - rec - let init = _paymentIn_init paymentIn - - paymentsPerPage = 7 - - addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table - ] - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) - - let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories - } - - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories - } - - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header - ] - } - - pure () - -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -getSearchPayments - :: forall t. Reflex t - => Dynamic t Text - -> Dynamic t Frequency - -> Dynamic t [Payment] - -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - ps <- payments - pure $ flip filter ps (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs new file mode 100644 index 0000000..cfdb441 --- /dev/null +++ b/client/src/View/Payment/Payment.hs @@ -0,0 +1,154 @@ +module View.Payment.Payment + ( view + , PaymentIn(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Frequency, Init (..), Payment (..), + PaymentCategory (..), PaymentId, + SavedPayment (..)) +import qualified Common.Util.Text as T +import View.Payment.Header (HeaderIn (..), HeaderOut (..)) +import qualified View.Payment.Header as Header +import View.Payment.Pages (PagesIn (..), PagesOut (..)) +import qualified View.Payment.Pages as Pages +import View.Payment.Table (TableIn (..), TableOut (..)) +import qualified View.Payment.Table as Table + +data PaymentIn = PaymentIn + { _paymentIn_init :: Init + } + +view :: forall t m. MonadWidget t m => PaymentIn -> m () +view paymentIn = do + R.elClass "main" "payment" $ do + rec + let init = _paymentIn_init paymentIn + + paymentsPerPage = 7 + + addPayment = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] + + payments <- reducePayments + (_init_payments init) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + paymentCategories <- reducePaymentCategories + (_init_paymentCategories init) + payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) + + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments + + header <- Header.widget $ HeaderIn + { _headerIn_init = init + , _headerIn_payments = payments + , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories + } + + table <- Table.widget $ TableIn + { _tableIn_init = init + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = searchPayments + , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories + } + + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> searchPayments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = R.leftmost $ + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header + ] + } + + pure () + +debounceSearchName + :: forall t m. MonadWidget t m + => Dynamic t Text + -> m (Event t Text, Dynamic t Text) +debounceSearchName searchName = do + event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) + dynamic <- R.holdDyn "" event + return (event, dynamic) + +reducePayments + :: forall t m. MonadWidget t m + => [Payment] + -> Event t Payment -- add payment + -> Event t Payment -- edit payment + -> Event t Payment -- delete payment + -> m (Dynamic t [Payment]) +reducePayments initPayments addPayment editPayment deletePayment = + R.foldDyn id initPayments $ R.leftmost + [ (:) <$> addPayment + , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) + , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) + ] + +reducePaymentCategories + :: forall t m. MonadWidget t m + => [PaymentCategory] + -> Dynamic t [Payment] -- payments + -> Event t PaymentCategory -- add payment category + -> Event t PaymentCategory -- edit payment category + -> Event t Payment -- delete payment + -> m (Dynamic t [PaymentCategory]) +reducePaymentCategories + initPaymentCategories + payments + addPaymentCategory + editPaymentCategory + deletePayment + = + R.foldDyn id initPaymentCategories $ R.leftmost + [ (:) <$> addPaymentCategory + , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) + , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) + ] + where + deletePaymentName = + R.attachWithMaybe + (\ps p -> + if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then + Nothing + else + Just (_payment_name p)) + (R.current payments) + deletePayment + lowerName = T.toLower . _payment_name + +getSearchPayments + :: forall t. Reflex t + => Dynamic t Text + -> Dynamic t Frequency + -> Dynamic t [Payment] + -> Dynamic t [Payment] +getSearchPayments name frequency payments = do + n <- name + f <- frequency + ps <- payments + pure $ flip filter ps (\p -> + ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) + && (_payment_frequency p == f) + )) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 40bc864..bf6b604 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -30,9 +30,6 @@ import qualified View.Payment.Edit as Edit import qualified Icon import qualified Util.Reflex as ReflexUtil --- TODO: remove -import Debug.Trace (trace) - data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index c2fde58..2561156 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -56,6 +56,7 @@ data Key = | Income_AddLong | Income_AddShort + | Income_Name | Income_Amount | Income_Clone | Income_CumulativeSince Text diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 3173561..25e9f4b 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -237,10 +237,15 @@ m l Income_AddShort = English -> "Add" French -> "Ajouter" +m l Income_Name = + case l of + English -> "Name" + French -> "Nom" + m l Income_Amount = case l of - English -> "Amount" - French -> "Montant" + English -> "Income" + French -> "Revenu" m l Income_Clone = case l of -- cgit v1.2.3 From 284214d3af39143fdbeca57ffa4864389e7d517a Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 14 Oct 2019 09:10:33 +0200 Subject: Show cumulative incomes per user in income page --- ISSUES.md | 1 - client/client.cabal | 1 + client/src/Util/Date.hs | 12 +++++++ client/src/View/Income/Income.hs | 71 ++++++++++++++++++++++++++++++---------- common/src/Common/Model/Payer.hs | 6 ++-- 5 files changed, 71 insertions(+), 20 deletions(-) create mode 100644 client/src/Util/Date.hs diff --git a/ISSUES.md b/ISSUES.md index fbbcc87..6863b00 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,6 +1,5 @@ ## Income view -- Show the income header - Add an income - Clone an income - Edit an income diff --git a/client/client.cabal b/client/client.cabal index f8fe1e1..eeeb8be 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -55,6 +55,7 @@ Executable client Icon Util.Ajax Util.Css + Util.Date Util.Either Util.List Util.Reflex diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs new file mode 100644 index 0000000..8fad881 --- /dev/null +++ b/client/src/Util/Date.hs @@ -0,0 +1,12 @@ +module Util.Date + ( utcToLocalDay + ) where + +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import qualified Data.Time.LocalTime as LocalTime + +utcToLocalDay :: UTCTime -> IO Day +utcToLocalDay time = do + timezone <- LocalTime.getCurrentTimeZone + return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 5e9ce1d..d0c0a45 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -3,19 +3,22 @@ module View.Income.Income , IncomeIn(..) ) where -import qualified Data.List as L -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Income (..), Init (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import Component (TableIn (..)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Clock as Clock +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) import qualified Component +import qualified Util.Date as DateUtil data IncomeIn = IncomeIn { _incomeIn_init :: Init @@ -25,11 +28,7 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m () view incomeIn = R.elClass "main" "income" $ do - R.divClass "withMargin" $ - R.divClass "titleButton" $ - R.el "h1" $ - R.text $ - Msg.get Msg.Income_MonthlyNet + header (_incomeIn_init incomeIn) Component.table $ TableIn { _tableIn_headerLabel = headerLabel @@ -42,8 +41,46 @@ view incomeIn = $ incomeIn , _tableIn_cell = cell (_incomeIn_init incomeIn) } + return () +header :: forall t m. MonadWidget t m => Init -> m () +header init = + R.divClass "withMargin" $ do + + currentTime <- liftIO Clock.getCurrentTime + + Maybe.fromMaybe R.blank $ + flip fmap useIncomesFrom $ \since -> + R.el "div" $ do + + R.el "h1" $ do + day <- liftIO $ DateUtil.utcToLocalDay since + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) + + R.el "ul" $ + flip mapM_ (_init_users init) $ \user -> + R.el "li" $ + R.text $ do + let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) + T.intercalate " " + [ _user_name user + , "−" + , Format.price (_init_currency init) $ + CM.cumulativeIncomesSince currentTime since incomes + ] + + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + where + useIncomesFrom = CM.useIncomesFrom + (map _user_id $_init_users init) + (_init_incomes init) + (_init_payments init) + data Header = UserHeader | AmountHeader diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs index d09dbf6..40228d5 100644 --- a/common/src/Common/Model/Payer.hs +++ b/common/src/Common/Model/Payer.hs @@ -1,6 +1,8 @@ module Common.Model.Payer - ( getExceedingPayers - , ExceedingPayer(..) + ( ExceedingPayer(..) + , getExceedingPayers + , useIncomesFrom + , cumulativeIncomesSince ) where import qualified Data.List as List -- cgit v1.2.3 From 0b40b6b5583b5c437f83e61bf8913f2b4c447b24 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 19 Oct 2019 09:36:03 +0200 Subject: Include pages into table component --- ISSUES.md | 1 + client/client.cabal | 1 + client/src/Component.hs | 1 + client/src/Component/Pages.hs | 88 ++++++++++++++++++++++++++++++++++++++++ client/src/Component/Table.hs | 53 +++++++++++++++++------- client/src/View/Income/Income.hs | 2 + server/server.cabal | 1 + server/src/Design/View/Pages.hs | 55 +++++++++++++++++++++++++ server/src/Design/Views.hs | 2 + 9 files changed, 189 insertions(+), 15 deletions(-) create mode 100644 client/src/Component/Pages.hs create mode 100644 server/src/Design/View/Pages.hs diff --git a/ISSUES.md b/ISSUES.md index 6863b00..04fdf2f 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -29,6 +29,7 @@ - category, - date. - Show statistics. +- Pages: 1 … 3 4 5 … 10 # Code diff --git a/client/client.cabal b/client/client.cabal index eeeb8be..8c25da7 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -50,6 +50,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.Pages Component.Table Component.Select Icon diff --git a/client/src/Component.hs b/client/src/Component.hs index 97c250e..4c51750 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -5,5 +5,6 @@ import Component.Form as X import Component.Input as X import Component.Link as X import Component.Modal as X +import Component.Pages as X import Component.Select as X import Component.Table as X diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs new file mode 100644 index 0000000..5611cb7 --- /dev/null +++ b/client/src/Component/Pages.hs @@ -0,0 +1,88 @@ +module Component.Pages + ( widget + , PagesIn(..) + , PagesOut(..) + ) where + +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button + +import qualified Icon +import qualified Util.Reflex as ReflexUtil + +data PagesIn t = PagesIn + { _pagesIn_total :: Dynamic t Int + , _pagesIn_perPage :: Int + , _pagesIn_reset :: Event t () + } + +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int + } + +widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) +widget pagesIn = do + currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + + where + total = _pagesIn_total pagesIn + perPage = _pagesIn_perPage pagesIn + reset = _pagesIn_reset pagesIn + +pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) +pageButtons total perPage reset = do + R.divClass "pages" $ do + rec + currentPage <- R.holdDyn 1 . R.leftmost $ + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + , 1 <$ reset + ] + + firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar + + previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + + pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> + pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) + + nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight + + lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar + + return currentPage + + where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) + pageEvent = R.switch . R.current . fmap R.leftmost + noCurrentPage = R.constDyn Nothing + +range :: Int -> Int -> [Int] +range currentPage maxPage = [start..end] + where sidePages = 2 + start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) + end = min maxPage (start + sidePages * 2) + +pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) +pageButton currentPage page content = do + clic <- _buttonOut_clic <$> (Button.button $ ButtonIn + { _buttonIn_class = do + cp <- currentPage + p <- page + if cp == Just p then "page current" else "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + , _buttonIn_tabIndex = Nothing + , _buttonIn_submit = False + }) + return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index a77a18d..b431c14 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,35 +4,58 @@ module Component.Table , TableOut(..) ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Component.Pages (PagesIn (..), PagesOut (..)) +import qualified Component.Pages as Pages data TableIn h r t = TableIn { _tableIn_headerLabel :: h -> Text , _tableIn_rows :: Dynamic t [r] , _tableIn_cell :: h -> r -> Text + , _tableIn_perPage :: Int + , _tableIn_resetPage :: Event t () } data TableOut = TableOut {} table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) -table tableIn = do +table tableIn = R.divClass "table" $ do + rec + R.divClass "lines" $ do + + R.divClass "header" $ + flip mapM_ [minBound..] $ \header -> + R.divClass "cell" . R.text $ + _tableIn_headerLabel tableIn header + + let rows = getRange + (_tableIn_perPage tableIn) + <$> (_pagesOut_currentPage pages) + <*> (_tableIn_rows tableIn) - R.divClass "lines" $ do - R.divClass "header" $ do - flip mapM_ [minBound..] $ \header -> - R.divClass "cell" . R.text $ - _tableIn_headerLabel tableIn header + R.simpleList rows $ \r -> + R.divClass "row" $ + flip mapM_ [minBound..] $ \h -> + R.divClass "cell name" $ + R.dynText $ + R.ffor r (_tableIn_cell tableIn h) - R.simpleList (_tableIn_rows tableIn) $ \r -> - R.divClass "row" $ - flip mapM_ [minBound..] $ \h -> - R.divClass "cell name" $ - R.dynText $ - R.ffor r (_tableIn_cell tableIn h) + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> (_tableIn_rows tableIn) + , _pagesIn_perPage = _tableIn_perPage tableIn + , _pagesIn_reset = _tableIn_resetPage tableIn + } + + return () return $ TableOut {} + +getRange :: forall a. Int -> Int -> [a] -> [a] +getRange perPage currentPage = + take perPage . drop ((currentPage - 1) * perPage) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d0c0a45..0fdd7d3 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -40,6 +40,8 @@ view incomeIn = . _incomeIn_init $ incomeIn , _tableIn_cell = cell (_incomeIn_init incomeIn) + , _tableIn_perPage = 7 + , _tableIn_resetPage = R.never } return () diff --git a/server/server.cabal b/server/server.cabal index 75af442..426f521 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -74,6 +74,7 @@ Executable server Design.Tooltip Design.View.Header Design.View.NotFound + Design.View.Pages Design.View.Payment Design.View.Payment.Add Design.View.Payment.Delete diff --git a/server/src/Design/View/Pages.hs b/server/src/Design/View/Pages.hs new file mode 100644 index 0000000..1482ef4 --- /dev/null +++ b/server/src/Design/View/Pages.hs @@ -0,0 +1,55 @@ +module Design.View.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = + ".pages" ? do + display flex + justifyContent center + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index bf39cff..73b7240 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -10,6 +10,7 @@ import qualified Design.Helper as Helper import qualified Design.Media as Media import qualified Design.View.Header as Header import qualified Design.View.NotFound as NotFound +import qualified Design.View.Pages as Pages import qualified Design.View.Payment as Payment import qualified Design.View.SignIn as SignIn import qualified Design.View.Stat as Stat @@ -23,6 +24,7 @@ design = do ".stat" ? Stat.design ".notfound" ? NotFound.design Table.design + Pages.design ".withMargin" ? do "margin" -: "0 2vw" -- cgit v1.2.3 From 6e9e34e92a244ab6c38d135d46f9f5bb01391906 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 09:51:52 +0200 Subject: Move income header and income table views into separate components --- client/client.cabal | 2 + client/src/View/Income/Header.hs | 60 +++++++++++++++++++++++ client/src/View/Income/Income.hs | 100 +++++---------------------------------- client/src/View/Income/Table.hs | 63 ++++++++++++++++++++++++ 4 files changed, 137 insertions(+), 88 deletions(-) create mode 100644 client/src/View/Income/Header.hs create mode 100644 client/src/View/Income/Table.hs diff --git a/client/client.cabal b/client/client.cabal index 8c25da7..06e77e0 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -65,7 +65,9 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Header View.Income.Income + View.Income.Table View.NotFound View.Payment.Add View.Payment.Clone diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs new file mode 100644 index 0000000..b7170c9 --- /dev/null +++ b/client/src/View/Income/Header.hs @@ -0,0 +1,60 @@ +module View.Income.Header + ( view + , HeaderIn(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Time.Clock as Clock +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import qualified Util.Date as DateUtil + +data HeaderIn = HeaderIn + { _headerIn_init :: Init + } + +view :: forall t m. MonadWidget t m => HeaderIn -> m () +view headerIn = + R.divClass "withMargin" $ do + + currentTime <- liftIO Clock.getCurrentTime + + Maybe.fromMaybe R.blank $ + flip fmap useIncomesFrom $ \since -> + R.el "div" $ do + + R.el "h1" $ do + day <- liftIO $ DateUtil.utcToLocalDay since + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) + + R.el "ul" $ + flip mapM_ (_init_users init) $ \user -> + R.el "li" $ + R.text $ do + let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) + T.intercalate " " + [ _user_name user + , "−" + , Format.price (_init_currency init) $ + CM.cumulativeIncomesSince currentTime since incomes + ] + + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ + Msg.get Msg.Income_MonthlyNet + + where + init = _headerIn_init headerIn + + useIncomesFrom = CM.useIncomesFrom + (map _user_id $_init_users init) + (_init_incomes init) + (_init_payments init) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 0fdd7d3..b0c6f0b 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -3,22 +3,14 @@ module View.Income.Income , IncomeIn(..) ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Time.Clock as Clock -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Income (..), Init (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import Component (TableIn (..)) -import qualified Component -import qualified Util.Date as DateUtil +import Common.Model (Init) +import View.Income.Header (HeaderIn (..)) +import qualified View.Income.Header as Header +import View.Income.Table (IncomeTableIn (..)) +import qualified View.Income.Table as Table data IncomeIn = IncomeIn { _incomeIn_init :: Init @@ -28,80 +20,12 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m () view incomeIn = R.elClass "main" "income" $ do - header (_incomeIn_init incomeIn) + Header.view $ HeaderIn + { _headerIn_init = _incomeIn_init incomeIn + } - Component.table $ TableIn - { _tableIn_headerLabel = headerLabel - , _tableIn_rows = - R.constDyn - . reverse - . L.sortOn _income_date - . _init_incomes - . _incomeIn_init - $ incomeIn - , _tableIn_cell = cell (_incomeIn_init incomeIn) - , _tableIn_perPage = 7 - , _tableIn_resetPage = R.never + Table.view $ IncomeTableIn + { _tableIn_init = _incomeIn_init incomeIn } return () - -header :: forall t m. MonadWidget t m => Init -> m () -header init = - R.divClass "withMargin" $ do - - currentTime <- liftIO Clock.getCurrentTime - - Maybe.fromMaybe R.blank $ - flip fmap useIncomesFrom $ \since -> - R.el "div" $ do - - R.el "h1" $ do - day <- liftIO $ DateUtil.utcToLocalDay since - R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) - - R.el "ul" $ - flip mapM_ (_init_users init) $ \user -> - R.el "li" $ - R.text $ do - let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) - T.intercalate " " - [ _user_name user - , "−" - , Format.price (_init_currency init) $ - CM.cumulativeIncomesSince currentTime since incomes - ] - - R.divClass "titleButton" $ - R.el "h1" $ - R.text $ - Msg.get Msg.Income_MonthlyNet - - where - useIncomesFrom = CM.useIncomesFrom - (map _user_id $_init_users init) - (_init_incomes init) - (_init_payments init) - -data Header - = UserHeader - | AmountHeader - | DateHeader - deriving (Eq, Show, Bounded, Enum) - -headerLabel :: Header -> Text -headerLabel UserHeader = Msg.get Msg.Income_Name -headerLabel DateHeader = Msg.get Msg.Income_Date -headerLabel AmountHeader = Msg.get Msg.Income_Amount - -cell :: Init -> Header -> Income -> Text -cell init header income = - case header of - UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) - - DateHeader -> - Format.longDay . _income_date $ income - - AmountHeader -> - Format.price (_init_currency init) . _income_amount $ income diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs new file mode 100644 index 0000000..2e8f4e6 --- /dev/null +++ b/client/src/View/Income/Table.hs @@ -0,0 +1,63 @@ +module View.Income.Table + ( view + , IncomeTableIn(..) + ) where + +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income (..), Init (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format +import Component (TableIn (..)) +import qualified Component + +data IncomeTableIn = IncomeTableIn + { _tableIn_init :: Init + } + +view :: forall t m. MonadWidget t m => IncomeTableIn -> m () +view tableIn = do + + Component.table $ TableIn + { _tableIn_headerLabel = headerLabel + , _tableIn_rows = + R.constDyn + . reverse + . L.sortOn _income_date + . _init_incomes + . _tableIn_init + $ tableIn + , _tableIn_cell = cell (_tableIn_init tableIn) + , _tableIn_perPage = 7 + , _tableIn_resetPage = R.never + } + + return () + +data Header + = UserHeader + | AmountHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel UserHeader = Msg.get Msg.Income_Name +headerLabel DateHeader = Msg.get Msg.Income_Date +headerLabel AmountHeader = Msg.get Msg.Income_Amount + +cell :: Init -> Header -> Income -> Text +cell init header income = + case header of + UserHeader -> + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + + DateHeader -> + Format.longDay . _income_date $ income + + AmountHeader -> + Format.price (_init_currency init) . _income_amount $ income -- cgit v1.2.3 From 7aadcc97f9df0e2daccbe8a8726d8bc6c63d67f4 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 12:02:21 +0200 Subject: Add income --- ISSUES.md | 2 +- client/client.cabal | 2 + client/src/Component.hs | 1 - client/src/View/Income/Add.hs | 36 +++++++++ client/src/View/Income/Form.hs | 113 ++++++++++++++++++++++++++++ client/src/View/Income/Header.hs | 55 ++++++++++---- client/src/View/Income/Income.hs | 21 ++++-- client/src/View/Income/Table.hs | 17 ++--- client/src/View/Payment/Delete.hs | 1 + client/src/View/Payment/Header.hs | 14 ++-- common/common.cabal | 4 +- common/src/Common/Model.hs | 3 +- common/src/Common/Model/CreateIncome.hs | 14 ---- common/src/Common/Model/CreateIncomeForm.hs | 15 ++++ common/src/Common/Model/EditIncomeForm.hs | 18 +++++ common/src/Common/Validation/Income.hs | 17 +++++ common/src/Common/Validation/Payment.hs | 1 - server/server.cabal | 3 + server/src/Controller/Income.hs | 23 ++++-- server/src/Model/CreateIncome.hs | 10 +++ server/src/Model/EditIncome.hs | 13 ++++ server/src/Persistence/Income.hs | 19 +++-- server/src/Validation/Income.hs | 27 +++++++ 23 files changed, 361 insertions(+), 68 deletions(-) create mode 100644 client/src/View/Income/Add.hs create mode 100644 client/src/View/Income/Form.hs delete mode 100644 common/src/Common/Model/CreateIncome.hs create mode 100644 common/src/Common/Model/CreateIncomeForm.hs create mode 100644 common/src/Common/Model/EditIncomeForm.hs create mode 100644 common/src/Common/Validation/Income.hs create mode 100644 server/src/Model/CreateIncome.hs create mode 100644 server/src/Model/EditIncome.hs create mode 100644 server/src/Validation/Income.hs diff --git a/ISSUES.md b/ISSUES.md index 04fdf2f..56f158d 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,6 +1,6 @@ ## Income view -- Add an income +- Take into account modified incomes into payment table - Clone an income - Edit an income - Remove an income diff --git a/client/client.cabal b/client/client.cabal index 06e77e0..bfcfc59 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -65,6 +65,8 @@ Executable client Util.WaitFor View.App View.Header + View.Income.Add + View.Income.Form View.Income.Header View.Income.Income View.Income.Table diff --git a/client/src/Component.hs b/client/src/Component.hs index 4c51750..b715a83 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -4,7 +4,6 @@ import Component.Button as X import Component.Form as X import Component.Input as X import Component.Link as X -import Component.Modal as X import Component.Pages as X import Component.Select as X import Component.Table as X diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs new file mode 100644 index 0000000..d83bb51 --- /dev/null +++ b/client/src/View/Income/Add.hs @@ -0,0 +1,36 @@ +module View.Income.Add + ( view + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Time.Clock as Time +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CreateIncomeForm (..), Income) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Component.Modal as Modal +import qualified Util.Reflex as ReflexUtil +import View.Income.Form (FormIn (..), FormOut (..)) +import qualified View.Income.Form as Form + +view :: forall t m. MonadWidget t m => Modal.Content t m Income +view cancel = do + + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + form <- R.dyn $ + return $ Form.view $ FormIn + { _formIn_cancel = cancel + , _formIn_headerLabel = Msg.get Msg.Income_AddLong + , _formIn_amount = "" + , _formIn_date = currentDay + , _formIn_mkPayload = CreateIncomeForm + , _formIn_httpMethod = Form.Post + } + + hide <- ReflexUtil.flatten (_formOut_hide <$> form) + addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form) + + return (hide, addIncome) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs new file mode 100644 index 0000000..b8a9094 --- /dev/null +++ b/client/src/View/Income/Form.hs @@ -0,0 +1,113 @@ +module View.Income.Form + ( view + , FormIn(..) + , HttpMethod(..) + , FormOut(..) + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Validation as V +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Income) +import qualified Common.Msg as Msg +import qualified Common.Validation.Income as IncomeValidation +import Component (ButtonIn (..), InputIn (..), + InputOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data FormIn t i = FormIn + { _formIn_cancel :: Event t () + , _formIn_headerLabel :: Text + , _formIn_amount :: Text + , _formIn_date :: Day + , _formIn_mkPayload :: Text -> Text -> i + , _formIn_httpMethod :: HttpMethod + } + +data HttpMethod = Put | Post + +data FormOut t = FormOut + { _formOut_hide :: Event t () + , _formOut_addIncome :: Event t Income + } + +view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t) +view formIn = do + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_formIn_headerLabel formIn) + + R.divClass "formContent" $ do + rec + let reset = R.leftmost + [ "" <$ cancel + , "" <$ addIncome + , "" <$ _formIn_cancel formIn + ] + + amount <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Amount + , _inputIn_initialValue = _formIn_amount formIn + , _inputIn_validation = IncomeValidation.amount + }) + (_formIn_amount formIn <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn + + date <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = IncomeValidation.date + }) + (initialDate <$ reset) + confirm) + + let income = do + a <- amount + d <- date + return . V.Success $ (_formIn_mkPayload formIn) a d + + (addIncome, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + confirm <- Component._buttonOut_clic <$> (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (addIncome, waiting) <- WaitFor.waitFor + (ajax "/api/income") + (ValidationUtil.fireValidation income confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm) + + return FormOut + { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ] + , _formOut_addIncome = addIncome + } + + where + ajax = + case _formIn_httpMethod formIn of + Post -> Ajax.postJson + Put -> Ajax.putJson diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index b7170c9..e384161 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -1,33 +1,46 @@ module View.Income.Header ( view , HeaderIn(..) + , HeaderOut(..) ) where import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Clock as Clock -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Income (..), Init (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format +import Component (ButtonOut (..)) +import qualified Component +import qualified Component.Modal as Modal import qualified Util.Date as DateUtil +import qualified View.Income.Add as Add -data HeaderIn = HeaderIn - { _headerIn_init :: Init +data HeaderIn t = HeaderIn + { _headerIn_init :: Init + , _headerIn_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => HeaderIn -> m () +data HeaderOut t = HeaderOut + { _headerOut_addIncome :: Event t Income + } + +view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) view headerIn = R.divClass "withMargin" $ do currentTime <- liftIO Clock.getCurrentTime - Maybe.fromMaybe R.blank $ - flip fmap useIncomesFrom $ \since -> + R.dyn . R.ffor useIncomesFrom $ \case + (Nothing, _) -> + R.blank + + (Just since, incomes) -> R.el "div" $ do R.el "h1" $ do @@ -38,23 +51,39 @@ view headerIn = flip mapM_ (_init_users init) $ \user -> R.el "li" $ R.text $ do - let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init) + let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes T.intercalate " " [ _user_name user , "−" , Format.price (_init_currency init) $ - CM.cumulativeIncomesSince currentTime since incomes + CM.cumulativeIncomesSince currentTime since userIncomes ] - R.divClass "titleButton" $ + R.divClass "titleButton" $ do R.el "h1" $ R.text $ Msg.get Msg.Income_MonthlyNet + addIncome <- _buttonOut_clic <$> + (Component.button . Component.defaultButtonIn . R.text $ + Msg.get Msg.Income_AddLong) + + addIncome <- Modal.view $ Modal.Input + { Modal._input_show = addIncome + , Modal._input_content = Add.view + } + + return $ HeaderOut + { _headerOut_addIncome = addIncome + } + where init = _headerIn_init headerIn - useIncomesFrom = CM.useIncomesFrom - (map _user_id $_init_users init) - (_init_incomes init) - (_init_payments init) + useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes -> + ( CM.useIncomesFrom + (map _user_id $_init_users init) + incomes + (_init_payments init) + , incomes + ) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index b0c6f0b..167aedf 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -3,11 +3,11 @@ module View.Income.Income , IncomeIn(..) ) where -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init) -import View.Income.Header (HeaderIn (..)) +import Common.Model (Init (..)) +import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header import View.Income.Table (IncomeTableIn (..)) import qualified View.Income.Table as Table @@ -20,12 +20,21 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m () view incomeIn = R.elClass "main" "income" $ do - Header.view $ HeaderIn - { _headerIn_init = _incomeIn_init incomeIn - } + rec + + incomes <- R.foldDyn + (:) + (_init_incomes . _incomeIn_init $ incomeIn) + (_headerOut_addIncome header) + + header <- Header.view $ HeaderIn + { _headerIn_init = _incomeIn_init incomeIn + , _headerIn_incomes = incomes + } Table.view $ IncomeTableIn { _tableIn_init = _incomeIn_init incomeIn + , _tableIn_incomes = incomes } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 2e8f4e6..5363ca5 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -6,7 +6,7 @@ module View.Income.Table import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Income (..), Init (..), User (..)) @@ -16,22 +16,17 @@ import qualified Common.View.Format as Format import Component (TableIn (..)) import qualified Component -data IncomeTableIn = IncomeTableIn - { _tableIn_init :: Init +data IncomeTableIn t = IncomeTableIn + { _tableIn_init :: Init + , _tableIn_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => IncomeTableIn -> m () +view :: forall t m. MonadWidget t m => IncomeTableIn t -> m () view tableIn = do Component.table $ TableIn { _tableIn_headerLabel = headerLabel - , _tableIn_rows = - R.constDyn - . reverse - . L.sortOn _income_date - . _init_incomes - . _tableIn_init - $ tableIn + , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date , _tableIn_cell = cell (_tableIn_init tableIn) , _tableIn_perPage = 7 , _tableIn_resetPage = R.never diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 521c1a7..dc7e395 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -13,6 +13,7 @@ import qualified Common.Msg as Msg import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component import qualified Component.Modal as Modal +import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 6ed3b0e..9db4c7c 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -111,16 +111,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen R.dynText . R.ffor exceedingPayer $ \ep -> Format.price currency $ _exceedingPayer_amount ep - addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn - { _buttonIn_class = R.constDyn "addPayment" - , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False - }) + addPayment <- _buttonOut_clic <$> + (Component.button $ + (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add)) + { _buttonIn_class = R.constDyn "addPayment" + }) Modal.view $ Modal.Input - { Modal._input_show = addPaymentClic + { Modal._input_show = addPayment , Modal._input_content = Add.view $ Add.Input { Add._input_categories = categories , Add._input_paymentCategories = paymentCategories diff --git a/common/common.cabal b/common/common.cabal index 64a3b3e..6c7c779 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -29,6 +29,7 @@ Library Exposed-modules: Common.Model + Common.Model.CreateIncomeForm Common.Model.CreatePaymentForm Common.Model.Email Common.Model.Payment @@ -40,6 +41,7 @@ Library Common.Util.Time Common.Util.Validation Common.Validation.Atomic + Common.Validation.Income Common.Validation.Payment Common.Validation.SignIn Common.View.Format @@ -50,10 +52,10 @@ Library Common.Message.Translation Common.Model.Category Common.Model.CreateCategory - Common.Model.CreateIncome Common.Model.Currency Common.Model.EditCategory Common.Model.EditIncome + Common.Model.EditIncomeForm Common.Model.EditPaymentForm Common.Model.Frequency Common.Model.Income diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 5b71a84..c9f500b 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -2,11 +2,12 @@ module Common.Model (module X) where import Common.Model.Category as X import Common.Model.CreateCategory as X -import Common.Model.CreateIncome as X +import Common.Model.CreateIncomeForm as X import Common.Model.CreatePaymentForm as X import Common.Model.Currency as X import Common.Model.EditCategory as X import Common.Model.EditIncome as X +import Common.Model.EditIncomeForm as X import Common.Model.EditPaymentForm as X import Common.Model.Email as X import Common.Model.Frequency as X diff --git a/common/src/Common/Model/CreateIncome.hs b/common/src/Common/Model/CreateIncome.hs deleted file mode 100644 index 644a51c..0000000 --- a/common/src/Common/Model/CreateIncome.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Common.Model.CreateIncome - ( CreateIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -data CreateIncome = CreateIncome - { _createIncome_date :: Day - , _createIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/common/src/Common/Model/CreateIncomeForm.hs b/common/src/Common/Model/CreateIncomeForm.hs new file mode 100644 index 0000000..e83bf0a --- /dev/null +++ b/common/src/Common/Model/CreateIncomeForm.hs @@ -0,0 +1,15 @@ +module Common.Model.CreateIncomeForm + ( CreateIncomeForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateIncomeForm = CreateIncomeForm + { _createIncomeForm_amount :: Text + , _createIncomeForm_date :: Text + } deriving (Show, Generic) + +instance FromJSON CreateIncomeForm +instance ToJSON CreateIncomeForm diff --git a/common/src/Common/Model/EditIncomeForm.hs b/common/src/Common/Model/EditIncomeForm.hs new file mode 100644 index 0000000..ff975fc --- /dev/null +++ b/common/src/Common/Model/EditIncomeForm.hs @@ -0,0 +1,18 @@ +module Common.Model.EditIncomeForm + ( EditIncomeForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Income (IncomeId) + +data EditIncomeForm = EditIncomeForm + { _editIncomeForm_id :: IncomeId + , _editIncomeForm_amount :: Text + , _editIncomeForm_date :: Text + } deriving (Show, Generic) + +instance FromJSON EditIncomeForm +instance ToJSON EditIncomeForm diff --git a/common/src/Common/Validation/Income.hs b/common/src/Common/Validation/Income.hs new file mode 100644 index 0000000..7a58bab --- /dev/null +++ b/common/src/Common/Validation/Income.hs @@ -0,0 +1,17 @@ +module Common.Validation.Income + ( amount + , date + ) where + +import Data.Text (Text) +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import qualified Common.Validation.Atomic as Atomic + +amount :: Text -> Validation Text Int +amount input = V.bindValidation (Atomic.number input) Atomic.nonNullNumber + +date :: Text -> Validation Text Day +date = Atomic.day diff --git a/common/src/Common/Validation/Payment.hs b/common/src/Common/Validation/Payment.hs index 1bb00ce..e3c447a 100644 --- a/common/src/Common/Validation/Payment.hs +++ b/common/src/Common/Validation/Payment.hs @@ -14,7 +14,6 @@ import Common.Model (CategoryId) import qualified Common.Msg as Msg import qualified Common.Validation.Atomic as Atomic - name :: Text -> Validation Text Text name = Atomic.nonEmpty diff --git a/server/server.cabal b/server/server.cabal index 426f521..022d496 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -94,7 +94,9 @@ Executable server Job.WeeklyReport Json LoginSession + Model.CreateIncome Model.CreatePayment + Model.EditIncome Model.EditPayment Model.IncomeResource Model.Mail @@ -113,6 +115,7 @@ Executable server Secure SendMail Util.Time + Validation.Income Validation.Payment View.Mail.SignIn View.Mail.WeeklyReport diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index ed58ac8..e013849 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -5,21 +5,32 @@ module Controller.Income ) where import Control.Monad.IO.Class (liftIO) +import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) -import Common.Model (CreateIncome (..), EditIncome (..), - IncomeId, User (..)) +import Common.Model (CreateIncomeForm (..), + EditIncome (..), IncomeId, + User (..)) -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateIncome (CreateIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence import qualified Secure +import qualified Validation.Income as IncomeValidation -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = +create :: CreateIncomeForm -> ActionM () +create form = Secure.loggedAction (\user -> - (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId + (liftIO . Query.run $ do + case IncomeValidation.createIncome form of + Success (CreateIncome amount date) -> do + Right <$> (IncomePersistence.create (_user_id user) date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) edit :: EditIncome -> ActionM () diff --git a/server/src/Model/CreateIncome.hs b/server/src/Model/CreateIncome.hs new file mode 100644 index 0000000..82451d2 --- /dev/null +++ b/server/src/Model/CreateIncome.hs @@ -0,0 +1,10 @@ +module Model.CreateIncome + ( CreateIncome(..) + ) where + +import Data.Time.Calendar (Day) + +data CreateIncome = CreateIncome + { _createIncome_amount :: Int + , _createIncome_date :: Day + } deriving (Show) diff --git a/server/src/Model/EditIncome.hs b/server/src/Model/EditIncome.hs new file mode 100644 index 0000000..ac3d311 --- /dev/null +++ b/server/src/Model/EditIncome.hs @@ -0,0 +1,13 @@ +module Model.EditIncome + ( EditIncome(..) + ) where + +import Data.Time.Calendar (Day) + +import Common.Model (IncomeId) + +data EditIncome = EditIncome + { _editIncome_id :: IncomeId + , _editIncome_amount :: Int + , _editIncome_date :: Day + } deriving (Show) diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cee9892..a0c3bbf 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -36,15 +36,24 @@ list = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = +create :: UserId -> Day -> Int -> Query Income +create userId date amount = Query (\conn -> do - now <- getCurrentTime + createdAt <- getCurrentTime SQLite.execute conn "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn + (userId, date, amount, createdAt) + incomeId <- SQLite.lastInsertRowId conn + return $ Income + { _income_id = incomeId + , _income_userId = userId + , _income_date = date + , _income_amount = amount + , _income_createdAt = createdAt + , _income_editedAt = Nothing + , _income_deletedAt = Nothing + } ) edit :: UserId -> IncomeId -> Day -> Int -> Query Bool diff --git a/server/src/Validation/Income.hs b/server/src/Validation/Income.hs new file mode 100644 index 0000000..5e034d1 --- /dev/null +++ b/server/src/Validation/Income.hs @@ -0,0 +1,27 @@ +module Validation.Income + ( createIncome + , editIncome + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..)) +import qualified Common.Validation.Income as IncomeValidation +import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) + +createIncome :: CreateIncomeForm -> Validation Text CreateIncome +createIncome form = + CreateIncome + <$> IncomeValidation.amount (_createIncomeForm_amount form) + <*> IncomeValidation.date (_createIncomeForm_date form) + +editIncome :: EditIncomeForm -> Validation Text EditIncome +editIncome form = + EditIncome + <$> V.Success (_editIncomeForm_id form) + <*> IncomeValidation.amount (_editIncomeForm_amount form) + <*> IncomeValidation.date (_editIncomeForm_date form) -- cgit v1.2.3 From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 21:31:57 +0200 Subject: Load init data per page with AJAX --- ISSUES.md | 3 +- client/client.cabal | 3 + client/src/Model/Loadable.hs | 51 ++++++++++++ client/src/Util/Ajax.hs | 21 +++-- client/src/View/App.hs | 16 ++-- client/src/View/Header.hs | 2 +- client/src/View/Income/Form.hs | 4 +- client/src/View/Income/Header.hs | 11 ++- client/src/View/Income/Income.hs | 73 +++++++++++----- client/src/View/Income/Init.hs | 11 +++ client/src/View/Income/Table.hs | 17 ++-- client/src/View/Payment/Form.hs | 4 +- client/src/View/Payment/Header.hs | 6 +- client/src/View/Payment/Init.hs | 13 +++ client/src/View/Payment/Payment.hs | 165 +++++++++++++++++++++++-------------- client/src/View/Payment/Table.hs | 21 +++-- client/src/View/SignIn.hs | 2 +- common/src/Common/Model/Init.hs | 22 ++--- server/server.cabal | 2 +- server/src/Controller/Category.hs | 9 +- server/src/Controller/Income.hs | 9 +- server/src/Controller/Index.hs | 11 +-- server/src/Controller/Payment.hs | 7 ++ server/src/Controller/User.hs | 17 ++++ server/src/Design/Global.hs | 12 +++ server/src/Main.hs | 24 +++++- server/src/Persistence/Init.hs | 25 ------ 27 files changed, 391 insertions(+), 170 deletions(-) create mode 100644 client/src/Model/Loadable.hs create mode 100644 client/src/View/Income/Init.hs create mode 100644 client/src/View/Payment/Init.hs create mode 100644 server/src/Controller/User.hs delete mode 100644 server/src/Persistence/Init.hs diff --git a/ISSUES.md b/ISSUES.md index 56f158d..95b435a 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,6 +1,5 @@ ## Income view -- Take into account modified incomes into payment table - Clone an income - Edit an income - Remove an income @@ -15,7 +14,7 @@ ## Mobile -- Slow, consider native ? +- Slow, consider native ? consider doing more work on the server ? # Additional features diff --git a/client/client.cabal b/client/client.cabal index bfcfc59..9a0d24e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -54,6 +54,8 @@ Executable client Component.Table Component.Select Icon + Model.Loadable + Model.Route Util.Ajax Util.Css Util.Date @@ -77,6 +79,7 @@ Executable client View.Payment.Edit View.Payment.Form View.Payment.Header + View.Payment.Init View.Payment.Pages View.Payment.Payment View.Payment.Table diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs new file mode 100644 index 0000000..3076b46 --- /dev/null +++ b/client/src/Model/Loadable.hs @@ -0,0 +1,51 @@ +module Model.Loadable + ( Loadable (..) + , fromEvent + , view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Data.Functor (Functor) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +data Loadable t + = Loading + | Error Text + | Loaded t + +instance Functor Loadable where + fmap f Loading = Loading + fmap f (Error e) = Error e + fmap f (Loaded x) = Loaded (f x) + +instance Applicative Loadable where + pure x = Loaded x + + Loading <*> _ = Loading + (Error e) <*> _ = Error e + (Loaded f) <*> Loading = Loading + (Loaded f) <*> (Error e) = Error e + (Loaded f) <*> (Loaded x) = Loaded (f x) + +instance Monad Loadable where + Loading >>= f = Loading + (Error e) >>= f = Error e + (Loaded x) >>= f = f x + +fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) +fromEvent = + R.foldDyn + (\res _ -> case res of + Left err -> Error err + Right t -> Loaded t + ) + Loading + +view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () +view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank +view _ (Error e) = R.text e +view f (Loaded x) = f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index a4f6a74..9cd5105 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,6 +1,7 @@ module Util.Ajax - ( postJson - , putJson + ( get + , post + , put , delete ) where @@ -20,21 +21,29 @@ import Reflex.Dom (Dynamic, Event, IsXhrPayload, XhrResponseHeaders (..)) import qualified Reflex.Dom as R -postJson +get + :: forall t m a. (MonadWidget t m, FromJSON a) + => Event t Text + -> m (Event t (Either Text a)) +get url = + fmap getJsonResult <$> + R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String "")) + +post :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -postJson url input = +post url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "POST" url <$> input) -putJson +put :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -putJson url input = +put url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "PUT" url <$> input) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 3292336..b468e56 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -7,7 +7,8 @@ import Prelude hiding (error, init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init, InitResult (..)) +import Common.Model (Currency, Init (..), InitResult (..), + UserId) import qualified Common.Msg as Msg import Model.Route (Route (..)) @@ -60,14 +61,19 @@ widget initResult = signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case - RootRoute -> + RootRoute -> do + paymentInit <- Payment.init Payment.view $ PaymentIn - { _paymentIn_init = init + { _paymentIn_currentUser = _init_currentUser init + , _paymentIn_currency = _init_currency init + , _paymentIn_init = paymentInit } - IncomeRoute -> + IncomeRoute -> do + incomeInit <- Income.init Income.view $ IncomeIn - { _incomeIn_init = init + { _incomeIn_currency = _init_currency init + , _incomeIn_init = incomeInit } NotFoundRoute -> diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 9a4de89..bd69e47 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -73,7 +73,7 @@ links route = do nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) nameSignOut initResult = case initResult of - (InitSuccess init) -> do + InitSuccess init -> do rec attr <- R.holdDyn (M.singleton "class" "nameSignOut") diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index b8a9094..2bfc23f 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -109,5 +109,5 @@ view formIn = do where ajax = case _formIn_httpMethod formIn of - Post -> Ajax.postJson - Put -> Ajax.putJson + Post -> Ajax.post + Put -> Ajax.put diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index e384161..4e08955 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -11,19 +11,22 @@ import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Income (..), Init (..), User (..)) +import Common.Model (Currency, Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format + import Component (ButtonOut (..)) import qualified Component import qualified Component.Modal as Modal import qualified Util.Date as DateUtil import qualified View.Income.Add as Add +import View.Income.Init (Init (..)) data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_incomes :: Dynamic t [Income] + { _headerIn_init :: Init + , _headerIn_currency :: Currency + , _headerIn_incomes :: Dynamic t [Income] } data HeaderOut t = HeaderOut @@ -55,7 +58,7 @@ view headerIn = T.intercalate " " [ _user_name user , "−" - , Format.price (_init_currency init) $ + , Format.price (_headerIn_currency headerIn) $ CM.cumulativeIncomesSince currentTime since userIncomes ] diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 167aedf..91682a0 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,40 +1,73 @@ module View.Income.Income - ( view + ( init + , view , IncomeIn(..) ) where +import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Currency) + +import Model.Loadable (Loadable (..)) +import qualified Model.Loadable as Loadable +import qualified Util.Ajax as AjaxUtil import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header +import View.Income.Init (Init (..)) import View.Income.Table (IncomeTableIn (..)) import qualified View.Income.Table as Table -data IncomeIn = IncomeIn - { _incomeIn_init :: Init +data IncomeIn t = IncomeIn + { _incomeIn_currency :: Currency + , _incomeIn_init :: Dynamic t (Loadable Init) } -view :: forall t m. MonadWidget t m => IncomeIn -> m () -view incomeIn = - R.elClass "main" "income" $ do +init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) +init = do + postBuild <- R.getPostBuild + + usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) + users <- Loadable.fromEvent usersEvent + + incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) + incomes <- Loadable.fromEvent incomesEvent + + paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) + payments <- Loadable.fromEvent paymentsEvent + + return $ do + us <- users + is <- incomes + ps <- payments + return $ Init <$> us <*> is <*> ps + +view :: forall t m. MonadWidget t m => IncomeIn t -> m () +view incomeIn = do + R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init -> + + R.elClass "main" "income" $ do + + rec - rec + incomes <- R.foldDyn + (:) + (_init_incomes init) + (_headerOut_addIncome header) - incomes <- R.foldDyn - (:) - (_init_incomes . _incomeIn_init $ incomeIn) - (_headerOut_addIncome header) + header <- Header.view $ HeaderIn + { _headerIn_init = init + , _headerIn_currency = _incomeIn_currency incomeIn + , _headerIn_incomes = incomes + } - header <- Header.view $ HeaderIn - { _headerIn_init = _incomeIn_init incomeIn - , _headerIn_incomes = incomes + Table.view $ IncomeTableIn + { _tableIn_init = init + , _tableIn_currency = _incomeIn_currency incomeIn + , _tableIn_incomes = incomes } - Table.view $ IncomeTableIn - { _tableIn_init = _incomeIn_init incomeIn - , _tableIn_incomes = incomes - } + return () - return () + return () diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs new file mode 100644 index 0000000..4f3ef99 --- /dev/null +++ b/client/src/View/Income/Init.hs @@ -0,0 +1,11 @@ +module View.Income.Init + ( Init(..) + ) where + +import Common.Model (Income, Payment, User) + +data Init = Init + { _init_users :: [User] + , _init_incomes :: [Income] + , _init_payments :: [Payment] + } deriving (Show) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 5363ca5..d42848b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -9,16 +9,19 @@ import Data.Text (Text) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Income (..), Init (..), User (..)) +import Common.Model (Currency, Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format + import Component (TableIn (..)) import qualified Component +import View.Income.Init (Init (..)) data IncomeTableIn t = IncomeTableIn - { _tableIn_init :: Init - , _tableIn_incomes :: Dynamic t [Income] + { _tableIn_init :: Init + , _tableIn_currency :: Currency + , _tableIn_incomes :: Dynamic t [Income] } view :: forall t m. MonadWidget t m => IncomeTableIn t -> m () @@ -27,7 +30,7 @@ view tableIn = do Component.table $ TableIn { _tableIn_headerLabel = headerLabel , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date - , _tableIn_cell = cell (_tableIn_init tableIn) + , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn) , _tableIn_perPage = 7 , _tableIn_resetPage = R.never } @@ -45,8 +48,8 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: Init -> Header -> Income -> Text -cell init header income = +cell :: Init -> Currency -> Header -> Income -> Text +cell init currency header income = case header of UserHeader -> Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) @@ -55,4 +58,4 @@ cell init header income = Format.longDay . _income_date $ income AmountHeader -> - Format.price (_init_currency init) . _income_amount $ income + Format.price currency . _income_amount $ income diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 7819836..c817831 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -165,8 +165,8 @@ view input = do ajax = case _input_httpMethod input of - Post -> Ajax.postJson - Put -> Ajax.putJson + Post -> Ajax.post + Put -> Ajax.put findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 9db4c7c..9ad90a9 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -20,7 +20,7 @@ import qualified Reflex.Dom as R import Common.Model (Category, Currency, ExceedingPayer (..), Frequency (..), - Income (..), Init (..), Payment (..), + Income (..), Payment (..), PaymentCategory, SavedPayment (..), User (..)) import qualified Common.Model as CM @@ -34,9 +34,11 @@ import qualified Component as Component import qualified Component.Modal as Modal import qualified Util.List as L import qualified View.Payment.Add as Add +import View.Payment.Init (Init (..)) data HeaderIn t = HeaderIn { _headerIn_init :: Init + , _headerIn_currency :: Currency , _headerIn_payments :: Dynamic t [Payment] , _headerIn_searchPayments :: Dynamic t [Payment] , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] @@ -78,7 +80,7 @@ widget headerIn = payments = _headerIn_payments headerIn users = _init_users init categories = _init_categories init - currency = _init_currency init + currency = _headerIn_currency headerIn paymentCategories = _headerIn_paymentCategories headerIn payerAndAdd diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs new file mode 100644 index 0000000..d9f85c8 --- /dev/null +++ b/client/src/View/Payment/Init.hs @@ -0,0 +1,13 @@ +module View.Payment.Init + ( Init(..) + ) where + +import Common.Model (Category, Income, Payment, PaymentCategory, User) + +data Init = Init + { _init_users :: [User] + , _init_payments :: [Payment] + , _init_incomes :: [Income] + , _init_categories :: [Category] + , _init_paymentCategories :: [PaymentCategory] + } deriving (Show) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index cfdb441..ec350e2 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,5 +1,6 @@ module View.Payment.Payment - ( view + ( init + , view , PaymentIn(..) ) where @@ -10,78 +11,118 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R -import Common.Model (Frequency, Init (..), Payment (..), - PaymentCategory (..), PaymentId, - SavedPayment (..)) +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, SavedPayment (..), User, + UserId) import qualified Common.Util.Text as T + +import Model.Loadable (Loadable (..)) +import qualified Model.Loadable as Loadable +import qualified Util.Ajax as AjaxUtil import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header +import View.Payment.Init (Init (..)) import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table -data PaymentIn = PaymentIn - { _paymentIn_init :: Init +init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) +init = do + postBuild <- R.getPostBuild + + incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) + incomes <- Loadable.fromEvent incomesEvent + + usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) + users <- Loadable.fromEvent usersEvent + + paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) + payments <- Loadable.fromEvent paymentsEvent + + paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild) + paymentCategories <- Loadable.fromEvent paymentCategoriesEvent + + categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild) + categories <- Loadable.fromEvent categoriesEvent + + return $ do + us <- users + ps <- payments + is <- incomes + cs <- categories + pcs <- paymentCategories + return $ Init <$> us <*> ps <*> is <*> cs <*> pcs + +data PaymentIn t = PaymentIn + { _paymentIn_currentUser :: UserId + , _paymentIn_currency :: Currency + , _paymentIn_init :: Dynamic t (Loadable Init) } -view :: forall t m. MonadWidget t m => PaymentIn -> m () +view :: forall t m. MonadWidget t m => PaymentIn t -> m () view paymentIn = do - R.elClass "main" "payment" $ do - rec - let init = _paymentIn_init paymentIn - - paymentsPerPage = 7 - - addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table - ] - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) - - let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories - } - - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories - } - - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header - ] - } - - pure () + R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init -> + + R.elClass "main" "payment" $ do + rec + let addPayment = R.leftmost + [ _headerOut_addPayment header + , _tableOut_addPayment table + ] + + paymentsPerPage = 7 + + payments <- reducePayments + (_init_payments init) + (_savedPayment_payment <$> addPayment) + (_savedPayment_payment <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + paymentCategories <- reducePaymentCategories + (_init_paymentCategories init) + payments + (_savedPayment_paymentCategory <$> addPayment) + (_savedPayment_paymentCategory <$> _tableOut_editPayment table) + (_tableOut_deletePayment table) + + (searchNameEvent, searchName) <- + debounceSearchName (_headerOut_searchName header) + + let searchPayments = + getSearchPayments searchName (_headerOut_searchFrequency header) payments + + header <- Header.widget $ HeaderIn + { _headerIn_init = init + , _headerIn_currency = _paymentIn_currency paymentIn + , _headerIn_payments = payments + , _headerIn_searchPayments = searchPayments + , _headerIn_paymentCategories = paymentCategories + } + + table <- Table.widget $ TableIn + { _tableIn_init = init + , _tableIn_currency = _paymentIn_currency paymentIn + , _tableIn_currentUser = _paymentIn_currentUser paymentIn + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = searchPayments + , _tableIn_perPage = paymentsPerPage + , _tableIn_paymentCategories = paymentCategories + } + + pages <- Pages.widget $ PagesIn + { _pagesIn_total = length <$> searchPayments + , _pagesIn_perPage = paymentsPerPage + , _pagesIn_reset = R.leftmost $ + [ () <$ searchNameEvent + , () <$ _headerOut_addPayment header + ] + } + + pure () + + return () debounceSearchName :: forall t m. MonadWidget t m diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index bf6b604..5ffa037 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,10 +13,10 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Frequency (Punctual), - Init (..), Payment (..), +import Common.Model (Category (..), Currency, + Frequency (Punctual), Payment (..), PaymentCategory (..), SavedPayment, - User (..)) + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -26,12 +26,15 @@ import qualified Component.Modal as Modal import qualified View.Payment.Clone as Clone import qualified View.Payment.Delete as Delete import qualified View.Payment.Edit as Edit +import View.Payment.Init (Init (..)) import qualified Icon import qualified Util.Reflex as ReflexUtil data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currency :: Currency + , _tableIn_currentUser :: UserId , _tableIn_currentPage :: Dynamic t Int , _tableIn_payments :: Dynamic t [Payment] , _tableIn_perPage :: Int @@ -61,7 +64,7 @@ widget tableIn = do R.divClass "cell" $ R.blank result <- - (R.simpleList paymentRange (paymentRow init paymentCategories)) + (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories)) return $ ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result @@ -80,6 +83,8 @@ widget tableIn = do where init = _tableIn_init tableIn + currency = _tableIn_currency tableIn + currentUser = _tableIn_currentUser tableIn currentPage = _tableIn_currentPage tableIn payments = _tableIn_payments tableIn paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage @@ -96,17 +101,19 @@ getPaymentRange perPage payments currentPage = paymentRow :: forall t m. MonadWidget t m => Init + -> Currency + -> UserId -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) -paymentRow init paymentCategories payment = +paymentRow init currency currentUser paymentCategories payment = R.divClass "row" $ do R.divClass "cell name" $ R.dynText $ fmap _payment_name payment R.divClass "cell cost" $ - R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment + R.dynText $ fmap (Format.price currency . _payment_cost) payment let user = R.ffor payment (\p -> CM.findUser (_payment_user p) (_init_users init)) @@ -162,7 +169,7 @@ paymentRow init paymentCategories payment = let isFromCurrentUser = R.ffor payment - (\p -> _payment_user p == _init_currentUser init) + (\p -> _payment_user p == currentUser) editPayment <- R.divClass "cell button" $ diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 8c248bd..4fe495b 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> _inputOut_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postJson "/api/askSignIn") + (Ajax.post "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs index 68b3f5d..5ef1535 100644 --- a/common/src/Common/Model/Init.hs +++ b/common/src/Common/Model/Init.hs @@ -2,24 +2,16 @@ module Common.Model.Init ( Init(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) -import Common.Model.Category (Category) -import Common.Model.Currency (Currency) -import Common.Model.Income (Income) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.User (User, UserId) +import Common.Model.Currency (Currency) +import Common.Model.User (User, UserId) data Init = Init - { _init_users :: [User] - , _init_currentUser :: UserId - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - , _init_currency :: Currency + { _init_users :: [User] + , _init_currentUser :: UserId + , _init_currency :: Currency } deriving (Show, Generic) instance FromJSON Init diff --git a/server/server.cabal b/server/server.cabal index 022d496..eeba14f 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -62,6 +62,7 @@ Executable server Controller.Income Controller.Index Controller.Payment + Controller.User Cookie Design.Color Design.Constants @@ -107,7 +108,6 @@ Executable server Persistence.Category Persistence.Frequency Persistence.Income - Persistence.Init Persistence.Payment Persistence.PaymentCategory Persistence.User diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 37b8357..e536caa 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( create + ( list + , create , edit , delete ) where @@ -19,6 +20,12 @@ import qualified Persistence.Category as CategoryPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ CategoryPersistence.list) >>= json + ) + create :: CreateCategory -> ActionM () create (CreateCategory name color) = Secure.loggedAction (\_ -> diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index e013849..b40976b 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income - ( create + ( list + , create , edit , delete ) where @@ -20,6 +21,12 @@ import qualified Persistence.Income as IncomePersistence import qualified Secure import qualified Validation.Income as IncomeValidation +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ IncomePersistence.list) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 5ebe921..3788685 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -16,8 +16,9 @@ import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), InitResult (..), - SignInForm (..), User (..)) +import Common.Model (Email (..), Init (..), + InitResult (..), SignInForm (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -26,7 +27,6 @@ import Conf (Conf (..)) import qualified LoginSession import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Persistence.Init as InitPersistence import qualified Persistence.User as UserPersistence import qualified Secure import qualified SendMail @@ -40,8 +40,9 @@ get conf = do case mbLoggedUser of Nothing -> return InitEmpty - Just user -> - liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf + Just user -> do + users <- liftIO . Query.run $ UserPersistence.list + return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) S.html $ page initResult askSignIn :: Conf -> SignInForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index ba9d1ba..30b63ff 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment ( list + , listPaymentCategories , create , edit , delete @@ -32,6 +33,12 @@ list = (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +listPaymentCategories :: ActionM () +listPaymentCategories = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json + ) + create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs new file mode 100644 index 0000000..a7bb136 --- /dev/null +++ b/server/src/Controller/User.hs @@ -0,0 +1,17 @@ +module Controller.User + ( list + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ UserPersistence.list) >>= S.json + ) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 5b8f2dc..598319b 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -52,6 +52,18 @@ global = do ".app" ? do appearAnimation + display flex + height (pct 100) + flexDirection column + + "main" ? + appearAnimation + + ".pageSpinner" ? do + display flex + alignItems center + justifyContent center + flexGrow 1 ".spinner" ? do display flex diff --git a/server/src/Main.hs b/server/src/Main.hs index e3dad9e..9882092 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -1,3 +1,8 @@ +module Main + ( main + ) where + +import qualified Network.HTTP.Types.Status as Status import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress)) import qualified Network.Wai.Middleware.Gzip as W import Network.Wai.Middleware.Static @@ -8,6 +13,7 @@ import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment +import qualified Controller.User as User import Job.Daemon (runDaemons) main :: IO () @@ -32,6 +38,12 @@ main = do S.post "/api/signOut" $ Index.signOut conf + S.get "/api/users"$ + User.list + + S.get "/api/payments" $ + Payment.list + S.post "/api/payment" $ S.jsonData >>= Payment.create @@ -42,6 +54,9 @@ main = do paymentId <- S.param "id" Payment.delete paymentId + S.get "/api/incomes" $ + Income.list + S.post "/api/income" $ S.jsonData >>= Income.create @@ -52,6 +67,12 @@ main = do incomeId <- S.param "id" Income.delete incomeId + S.get "/api/paymentCategories" $ + Payment.listPaymentCategories + + S.get "/api/categories" $ + Category.list + S.post "/api/category" $ S.jsonData >>= Category.create @@ -62,5 +83,6 @@ main = do categoryId <- S.param "id" Category.delete categoryId - S.notFound $ + S.notFound $ do + S.status Status.ok200 Index.get conf diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs deleted file mode 100644 index 74d9172..0000000 --- a/server/src/Persistence/Init.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Persistence.Init - ( getInit - ) where - -import Common.Model (Init (Init), User (..)) - -import Conf (Conf) -import qualified Conf -import Model.Query (Query) -import qualified Persistence.Category as CategoryPersistence -import qualified Persistence.Income as IncomePersistence -import qualified Persistence.Payment as PaymentPersistence -import qualified Persistence.PaymentCategory as PaymentCategoryPersistence -import qualified Persistence.User as UserPersistence - -getInit :: User -> Conf -> Query Init -getInit user conf = - Init <$> - UserPersistence.list <*> - (return . _user_id $ user) <*> - PaymentPersistence.listActive <*> - IncomePersistence.list <*> - CategoryPersistence.list <*> - PaymentCategoryPersistence.list <*> - (return . Conf.currency $ conf) -- cgit v1.2.3 From 33e78f2ebbf5bf7b40e7aa732cc7c019f6df3f12 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 22:08:31 +0200 Subject: Simplify page initialization --- client/client.cabal | 6 ++-- client/src/Component/Button.hs | 2 +- client/src/Component/Input.hs | 2 +- client/src/Component/Pages.hs | 2 +- client/src/Icon.hs | 71 -------------------------------------- client/src/Loadable.hs | 51 +++++++++++++++++++++++++++ client/src/Model/Loadable.hs | 51 --------------------------- client/src/Util/Ajax.hs | 11 +++++- client/src/View/Header.hs | 2 +- client/src/View/Icon.hs | 71 ++++++++++++++++++++++++++++++++++++++ client/src/View/Income/Income.hs | 19 ++++------ client/src/View/Payment/Pages.hs | 2 +- client/src/View/Payment/Payment.hs | 27 +++++---------- client/src/View/Payment/Table.hs | 2 +- 14 files changed, 155 insertions(+), 164 deletions(-) delete mode 100644 client/src/Icon.hs create mode 100644 client/src/Loadable.hs delete mode 100644 client/src/Model/Loadable.hs create mode 100644 client/src/View/Icon.hs diff --git a/client/client.cabal b/client/client.cabal index 9a0d24e..9e0a47e 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -51,10 +51,9 @@ Executable client Component.Link Component.Modal Component.Pages - Component.Table Component.Select - Icon - Model.Loadable + Component.Table + Loadable Model.Route Util.Ajax Util.Css @@ -67,6 +66,7 @@ Executable client Util.WaitFor View.App View.Header + View.Icon View.Income.Add View.Income.Form View.Income.Header diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 46c0afa..b1175d7 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -12,7 +12,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import qualified Icon +import qualified View.Icon as Icon data ButtonIn t m = ButtonIn { _buttonIn_class :: Dynamic t Text diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 0c84754..9ab4d58 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -19,7 +19,7 @@ import qualified Reflex.Dom as R import qualified Common.Util.Validation as ValidationUtil import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button -import qualified Icon +import qualified View.Icon as Icon data InputIn a = InputIn { _inputIn_hasResetButton :: Bool diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index 5611cb7..7843ef6 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -11,8 +11,8 @@ import qualified Reflex.Dom as R import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button -import qualified Icon import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data PagesIn t = PagesIn { _pagesIn_total :: Dynamic t Int diff --git a/client/src/Icon.hs b/client/src/Icon.hs deleted file mode 100644 index 1a45933..0000000 --- a/client/src/Icon.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Icon - ( clone - , cross - , delete - , edit - , loading - , doubleLeft - , doubleLeftBar - , doubleRight - , doubleRightBar - , signOut - ) where - -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -clone :: forall t m. MonadWidget t m => m () -clone = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank - -cross :: forall t m. MonadWidget t m => m () -cross = - svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank - -delete :: forall t m. MonadWidget t m => m () -delete = - svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank - -doubleLeft :: forall t m. MonadWidget t m => m () -doubleLeft = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank - -doubleLeftBar :: forall t m. MonadWidget t m => m () -doubleLeftBar = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank - -doubleRight :: forall t m. MonadWidget t m => m () -doubleRight = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank - -doubleRightBar :: forall t m. MonadWidget t m => m () -doubleRightBar = - svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank - -edit :: forall t m. MonadWidget t m => m () -edit = - svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank - -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ - svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank - -svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a -svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs new file mode 100644 index 0000000..8714a4d --- /dev/null +++ b/client/src/Loadable.hs @@ -0,0 +1,51 @@ +module Loadable + ( Loadable (..) + , fromEvent + , view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +import Data.Functor (Functor) +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +data Loadable t + = Loading + | Error Text + | Loaded t + +instance Functor Loadable where + fmap f Loading = Loading + fmap f (Error e) = Error e + fmap f (Loaded x) = Loaded (f x) + +instance Applicative Loadable where + pure x = Loaded x + + Loading <*> _ = Loading + (Error e) <*> _ = Error e + (Loaded f) <*> Loading = Loading + (Loaded f) <*> (Error e) = Error e + (Loaded f) <*> (Loaded x) = Loaded (f x) + +instance Monad Loadable where + Loading >>= f = Loading + (Error e) >>= f = Error e + (Loaded x) >>= f = f x + +fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) +fromEvent = + R.foldDyn + (\res _ -> case res of + Left err -> Error err + Right t -> Loaded t + ) + Loading + +view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () +view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank +view _ (Error e) = R.text e +view f (Loaded x) = f x diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs deleted file mode 100644 index 3076b46..0000000 --- a/client/src/Model/Loadable.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Model.Loadable - ( Loadable (..) - , fromEvent - , view - ) where - -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Data.Functor (Functor) -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -data Loadable t - = Loading - | Error Text - | Loaded t - -instance Functor Loadable where - fmap f Loading = Loading - fmap f (Error e) = Error e - fmap f (Loaded x) = Loaded (f x) - -instance Applicative Loadable where - pure x = Loaded x - - Loading <*> _ = Loading - (Error e) <*> _ = Error e - (Loaded f) <*> Loading = Loading - (Loaded f) <*> (Error e) = Error e - (Loaded f) <*> (Loaded x) = Loaded (f x) - -instance Monad Loadable where - Loading >>= f = Loading - (Error e) >>= f = Error e - (Loaded x) >>= f = f x - -fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) -fromEvent = - R.foldDyn - (\res _ -> case res of - Left err -> Error err - Right t -> Loaded t - ) - Loading - -view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () -view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank -view _ (Error e) = R.text e -view f (Loaded x) = f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 9cd5105..47f4f3c 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,5 +1,6 @@ module Util.Ajax - ( get + ( getNow + , get , post , put , delete @@ -21,6 +22,14 @@ import Reflex.Dom (Dynamic, Event, IsXhrPayload, XhrResponseHeaders (..)) import qualified Reflex.Dom as R +import Loadable (Loadable) +import qualified Loadable + +getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a)) +getNow url = do + postBuild <- R.getPostBuild + get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent + get :: forall t m a. (MonadWidget t m, FromJSON a) => Event t Text diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index bd69e47..68329eb 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -18,10 +18,10 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import Component (ButtonIn (..)) import qualified Component as Component -import qualified Icon import Model.Route (Route (..)) import qualified Util.Css as CssUtil import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data HeaderIn t = HeaderIn { _headerIn_initResult :: InitResult diff --git a/client/src/View/Icon.hs b/client/src/View/Icon.hs new file mode 100644 index 0000000..cc2ef3f --- /dev/null +++ b/client/src/View/Icon.hs @@ -0,0 +1,71 @@ +module View.Icon + ( clone + , cross + , delete + , edit + , loading + , doubleLeft + , doubleLeftBar + , doubleRight + , doubleRightBar + , signOut + ) where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +clone :: forall t m. MonadWidget t m => m () +clone = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ + svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank + +cross :: forall t m. MonadWidget t m => m () +cross = + svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank + +delete :: forall t m. MonadWidget t m => m () +delete = + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank + +doubleLeft :: forall t m. MonadWidget t m => m () +doubleLeft = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank + +doubleLeftBar :: forall t m. MonadWidget t m => m () +doubleLeftBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank + +doubleRight :: forall t m. MonadWidget t m => m () +doubleRight = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +doubleRightBar :: forall t m. MonadWidget t m => m () +doubleRightBar = + svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank + +edit :: forall t m. MonadWidget t m => m () +edit = + svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank + +loading :: forall t m. MonadWidget t m => m () +loading = + svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $ + svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank + +signOut :: forall t m. MonadWidget t m => m () +signOut = + svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank + +svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a +svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 91682a0..18ebe7c 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -4,14 +4,15 @@ module View.Income.Income , IncomeIn(..) ) where +import Data.Aeson (FromJSON) import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency) -import Model.Loadable (Loadable (..)) -import qualified Model.Loadable as Loadable +import Loadable (Loadable (..)) +import qualified Loadable import qualified Util.Ajax as AjaxUtil import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header @@ -26,17 +27,9 @@ data IncomeIn t = IncomeIn init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) init = do - postBuild <- R.getPostBuild - - usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) - users <- Loadable.fromEvent usersEvent - - incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) - incomes <- Loadable.fromEvent incomesEvent - - paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) - payments <- Loadable.fromEvent paymentsEvent - + users <- AjaxUtil.getNow "api/users" + incomes <- AjaxUtil.getNow "api/incomes" + payments <- AjaxUtil.getNow "api/payments" return $ do us <- users is <- incomes diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 9247143..5681935 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -11,8 +11,8 @@ import qualified Reflex.Dom as R import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component -import qualified Icon import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data PagesIn t = PagesIn { _pagesIn_total :: Dynamic t Int diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index ec350e2..5f0d03c 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -17,8 +17,8 @@ import Common.Model (Currency, Frequency, Income (..), UserId) import qualified Common.Util.Text as T -import Model.Loadable (Loadable (..)) -import qualified Model.Loadable as Loadable +import Loadable (Loadable (..)) +import qualified Loadable import qualified Util.Ajax as AjaxUtil import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header @@ -30,23 +30,11 @@ import qualified View.Payment.Table as Table init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) init = do - postBuild <- R.getPostBuild - - incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild) - incomes <- Loadable.fromEvent incomesEvent - - usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild) - users <- Loadable.fromEvent usersEvent - - paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild) - payments <- Loadable.fromEvent paymentsEvent - - paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild) - paymentCategories <- Loadable.fromEvent paymentCategoriesEvent - - categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild) - categories <- Loadable.fromEvent categoriesEvent - + users <- AjaxUtil.getNow "api/users" + payments <- AjaxUtil.getNow "api/payments" + incomes <- AjaxUtil.getNow "api/incomes" + categories <- AjaxUtil.getNow "api/categories" + paymentCategories <- AjaxUtil.getNow "api/paymentCategories" return $ do us <- users ps <- payments @@ -55,6 +43,7 @@ init = do pcs <- paymentCategories return $ Init <$> us <*> ps <*> is <*> cs <*> pcs + data PaymentIn t = PaymentIn { _paymentIn_currentUser :: UserId , _paymentIn_currency :: Currency diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 5ffa037..3a0a4bf 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -28,8 +28,8 @@ import qualified View.Payment.Delete as Delete import qualified View.Payment.Edit as Edit import View.Payment.Init (Init (..)) -import qualified Icon import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon data TableIn t = TableIn { _tableIn_init :: Init -- cgit v1.2.3 From 80f09e8b3a5c856e60922a73c9161a8c5392e4d4 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 21:35:03 +0200 Subject: Create ModalForm component --- client/client.cabal | 1 + client/src/Component.hs | 15 +-- client/src/Component/ModalForm.hs | 70 +++++++++++++ client/src/View/Income/Add.hs | 3 +- client/src/View/Income/Form.hs | 138 +++++++++++-------------- client/src/View/Payment/Add.hs | 3 +- client/src/View/Payment/Clone.hs | 3 +- client/src/View/Payment/Edit.hs | 3 +- client/src/View/Payment/Form.hs | 205 +++++++++++++++++--------------------- common/common.cabal | 1 + server/server.cabal | 1 + 11 files changed, 236 insertions(+), 207 deletions(-) create mode 100644 client/src/Component/ModalForm.hs diff --git a/client/client.cabal b/client/client.cabal index 9e0a47e..a7d3751 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -20,6 +20,7 @@ Executable client MultiParamTypeClasses OverloadedStrings RecursiveDo + ScopedTypeVariables Build-depends: aeson diff --git a/client/src/Component.hs b/client/src/Component.hs index b715a83..fa4e4ea 100644 --- a/client/src/Component.hs +++ b/client/src/Component.hs @@ -1,9 +1,10 @@ module Component (module X) where -import Component.Button as X -import Component.Form as X -import Component.Input as X -import Component.Link as X -import Component.Pages as X -import Component.Select as X -import Component.Table as X +import Component.Button as X +import Component.Form as X +import Component.Input as X +import Component.Link as X +import Component.ModalForm as X +import Component.Pages as X +import Component.Select as X +import Component.Table as X diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs new file mode 100644 index 0000000..63cb1d2 --- /dev/null +++ b/client/src/Component/ModalForm.hs @@ -0,0 +1,70 @@ +module Component.ModalForm + ( modalForm + , ModalFormIn(..) + , ModalFormOut(..) + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Button +import qualified Util.Either as EitherUtil +import qualified Util.Validation as ValidationUtil +import qualified Util.WaitFor as WaitFor + +data ModalFormIn m t a b e = ModalFormIn + { _modalFormIn_headerLabel :: Text + , _modalFormIn_form :: m (Dynamic t (Validation e a)) + , _modalFormIn_ajax :: Event t a -> m (Event t (Either Text b)) + } + +data ModalFormOut t a = ModalFormOut + { _modalFormOut_hide :: Event t () + , _modalFormOut_cancel :: Event t () + , _modalFormOut_confirm :: Event t () + , _modalFormOut_validate :: Event t a + } + +modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b) +modalForm modalFormIn = + R.divClass "form" $ do + R.divClass "formHeader" $ + R.text (_modalFormIn_headerLabel modalFormIn) + + R.divClass "formContent" $ do + rec + form <- _modalFormIn_form modalFormIn + + (validate, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Button._buttonOut_clic <$> (Button.button $ + (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) + { _buttonIn_class = R.constDyn "undo" }) + + confirm <- Button._buttonOut_clic <$> (Button.button $ + (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { _buttonIn_class = R.constDyn "confirm" + , _buttonIn_waiting = waiting + , _buttonIn_submit = True + }) + + (validate, waiting) <- WaitFor.waitFor + (_modalFormIn_ajax modalFormIn) + (ValidationUtil.fireValidation form confirm) + + return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) + + return ModalFormOut + { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ] + , _modalFormOut_cancel = cancel + , _modalFormOut_confirm = confirm + , _modalFormOut_validate = validate + } diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index d83bb51..0b1bd04 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -11,6 +11,7 @@ import Common.Model (CreateIncomeForm (..), Income) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import View.Income.Form (FormIn (..), FormOut (..)) import qualified View.Income.Form as Form @@ -27,7 +28,7 @@ view cancel = do , _formIn_amount = "" , _formIn_date = currentDay , _formIn_mkPayload = CreateIncomeForm - , _formIn_httpMethod = Form.Post + , _formIn_ajax = Ajax.post } hide <- ReflexUtil.flatten (_formOut_hide <$> form) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 2bfc23f..824bb0a 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -1,113 +1,89 @@ module View.Income.Form ( view , FormIn(..) - , HttpMethod(..) , FormOut(..) ) where -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import Data.Validation (Validation) import qualified Data.Validation as V -import Reflex.Dom (Event, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Income) import qualified Common.Msg as Msg import qualified Common.Validation.Income as IncomeValidation -import Component (ButtonIn (..), InputIn (..), - InputOut (..)) +import Component (InputIn (..), InputOut (..), + ModalFormIn (..), ModalFormOut (..)) import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.Validation as ValidationUtil -import qualified Util.WaitFor as WaitFor -data FormIn t i = FormIn +data FormIn m t a = FormIn { _formIn_cancel :: Event t () , _formIn_headerLabel :: Text , _formIn_amount :: Text , _formIn_date :: Day - , _formIn_mkPayload :: Text -> Text -> i - , _formIn_httpMethod :: HttpMethod + , _formIn_mkPayload :: Text -> Text -> a + , _formIn_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) } -data HttpMethod = Put | Post - data FormOut t = FormOut { _formOut_hide :: Event t () , _formOut_addIncome :: Event t Income } -view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t) +view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t) view formIn = do - R.divClass "form" $ do - R.divClass "formHeader" $ - R.text (_formIn_headerLabel formIn) - - R.divClass "formContent" $ do - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addIncome - , "" <$ _formIn_cancel formIn - ] - - amount <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Amount - , _inputIn_initialValue = _formIn_amount formIn - , _inputIn_validation = IncomeValidation.amount - }) - (_formIn_amount formIn <$ reset) - confirm) - - let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn - - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = IncomeValidation.date - }) - (initialDate <$ reset) - confirm) - - let income = do - a <- amount - d <- date - return . V.Success $ (_formIn_mkPayload formIn) a d - - (addIncome, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addIncome, waiting) <- WaitFor.waitFor - (ajax "/api/income") - (ValidationUtil.fireValidation income confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm) - - return FormOut - { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ] - , _formOut_addIncome = addIncome - } + rec + let reset = R.leftmost + [ "" <$ _modalFormOut_cancel modalForm + , "" <$ _modalFormOut_validate modalForm + , "" <$ _formIn_cancel formIn + ] + + modalForm <- Component.modalForm $ ModalFormIn + { _modalFormIn_headerLabel = _formIn_headerLabel formIn + , _modalFormIn_ajax = _formIn_ajax formIn "/api/income" + , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + } + + return $ FormOut + { _formOut_hide = _modalFormOut_hide modalForm + , _formOut_addIncome = _modalFormOut_validate modalForm + } where - ajax = - case _formIn_httpMethod formIn of - Post -> Ajax.post - Put -> Ajax.put + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text a)) + form reset confirm = do + amount <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Amount + , _inputIn_initialValue = _formIn_amount formIn + , _inputIn_validation = IncomeValidation.amount + }) + (_formIn_amount formIn <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn + + date <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Income_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = IncomeValidation.date + }) + (initialDate <$ reset) + confirm) + + return $ do + a <- amount + d <- date + return . V.Success $ (_formIn_mkPayload formIn) a d diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 28c0148..163a200 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -17,6 +17,7 @@ import Common.Model (Category (..), CreatePaymentForm (..), import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form @@ -45,7 +46,7 @@ view input cancel = do , Form._input_category = -1 , Form._input_frequency = frequency , Form._input_mkPayload = CreatePaymentForm - , Form._input_httpMethod = Form.Post + , Form._input_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 60694ca..2fa27f3 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -17,6 +17,7 @@ import Common.Model (Category (..), CategoryId, import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form @@ -48,7 +49,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = CreatePaymentForm - , Form._input_httpMethod = Form.Post + , Form._input_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 0361602..77841ce 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -14,6 +14,7 @@ import Common.Model (Category (..), CategoryId, SavedPayment (..)) import qualified Common.Msg as Msg import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form @@ -43,7 +44,7 @@ view input cancel = do , Form._input_category = category , Form._input_frequency = _payment_frequency payment , Form._input_mkPayload = EditPaymentForm (_payment_id payment) - , Form._input_httpMethod = Form.Put + , Form._input_ajax = Ajax.put } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index c817831..1f068fd 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,23 +1,21 @@ module View.Payment.Form ( view , Input(..) - , HttpMethod(..) , Output(..) ) where -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) import Data.Aeson (ToJSON) import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import Data.Validation (Validation) import qualified Data.Validation as V -import Reflex.Dom (Dynamic, Event, MonadHold, - MonadWidget, Reflex) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import qualified Text.Read as T @@ -27,16 +25,13 @@ import Common.Model (Category (..), CategoryId, SavedPayment (..)) import qualified Common.Msg as Msg import qualified Common.Validation.Payment as PaymentValidation -import Component (ButtonIn (..), InputIn (..), - InputOut (..), SelectIn (..), - SelectOut (..)) +import Component (InputIn (..), InputOut (..), + ModalFormIn (..), ModalFormOut (..), + SelectIn (..), SelectOut (..)) import qualified Component as Component -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil -import qualified Util.WaitFor as WaitFor -data Input t p = Input +data Input m t a = Input { _input_cancel :: Event t () , _input_headerLabel :: Text , _input_categories :: [Category] @@ -46,114 +41,99 @@ data Input t p = Input , _input_date :: Day , _input_category :: CategoryId , _input_frequency :: Frequency - , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> p - , _input_httpMethod :: HttpMethod + , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a + , _input_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) } -data HttpMethod = Put | Post - data Output t = Output { _output_hide :: Event t () , _output_addPayment :: Event t SavedPayment } -view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t) +view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t) view input = do - R.divClass "form" $ do - R.divClass "formHeader" $ - R.text (_input_headerLabel input) - - R.divClass "formContent" $ do - rec - let reset = R.leftmost - [ "" <$ cancel - , "" <$ addPayment - , "" <$ _input_cancel input - ] - - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_initialValue = _input_name input - , _inputIn_validation = PaymentValidation.name - }) - (_input_name input <$ reset) - confirm - - cost <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_initialValue = _input_cost input - , _inputIn_validation = PaymentValidation.cost - }) - (_input_cost input <$ reset) - confirm) - - let initialDate = T.pack . Calendar.showGregorian . _input_date $ input - - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date - }) - (initialDate <$ reset) - confirm) - - let setCategory = - R.fmapMaybe id . R.updated $ - R.ffor (_inputOut_raw name) $ \name -> - findCategory name (_input_paymentCategories input) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = _input_category input - , _selectIn_value = setCategory - , _selectIn_values = R.constDyn categories - , _selectIn_reset = _input_category input <$ reset - , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) - , _selectIn_validate = confirm - }) - - let payment = do - n <- _inputOut_value name - c <- cost - d <- date - cat <- category - return ((_input_mkPayload input) - <$> ValidationUtil.nelError n - <*> V.Success c - <*> V.Success d - <*> ValidationUtil.nelError cat - <*> V.Success (_input_frequency input)) - - (addPayment, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) - - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True - }) - - (addPayment, waiting) <- WaitFor.waitFor - (ajax "/api/payment") - (ValidationUtil.fireValidation payment confirm) - - return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm) - - return Output - { _output_hide = R.leftmost [ cancel, () <$ addPayment ] - , _output_addPayment = addPayment - } + rec + let reset = R.leftmost + [ "" <$ _modalFormOut_cancel modalForm + , "" <$ _modalFormOut_validate modalForm + , "" <$ _input_cancel input + ] + + modalForm <- Component.modalForm $ ModalFormIn + { _modalFormIn_headerLabel = _input_headerLabel input + , _modalFormIn_ajax = _input_ajax input "/api/payment" + , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + } + + return $ Output + { _output_hide = _modalFormOut_hide modalForm + , _output_addPayment = _modalFormOut_validate modalForm + } where + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation (NonEmpty Text) a)) + form reset confirm = do + name <- Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Name + , _inputIn_initialValue = _input_name input + , _inputIn_validation = PaymentValidation.name + }) + (_input_name input <$ reset) + confirm + + cost <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Cost + , _inputIn_initialValue = _input_cost input + , _inputIn_validation = PaymentValidation.cost + }) + (_input_cost input <$ reset) + confirm) + + let initialDate = T.pack . Calendar.showGregorian . _input_date $ input + + date <- _inputOut_raw <$> (Component.input + (Component.defaultInputIn + { _inputIn_label = Msg.get Msg.Payment_Date + , _inputIn_initialValue = initialDate + , _inputIn_inputType = "date" + , _inputIn_hasResetButton = False + , _inputIn_validation = PaymentValidation.date + }) + (initialDate <$ reset) + confirm) + + let setCategory = + R.fmapMaybe id . R.updated $ + R.ffor (_inputOut_raw name) $ \name -> + findCategory name (_input_paymentCategories input) + + category <- _selectOut_value <$> (Component.select $ SelectIn + { _selectIn_label = Msg.get Msg.Payment_Category + , _selectIn_initialValue = _input_category input + , _selectIn_value = setCategory + , _selectIn_values = R.constDyn categories + , _selectIn_reset = _input_category input <$ reset + , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) + , _selectIn_validate = confirm + }) + + return $ do + n <- _inputOut_value name + c <- cost + d <- date + cat <- category + return ((_input_mkPayload input) + <$> ValidationUtil.nelError n + <*> V.Success c + <*> V.Success d + <*> ValidationUtil.nelError cat + <*> V.Success (_input_frequency input)) + frequencies = M.fromList [ (Punctual, Msg.get Msg.Payment_PunctualMale) @@ -163,11 +143,6 @@ view input = do categories = M.fromList . flip map (_input_categories input) $ \c -> (_category_id c, _category_name c) - ajax = - case _input_httpMethod input of - Post -> Ajax.post - Put -> Ajax.put - findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId findCategory paymentName = fmap _paymentCategory_category diff --git a/common/common.cabal b/common/common.cabal index 6c7c779..1a441c5 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -19,6 +19,7 @@ Library LambdaCase MultiParamTypeClasses OverloadedStrings + ScopedTypeVariables Build-depends: aeson diff --git a/server/server.cabal b/server/server.cabal index eeba14f..f1105ff 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -19,6 +19,7 @@ Executable server LambdaCase MultiParamTypeClasses OverloadedStrings + ScopedTypeVariables Build-depends: aeson -- cgit v1.2.3 From 613ffccac4b3ab25c6d4c631fab757da0b35acf6 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 22:26:38 +0200 Subject: Harmonize view component code style --- client/client.cabal | 1 - client/src/Component.hs | 10 --- client/src/Component/Button.hs | 56 ++++++++-------- client/src/Component/Form.hs | 6 +- client/src/Component/Input.hs | 79 +++++++++++------------ client/src/Component/Link.hs | 6 +- client/src/Component/Modal.hs | 14 ++-- client/src/Component/ModalForm.hs | 61 +++++++++--------- client/src/Component/Pages.hs | 45 +++++++------ client/src/Component/Select.hs | 56 ++++++++-------- client/src/Component/Table.hs | 45 +++++++------ client/src/View/App.hs | 27 ++++---- client/src/View/Header.hs | 82 +++++++++++------------ client/src/View/Income/Add.hs | 19 +++--- client/src/View/Income/Form.hs | 83 ++++++++++++------------ client/src/View/Income/Header.hs | 43 ++++++------- client/src/View/Income/Income.hs | 34 +++++----- client/src/View/Income/Table.hs | 29 ++++----- client/src/View/NotFound.hs | 12 ++-- client/src/View/Payment/Add.hs | 40 ++++++------ client/src/View/Payment/Clone.hs | 46 ++++++------- client/src/View/Payment/Delete.hs | 57 ++++++++-------- client/src/View/Payment/Edit.hs | 46 ++++++------- client/src/View/Payment/Form.hs | 129 ++++++++++++++++++------------------- client/src/View/Payment/Header.hs | 96 ++++++++++++++------------- client/src/View/Payment/Pages.hs | 57 ++++++++-------- client/src/View/Payment/Payment.hs | 75 +++++++++++---------- client/src/View/Payment/Table.hs | 121 +++++++++++++++++----------------- client/src/View/SignIn.hs | 28 ++++---- 29 files changed, 685 insertions(+), 718 deletions(-) delete mode 100644 client/src/Component.hs diff --git a/client/client.cabal b/client/client.cabal index a7d3751..c78ed87 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -45,7 +45,6 @@ Executable client , uri-bytestring other-modules: - Component Component.Button Component.Form Component.Input diff --git a/client/src/Component.hs b/client/src/Component.hs deleted file mode 100644 index fa4e4ea..0000000 --- a/client/src/Component.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Component (module X) where - -import Component.Button as X -import Component.Form as X -import Component.Input as X -import Component.Link as X -import Component.ModalForm as X -import Component.Pages as X -import Component.Select as X -import Component.Table as X diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index b1175d7..6faecef 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -1,8 +1,8 @@ module Component.Button - ( ButtonIn(..) - , ButtonOut(..) - , button - , defaultButtonIn + ( In(..) + , Out(..) + , view + , defaultIn ) where import qualified Data.Map as M @@ -14,44 +14,44 @@ import qualified Reflex.Dom as R import qualified View.Icon as Icon -data ButtonIn t m = ButtonIn - { _buttonIn_class :: Dynamic t Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool - , _buttonIn_tabIndex :: Maybe Int - , _buttonIn_submit :: Bool +data In t m = In + { _in_class :: Dynamic t Text + , _in_content :: m () + , _in_waiting :: Event t Bool + , _in_tabIndex :: Maybe Int + , _in_submit :: Bool } -defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m -defaultButtonIn content = ButtonIn - { _buttonIn_class = R.constDyn "" - , _buttonIn_content = content - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False +defaultIn :: MonadWidget t m => m () -> In t m +defaultIn content = In + { _in_class = R.constDyn "" + , _in_content = content + , _in_waiting = R.never + , _in_tabIndex = Nothing + , _in_submit = False } -data ButtonOut t = ButtonOut - { _buttonOut_clic :: Event t () +data Out t = Out + { _out_clic :: Event t () } -button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) -button buttonIn = do - dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn +view :: forall t m. MonadWidget t m => In t m -> m (Out t) +view input = do + dynWaiting <- R.holdDyn False $ _in_waiting input let attr = do - buttonClass <- _buttonIn_class buttonIn + buttonClass <- _in_class input waiting <- dynWaiting return . M.fromList . catMaybes $ - [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button") - , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn + [ Just ("type", if _in_submit input then "submit" else "button") + , (\i -> ("tabindex", T.pack . show $ i)) <$> _in_tabIndex input , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ]) ] (e, _) <- R.elDynAttr' "button" attr $ do Icon.loading - R.divClass "content" $ _buttonIn_content buttonIn + R.divClass "content" $ _in_content input - return $ ButtonOut - { _buttonOut_clic = R.domEvent R.Click e + return $ Out + { _out_clic = R.domEvent R.Click e } diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs index 6ea02fa..6878e68 100644 --- a/client/src/Component/Form.hs +++ b/client/src/Component/Form.hs @@ -1,12 +1,12 @@ module Component.Form - ( form + ( view ) where import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -form :: forall t m a. MonadWidget t m => m a -> m a -form content = +view :: forall t m a. MonadWidget t m => m a -> m a +view content = R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ content diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 9ab4d58..37020da 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -1,8 +1,8 @@ module Component.Input - ( InputIn(..) - , InputOut(..) - , input - , defaultInputIn + ( In(..) + , Out(..) + , view + , defaultIn ) where import qualified Data.Map as M @@ -17,40 +17,39 @@ import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex, import qualified Reflex.Dom as R import qualified Common.Util.Validation as ValidationUtil -import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified View.Icon as Icon -data InputIn a = InputIn - { _inputIn_hasResetButton :: Bool - , _inputIn_label :: Text - , _inputIn_initialValue :: Text - , _inputIn_inputType :: Text - , _inputIn_validation :: Text -> Validation Text a +data In a = In + { _in_hasResetButton :: Bool + , _in_label :: Text + , _in_initialValue :: Text + , _in_inputType :: Text + , _in_validation :: Text -> Validation Text a } -defaultInputIn :: InputIn Text -defaultInputIn = InputIn - { _inputIn_hasResetButton = True - , _inputIn_label = "" - , _inputIn_initialValue = "" - , _inputIn_inputType = "text" - , _inputIn_validation = V.Success +defaultIn :: In Text +defaultIn = In + { _in_hasResetButton = True + , _in_label = "" + , _in_initialValue = "" + , _in_inputType = "text" + , _in_validation = V.Success } -data InputOut t a = InputOut - { _inputOut_raw :: Dynamic t Text - , _inputOut_value :: Dynamic t (Validation Text a) - , _inputOut_enter :: Event t () +data Out t a = Out + { _out_raw :: Dynamic t Text + , _out_value :: Dynamic t (Validation Text a) + , _out_enter :: Event t () } -input +view :: forall t m a b. MonadWidget t m - => InputIn a + => In a -> Event t Text -- reset -> Event t b -- validate - -> m (InputOut t a) -input inputIn reset validate = do + -> m (Out t a) +view input reset validate = do rec let resetValue = R.leftmost [ reset @@ -58,7 +57,7 @@ input inputIn reset validate = do ] inputAttr = R.ffor value (\v -> - if T.null v && _inputIn_inputType inputIn /= "date" + if T.null v && _in_inputType input /= "date" then M.empty else M.singleton "class" "filled") @@ -70,7 +69,7 @@ input inputIn reset validate = do , if Maybe.isJust e then "error" else "" ]) - let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v)) + let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v)) inputError <- getInputError valueWithValidation validate (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do @@ -79,21 +78,21 @@ input inputIn reset validate = do textInput <- R.textInput $ R.def & R.attributes .~ inputAttr & R.setValue .~ resetValue - & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn) - & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn) + & R.textInputConfig_initialValue .~ (_in_initialValue input) + & R.textInputConfig_inputType .~ (_in_inputType input) R.divClass "label" $ - R.text (_inputIn_label inputIn) + R.text (_in_label input) return textInput resetClic <- - if _inputIn_hasResetButton inputIn + if _in_hasResetButton input then - _buttonOut_clic <$> (Button.button $ - (Button.defaultButtonIn Icon.cross) - { _buttonIn_class = R.constDyn "reset" - , _buttonIn_tabIndex = Just (-1) + Button._out_clic <$> (Button.view $ + (Button.defaultIn Icon.cross) + { Button._in_class = R.constDyn "reset" + , Button._in_tabIndex = Just (-1) }) else return R.never @@ -105,10 +104,10 @@ input inputIn reset validate = do let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_raw = value - , _inputOut_value = fmap snd valueWithValidation - , _inputOut_enter = enter + return $ Out + { _out_raw = value + , _out_value = fmap snd valueWithValidation + , _out_enter = enter } getInputError diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs index 7e8558b..1fd620e 100644 --- a/client/src/Component/Link.hs +++ b/client/src/Component/Link.hs @@ -1,5 +1,5 @@ module Component.Link - ( link + ( view ) where import Data.Map (Map) @@ -9,8 +9,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () -link href inputAttrs content = +view :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m () +view href inputAttrs content = R.elDynAttr "a" attrs (R.text content) where diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 96c2679..50af469 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,5 +1,5 @@ module Component.Modal - ( Input(..) + ( In(..) , Content , view ) where @@ -22,15 +22,15 @@ import qualified Util.Reflex as ReflexUtil -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) type Content t m a = Event t () -> m (Event t (), Event t a) -data Input t m a = Input - { _input_show :: Event t () - , _input_content :: Content t m a +data In t m a = In + { _in_show :: Event t () + , _in_content :: Content t m a } -view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a) +view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a) view input = do rec - let show = Show <$ (_input_show input) + let show = Show <$ (_in_show input) startHiding = R.attachWithMaybe @@ -61,7 +61,7 @@ view input = do (do (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank let curtainClick = R.domEvent R.Click curtain - (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick) + (hide, content) <- R.divClass "g-Modal__Content" (_in_content input curtainClick) return (curtainClick, hide, content)) diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index 63cb1d2..ea53beb 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -1,7 +1,7 @@ module Component.ModalForm - ( modalForm - , ModalFormIn(..) - , ModalFormOut(..) + ( view + , In(..) + , Out(..) ) where import Data.Aeson (ToJSON) @@ -14,57 +14,56 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import qualified Common.Msg as Msg -import Component.Button (ButtonIn (..)) import qualified Component.Button as Button import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data ModalFormIn m t a b e = ModalFormIn - { _modalFormIn_headerLabel :: Text - , _modalFormIn_form :: m (Dynamic t (Validation e a)) - , _modalFormIn_ajax :: Event t a -> m (Event t (Either Text b)) +data In m t a b e = In + { _in_headerLabel :: Text + , _in_form :: m (Dynamic t (Validation e a)) + , _in_ajax :: Event t a -> m (Event t (Either Text b)) } -data ModalFormOut t a = ModalFormOut - { _modalFormOut_hide :: Event t () - , _modalFormOut_cancel :: Event t () - , _modalFormOut_confirm :: Event t () - , _modalFormOut_validate :: Event t a +data Out t a = Out + { _out_hide :: Event t () + , _out_cancel :: Event t () + , _out_confirm :: Event t () + , _out_validate :: Event t a } -modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b) -modalForm modalFormIn = +view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b) +view input = R.divClass "form" $ do R.divClass "formHeader" $ - R.text (_modalFormIn_headerLabel modalFormIn) + R.text (_in_headerLabel input) R.divClass "formContent" $ do rec - form <- _modalFormIn_form modalFormIn + form <- _in_form input (validate, cancel, confirm) <- R.divClass "buttons" $ do rec - cancel <- Button._buttonOut_clic <$> (Button.button $ - (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) - confirm <- Button._buttonOut_clic <$> (Button.button $ - (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_waiting = waiting + , Button._in_submit = True }) (validate, waiting) <- WaitFor.waitFor - (_modalFormIn_ajax modalFormIn) + (_in_ajax input) (ValidationUtil.fireValidation form confirm) return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) - return ModalFormOut - { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ] - , _modalFormOut_cancel = cancel - , _modalFormOut_confirm = confirm - , _modalFormOut_validate = validate + return Out + { _out_hide = R.leftmost [ cancel, () <$ validate ] + , _out_cancel = cancel + , _out_confirm = confirm + , _out_validate = validate } diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index 7843ef6..7284a36 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -1,41 +1,40 @@ module Component.Pages - ( widget - , PagesIn(..) - , PagesOut(..) + ( view + , In(..) + , Out(..) ) where import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Component.Button (ButtonIn (..), ButtonOut (..)) import qualified Component.Button as Button import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data PagesIn t = PagesIn - { _pagesIn_total :: Dynamic t Int - , _pagesIn_perPage :: Int - , _pagesIn_reset :: Event t () +data In t = In + { _in_total :: Dynamic t Int + , _in_perPage :: Int + , _in_reset :: Event t () } -data PagesOut t = PagesOut - { _pagesOut_currentPage :: Dynamic t Int +data Out t = Out + { _out_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) -widget pagesIn = do +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - return $ PagesOut - { _pagesOut_currentPage = currentPage + return $ Out + { _out_currentPage = currentPage } where - total = _pagesIn_total pagesIn - perPage = _pagesIn_perPage pagesIn - reset = _pagesIn_reset pagesIn + total = _in_total input + perPage = _in_perPage input + reset = _in_reset input pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) pageButtons total perPage reset = do @@ -75,14 +74,14 @@ range currentPage maxPage = [start..end] pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do - clic <- _buttonOut_clic <$> (Button.button $ ButtonIn - { _buttonIn_class = do + clic <- Button._out_clic <$> (Button.view $ Button.In + { Button._in_class = do cp <- currentPage p <- page if cp == Just p then "page current" else "page" - , _buttonIn_content = content - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False + , Button._in_content = content + , Button._in_waiting = R.never + , Button._in_tabIndex = Nothing + , Button._in_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 102f554..375ae06 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -1,7 +1,7 @@ module Component.Select - ( SelectIn(..) - , SelectOut(..) - , select + ( view + , In(..) + , Out(..) ) where import Data.Map (Map) @@ -15,58 +15,58 @@ import qualified Reflex.Dom as R import qualified Util.Validation as ValidationUtil -data (Reflex t) => SelectIn t a b c = SelectIn - { _selectIn_label :: Text - , _selectIn_initialValue :: a - , _selectIn_value :: Event t a - , _selectIn_values :: Dynamic t (Map a Text) - , _selectIn_reset :: Event t b - , _selectIn_isValid :: a -> Validation Text a - , _selectIn_validate :: Event t c +data (Reflex t) => In t a b c = In + { _in_label :: Text + , _in_initialValue :: a + , _in_value :: Event t a + , _in_values :: Dynamic t (Map a Text) + , _in_reset :: Event t b + , _in_isValid :: a -> Validation Text a + , _in_validate :: Event t c } -data SelectOut t a = SelectOut - { _selectOut_raw :: Dynamic t a - , _selectOut_value :: Dynamic t (Validation Text a) +data Out t a = Out + { _out_raw :: Dynamic t a + , _out_value :: Dynamic t (Validation Text a) } -select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a) -select selectIn = do +view :: forall t m a b c. (Ord a, MonadWidget t m) => In t a b c -> m (Out t a) +view input = do rec let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " - [ "selectInput" + [ "input" , if Maybe.isJust e then "error" else "" ]) validatedValue = - fmap (_selectIn_isValid selectIn) value + fmap (_in_isValid input) value maybeError = fmap ValidationUtil.maybeError validatedValue showedError <- R.holdDyn Nothing $ R.leftmost - [ Nothing <$ _selectIn_reset selectIn + [ Nothing <$ _in_reset input , R.updated maybeError - , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn) + , R.attachWith const (R.current maybeError) (_in_validate input) ] value <- R.elDynAttr "div" containerAttr $ do - let initialValue = _selectIn_initialValue selectIn + let initialValue = _in_initialValue input let setValue = R.leftmost - [ initialValue <$ (_selectIn_reset selectIn) - , _selectIn_value selectIn + [ initialValue <$ (_in_reset input) + , _in_value input ] value <- R.el "label" $ do R.divClass "label" $ - R.text (_selectIn_label selectIn) + R.text (_in_label input) R._dropdown_value <$> R.dropdown initialValue - (_selectIn_values selectIn) + (_in_values input) (R.def { R._dropdownConfig_setValue = setValue }) R.divClass "errorMessage" . R.dynText $ @@ -74,7 +74,7 @@ select selectIn = do return value - return SelectOut - { _selectOut_raw = value - , _selectOut_value = validatedValue + return Out + { _out_raw = value + , _out_value = validatedValue } diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index b431c14..bf76566 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -1,29 +1,28 @@ module Component.Table - ( table - , TableIn(..) - , TableOut(..) + ( view + , In(..) + , Out(..) ) where import Data.Text (Text) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Component.Pages (PagesIn (..), PagesOut (..)) import qualified Component.Pages as Pages -data TableIn h r t = TableIn - { _tableIn_headerLabel :: h -> Text - , _tableIn_rows :: Dynamic t [r] - , _tableIn_cell :: h -> r -> Text - , _tableIn_perPage :: Int - , _tableIn_resetPage :: Event t () +data In h r t = In + { _in_headerLabel :: h -> Text + , _in_rows :: Dynamic t [r] + , _in_cell :: h -> r -> Text + , _in_perPage :: Int + , _in_resetPage :: Event t () } -data TableOut = TableOut +data Out = Out {} -table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut) -table tableIn = +view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In h r t -> m (Out) +view input = R.divClass "table" $ do rec R.divClass "lines" $ do @@ -31,29 +30,29 @@ table tableIn = R.divClass "header" $ flip mapM_ [minBound..] $ \header -> R.divClass "cell" . R.text $ - _tableIn_headerLabel tableIn header + _in_headerLabel input header let rows = getRange - (_tableIn_perPage tableIn) - <$> (_pagesOut_currentPage pages) - <*> (_tableIn_rows tableIn) + (_in_perPage input) + <$> (Pages._out_currentPage pages) + <*> (_in_rows input) R.simpleList rows $ \r -> R.divClass "row" $ flip mapM_ [minBound..] $ \h -> R.divClass "cell name" $ R.dynText $ - R.ffor r (_tableIn_cell tableIn h) + R.ffor r (_in_cell input h) - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> (_tableIn_rows tableIn) - , _pagesIn_perPage = _tableIn_perPage tableIn - , _pagesIn_reset = _tableIn_resetPage tableIn + pages <- Pages.view $ Pages.In + { Pages._in_total = length <$> (_in_rows input) + , Pages._in_perPage = _in_perPage input + , Pages._in_reset = _in_resetPage input } return () - return $ TableOut + return $ Out {} getRange :: forall a. Int -> Int -> [a] -> [a] diff --git a/client/src/View/App.hs b/client/src/View/App.hs index b468e56..e0a52e2 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -13,12 +13,9 @@ import qualified Common.Msg as Msg import Model.Route (Route (..)) import qualified Util.Router as Router -import View.Header (HeaderIn (..)) import qualified View.Header as Header -import View.Income.Income (IncomeIn (..)) import qualified View.Income.Income as Income import qualified View.NotFound as NotFound -import View.Payment.Payment (PaymentIn (..)) import qualified View.Payment.Payment as Payment import qualified View.SignIn as SignIn @@ -28,17 +25,17 @@ widget initResult = route <- getRoute - headerOut <- Header.view $ HeaderIn - { _headerIn_initResult = initResult - , _headerIn_isInitSuccess = + header <- Header.view $ Header.In + { Header._in_initResult = initResult + , Header._in_isInitSuccess = case initResult of InitSuccess _ -> True _ -> False - , _headerIn_route = route + , Header._in_route = route } let signOut = - Header._headerOut_signOut headerOut + Header._out_signOut header mainContent = case initResult of @@ -63,17 +60,17 @@ signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> do paymentInit <- Payment.init - Payment.view $ PaymentIn - { _paymentIn_currentUser = _init_currentUser init - , _paymentIn_currency = _init_currency init - , _paymentIn_init = paymentInit + Payment.view $ Payment.In + { Payment._in_currentUser = _init_currentUser init + , Payment._in_currency = _init_currency init + , Payment._in_init = paymentInit } IncomeRoute -> do incomeInit <- Income.init - Income.view $ IncomeIn - { _incomeIn_currency = _init_currency init - , _incomeIn_init = incomeInit + Income.view $ Income.In + { Income._in_currency = _init_currency init + , Income._in_init = incomeInit } NotFoundRoute -> diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 68329eb..3f58dd5 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,40 +1,40 @@ module View.Header ( view - , HeaderIn(..) - , HeaderOut(..) + , In(..) + , Out(..) ) where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init (..), InitResult (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import Component (ButtonIn (..)) -import qualified Component as Component -import Model.Route (Route (..)) -import qualified Util.Css as CssUtil -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon - -data HeaderIn t = HeaderIn - { _headerIn_initResult :: InitResult - , _headerIn_isInitSuccess :: Bool - , _headerIn_route :: Dynamic t Route +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Link as Link +import Model.Route (Route (..)) +import qualified Util.Css as CssUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon + +data In t = In + { _in_initResult :: InitResult + , _in_isInitSuccess :: Bool + , _in_route :: Dynamic t Route } -data HeaderOut t = HeaderOut - { _headerOut_signOut :: Event t () +data Out t = Out + { _out_signOut :: Event t () } -view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t) -view headerIn = +view :: forall t m. MonadWidget t m => (In t) -> m (Out t) +view input = R.el "header" $ do R.divClass "title" $ @@ -42,23 +42,23 @@ view headerIn = signOut <- R.el "div" $ do rec - showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut) - ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn) - signOut <- nameSignOut $ _headerIn_initResult headerIn + showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut) + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) + signOut <- nameSignOut $ _in_initResult input return signOut - return $ HeaderOut - { _headerOut_signOut = signOut + return $ Out + { _out_signOut = signOut } links :: forall t m. MonadWidget t m => Dynamic t Route -> m () links route = do - Component.link + Link.view "/" (R.ffor route (attrs RootRoute)) (Msg.get Msg.Payment_Title) - Component.link + Link.view "/income" (R.ffor route (attrs IncomeRoute)) (Msg.get Msg.Income_Title) @@ -92,12 +92,12 @@ nameSignOut initResult = case initResult of signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do rec - signOut <- Component.button $ - (Component.defaultButtonIn Icon.signOut) - { _buttonIn_class = R.constDyn "signOut item" - , _buttonIn_waiting = waiting + signOut <- Button.view $ + (Button.defaultIn Icon.signOut) + { Button._in_class = R.constDyn "signOut item" + , Button._in_waiting = waiting } - let signOutClic = Component._buttonOut_clic signOut + let signOutClic = Button._out_clic signOut waiting = R.leftmost [ fmap (const True) signOutClic , fmap (const False) signOutSuccess diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index 0b1bd04..f8f107f 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -13,7 +13,6 @@ import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil -import View.Income.Form (FormIn (..), FormOut (..)) import qualified View.Income.Form as Form view :: forall t m. MonadWidget t m => Modal.Content t m Income @@ -22,16 +21,16 @@ view cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay form <- R.dyn $ - return $ Form.view $ FormIn - { _formIn_cancel = cancel - , _formIn_headerLabel = Msg.get Msg.Income_AddLong - , _formIn_amount = "" - , _formIn_date = currentDay - , _formIn_mkPayload = CreateIncomeForm - , _formIn_ajax = Ajax.post + return $ Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Income_AddLong + , Form._in_amount = "" + , Form._in_date = currentDay + , Form._in_mkPayload = CreateIncomeForm + , Form._in_ajax = Ajax.post } - hide <- ReflexUtil.flatten (_formOut_hide <$> form) - addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form) + hide <- ReflexUtil.flatten (Form._out_hide <$> form) + addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form) return (hide, addIncome) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 824bb0a..917edf1 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -1,7 +1,7 @@ module View.Income.Form ( view - , FormIn(..) - , FormOut(..) + , In(..) + , Out(..) ) where import Data.Aeson (FromJSON, ToJSON) @@ -17,42 +17,41 @@ import qualified Reflex.Dom as R import Common.Model (Income) import qualified Common.Msg as Msg import qualified Common.Validation.Income as IncomeValidation -import Component (InputIn (..), InputOut (..), - ModalFormIn (..), ModalFormOut (..)) -import qualified Component as Component +import qualified Component.Input as Input +import qualified Component.ModalForm as ModalForm -data FormIn m t a = FormIn - { _formIn_cancel :: Event t () - , _formIn_headerLabel :: Text - , _formIn_amount :: Text - , _formIn_date :: Day - , _formIn_mkPayload :: Text -> Text -> a - , _formIn_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) +data In m t a = In + { _in_cancel :: Event t () + , _in_headerLabel :: Text + , _in_amount :: Text + , _in_date :: Day + , _in_mkPayload :: Text -> Text -> a + , _in_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) } -data FormOut t = FormOut - { _formOut_hide :: Event t () - , _formOut_addIncome :: Event t Income +data Out t = Out + { _out_hide :: Event t () + , _out_addIncome :: Event t Income } -view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t) -view formIn = do +view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) +view input = do rec let reset = R.leftmost - [ "" <$ _modalFormOut_cancel modalForm - , "" <$ _modalFormOut_validate modalForm - , "" <$ _formIn_cancel formIn + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ _in_cancel input ] - modalForm <- Component.modalForm $ ModalFormIn - { _modalFormIn_headerLabel = _formIn_headerLabel formIn - , _modalFormIn_ajax = _formIn_ajax formIn "/api/income" - , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = _in_headerLabel input + , ModalForm._in_ajax = _in_ajax input "/api/income" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ FormOut - { _formOut_hide = _modalFormOut_hide modalForm - , _formOut_addIncome = _modalFormOut_validate modalForm + return $ Out + { _out_hide = ModalForm._out_hide modalForm + , _out_addIncome = ModalForm._out_validate modalForm } where @@ -61,24 +60,24 @@ view formIn = do -> Event t () -> m (Dynamic t (Validation Text a)) form reset confirm = do - amount <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Amount - , _inputIn_initialValue = _formIn_amount formIn - , _inputIn_validation = IncomeValidation.amount + amount <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Income_Amount + , Input._in_initialValue = _in_amount input + , Input._in_validation = IncomeValidation.amount }) - (_formIn_amount formIn <$ reset) + (_in_amount input <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn + let initialDate = T.pack . Calendar.showGregorian . _in_date $ input - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Income_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = IncomeValidation.date + date <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Income_Date + , Input._in_initialValue = initialDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = IncomeValidation.date }) (initialDate <$ reset) confirm) @@ -86,4 +85,4 @@ view formIn = do return $ do a <- amount d <- date - return . V.Success $ (_formIn_mkPayload formIn) a d + return . V.Success $ (_in_mkPayload input) a d diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 4e08955..ae1174a 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -1,7 +1,7 @@ module View.Income.Header ( view - , HeaderIn(..) - , HeaderOut(..) + , In(..) + , Out(..) ) where import Control.Monad.IO.Class (liftIO) @@ -16,25 +16,24 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonOut (..)) -import qualified Component +import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified Util.Date as DateUtil import qualified View.Income.Add as Add import View.Income.Init (Init (..)) -data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_currency :: Currency - , _headerIn_incomes :: Dynamic t [Income] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_incomes :: Dynamic t [Income] } -data HeaderOut t = HeaderOut - { _headerOut_addIncome :: Event t Income +data Out t = Out + { _out_addIncome :: Event t Income } -view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) -view headerIn = +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = R.divClass "withMargin" $ do currentTime <- liftIO Clock.getCurrentTime @@ -58,7 +57,7 @@ view headerIn = T.intercalate " " [ _user_name user , "−" - , Format.price (_headerIn_currency headerIn) $ + , Format.price (_in_currency input) $ CM.cumulativeIncomesSince currentTime since userIncomes ] @@ -67,23 +66,23 @@ view headerIn = R.text $ Msg.get Msg.Income_MonthlyNet - addIncome <- _buttonOut_clic <$> - (Component.button . Component.defaultButtonIn . R.text $ + addIncome <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ Msg.get Msg.Income_AddLong) - addIncome <- Modal.view $ Modal.Input - { Modal._input_show = addIncome - , Modal._input_content = Add.view + addIncome <- Modal.view $ Modal.In + { Modal._in_show = addIncome + , Modal._in_content = Add.view } - return $ HeaderOut - { _headerOut_addIncome = addIncome + return $ Out + { _out_addIncome = addIncome } where - init = _headerIn_init headerIn + init = _in_init input - useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes -> + useIncomesFrom = R.ffor (_in_incomes input) $ \incomes -> ( CM.useIncomesFrom (map _user_id $_init_users init) incomes diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 18ebe7c..f8359bb 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,7 +1,7 @@ module View.Income.Income ( init , view - , IncomeIn(..) + , In(..) ) where import Data.Aeson (FromJSON) @@ -14,15 +14,13 @@ import Common.Model (Currency) import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil -import View.Income.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Income.Header as Header import View.Income.Init (Init (..)) -import View.Income.Table (IncomeTableIn (..)) import qualified View.Income.Table as Table -data IncomeIn t = IncomeIn - { _incomeIn_currency :: Currency - , _incomeIn_init :: Dynamic t (Loadable Init) +data In t = In + { _in_currency :: Currency + , _in_init :: Dynamic t (Loadable Init) } init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) @@ -36,9 +34,9 @@ init = do ps <- payments return $ Init <$> us <*> is <*> ps -view :: forall t m. MonadWidget t m => IncomeIn t -> m () -view incomeIn = do - R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init -> +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> R.elClass "main" "income" $ do @@ -47,18 +45,18 @@ view incomeIn = do incomes <- R.foldDyn (:) (_init_incomes init) - (_headerOut_addIncome header) + (Header._out_addIncome header) - header <- Header.view $ HeaderIn - { _headerIn_init = init - , _headerIn_currency = _incomeIn_currency incomeIn - , _headerIn_incomes = incomes + header <- Header.view $ Header.In + { Header._in_init = init + , Header._in_currency = _in_currency input + , Header._in_incomes = incomes } - Table.view $ IncomeTableIn - { _tableIn_init = init - , _tableIn_currency = _incomeIn_currency incomeIn - , _tableIn_incomes = incomes + Table.view $ Table.In + { Table._in_init = init + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index d42848b..9cb705f 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -1,6 +1,6 @@ module View.Income.Table ( view - , IncomeTableIn(..) + , In(..) ) where import qualified Data.List as L @@ -14,25 +14,24 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (TableIn (..)) -import qualified Component +import qualified Component.Table as Table import View.Income.Init (Init (..)) -data IncomeTableIn t = IncomeTableIn - { _tableIn_init :: Init - , _tableIn_currency :: Currency - , _tableIn_incomes :: Dynamic t [Income] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => IncomeTableIn t -> m () -view tableIn = do +view :: forall t m. MonadWidget t m => In t -> m () +view input = do - Component.table $ TableIn - { _tableIn_headerLabel = headerLabel - , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date - , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn) - , _tableIn_perPage = 7 - , _tableIn_resetPage = R.never + Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date + , Table._in_cell = cell (_in_init input) (_in_currency input) + , Table._in_perPage = 7 + , Table._in_resetPage = R.never } return () diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs index 1d4e477..1597849 100644 --- a/client/src/View/NotFound.hs +++ b/client/src/View/NotFound.hs @@ -2,19 +2,19 @@ module View.NotFound ( view ) where -import qualified Data.Map as M -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Msg as Msg -import qualified Component as Component +import qualified Common.Msg as Msg +import qualified Component.Link as Link view :: forall t m. MonadWidget t m => m () view = R.divClass "notfound" $ do R.text (Msg.get Msg.NotFound_Message) - Component.link + Link.view "/" (R.constDyn $ M.singleton "class" "link") (Msg.get Msg.NotFound_LinkMessage) diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 163a200..e983465 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -1,6 +1,6 @@ module View.Payment.Add ( view - , Input(..) + , In(..) ) where import Control.Monad (join) @@ -21,32 +21,32 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form -data Input t = Input - { _input_categories :: [Category] - , _input_paymentCategories :: Dynamic t [PaymentCategory] - , _input_frequency :: Dynamic t Frequency +data In t = In + { _in_categories :: [Category] + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_frequency :: Dynamic t Frequency } -view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay formOutput <- R.dyn $ do - paymentCategories <- _input_paymentCategories input - frequency <- _input_frequency input - return $ Form.view $ Form.Input - { Form._input_cancel = cancel - , Form._input_headerLabel = Msg.get Msg.Payment_Add - , Form._input_categories = _input_categories input - , Form._input_paymentCategories = paymentCategories - , Form._input_name = "" - , Form._input_cost = "" - , Form._input_date = currentDay - , Form._input_category = -1 - , Form._input_frequency = frequency - , Form._input_mkPayload = CreatePaymentForm - , Form._input_ajax = Ajax.post + paymentCategories <- _in_paymentCategories input + frequency <- _in_frequency input + return $ Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Payment_Add + , Form._in_categories = _in_categories input + , Form._in_paymentCategories = paymentCategories + , Form._in_name = "" + , Form._in_cost = "" + , Form._in_date = currentDay + , Form._in_category = -1 + , Form._in_frequency = frequency + , Form._in_mkPayload = CreatePaymentForm + , Form._in_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 2fa27f3..56a33d9 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -1,5 +1,5 @@ module View.Payment.Clone - ( Input(..) + ( In(..) , view ) where @@ -21,35 +21,35 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form -data Input t = Input - { _input_show :: Event t () - , _input_categories :: [Category] - , _input_paymentCategories :: Dynamic t [PaymentCategory] - , _input_payment :: Dynamic t Payment - , _input_category :: Dynamic t CategoryId +data In t = In + { _in_show :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_payment :: Dynamic t Payment + , _in_category :: Dynamic t CategoryId } -view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay formOutput <- R.dyn $ do - paymentCategories <- _input_paymentCategories input - payment <- _input_payment input - category <- _input_category input - return . Form.view $ Form.Input - { Form._input_cancel = cancel - , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong - , Form._input_categories = _input_categories input - , Form._input_paymentCategories = paymentCategories - , Form._input_name = _payment_name payment - , Form._input_cost = T.pack . show . _payment_cost $ payment - , Form._input_date = currentDay - , Form._input_category = category - , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = CreatePaymentForm - , Form._input_ajax = Ajax.post + paymentCategories <- _in_paymentCategories input + payment <- _in_payment input + category <- _in_category input + return . Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong + , Form._in_categories = _in_categories input + , Form._in_paymentCategories = paymentCategories + , Form._in_name = _payment_name payment + , Form._in_cost = T.pack . show . _payment_cost $ payment + , Form._in_date = currentDay + , Form._in_category = category + , Form._in_frequency = _payment_frequency payment + , Form._in_mkPayload = CreatePaymentForm + , Form._in_ajax = Ajax.post } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index dc7e395..471463c 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -1,28 +1,27 @@ module View.Payment.Delete - ( Input(..) + ( In(..) , view ) where -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component -import qualified Component.Modal as Modal -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data Input t = Input - { _input_payment :: Dynamic t Payment +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Payment (..)) +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Modal as Modal +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data In t = In + { _in_payment :: Dynamic t Payment } -view :: forall t m. MonadWidget t m => (Input t) -> Modal.Content t m Payment +view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment view input _ = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm @@ -31,20 +30,20 @@ view input _ = (confirm, cancel) <- R.divClass "buttons" $ do - cancel <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo)) - { _buttonIn_class = R.constDyn "undo" }) + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) rec - confirm <- Component._buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { _buttonIn_class = R.constDyn "confirm" - , _buttonIn_submit = True - , _buttonIn_waiting = waiting + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_submit = True + , Button._in_waiting = waiting }) let url = - R.ffor (_input_payment input) (\id -> + R.ffor (_in_payment input) (\id -> T.concat ["/api/payment/", T.pack . show $ _payment_id id] ) @@ -56,5 +55,5 @@ view input _ = return $ ( R.leftmost [ cancel, () <$ confirm ] - , R.tag (R.current $ _input_payment input) confirm + , R.tag (R.current $ _in_payment input) confirm ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs index 77841ce..5cb4537 100644 --- a/client/src/View/Payment/Edit.hs +++ b/client/src/View/Payment/Edit.hs @@ -1,5 +1,5 @@ module View.Payment.Edit - ( Input(..) + ( In(..) , view ) where @@ -18,33 +18,33 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form -data Input t = Input - { _input_show :: Event t () - , _input_categories :: [Category] - , _input_paymentCategories :: Dynamic t [PaymentCategory] - , _input_payment :: Dynamic t Payment - , _input_category :: Dynamic t CategoryId +data In t = In + { _in_show :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_payment :: Dynamic t Payment + , _in_category :: Dynamic t CategoryId } -view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment view input cancel = do formOutput <- R.dyn $ do - paymentCategories <- _input_paymentCategories input - payment <- _input_payment input - category <- _input_category input - return . Form.view $ Form.Input - { Form._input_cancel = cancel - , Form._input_headerLabel = Msg.get Msg.Payment_EditLong - , Form._input_categories = _input_categories input - , Form._input_paymentCategories = paymentCategories - , Form._input_name = _payment_name payment - , Form._input_cost = T.pack . show . _payment_cost $ payment - , Form._input_date = _payment_date payment - , Form._input_category = category - , Form._input_frequency = _payment_frequency payment - , Form._input_mkPayload = EditPaymentForm (_payment_id payment) - , Form._input_ajax = Ajax.put + paymentCategories <- _in_paymentCategories input + payment <- _in_payment input + category <- _in_category input + return . Form.view $ Form.In + { Form._in_cancel = cancel + , Form._in_headerLabel = Msg.get Msg.Payment_EditLong + , Form._in_categories = _in_categories input + , Form._in_paymentCategories = paymentCategories + , Form._in_name = _payment_name payment + , Form._in_cost = T.pack . show . _payment_cost $ payment + , Form._in_date = _payment_date payment + , Form._in_category = category + , Form._in_frequency = _payment_frequency payment + , Form._in_mkPayload = EditPaymentForm (_payment_id payment) + , Form._in_ajax = Ajax.put } hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 1f068fd..29768aa 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,7 +1,7 @@ module View.Payment.Form ( view - , Input(..) - , Output(..) + , In(..) + , Out(..) ) where import Data.Aeson (ToJSON) @@ -25,49 +25,48 @@ import Common.Model (Category (..), CategoryId, SavedPayment (..)) import qualified Common.Msg as Msg import qualified Common.Validation.Payment as PaymentValidation -import Component (InputIn (..), InputOut (..), - ModalFormIn (..), ModalFormOut (..), - SelectIn (..), SelectOut (..)) -import qualified Component as Component +import qualified Component.Input as Input +import qualified Component.ModalForm as ModalForm +import qualified Component.Select as Select import qualified Util.Validation as ValidationUtil -data Input m t a = Input - { _input_cancel :: Event t () - , _input_headerLabel :: Text - , _input_categories :: [Category] - , _input_paymentCategories :: [PaymentCategory] - , _input_name :: Text - , _input_cost :: Text - , _input_date :: Day - , _input_category :: CategoryId - , _input_frequency :: Frequency - , _input_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a - , _input_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) +data In m t a = In + { _in_cancel :: Event t () + , _in_headerLabel :: Text + , _in_categories :: [Category] + , _in_paymentCategories :: [PaymentCategory] + , _in_name :: Text + , _in_cost :: Text + , _in_date :: Day + , _in_category :: CategoryId + , _in_frequency :: Frequency + , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a + , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) } -data Output t = Output +data Out t = Out { _output_hide :: Event t () , _output_addPayment :: Event t SavedPayment } -view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t) +view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) view input = do rec let reset = R.leftmost - [ "" <$ _modalFormOut_cancel modalForm - , "" <$ _modalFormOut_validate modalForm - , "" <$ _input_cancel input + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ _in_cancel input ] - modalForm <- Component.modalForm $ ModalFormIn - { _modalFormIn_headerLabel = _input_headerLabel input - , _modalFormIn_ajax = _input_ajax input "/api/payment" - , _modalFormIn_form = form reset (_modalFormOut_confirm modalForm) + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = _in_headerLabel input + , ModalForm._in_ajax = _in_ajax input "/api/payment" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Output - { _output_hide = _modalFormOut_hide modalForm - , _output_addPayment = _modalFormOut_validate modalForm + return $ Out + { _output_hide = ModalForm._out_hide modalForm + , _output_addPayment = ModalForm._out_validate modalForm } where @@ -76,63 +75,63 @@ view input = do -> Event t () -> m (Dynamic t (Validation (NonEmpty Text) a)) form reset confirm = do - name <- Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Name - , _inputIn_initialValue = _input_name input - , _inputIn_validation = PaymentValidation.name + name <- Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Name + , Input._in_initialValue = _in_name input + , Input._in_validation = PaymentValidation.name }) - (_input_name input <$ reset) + (_in_name input <$ reset) confirm - cost <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Cost - , _inputIn_initialValue = _input_cost input - , _inputIn_validation = PaymentValidation.cost + cost <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Cost + , Input._in_initialValue = _in_cost input + , Input._in_validation = PaymentValidation.cost }) - (_input_cost input <$ reset) + (_in_cost input <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _input_date $ input + let initialDate = T.pack . Calendar.showGregorian . _in_date $ input - date <- _inputOut_raw <$> (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.Payment_Date - , _inputIn_initialValue = initialDate - , _inputIn_inputType = "date" - , _inputIn_hasResetButton = False - , _inputIn_validation = PaymentValidation.date + date <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = initialDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date }) (initialDate <$ reset) confirm) let setCategory = R.fmapMaybe id . R.updated $ - R.ffor (_inputOut_raw name) $ \name -> - findCategory name (_input_paymentCategories input) - - category <- _selectOut_value <$> (Component.select $ SelectIn - { _selectIn_label = Msg.get Msg.Payment_Category - , _selectIn_initialValue = _input_category input - , _selectIn_value = setCategory - , _selectIn_values = R.constDyn categories - , _selectIn_reset = _input_category input <$ reset - , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input) - , _selectIn_validate = confirm + R.ffor (Input._out_raw name) $ \name -> + findCategory name (_in_paymentCategories input) + + category <- Select._out_value <$> (Select.view $ Select.In + { Select._in_label = Msg.get Msg.Payment_Category + , Select._in_initialValue = _in_category input + , Select._in_value = setCategory + , Select._in_values = R.constDyn categories + , Select._in_reset = _in_category input <$ reset + , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) + , Select._in_validate = confirm }) return $ do - n <- _inputOut_value name + n <- Input._out_value name c <- cost d <- date cat <- category - return ((_input_mkPayload input) + return ((_in_mkPayload input) <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success (_input_frequency input)) + <*> V.Success (_in_frequency input)) frequencies = M.fromList @@ -140,7 +139,7 @@ view input = do , (Monthly, Msg.get Msg.Payment_MonthlyMale) ] - categories = M.fromList . flip map (_input_categories input) $ \c -> + categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 9ad90a9..00987a3 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -1,7 +1,7 @@ module View.Payment.Header - ( widget - , HeaderIn(..) - , HeaderOut(..) + ( view + , In(..) + , Out(..) ) where import Control.Monad (forM_) @@ -27,31 +27,30 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..), - SelectIn (..), SelectOut (..)) -import qualified Component as Component +import qualified Component.Button as Button +import qualified Component.Input as Input import qualified Component.Modal as Modal +import qualified Component.Select as Select import qualified Util.List as L import qualified View.Payment.Add as Add import View.Payment.Init (Init (..)) -data HeaderIn t = HeaderIn - { _headerIn_init :: Init - , _headerIn_currency :: Currency - , _headerIn_payments :: Dynamic t [Payment] - , _headerIn_searchPayments :: Dynamic t [Payment] - , _headerIn_paymentCategories :: Dynamic t [PaymentCategory] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_payments :: Dynamic t [Payment] + , _in_searchPayments :: Dynamic t [Payment] + , _in_paymentCategories :: Dynamic t [PaymentCategory] } -data HeaderOut t = HeaderOut - { _headerOut_searchName :: Dynamic t Text - , _headerOut_searchFrequency :: Dynamic t Frequency - , _headerOut_addPayment :: Event t SavedPayment +data Out t = Out + { _out_searchName :: Dynamic t Text + , _out_searchFrequency :: Dynamic t Frequency + , _out_addPayment :: Event t SavedPayment } -widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) -widget headerIn = +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = R.divClass "header" $ do rec addPayment <- @@ -66,22 +65,22 @@ widget headerIn = let resetSearchName = fmap (const ()) $ addPayment (searchName, searchFrequency) <- searchLine resetSearchName - infos (_headerIn_searchPayments headerIn) users currency + infos (_in_searchPayments input) users currency - return $ HeaderOut - { _headerOut_searchName = searchName - , _headerOut_searchFrequency = searchFrequency - , _headerOut_addPayment = addPayment + return $ Out + { _out_searchName = searchName + , _out_searchFrequency = searchFrequency + , _out_addPayment = addPayment } where - init = _headerIn_init headerIn + init = _in_init input incomes = _init_incomes init initPayments = _init_payments init - payments = _headerIn_payments headerIn + payments = _in_payments input users = _init_users init categories = _init_categories init - currency = _headerIn_currency headerIn - paymentCategories = _headerIn_paymentCategories headerIn + currency = _in_currency input + paymentCategories = _in_paymentCategories input payerAndAdd :: forall t m. MonadWidget t m @@ -113,18 +112,18 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen R.dynText . R.ffor exceedingPayer $ \ep -> Format.price currency $ _exceedingPayer_amount ep - addPayment <- _buttonOut_clic <$> - (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add)) - { _buttonIn_class = R.constDyn "addPayment" + addPayment <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" }) - Modal.view $ Modal.Input - { Modal._input_show = addPayment - , Modal._input_content = Add.view $ Add.Input - { Add._input_categories = categories - , Add._input_paymentCategories = paymentCategories - , Add._input_frequency = frequency + Modal.view $ Modal.In + { Modal._in_show = addPayment + , Modal._in_content = Add.view $ Add.In + { Add._in_categories = categories + , Add._in_paymentCategories = paymentCategories + , Add._in_frequency = frequency } } @@ -134,8 +133,8 @@ searchLine -> m (Dynamic t Text, Dynamic t Frequency) searchLine reset = do R.divClass "searchLine" $ do - searchName <- _inputOut_raw <$> (Component.input - ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name }) + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) ("" <$ reset) R.never) @@ -144,15 +143,14 @@ searchLine reset = do , (Monthly, Msg.get Msg.Payment_MonthlyMale) ] - searchFrequency <- _selectOut_raw <$> (Component.select $ - SelectIn - { _selectIn_label = "" - , _selectIn_initialValue = Punctual - , _selectIn_value = R.never - , _selectIn_values = R.constDyn frequencies - , _selectIn_reset = R.never - , _selectIn_isValid = V.Success - , _selectIn_validate = R.never + searchFrequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never }) return (searchName, searchFrequency) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 5681935..9a1902c 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,41 +1,40 @@ module View.Payment.Pages - ( widget - , PagesIn(..) - , PagesOut(..) + ( view + , In(..) + , Out(..) ) where -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import qualified Component.Button as Button -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon -data PagesIn t = PagesIn - { _pagesIn_total :: Dynamic t Int - , _pagesIn_perPage :: Int - , _pagesIn_reset :: Event t () +data In t = In + { _in_total :: Dynamic t Int + , _in_perPage :: Int + , _in_reset :: Event t () } -data PagesOut t = PagesOut - { _pagesOut_currentPage :: Dynamic t Int +data Out t = Out + { _out_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) -widget pagesIn = do +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - return $ PagesOut - { _pagesOut_currentPage = currentPage + return $ Out + { _out_currentPage = currentPage } where - total = _pagesIn_total pagesIn - perPage = _pagesIn_perPage pagesIn - reset = _pagesIn_reset pagesIn + total = _in_total input + perPage = _in_perPage input + reset = _in_reset input pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) pageButtons total perPage reset = do @@ -75,14 +74,14 @@ range currentPage maxPage = [start..end] pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do - clic <- _buttonOut_clic <$> (Component.button $ ButtonIn - { _buttonIn_class = do + clic <- Button._out_clic <$> (Button.view $ Button.In + { Button._in_class = do cp <- currentPage p <- page if cp == Just p then "page current" else "page" - , _buttonIn_content = content - , _buttonIn_waiting = R.never - , _buttonIn_tabIndex = Nothing - , _buttonIn_submit = False + , Button._in_content = content + , Button._in_waiting = R.never + , Button._in_tabIndex = Nothing + , Button._in_submit = False }) return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 5f0d03c..f86acd8 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,7 +1,7 @@ module View.Payment.Payment ( init , view - , PaymentIn(..) + , In(..) ) where import Data.Text (Text) @@ -20,12 +20,9 @@ import qualified Common.Util.Text as T import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil -import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Init (Init (..)) -import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn (..), TableOut (..)) import qualified View.Payment.Table as Table init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) @@ -44,21 +41,21 @@ init = do return $ Init <$> us <*> ps <*> is <*> cs <*> pcs -data PaymentIn t = PaymentIn - { _paymentIn_currentUser :: UserId - , _paymentIn_currency :: Currency - , _paymentIn_init :: Dynamic t (Loadable Init) +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_init :: Dynamic t (Loadable Init) } -view :: forall t m. MonadWidget t m => PaymentIn t -> m () -view paymentIn = do - R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init -> +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> R.elClass "main" "payment" $ do rec let addPayment = R.leftmost - [ _headerOut_addPayment header - , _tableOut_addPayment table + [ Header._out_addPayment header + , Table._out_addPayment table ] paymentsPerPage = 7 @@ -66,46 +63,46 @@ view paymentIn = do payments <- reducePayments (_init_payments init) (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) + (_savedPayment_payment <$> Table._out_editPayment table) + (Table._out_deletePayment table) paymentCategories <- reducePaymentCategories (_init_paymentCategories init) payments (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> _tableOut_editPayment table) - (_tableOut_deletePayment table) + (_savedPayment_paymentCategory <$> Table._out_editPayment table) + (Table._out_deletePayment table) (searchNameEvent, searchName) <- - debounceSearchName (_headerOut_searchName header) + debounceSearchName (Header._out_searchName header) let searchPayments = - getSearchPayments searchName (_headerOut_searchFrequency header) payments - - header <- Header.widget $ HeaderIn - { _headerIn_init = init - , _headerIn_currency = _paymentIn_currency paymentIn - , _headerIn_payments = payments - , _headerIn_searchPayments = searchPayments - , _headerIn_paymentCategories = paymentCategories + getSearchPayments searchName (Header._out_searchFrequency header) payments + + header <- Header.view $ Header.In + { Header._in_init = init + , Header._in_currency = _in_currency input + , Header._in_payments = payments + , Header._in_searchPayments = searchPayments + , Header._in_paymentCategories = paymentCategories } - table <- Table.widget $ TableIn - { _tableIn_init = init - , _tableIn_currency = _paymentIn_currency paymentIn - , _tableIn_currentUser = _paymentIn_currentUser paymentIn - , _tableIn_currentPage = _pagesOut_currentPage pages - , _tableIn_payments = searchPayments - , _tableIn_perPage = paymentsPerPage - , _tableIn_paymentCategories = paymentCategories + table <- Table.view $ Table.In + { Table._in_init = init + , Table._in_currency = _in_currency input + , Table._in_currentUser = _in_currentUser input + , Table._in_currentPage = Pages._out_currentPage pages + , Table._in_payments = searchPayments + , Table._in_perPage = paymentsPerPage + , Table._in_paymentCategories = paymentCategories } - pages <- Pages.widget $ PagesIn - { _pagesIn_total = length <$> searchPayments - , _pagesIn_perPage = paymentsPerPage - , _pagesIn_reset = R.leftmost $ + pages <- Pages.view $ Pages.In + { Pages._in_total = length <$> searchPayments + , Pages._in_perPage = paymentsPerPage + , Pages._in_reset = R.leftmost $ [ () <$ searchNameEvent - , () <$ _headerOut_addPayment header + , () <$ Header._out_addPayment header ] } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 3a0a4bf..0793836 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,7 +1,7 @@ module View.Payment.Table - ( widget - , TableIn(..) - , TableOut(..) + ( view + , In(..) + , Out(..) ) where import qualified Data.List as L @@ -20,8 +20,7 @@ import Common.Model (Category (..), Currency, import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component +import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified View.Payment.Clone as Clone import qualified View.Payment.Delete as Delete @@ -31,25 +30,25 @@ import View.Payment.Init (Init (..)) import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data TableIn t = TableIn - { _tableIn_init :: Init - , _tableIn_currency :: Currency - , _tableIn_currentUser :: UserId - , _tableIn_currentPage :: Dynamic t Int - , _tableIn_payments :: Dynamic t [Payment] - , _tableIn_perPage :: Int - , _tableIn_paymentCategories :: Dynamic t [PaymentCategory] - , _tableIn_categories :: [Category] +data In t = In + { _in_init :: Init + , _in_currency :: Currency + , _in_currentUser :: UserId + , _in_currentPage :: Dynamic t Int + , _in_payments :: Dynamic t [Payment] + , _in_perPage :: Int + , _in_paymentCategories :: Dynamic t [PaymentCategory] + , _in_categories :: [Category] } -data TableOut t = TableOut - { _tableOut_addPayment :: Event t SavedPayment - , _tableOut_editPayment :: Event t SavedPayment - , _tableOut_deletePayment :: Event t Payment +data Out t = Out + { _out_addPayment :: Event t SavedPayment + , _out_editPayment :: Event t SavedPayment + , _out_deletePayment :: Event t Payment } -widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t) -widget tableIn = do +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do R.divClass "table" $ do (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do @@ -75,20 +74,20 @@ widget tableIn = do ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ R.text $ Msg.get Msg.Payment_Empty - return $ TableOut - { _tableOut_addPayment = addPayment - , _tableOut_editPayment = editPayment - , _tableOut_deletePayment = deletePayment + return $ Out + { _out_addPayment = addPayment + , _out_editPayment = editPayment + , _out_deletePayment = deletePayment } where - init = _tableIn_init tableIn - currency = _tableIn_currency tableIn - currentUser = _tableIn_currentUser tableIn - currentPage = _tableIn_currentPage tableIn - payments = _tableIn_payments tableIn - paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage - paymentCategories = _tableIn_paymentCategories tableIn + init = _in_init input + currency = _in_currency input + currentUser = _in_currentUser input + currentPage = _in_currentPage input + payments = _in_payments input + paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage + paymentCategories = _in_paymentCategories input getPaymentRange :: Int -> [Payment] -> Int -> [Payment] getPaymentRange perPage payments currentPage = @@ -150,19 +149,19 @@ paymentRow init currency currentUser paymentCategories payment = clonePayment <- R.divClass "cell button" $ - _buttonOut_clic <$> (Component.button $ - Component.defaultButtonIn Icon.clone) + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.clone) paymentCloned <- - Modal.view $ Modal.Input - { Modal._input_show = clonePayment - , Modal._input_content = - Clone.view $ Clone.Input - { Clone._input_show = clonePayment - , Clone._input_categories = _init_categories init - , Clone._input_paymentCategories = paymentCategories - , Clone._input_payment = payment - , Clone._input_category = categoryId + Modal.view $ Modal.In + { Modal._in_show = clonePayment + , Modal._in_content = + Clone.view $ Clone.In + { Clone._in_show = clonePayment + , Clone._in_categories = _init_categories init + , Clone._in_paymentCategories = paymentCategories + , Clone._in_payment = payment + , Clone._in_category = categoryId } } @@ -174,36 +173,36 @@ paymentRow init currency currentUser paymentCategories payment = editPayment <- R.divClass "cell button" $ ReflexUtil.divVisibleIf isFromCurrentUser $ - _buttonOut_clic <$> (Component.button $ - Component.defaultButtonIn Icon.edit) + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.edit) paymentEdited <- - Modal.view $ Modal.Input - { Modal._input_show = editPayment - , Modal._input_content = - Edit.view $ Edit.Input - { Edit._input_show = editPayment - , Edit._input_categories = _init_categories init - , Edit._input_paymentCategories = paymentCategories - , Edit._input_payment = payment - , Edit._input_category = categoryId + Modal.view $ Modal.In + { Modal._in_show = editPayment + , Modal._in_content = + Edit.view $ Edit.In + { Edit._in_show = editPayment + , Edit._in_categories = _init_categories init + , Edit._in_paymentCategories = paymentCategories + , Edit._in_payment = payment + , Edit._in_category = categoryId } } deletePayment <- R.divClass "cell button" $ ReflexUtil.divVisibleIf isFromCurrentUser $ - _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn Icon.delete) - { _buttonIn_class = R.constDyn "deletePayment" + Button._out_clic <$> (Button.view $ + (Button.defaultIn Icon.delete) + { Button._in_class = R.constDyn "deletePayment" }) paymentDeleted <- - Modal.view $ Modal.Input - { Modal._input_show = deletePayment - , Modal._input_content = - Delete.view $ Delete.Input - { Delete._input_payment = payment + Modal.view $ Modal.In + { Modal._in_show = deletePayment + , Modal._in_content = + Delete.view $ Delete.In + { Delete._in_payment = payment } } diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 4fe495b..a589fc3 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -15,9 +15,9 @@ import Common.Model (SignInForm (SignInForm)) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation -import Component (ButtonIn (..), ButtonOut (..), - InputIn (..), InputOut (..)) -import qualified Component as Component +import qualified Component.Button as Button +import qualified Component.Form as Form +import qualified Component.Input as Input import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor @@ -30,24 +30,24 @@ data SignInMessage = view :: forall t m. MonadWidget t m => SignInMessage -> m () view signInMessage = R.divClass "signIn" $ - Component.form $ do + Form.view $ do rec - input <- (Component.input - (Component.defaultInputIn - { _inputIn_label = Msg.get Msg.SignIn_EmailLabel - , _inputIn_validation = SignInValidation.email + input <- (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_EmailLabel + , Input._in_validation = SignInValidation.email }) ("" <$ R.ffilter Either.isRight signInResult) validate) - validate <- _buttonOut_clic <$> (Component.button $ - (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button)) - { _buttonIn_class = R.constDyn "validate" - , _buttonIn_waiting = waiting - , _buttonIn_submit = True + validate <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.SignIn_Button)) + { Button._in_class = R.constDyn "validate" + , Button._in_waiting = waiting + , Button._in_submit = True }) - let form = SignInForm <$> _inputOut_raw input + let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor (Ajax.post "/api/askSignIn") -- cgit v1.2.3 From 61ff1443c42def5a09f624e3df2e2520e97610d0 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 22 Oct 2019 23:25:05 +0200 Subject: Clone incomes --- ISSUES.md | 9 ++++-- client/src/Component/Table.hs | 54 ++++++++++++++++++++++++--------- client/src/View/Income/Add.hs | 20 ++++++++---- client/src/View/Income/Header.hs | 2 +- client/src/View/Income/Income.hs | 17 ++++++----- client/src/View/Income/Table.hs | 32 +++++++++++++------ client/src/View/Payment/Clone.hs | 6 ++-- server/src/Design/View/Payment/Table.hs | 5 --- server/src/Design/View/Table.hs | 3 ++ 9 files changed, 99 insertions(+), 49 deletions(-) diff --git a/ISSUES.md b/ISSUES.md index 95b435a..db60794 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,9 +1,12 @@ ## Income view -- Clone an income - Edit an income - Remove an income +## Payment + +- Use income table factorizations + ## Category view - Show the category table @@ -12,9 +15,9 @@ - Edit a category - Remove a category -## Mobile +## Slow -- Slow, consider native ? consider doing more work on the server ? +- Implement server side paging # Additional features diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index bf76566..5819f45 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,56 +4,82 @@ module Component.Table , Out(..) ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Component.Pages as Pages +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import qualified Util.Reflex as ReflexUtil +import qualified View.Icon as Icon -data In h r t = In +data In m t h r a = In { _in_headerLabel :: h -> Text , _in_rows :: Dynamic t [r] , _in_cell :: h -> r -> Text , _in_perPage :: Int , _in_resetPage :: Event t () + , _in_cloneModal :: Dynamic t r -> Modal.Content t m a } -data Out = Out - {} +data Out t a = Out + { _out_add :: Event t a + } -view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In h r t -> m (Out) +view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) view input = R.divClass "table" $ do rec - R.divClass "lines" $ do + result <- R.divClass "lines" $ do - R.divClass "header" $ + R.divClass "header" $ do flip mapM_ [minBound..] $ \header -> R.divClass "cell" . R.text $ _in_headerLabel input header + R.divClass "cell" $ R.blank + let rows = getRange (_in_perPage input) <$> (Pages._out_currentPage pages) <*> (_in_rows input) R.simpleList rows $ \r -> - R.divClass "row" $ + R.divClass "row" $ do flip mapM_ [minBound..] $ \h -> - R.divClass "cell name" $ + R.divClass "cell" $ R.dynText $ R.ffor r (_in_cell input h) + clone <- + R.divClass "cell button" $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.clone) + + cloned <- + Modal.view $ Modal.In + { Modal._in_show = clone + , Modal._in_content = _in_cloneModal input r + } + + return cloned + pages <- Pages.view $ Pages.In { Pages._in_total = length <$> (_in_rows input) , Pages._in_perPage = _in_perPage input , Pages._in_reset = _in_resetPage input } - return () + -- return $ + -- ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result + -- , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result + -- , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result + -- ) return $ Out - {} + { _out_add = R.switch . R.current . fmap R.leftmost $ result + } getRange :: forall a. Int -> Int -> [a] -> [a] getRange perPage currentPage = diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index f8f107f..d07bd45 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -1,13 +1,16 @@ module View.Income.Add ( view + , In(..) ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T import qualified Data.Time.Clock as Time -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (CreateIncomeForm (..), Income) +import Common.Model (CreateIncomeForm (..), Income (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Component.Modal as Modal @@ -15,16 +18,21 @@ import qualified Util.Ajax as Ajax import qualified Util.Reflex as ReflexUtil import qualified View.Income.Form as Form -view :: forall t m. MonadWidget t m => Modal.Content t m Income -view cancel = do +data In t = In + { _in_income :: Dynamic t (Maybe Income) + } + +view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income +view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - form <- R.dyn $ + form <- R.dyn $ do + income <- _in_income input return $ Form.view $ Form.In { Form._in_cancel = cancel , Form._in_headerLabel = Msg.get Msg.Income_AddLong - , Form._in_amount = "" + , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income) , Form._in_date = currentDay , Form._in_mkPayload = CreateIncomeForm , Form._in_ajax = Ajax.post diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index ae1174a..0360d1f 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -72,7 +72,7 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Add.view + , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing } } return $ Out diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index f8359bb..b97613d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -41,11 +41,14 @@ view input = do R.elClass "main" "income" $ do rec - + let addIncome = R.leftmost + [ Header._out_addIncome header + , Table._out_addIncome table + ] incomes <- R.foldDyn (:) (_init_incomes init) - (Header._out_addIncome header) + addIncome header <- Header.view $ Header.In { Header._in_init = init @@ -53,11 +56,11 @@ view input = do , Header._in_incomes = incomes } - Table.view $ Table.In - { Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_incomes = incomes - } + table <- Table.view $ Table.In + { Table._in_init = init + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes + } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 9cb705f..358cb17 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -1,12 +1,13 @@ module View.Income.Table ( view , In(..) + , Out(..) ) where import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, Income (..), User (..)) @@ -15,6 +16,7 @@ import qualified Common.Msg as Msg import qualified Common.View.Format as Format import qualified Component.Table as Table +import qualified View.Income.Add as Add import View.Income.Init (Init (..)) data In t = In @@ -23,18 +25,28 @@ data In t = In , _in_incomes :: Dynamic t [Income] } -view :: forall t m. MonadWidget t m => In t -> m () +data Out t = Out + { _out_addIncome :: Event t Income + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - Table.view $ Table.In - { Table._in_headerLabel = headerLabel - , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date - , Table._in_cell = cell (_in_init input) (_in_currency input) - , Table._in_perPage = 7 - , Table._in_resetPage = R.never - } + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date + , Table._in_cell = cell (_in_init input) (_in_currency input) + , Table._in_perPage = 7 + , Table._in_resetPage = R.never + , Table._in_cloneModal = \income -> + Add.view $ Add.In + { Add._in_income = Just <$> income + } + } - return () + return $ Out + { _out_addIncome = Table._out_add table + } data Header = UserHeader diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs index 56a33d9..82b0c27 100644 --- a/client/src/View/Payment/Clone.hs +++ b/client/src/View/Payment/Clone.hs @@ -34,7 +34,7 @@ view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - formOutput <- R.dyn $ do + form <- R.dyn $ do paymentCategories <- _in_paymentCategories input payment <- _in_payment input category <- _in_category input @@ -52,8 +52,8 @@ view input cancel = do , Form._in_ajax = Ajax.post } - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) + hide <- ReflexUtil.flatten (Form._output_hide <$> form) + clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form) return $ ( hide diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs index 26dc9ed..67828c9 100644 --- a/server/src/Design/View/Payment/Table.hs +++ b/server/src/Design/View/Payment/Table.hs @@ -4,7 +4,6 @@ module Design.View.Payment.Table import Clay -import qualified Design.Color as Color import qualified Design.Media as Media design :: Css @@ -34,7 +33,3 @@ design = do ".shortDate" ? display none ".longDate" ? display inline marginBottom (em 0.5) - - ".button" & svg ? do - "path" ? ("fill" -: Color.toString Color.chestnutRose) - width (px 18) diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index cd406fc..1c4e806 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -72,6 +72,9 @@ design = do textAlign (alignSide sideCenter) button ? do padding (px 10) (px 10) (px 10) (px 10) + svg ? do + "path" ? ("fill" -: Color.toString Color.chestnutRose) + width (px 18) hover & "svg path" ? do "fill" -: "rgb(237, 122, 116)" -- cgit v1.2.3 From f968c8ce63e1aec119b1e6f414cf27e2c0294bcb Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 21:09:54 +0200 Subject: Delete income --- ISSUES.md | 9 ++++-- client/client.cabal | 1 + client/src/Component/ConfirmDialog.hs | 49 ++++++++++++++++++++++++++++++ client/src/Component/Table.hs | 42 ++++++++++++++++++------- client/src/Util/Reflex.hs | 8 +++++ client/src/View/App.hs | 3 +- client/src/View/Income/Add.hs | 22 ++++++-------- client/src/View/Income/Header.hs | 6 ++-- client/src/View/Income/Income.hs | 33 ++++++++++++++------ client/src/View/Income/Table.hs | 54 ++++++++++++++++++++++----------- client/src/View/Payment/Delete.hs | 1 - server/server.cabal | 1 + server/src/Design/View/ConfirmDialog.hs | 36 ++++++++++++++++++++++ server/src/Design/Views.hs | 24 ++++++++------- 14 files changed, 221 insertions(+), 68 deletions(-) create mode 100644 client/src/Component/ConfirmDialog.hs create mode 100644 server/src/Design/View/ConfirmDialog.hs diff --git a/ISSUES.md b/ISSUES.md index db60794..0249eab 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,7 +1,8 @@ +# MVP + ## Income view - Edit an income -- Remove an income ## Payment @@ -15,10 +16,14 @@ - Edit a category - Remove a category -## Slow +## Low speed - Implement server side paging +## Bugs + +- Fix page flickering on loading + # Additional features - Remove unused payment category after payment edit on frontend diff --git a/client/client.cabal b/client/client.cabal index c78ed87..6163ab0 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -46,6 +46,7 @@ Executable client other-modules: Component.Button + Component.ConfirmDialog Component.Form Component.Input Component.Link diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs new file mode 100644 index 0000000..50e30ed --- /dev/null +++ b/client/src/Component/ConfirmDialog.hs @@ -0,0 +1,49 @@ +module Component.ConfirmDialog + ( In(..) + , view + ) where + +import Data.Text (Text) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R + +import qualified Common.Msg as Msg +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Util.Either as EitherUtil +import qualified Util.WaitFor as WaitFor + +data In t m a = In + { _in_header :: Text + , _in_confirm :: Event t () -> m (Event t a) + } + +view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a +view input _ = + R.divClass "confirm" $ do + R.divClass "confirmHeader" $ + R.text $ _in_header input + + R.divClass "confirmContent" $ do + (confirm, cancel) <- R.divClass "buttons" $ do + + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) + + rec + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_submit = True + , Button._in_waiting = waiting + }) + + (result, waiting) <- WaitFor.waitFor (_in_confirm input) confirm + + return (result, cancel) + + return $ + ( R.leftmost [ cancel, () <$ confirm ] + , confirm + ) diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 5819f45..b3c70a0 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -20,11 +20,14 @@ data In m t h r a = In , _in_cell :: h -> r -> Text , _in_perPage :: Int , _in_resetPage :: Event t () - , _in_cloneModal :: Dynamic t r -> Modal.Content t m a + , _in_cloneModal :: r -> Modal.Content t m a + , _in_deleteModal :: r -> Modal.Content t m a + , _in_isOwner :: r -> Bool } data Out t a = Out - { _out_add :: Event t a + { _out_add :: Event t a + , _out_delete :: Event t a } view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) @@ -39,6 +42,7 @@ view input = _in_headerLabel input header R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank let rows = getRange (_in_perPage input) @@ -60,25 +64,41 @@ view input = cloned <- Modal.view $ Modal.In { Modal._in_show = clone - , Modal._in_content = _in_cloneModal input r + , Modal._in_content = \curtainClick -> + (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick) + >>= ReflexUtil.flattenTuple + } + + let isOwner = R.ffor r (_in_isOwner input) + + delete <- + R.divClass "cell button" $ + ReflexUtil.divVisibleIf isOwner $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.delete) + + deleted <- + Modal.view $ Modal.In + { Modal._in_show = delete + , Modal._in_content = \curtainClick -> + (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick) + >>= ReflexUtil.flattenTuple } - return cloned + return (cloned, deleted) pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> (_in_rows input) + { Pages._in_total = length <$> _in_rows input , Pages._in_perPage = _in_perPage input , Pages._in_reset = _in_resetPage input } - -- return $ - -- ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - -- , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result - -- , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result - -- ) + let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result + delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result return $ Out - { _out_add = R.switch . R.current . fmap R.leftmost $ result + { _out_add = add + , _out_delete = delete } getRange :: forall a. Int -> Int -> [a] -> [a] diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs index c14feeb..9f51c5c 100644 --- a/client/src/Util/Reflex.hs +++ b/client/src/Util/Reflex.hs @@ -4,6 +4,7 @@ module Util.Reflex , divVisibleIf , divClassVisibleIf , flatten + , flattenTuple , getBody ) where @@ -44,6 +45,13 @@ flatten e = do dyn <- R.holdDyn R.never e return $ R.switchDyn dyn + +flattenTuple + :: forall t m a b. MonadWidget t m + => Event t (Event t a, Event t b) + -> m (Event t a, Event t b) +flattenTuple e = (,) <$> (flatten $ fmap fst e) <*> (flatten $ fmap snd e) + getBody :: forall t m. MonadWidget t m => m Element getBody = do document <- Dom.currentDocumentUnchecked diff --git a/client/src/View/App.hs b/client/src/View/App.hs index e0a52e2..1e26417 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -69,7 +69,8 @@ signedWidget init route = do IncomeRoute -> do incomeInit <- Income.init Income.view $ Income.In - { Income._in_currency = _init_currency init + { Income._in_currentUser = _init_currentUser init + , Income._in_currency = _init_currency init , Income._in_init = incomeInit } diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs index d07bd45..7780d73 100644 --- a/client/src/View/Income/Add.hs +++ b/client/src/View/Income/Add.hs @@ -7,19 +7,18 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) import Common.Model (CreateIncomeForm (..), Income (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil +import qualified Component.Form import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil import qualified View.Income.Form as Form data In t = In - { _in_income :: Dynamic t (Maybe Income) + { _in_income :: Maybe Income } view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income @@ -27,18 +26,17 @@ view input cancel = do currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - form <- R.dyn $ do - income <- _in_income input - return $ Form.view $ Form.In + let amount = + Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input)) + + form <- + Component.Form.view $ Form.view $ Form.In { Form._in_cancel = cancel , Form._in_headerLabel = Msg.get Msg.Income_AddLong - , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income) + , Form._in_amount = amount , Form._in_date = currentDay , Form._in_mkPayload = CreateIncomeForm , Form._in_ajax = Ajax.post } - hide <- ReflexUtil.flatten (Form._out_hide <$> form) - addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form) - - return (hide, addIncome) + return (Form._out_hide form, Form._out_addIncome form) diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 0360d1f..f17e774 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -29,7 +29,7 @@ data In t = In } data Out t = Out - { _out_addIncome :: Event t Income + { _out_add :: Event t Income } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -72,11 +72,11 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing } + , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing } } return $ Out - { _out_addIncome = addIncome + { _out_add = addIncome } where diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index b97613d..2784cac 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -6,10 +6,10 @@ module View.Income.Income import Data.Aeson (FromJSON) import Prelude hiding (init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency) +import Common.Model (Currency, Income (..), UserId) import Loadable (Loadable (..)) import qualified Loadable @@ -19,8 +19,9 @@ import View.Income.Init (Init (..)) import qualified View.Income.Table as Table data In t = In - { _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_init :: Dynamic t (Loadable Init) } init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) @@ -42,13 +43,14 @@ view input = do rec let addIncome = R.leftmost - [ Header._out_addIncome header - , Table._out_addIncome table + [ Header._out_add header + , Table._out_add table ] - incomes <- R.foldDyn - (:) + + incomes <- reduceIncomes (_init_incomes init) addIncome + (Table._out_delete table) header <- Header.view $ Header.In { Header._in_init = init @@ -57,7 +59,8 @@ view input = do } table <- Table.view $ Table.In - { Table._in_init = init + { Table._in_currentUser = _in_currentUser input + , Table._in_init = init , Table._in_currency = _in_currency input , Table._in_incomes = incomes } @@ -65,3 +68,15 @@ view input = do return () return () + +reduceIncomes + :: forall t m. MonadWidget t m + => [Income] + -> Event t Income -- add income + -> Event t Income -- delete income + -> m (Dynamic t [Income]) +reduceIncomes initIncomes add delete = + R.foldDyn id initIncomes $ R.leftmost + [ (:) <$> add + , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id)) + ] diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 358cb17..16ebf7c 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -4,29 +4,36 @@ module View.Income.Table , Out(..) ) where -import qualified Data.List as L -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format +import Common.Model (Currency, Income (..), User (..), + UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format -import qualified Component.Table as Table -import qualified View.Income.Add as Add -import View.Income.Init (Init (..)) +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Income.Add as Add +import View.Income.Init (Init (..)) data In t = In - { _in_init :: Init - , _in_currency :: Currency - , _in_incomes :: Dynamic t [Income] + { _in_currentUser :: UserId + , _in_init :: Init + , _in_currency :: Currency + , _in_incomes :: Dynamic t [Income] } data Out t = Out - { _out_addIncome :: Event t Income + { _out_add :: Event t Income + , _out_delete :: Event t Income } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -40,12 +47,23 @@ view input = do , Table._in_resetPage = R.never , Table._in_cloneModal = \income -> Add.view $ Add.In - { Add._in_income = Just <$> income + { Add._in_income = Just income } + , Table._in_deleteModal = \income -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Income_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) + e + return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId } return $ Out - { _out_addIncome = Table._out_add table + { _out_add = Table._out_add table + , _out_delete = Table._out_delete table } data Header diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index 471463c..e5e7219 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -12,7 +12,6 @@ import Common.Model (Payment (..)) import qualified Common.Msg as Msg import qualified Component.Button as Button import qualified Component.Modal as Modal -import qualified Component.Modal as Modal import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor diff --git a/server/server.cabal b/server/server.cabal index f1105ff..c7b4f2b 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -74,6 +74,7 @@ Executable server Design.Media Design.Modal Design.Tooltip + Design.View.ConfirmDialog Design.View.Header Design.View.NotFound Design.View.Pages diff --git a/server/src/Design/View/ConfirmDialog.hs b/server/src/Design/View/ConfirmDialog.hs new file mode 100644 index 0000000..410d4d8 --- /dev/null +++ b/server/src/Design/View/ConfirmDialog.hs @@ -0,0 +1,36 @@ +module Design.View.ConfirmDialog + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".confirm" ? do + ".confirmHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".confirmContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten + + (".confirm" <> ".undo") ? + width (px 90) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 73b7240..5c9e307 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -4,17 +4,18 @@ module Design.Views import Clay -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media -import qualified Design.View.Header as Header -import qualified Design.View.NotFound as NotFound -import qualified Design.View.Pages as Pages -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media +import qualified Design.View.ConfirmDialog as ConfirmDialog +import qualified Design.View.Header as Header +import qualified Design.View.NotFound as NotFound +import qualified Design.View.Pages as Pages +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table design :: Css design = do @@ -25,6 +26,7 @@ design = do ".notfound" ? NotFound.design Table.design Pages.design + ConfirmDialog.design ".withMargin" ? do "margin" -: "0 2vw" -- cgit v1.2.3 From e4b32ce15f8c92f3b477d3f3d4d301ba08f9b5e3 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:35:27 +0200 Subject: Edit an income --- ISSUES.md | 4 +- client/client.cabal | 2 +- client/src/Component/ModalForm.hs | 50 +++++++++++----------- client/src/Component/Table.hs | 25 +++++++++-- client/src/View/Income/Add.hs | 42 ------------------ client/src/View/Income/Form.hs | 89 +++++++++++++++++++++++++++------------ client/src/View/Income/Header.hs | 7 +-- client/src/View/Income/Income.hs | 9 ++-- client/src/View/Income/Table.hs | 17 +++++--- server/src/Controller/Income.hs | 21 +++++---- server/src/Persistence/Income.hs | 31 ++++++++------ 11 files changed, 166 insertions(+), 131 deletions(-) delete mode 100644 client/src/View/Income/Add.hs diff --git a/ISSUES.md b/ISSUES.md index 0249eab..928dc7f 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -2,7 +2,7 @@ ## Income view -- Edit an income +- Go to page 1 after adding an income ## Payment @@ -23,6 +23,7 @@ ## Bugs - Fix page flickering on loading +- After modal close, it is still on the DOM, preventing any click # Additional features @@ -40,6 +41,7 @@ # Code +- Do something with ModalForm and ConfirmDialog - remove client warning messages - Use BEM style - Move the CSS out from the index page diff --git a/client/client.cabal b/client/client.cabal index 6163ab0..9a212e8 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -51,6 +51,7 @@ Executable client Component.Input Component.Link Component.Modal + Component.ModalForm Component.Pages Component.Select Component.Table @@ -68,7 +69,6 @@ Executable client View.App View.Header View.Icon - View.Income.Add View.Income.Form View.Income.Header View.Income.Income diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index ea53beb..f5bf287 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -15,6 +15,7 @@ import qualified Reflex.Dom as R import qualified Common.Msg as Msg import qualified Component.Button as Button +import qualified Component.Form as Form import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor @@ -38,32 +39,33 @@ view input = R.divClass "formHeader" $ R.text (_in_headerLabel input) - R.divClass "formContent" $ do - rec - form <- _in_form input + Form.view $ + R.divClass "formContent" $ do + rec + form <- _in_form input - (validate, cancel, confirm) <- R.divClass "buttons" $ do - rec - cancel <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) - { Button._in_class = R.constDyn "undo" }) + (validate, cancel, confirm) <- R.divClass "buttons" $ do + rec + cancel <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) + { Button._in_class = R.constDyn "undo" }) - confirm <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { Button._in_class = R.constDyn "confirm" - , Button._in_waiting = waiting - , Button._in_submit = True - }) + confirm <- Button._out_clic <$> (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) + { Button._in_class = R.constDyn "confirm" + , Button._in_waiting = waiting + , Button._in_submit = True + }) - (validate, waiting) <- WaitFor.waitFor - (_in_ajax input) - (ValidationUtil.fireValidation form confirm) + (validate, waiting) <- WaitFor.waitFor + (_in_ajax input) + (ValidationUtil.fireValidation form confirm) - return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) + return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm) - return Out - { _out_hide = R.leftmost [ cancel, () <$ validate ] - , _out_cancel = cancel - , _out_confirm = confirm - , _out_validate = validate - } + return Out + { _out_hide = R.leftmost [ cancel, () <$ validate ] + , _out_cancel = cancel + , _out_confirm = confirm + , _out_validate = validate + } diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index b3c70a0..a02eaa7 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -21,12 +21,14 @@ data In m t h r a = In , _in_perPage :: Int , _in_resetPage :: Event t () , _in_cloneModal :: r -> Modal.Content t m a + , _in_editModal :: r -> Modal.Content t m a , _in_deleteModal :: r -> Modal.Content t m a , _in_isOwner :: r -> Bool } data Out t a = Out { _out_add :: Event t a + , _out_edit :: Event t a , _out_delete :: Event t a } @@ -43,6 +45,7 @@ view input = R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank + R.divClass "cell" $ R.blank let rows = getRange (_in_perPage input) @@ -71,6 +74,20 @@ view input = let isOwner = R.ffor r (_in_isOwner input) + edit <- + R.divClass "cell button" $ + ReflexUtil.divVisibleIf isOwner $ + Button._out_clic <$> (Button.view $ + Button.defaultIn Icon.edit) + + edited <- + Modal.view $ Modal.In + { Modal._in_show = edit + , Modal._in_content = \curtainClick -> + (R.dyn . R.ffor r $ \r2 -> _in_editModal input r2 curtainClick) + >>= ReflexUtil.flattenTuple + } + delete <- R.divClass "cell button" $ ReflexUtil.divVisibleIf isOwner $ @@ -85,7 +102,7 @@ view input = >>= ReflexUtil.flattenTuple } - return (cloned, deleted) + return (cloned, edited, deleted) pages <- Pages.view $ Pages.In { Pages._in_total = length <$> _in_rows input @@ -93,11 +110,13 @@ view input = , Pages._in_reset = _in_resetPage input } - let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result - delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result + let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result + edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result + delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result return $ Out { _out_add = add + , _out_edit = edit , _out_delete = delete } diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs deleted file mode 100644 index 7780d73..0000000 --- a/client/src/View/Income/Add.hs +++ /dev/null @@ -1,42 +0,0 @@ -module View.Income.Add - ( view - , In(..) - ) where - -import Control.Monad.IO.Class (liftIO) -import qualified Data.Maybe as Maybe -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (MonadWidget) - -import Common.Model (CreateIncomeForm (..), Income (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Form -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified View.Income.Form as Form - -data In t = In - { _in_income :: Maybe Income - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - let amount = - Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input)) - - form <- - Component.Form.view $ Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Income_AddLong - , Form._in_amount = amount - , Form._in_date = currentDay - , Form._in_mkPayload = CreateIncomeForm - , Form._in_ajax = Ajax.post - } - - return (Form._out_hide form, Form._out_addIncome form) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 917edf1..5f354a2 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -1,60 +1,59 @@ module View.Income.Form ( view , In(..) - , Out(..) + , Operation(..) ) where -import Data.Aeson (FromJSON, ToJSON) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (ToJSON) +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time import Data.Validation (Validation) import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Income) +import Common.Model (EditIncomeForm (..), Income (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Income as IncomeValidation import qualified Component.Input as Input +import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax -data In m t a = In - { _in_cancel :: Event t () - , _in_headerLabel :: Text - , _in_amount :: Text - , _in_date :: Day - , _in_mkPayload :: Text -> Text -> a - , _in_ajax :: Text -> Event t a -> m (Event t (Either Text Income)) +data In t a = In + { _in_operation :: Operation a } -data Out t = Out - { _out_hide :: Event t () - , _out_addIncome :: Event t Income - } +data Operation a + = New (Text -> Text -> a) + | Clone (Text -> Text -> a) Income + | Edit (Text -> Text -> a) Income + +view :: forall t m a. (MonadWidget t m, ToJSON a) => In t a -> Modal.Content t m Income +view input cancel = do -view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) -view input = do rec let reset = R.leftmost [ "" <$ ModalForm._out_cancel modalForm , "" <$ ModalForm._out_validate modalForm - , "" <$ _in_cancel input + , "" <$ cancel ] modalForm <- ModalForm.view $ ModalForm.In - { ModalForm._in_headerLabel = _in_headerLabel input - , ModalForm._in_ajax = _in_ajax input "/api/income" + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/income" , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Out - { _out_hide = ModalForm._out_hide modalForm - , _out_addIncome = ModalForm._out_validate modalForm - } + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) where + form :: Event t String -> Event t () @@ -63,13 +62,15 @@ view input = do amount <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Income_Amount - , Input._in_initialValue = _in_amount input + , Input._in_initialValue = amount , Input._in_validation = IncomeValidation.amount }) - (_in_amount input <$ reset) + (amount <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _in_date $ input + currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay + + let initialDate = T.pack . Calendar.showGregorian $ date currentDay date <- Input._out_raw <$> (Input.view (Input.defaultIn @@ -85,4 +86,36 @@ view input = do return $ do a <- amount d <- date - return . V.Success $ (_in_mkPayload input) a d + return . V.Success $ mkPayload a d + + op = _in_operation input + + amount = + case op of + New _ -> "" + Clone _ income -> T.pack . show . _income_amount $ income + Edit _ income -> T.pack . show . _income_amount $ income + + date currentDay = + case op of + New _ -> currentDay + Clone _ _ -> currentDay + Edit _ income -> _income_date income + + ajax = + case op of + New _ -> Ajax.post + Clone _ _ -> Ajax.post + Edit _ _ -> Ajax.put + + headerLabel = + case op of + New _ -> Msg.get Msg.Income_AddLong + Clone _ _ -> Msg.get Msg.Income_AddLong + Edit _ _ -> Msg.get Msg.Income_Edit + + mkPayload = + case op of + New f -> f + Clone f _ -> f + Edit f _ -> f diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index f17e774..182db33 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -11,7 +11,8 @@ import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..)) +import Common.Model (CreateIncomeForm (..), Currency, + Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -19,7 +20,7 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified Util.Date as DateUtil -import qualified View.Income.Add as Add +import qualified View.Income.Form as Form import View.Income.Init (Init (..)) data In t = In @@ -72,7 +73,7 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing } + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New CreateIncomeForm } } return $ Out diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 2784cac..90f1fde 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -50,6 +50,7 @@ view input = do incomes <- reduceIncomes (_init_incomes init) addIncome + (Table._out_edit table) (Table._out_delete table) header <- Header.view $ Header.In @@ -72,11 +73,13 @@ view input = do reduceIncomes :: forall t m. MonadWidget t m => [Income] - -> Event t Income -- add income - -> Event t Income -- delete income + -> Event t Income -- add + -> Event t Income -- edit + -> Event t Income -- delete -> m (Dynamic t [Income]) -reduceIncomes initIncomes add delete = +reduceIncomes initIncomes add edit delete = R.foldDyn id initIncomes $ R.leftmost [ (:) <$> add + , R.ffor edit (\p -> (p:) . filter ((/= (_income_id p)) . _income_id)) , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id)) ] diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 16ebf7c..f865fd9 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -11,8 +11,9 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..), - UserId) +import Common.Model (CreateIncomeForm (..), Currency, + EditIncomeForm (..), Income (..), + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -21,7 +22,7 @@ import qualified Component.ConfirmDialog as ConfirmDialog import qualified Component.Table as Table import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil -import qualified View.Income.Add as Add +import qualified View.Income.Form as Form import View.Income.Init (Init (..)) data In t = In @@ -33,6 +34,7 @@ data In t = In data Out t = Out { _out_add :: Event t Income + , _out_edit :: Event t Income , _out_delete :: Event t Income } @@ -46,8 +48,12 @@ view input = do , Table._in_perPage = 7 , Table._in_resetPage = R.never , Table._in_cloneModal = \income -> - Add.view $ Add.In - { Add._in_income = Just income + Form.view $ Form.In + { Form._in_operation = Form.Clone CreateIncomeForm income + } + , Table._in_editModal = \income -> + Form.view $ Form.In + { Form._in_operation = Form.Edit (EditIncomeForm $ _income_id income) income } , Table._in_deleteModal = \income -> ConfirmDialog.view $ ConfirmDialog.In @@ -63,6 +69,7 @@ view input = do return $ Out { _out_add = Table._out_add table + , _out_edit = Table._out_edit table , _out_delete = Table._out_delete table } diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index b40976b..236e032 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -11,11 +11,12 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncome (..), IncomeId, + EditIncomeForm (..), IncomeId, User (..)) import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence import qualified Secure @@ -40,13 +41,17 @@ create form = ) >>= ControllerHelper.jsonOrBadRequest ) -edit :: EditIncome -> ActionM () -edit (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount - if updated - then status Status.ok200 - else status Status.badRequest400 +edit :: EditIncomeForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.editIncome form of + Success (EditIncome incomeId amount date) -> do + Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) delete :: IncomeId -> ActionM () diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index a0c3bbf..2b9bf0c 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -56,25 +56,30 @@ create userId date amount = } ) -edit :: UserId -> IncomeId -> Day -> Int -> Query Bool -edit incomeUserId incomeId incomeDate incomeAmount = +edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) +edit userId incomeId incomeDate incomeAmount = Query (\conn -> do mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False + do + currentTime <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" + (currentTime, incomeDate, incomeAmount, incomeId, userId) + return . Just $ Income + { _income_id = incomeId + , _income_userId = userId + , _income_date = incomeDate + , _income_amount = incomeAmount + , _income_createdAt = _income_createdAt income + , _income_editedAt = Just currentTime + , _income_deletedAt = Nothing + } Nothing -> - return False + return Nothing ) delete :: UserId -> PaymentId -> Query () -- cgit v1.2.3 From c53198a7dd46f1575a33f823c29fa02126429e8f Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:41:51 +0200 Subject: Go to initial page after adding an income --- client/src/View/Income/Income.hs | 1 + client/src/View/Income/Table.hs | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 90f1fde..2f0b8f5 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -64,6 +64,7 @@ view input = do , Table._in_init = init , Table._in_currency = _in_currency input , Table._in_incomes = incomes + , Table._in_resetPage = () <$ addIncome } return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index f865fd9..c754a77 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -30,6 +30,7 @@ data In t = In , _in_init :: Init , _in_currency :: Currency , _in_incomes :: Dynamic t [Income] + , _in_resetPage :: Event t () } data Out t = Out @@ -46,7 +47,7 @@ view input = do , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date , Table._in_cell = cell (_in_init input) (_in_currency input) , Table._in_perPage = 7 - , Table._in_resetPage = R.never + , Table._in_resetPage = _in_resetPage input , Table._in_cloneModal = \income -> Form.view $ Form.In { Form._in_operation = Form.Clone CreateIncomeForm income -- cgit v1.2.3 From 62f990c92b51aeca44d50c154cb4a18e2da3637c Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:45:02 +0200 Subject: Disable appear animation on main block --- ISSUES.md | 19 ++++++++++--------- server/src/Design/Global.hs | 4 ++-- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/ISSUES.md b/ISSUES.md index 928dc7f..da9103f 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,9 +1,5 @@ # MVP -## Income view - -- Go to page 1 after adding an income - ## Payment - Use income table factorizations @@ -22,10 +18,15 @@ ## Bugs -- Fix page flickering on loading - After modal close, it is still on the DOM, preventing any click -# Additional features +# Next + +## Bugs + +- Fix page flickering on loading + +## Additional features - Remove unused payment category after payment edit on frontend - Auto focus on first input when payment modal is open @@ -39,7 +40,7 @@ - Show statistics. - Pages: 1 … 3 4 5 … 10 -# Code +## Code - Do something with ModalForm and ConfirmDialog - remove client warning messages @@ -48,11 +49,11 @@ - Test exceedingPayers - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) -# DB +## DB - Add DB indexes -# Tooling +## Tooling - deploy command - migration diff (use flyway?). diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 598319b..f9884bd 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -56,8 +56,8 @@ global = do height (pct 100) flexDirection column - "main" ? - appearAnimation + -- "main" ? + -- appearAnimation ".pageSpinner" ? do display flex -- cgit v1.2.3 From 8ef4d96644bce59bbb736af6359e644743e5610a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 27 Oct 2019 17:02:43 +0100 Subject: Refactor income form component concerning payload creation --- client/src/View/Income/Form.hs | 48 +++++++++++++++++++--------------------- client/src/View/Income/Header.hs | 5 ++--- client/src/View/Income/Table.hs | 9 ++++---- 3 files changed, 29 insertions(+), 33 deletions(-) diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index 5f354a2..a4f7de8 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -5,7 +5,8 @@ module View.Income.Form ) where import Control.Monad.IO.Class (liftIO) -import Data.Aeson (ToJSON) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -16,7 +17,8 @@ import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (EditIncomeForm (..), Income (..)) +import Common.Model (CreateIncomeForm (..), + EditIncomeForm (..), Income (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Income as IncomeValidation @@ -25,16 +27,16 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Util.Ajax as Ajax -data In t a = In - { _in_operation :: Operation a +data In t = In + { _in_operation :: Operation } -data Operation a - = New (Text -> Text -> a) - | Clone (Text -> Text -> a) Income - | Edit (Text -> Text -> a) Income +data Operation + = New + | Clone Income + | Edit Income -view :: forall t m a. (MonadWidget t m, ToJSON a) => In t a -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income view input cancel = do rec @@ -57,7 +59,7 @@ view input cancel = do form :: Event t String -> Event t () - -> m (Dynamic t (Validation Text a)) + -> m (Dynamic t (Validation Text Value)) form reset confirm = do amount <- Input._out_raw <$> (Input.view (Input.defaultIn @@ -92,30 +94,26 @@ view input cancel = do amount = case op of - New _ -> "" - Clone _ income -> T.pack . show . _income_amount $ income - Edit _ income -> T.pack . show . _income_amount $ income + New -> "" + Clone income -> T.pack . show . _income_amount $ income + Edit income -> T.pack . show . _income_amount $ income date currentDay = case op of - New _ -> currentDay - Clone _ _ -> currentDay - Edit _ income -> _income_date income + Edit income -> _income_date income + _ -> currentDay ajax = case op of - New _ -> Ajax.post - Clone _ _ -> Ajax.post - Edit _ _ -> Ajax.put + Edit _ -> Ajax.put + _ -> Ajax.post headerLabel = case op of - New _ -> Msg.get Msg.Income_AddLong - Clone _ _ -> Msg.get Msg.Income_AddLong - Edit _ _ -> Msg.get Msg.Income_Edit + Edit _ -> Msg.get Msg.Income_Edit + _ -> Msg.get Msg.Income_AddLong mkPayload = case op of - New f -> f - Clone f _ -> f - Edit f _ -> f + Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b + _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 182db33..8e82525 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -11,8 +11,7 @@ import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (CreateIncomeForm (..), Currency, - Income (..), User (..)) +import Common.Model (Currency, Income (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -73,7 +72,7 @@ view input = addIncome <- Modal.view $ Modal.In { Modal._in_show = addIncome - , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New CreateIncomeForm } + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } } return $ Out diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c754a77..d089d9f 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -11,9 +11,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (CreateIncomeForm (..), Currency, - EditIncomeForm (..), Income (..), - User (..), UserId) +import Common.Model (Currency, Income (..), User (..), + UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -50,11 +49,11 @@ view input = do , Table._in_resetPage = _in_resetPage input , Table._in_cloneModal = \income -> Form.view $ Form.In - { Form._in_operation = Form.Clone CreateIncomeForm income + { Form._in_operation = Form.Clone income } , Table._in_editModal = \income -> Form.view $ Form.In - { Form._in_operation = Form.Edit (EditIncomeForm $ _income_id income) income + { Form._in_operation = Form.Edit income } , Table._in_deleteModal = \income -> ConfirmDialog.view $ ConfirmDialog.In -- cgit v1.2.3 From b97ad942495352c3fc1e0c820cfba82a9693ac7a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 27 Oct 2019 20:26:29 +0100 Subject: WIP Set up server side paging for incomes --- ISSUES.md | 10 +-- client/client.cabal | 1 + client/src/Component/Pages.hs | 37 ++++++----- client/src/Component/Table.hs | 20 +----- client/src/Loadable.hs | 9 +++ client/src/View/Income/Income.hs | 101 ++++++++++++++--------------- client/src/View/Income/Reducer.hs | 66 +++++++++++++++++++ client/src/View/Income/Table.hs | 13 ++-- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/IncomesAndCount.hs | 16 +++++ server/src/Controller/Income.hs | 13 +++- server/src/Main.hs | 5 ++ server/src/Persistence/Income.hs | 26 +++++++- 14 files changed, 218 insertions(+), 101 deletions(-) create mode 100644 client/src/View/Income/Reducer.hs create mode 100644 common/src/Common/Model/IncomesAndCount.hs diff --git a/ISSUES.md b/ISSUES.md index da9103f..4cfc960 100644 --- a/ISSUES.md +++ b/ISSUES.md @@ -1,8 +1,13 @@ # MVP +## Income + +- Implement server side paging + ## Payment - Use income table factorizations +- Implement server side paging ## Category view @@ -12,10 +17,6 @@ - Edit a category - Remove a category -## Low speed - -- Implement server side paging - ## Bugs - After modal close, it is still on the DOM, preventing any click @@ -48,6 +49,7 @@ - Move the CSS out from the index page - Test exceedingPayers - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) +- ajax query parameters ## DB diff --git a/client/client.cabal b/client/client.cabal index 9a212e8..8648d57 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -72,6 +72,7 @@ Executable client View.Income.Form View.Income.Header View.Income.Income + View.Income.Reducer View.Income.Table View.NotFound View.Payment.Add diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index 7284a36..a297222 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -16,38 +16,43 @@ import qualified View.Icon as Icon data In t = In { _in_total :: Dynamic t Int , _in_perPage :: Int - , _in_reset :: Event t () } data Out t = Out - { _out_currentPage :: Dynamic t Int + { _out_newPage :: Event t Int + , _out_currentPage :: Dynamic t Int } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset + (newPage, currentPage) <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage return $ Out - { _out_currentPage = currentPage + { _out_newPage = newPage + , _out_currentPage = currentPage } where total = _in_total input perPage = _in_perPage input - reset = _in_reset input -pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) -pageButtons total perPage reset = do +pageButtons + :: forall t m. MonadWidget t m + => Dynamic t Int + -> Int + -> m (Event t Int, Dynamic t Int) +pageButtons total perPage = do R.divClass "pages" $ do rec - currentPage <- R.holdDyn 1 . R.leftmost $ - [ firstPageClic - , previousPageClic - , pageClic - , nextPageClic - , lastPageClic - , 1 <$ reset - ] + let newPage = R.leftmost + [ firstPageClic + , previousPageClic + , pageClic + , nextPageClic + , lastPageClic + ] + + currentPage <- R.holdDyn 1 newPage firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -60,7 +65,7 @@ pageButtons total perPage reset = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return currentPage + return (newPage, currentPage) where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) pageEvent = R.switch . R.current . fmap R.leftmost diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index a02eaa7..7103abd 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -10,7 +10,6 @@ import qualified Reflex.Dom as R import qualified Component.Button as Button import qualified Component.Modal as Modal -import qualified Component.Pages as Pages import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon @@ -18,8 +17,6 @@ data In m t h r a = In { _in_headerLabel :: h -> Text , _in_rows :: Dynamic t [r] , _in_cell :: h -> r -> Text - , _in_perPage :: Int - , _in_resetPage :: Event t () , _in_cloneModal :: r -> Modal.Content t m a , _in_editModal :: r -> Modal.Content t m a , _in_deleteModal :: r -> Modal.Content t m a @@ -47,12 +44,7 @@ view input = R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - let rows = getRange - (_in_perPage input) - <$> (Pages._out_currentPage pages) - <*> (_in_rows input) - - R.simpleList rows $ \r -> + R.simpleList (_in_rows input) $ \r -> R.divClass "row" $ do flip mapM_ [minBound..] $ \h -> R.divClass "cell" $ @@ -104,12 +96,6 @@ view input = return (cloned, edited, deleted) - pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> _in_rows input - , Pages._in_perPage = _in_perPage input - , Pages._in_reset = _in_resetPage input - } - let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result @@ -119,7 +105,3 @@ view input = , _out_edit = edit , _out_delete = delete } - -getRange :: forall a. Int -> Int -> [a] -> [a] -getRange perPage currentPage = - take perPage . drop ((currentPage - 1) * perPage) diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 8714a4d..a5c1d41 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -49,3 +49,12 @@ view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank view _ (Error e) = R.text e view f (Loaded x) = f x + +-- view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +-- view _ (Loading) = do +-- R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank +-- return Nothing +-- view _ (Error e) = do +-- R.text e +-- return Nothing +-- view f (Loaded x) = Just <$> (f x) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index 2f0b8f5..c48f325 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -4,19 +4,23 @@ module View.Income.Income , In(..) ) where -import Data.Aeson (FromJSON) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Aeson (FromJSON) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), UserId) +import Common.Model (Currency, Income (..), + IncomesAndCount (..), UserId) -import Loadable (Loadable (..)) +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified View.Income.Header as Header -import View.Income.Init (Init (..)) -import qualified View.Income.Table as Table +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +-- import qualified View.Income.Header as Header +import View.Income.Init (Init (..)) +import qualified View.Income.Reducer as Reducer +import qualified View.Income.Table as Table data In t = In { _in_currentUser :: UserId @@ -37,50 +41,45 @@ init = do view :: forall t m. MonadWidget t m => In t -> m () view input = do - R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> + -- rec + -- incomes <- Reducer.reducer + -- { Reducer._in_newPage = ReflexUtil.flatten (Table._out_newPage <$> table) + -- , Reducer._in_currentPage = ReflexUtil.flatten (Table._out_currentPage <$> table) + -- , Reducer._in_addIncome = ReflexUtil.flatten (Table._out_add <$> table) + -- , Reducer._in_editIncome = ReflexUtil.flatten (Table._out_edit <$> table) + -- , Reducer._in_deleteIncome = ReflexUtil.flatten (Table._out_delete <$> table) + -- } - R.elClass "main" "income" $ do + rec + incomes <- Reducer.reducer $ Reducer.In + { Reducer._in_newPage = Pages._out_newPage pages + , Reducer._in_currentPage = Pages._out_currentPage pages + , Reducer._in_addIncome = Table._out_add table + , Reducer._in_editIncome = Table._out_edit table + , Reducer._in_deleteIncome = Table._out_delete table + } - rec - let addIncome = R.leftmost - [ Header._out_add header - , Table._out_add table - ] + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_incomes = R.ffor incomes $ \case + Loaded (IncomesAndCount xs _) -> xs + _ -> [] + } - incomes <- reduceIncomes - (_init_incomes init) - addIncome - (Table._out_edit table) - (Table._out_delete table) + pages <- Pages.view $ Pages.In + { Pages._in_total = R.ffor incomes $ \case + Loaded (IncomesAndCount _ n) -> n + _ -> 0 + , Pages._in_perPage = Reducer.perPage + } - header <- Header.view $ Header.In - { Header._in_init = init - , Header._in_currency = _in_currency input - , Header._in_incomes = incomes - } - - table <- Table.view $ Table.In - { Table._in_currentUser = _in_currentUser input - , Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_incomes = incomes - , Table._in_resetPage = () <$ addIncome - } - - return () + -- -- table :: Event t (Maybe (Table.Out t)) + -- table <- R.dyn . R.ffor incomes . Loadable.view $ \incomes -> + -- Table.view $ Table.In + -- { Table._in_currentUser = _in_currentUser input + -- , Table._in_currency = _in_currency input + -- , Table._in_incomes = incomes + -- } return () - -reduceIncomes - :: forall t m. MonadWidget t m - => [Income] - -> Event t Income -- add - -> Event t Income -- edit - -> Event t Income -- delete - -> m (Dynamic t [Income]) -reduceIncomes initIncomes add edit delete = - R.foldDyn id initIncomes $ R.leftmost - [ (:) <$> add - , R.ffor edit (\p -> (p:) . filter ((/= (_income_id p)) . _income_id)) - , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id)) - ] diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs new file mode 100644 index 0000000..5b346cb --- /dev/null +++ b/client/src/View/Income/Reducer.hs @@ -0,0 +1,66 @@ +module View.Income.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (IncomesAndCount) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_newPage :: Event t Int + , _in_currentPage :: Dynamic t Int + , _in_addIncome :: Event t a + , _in_editIncome :: Event t b + , _in_deleteIncome :: Event t c + } + +data Action + = LoadPage Int + | GetResult (Either Text IncomesAndCount) + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomesAndCount)) +reducer input = do + + postBuild <- R.getPostBuild + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_newPage input + , 1 <$ _in_addIncome input + , R.tag (R.current $ _in_currentPage input) (_in_editIncome input) + , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.foldDyn + (\action _ -> case action of + LoadPage _ -> Loading + GetResult (Left err) -> Error err + GetResult (Right incomes) -> Loaded incomes + ) + Loading + (R.leftmost + [ LoadPage <$> loadPage + , GetResult <$> getResult + ]) + + where + pageUrl p = + "api/v2/incomes?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index d089d9f..6d69c19 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -22,14 +22,11 @@ import qualified Component.Table as Table import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified View.Income.Form as Form -import View.Income.Init (Init (..)) data In t = In { _in_currentUser :: UserId - , _in_init :: Init , _in_currency :: Currency , _in_incomes :: Dynamic t [Income] - , _in_resetPage :: Event t () } data Out t = Out @@ -44,9 +41,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date - , Table._in_cell = cell (_in_init input) (_in_currency input) - , Table._in_perPage = 7 - , Table._in_resetPage = _in_resetPage input + , Table._in_cell = cell [] (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In { Form._in_operation = Form.Clone income @@ -84,11 +79,11 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: Init -> Currency -> Header -> Income -> Text -cell init currency header income = +cell :: [User] -> Currency -> Header -> Income -> Text +cell users currency header income = case header of UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init) + Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users DateHeader -> Format.longDay . _income_date $ income diff --git a/common/common.cabal b/common/common.cabal index 1a441c5..9f3f65b 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -60,6 +60,7 @@ Library Common.Model.EditPaymentForm Common.Model.Frequency Common.Model.Income + Common.Model.IncomesAndCount Common.Model.Init Common.Model.InitResult Common.Model.Payer diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index c9f500b..3a5a627 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -12,6 +12,7 @@ import Common.Model.EditPaymentForm as X import Common.Model.Email as X import Common.Model.Frequency as X import Common.Model.Income as X +import Common.Model.IncomesAndCount as X import Common.Model.Init as X import Common.Model.InitResult as X import Common.Model.Payer as X diff --git a/common/src/Common/Model/IncomesAndCount.hs b/common/src/Common/Model/IncomesAndCount.hs new file mode 100644 index 0000000..4365180 --- /dev/null +++ b/common/src/Common/Model/IncomesAndCount.hs @@ -0,0 +1,16 @@ +module Common.Model.IncomesAndCount + ( IncomesAndCount(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Income (Income) + +data IncomesAndCount = IncomesAndCount + { _incomesAndCount_incomes :: [Income] + , _incomesAndCount_count :: Int + } deriving (Show, Generic) + +instance FromJSON IncomesAndCount +instance ToJSON IncomesAndCount diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 236e032..3272cbf 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income ( list + , listv2 , create , edit , delete @@ -12,7 +13,7 @@ import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeId, - User (..)) + IncomesAndCount (..), User (..)) import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -28,6 +29,16 @@ list = (liftIO . Query.run $ IncomePersistence.list) >>= json ) +listv2 :: Int -> Int -> ActionM () +listv2 page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- IncomePersistence.count + incomes <- IncomePersistence.listv2 page perPage + return $ IncomesAndCount incomes count + ) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Main.hs b/server/src/Main.hs index 9882092..00e8d1c 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -54,6 +54,11 @@ main = do paymentId <- S.param "id" Payment.delete paymentId + S.get "/api/v2/incomes" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Income.listv2 page perPage + S.get "/api/incomes" $ Income.list diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 2b9bf0c..de55a18 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,5 +1,7 @@ module Persistence.Income - ( list + ( count + , list + , listv2 , create , edit , delete @@ -29,6 +31,18 @@ instance FromRow Row where SQLite.field <*> SQLite.field) +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" + ) + list :: Query [Income] list = Query (\conn -> @@ -36,6 +50,16 @@ list = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) +listv2 :: Int -> Int -> Query [Income] +listv2 page perPage = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do -- cgit v1.2.3 From 227dcd4435b775d7dbc5ae5d3d81b589897253cc Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 2 Nov 2019 20:52:27 +0100 Subject: Implement incomes server side paging --- .stylish-haskell.yaml | 1 + ISSUES.md | 64 --------------------------------------- README.md | 4 --- client/src/Component/Pages.hs | 22 +++++--------- client/src/Component/Table.hs | 62 +++++++++++++++++++------------------- client/src/Loadable.hs | 17 +++-------- client/src/Util/Reflex.hs | 1 - client/src/View/Income/Income.hs | 65 +++++++++++++++++++--------------------- client/src/View/Income/Table.hs | 4 +-- 9 files changed, 77 insertions(+), 163 deletions(-) delete mode 100644 ISSUES.md diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 034ace0..82305b9 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -31,3 +31,4 @@ language_extensions: - MultiParamTypeClasses - OverloadedStrings - RecursiveDo + - ScopedTypeVariables diff --git a/ISSUES.md b/ISSUES.md deleted file mode 100644 index 4cfc960..0000000 --- a/ISSUES.md +++ /dev/null @@ -1,64 +0,0 @@ -# MVP - -## Income - -- Implement server side paging - -## Payment - -- Use income table factorizations -- Implement server side paging - -## Category view - -- Show the category table -- Add a category -- Clone a category -- Edit a category -- Remove a category - -## Bugs - -- After modal close, it is still on the DOM, preventing any click - -# Next - -## Bugs - -- Fix page flickering on loading - -## Additional features - -- Remove unused payment category after payment edit on frontend -- Auto focus on first input when payment modal is open -- Add icon tooltip -- HTTP error message -- Use only one loader -- Login with email and password -- Search payments by: - - category, - - date. -- Show statistics. -- Pages: 1 … 3 4 5 … 10 - -## Code - -- Do something with ModalForm and ConfirmDialog -- remove client warning messages -- Use BEM style -- Move the CSS out from the index page -- Test exceedingPayers -- try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) -- ajax query parameters - -## DB - -- Add DB indexes - -## Tooling - -- deploy command -- migration diff (use flyway?). -- use ghcid -- set up fast deploy -- pin nixpkgs diff --git a/README.md b/README.md index 7f8d8f3..c83a18b 100644 --- a/README.md +++ b/README.md @@ -55,7 +55,3 @@ See [application.conf](application.conf). - [reflex](https://hackage.haskell.org/package/reflex-0.6.2.4/docs/doc-index-All.html) - [reflex-dom](https://hackage.haskell.org/package/reflex-dom-core-0.5/docs/doc-index-All.html) - -## Issues - -See [ISSUES.md](ISSUES.md). diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs index a297222..d54cd3d 100644 --- a/client/src/Component/Pages.hs +++ b/client/src/Component/Pages.hs @@ -16,32 +16,26 @@ import qualified View.Icon as Icon data In t = In { _in_total :: Dynamic t Int , _in_perPage :: Int + , _in_page :: Int } data Out t = Out { _out_newPage :: Event t Int - , _out_currentPage :: Dynamic t Int } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - (newPage, currentPage) <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage + newPage <- ReflexUtil.divVisibleIf ((> 0) <$> (_in_total input)) $ pageButtons input return $ Out { _out_newPage = newPage - , _out_currentPage = currentPage } - where - total = _in_total input - perPage = _in_perPage input - pageButtons :: forall t m. MonadWidget t m - => Dynamic t Int - -> Int - -> m (Event t Int, Dynamic t Int) -pageButtons total perPage = do + => In t + -> m (Event t Int) +pageButtons input = do R.divClass "pages" $ do rec let newPage = R.leftmost @@ -52,7 +46,7 @@ pageButtons total perPage = do , lastPageClic ] - currentPage <- R.holdDyn 1 newPage + currentPage <- R.holdDyn (_in_page input) newPage firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar @@ -65,9 +59,9 @@ pageButtons total perPage = do lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - return (newPage, currentPage) + return newPage - where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) + where maxPage = R.ffor (_in_total input) (\t -> ceiling $ toRational t / toRational (_in_perPage input)) pageEvent = R.switch . R.current . fmap R.leftmost noCurrentPage = R.constDyn Nothing diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 7103abd..3b9ec24 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,8 +4,9 @@ module Component.Table , Out(..) ) where +import qualified Data.Map as M import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget) +import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R import qualified Component.Button as Button @@ -15,7 +16,7 @@ import qualified View.Icon as Icon data In m t h r a = In { _in_headerLabel :: h -> Text - , _in_rows :: Dynamic t [r] + , _in_rows :: [r] , _in_cell :: h -> r -> Text , _in_cloneModal :: r -> Modal.Content t m a , _in_editModal :: r -> Modal.Content t m a @@ -44,61 +45,60 @@ view input = R.divClass "cell" $ R.blank R.divClass "cell" $ R.blank - R.simpleList (_in_rows input) $ \r -> + flip mapM (_in_rows input) $ \row -> R.divClass "row" $ do - flip mapM_ [minBound..] $ \h -> + flip mapM_ [minBound..] $ \header -> R.divClass "cell" $ - R.dynText $ - R.ffor r (_in_cell input h) + R.text $ + _in_cell input header row - clone <- + cloneButton <- R.divClass "cell button" $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.clone) - cloned <- + clone <- Modal.view $ Modal.In - { Modal._in_show = clone - , Modal._in_content = \curtainClick -> - (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick) - >>= ReflexUtil.flattenTuple + { Modal._in_show = cloneButton + , Modal._in_content = _in_cloneModal input row } - let isOwner = R.ffor r (_in_isOwner input) + let isOwner = _in_isOwner input row - edit <- + let visibleIf cond = + R.elAttr + "div" + (if cond then M.empty else M.singleton "style" "display:none") + + editButton <- R.divClass "cell button" $ - ReflexUtil.divVisibleIf isOwner $ + visibleIf isOwner $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.edit) - edited <- + edit <- Modal.view $ Modal.In - { Modal._in_show = edit - , Modal._in_content = \curtainClick -> - (R.dyn . R.ffor r $ \r2 -> _in_editModal input r2 curtainClick) - >>= ReflexUtil.flattenTuple + { Modal._in_show = editButton + , Modal._in_content = _in_editModal input row } - delete <- + deleteButton <- R.divClass "cell button" $ - ReflexUtil.divVisibleIf isOwner $ + visibleIf isOwner $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.delete) - deleted <- + delete <- Modal.view $ Modal.In - { Modal._in_show = delete - , Modal._in_content = \curtainClick -> - (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick) - >>= ReflexUtil.flattenTuple + { Modal._in_show = deleteButton + , Modal._in_content = _in_deleteModal input row } - return (cloned, edited, deleted) + return (clone, edit, delete) - let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result - delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result + let add = R.leftmost . map (\(a, _, _) -> a) $ result + edit = R.leftmost . map (\(_, a, _) -> a) $ result + delete = R.leftmost . map (\(_, _, a) -> a) $ result return $ Out { _out_add = add diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index a5c1d41..f57b99c 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -45,16 +45,7 @@ fromEvent = ) Loading -view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m () -view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank -view _ (Error e) = R.text e -view f (Loaded x) = f x - --- view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) --- view _ (Loading) = do --- R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank --- return Nothing --- view _ (Error e) = do --- R.text e --- return Nothing --- view f (Loaded x) = Just <$> (f x) +view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing +view _ (Error e) = R.text e >> return Nothing +view f (Loaded x) = Just <$> f x diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs index 9f51c5c..aa5cebb 100644 --- a/client/src/Util/Reflex.hs +++ b/client/src/Util/Reflex.hs @@ -45,7 +45,6 @@ flatten e = do dyn <- R.holdDyn R.never e return $ R.switchDyn dyn - flattenTuple :: forall t m a b. MonadWidget t m => Event t (Event t a, Event t b) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index c48f325..fedf3d8 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE ExplicitForAll #-} + module View.Income.Income ( init , view , In(..) ) where +import qualified Data.Text as T import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe import Prelude hiding (init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R @@ -41,45 +45,38 @@ init = do view :: forall t m. MonadWidget t m => In t -> m () view input = do - -- rec - -- incomes <- Reducer.reducer - -- { Reducer._in_newPage = ReflexUtil.flatten (Table._out_newPage <$> table) - -- , Reducer._in_currentPage = ReflexUtil.flatten (Table._out_currentPage <$> table) - -- , Reducer._in_addIncome = ReflexUtil.flatten (Table._out_add <$> table) - -- , Reducer._in_editIncome = ReflexUtil.flatten (Table._out_edit <$> table) - -- , Reducer._in_deleteIncome = ReflexUtil.flatten (Table._out_delete <$> table) - -- } - rec incomes <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = Pages._out_newPage pages - , Reducer._in_currentPage = Pages._out_currentPage pages - , Reducer._in_addIncome = Table._out_add table - , Reducer._in_editIncome = Table._out_edit table - , Reducer._in_deleteIncome = Table._out_delete table + { Reducer._in_newPage = newPage + , Reducer._in_currentPage = currentPage + , Reducer._in_addIncome = addIncome + , Reducer._in_editIncome = editIncome + , Reducer._in_deleteIncome = deleteIncome } - table <- Table.view $ Table.In - { Table._in_currentUser = _in_currentUser input - , Table._in_currency = _in_currency input - , Table._in_incomes = R.ffor incomes $ \case - Loaded (IncomesAndCount xs _) -> xs - _ -> [] - } + let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - pages <- Pages.view $ Pages.In - { Pages._in_total = R.ffor incomes $ \case - Loaded (IncomesAndCount _ n) -> n - _ -> 0 - , Pages._in_perPage = Reducer.perPage - } + newPage <- eventFromResult $ Pages._out_newPage . snd + currentPage <- R.holdDyn 1 newPage + addIncome <- eventFromResult $ Table._out_add . fst + editIncome <- eventFromResult $ Table._out_edit . fst + deleteIncome <- eventFromResult $ Table._out_delete . fst + + result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> + flip Loadable.view is $ \(IncomesAndCount incomes count) -> do + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_incomes = incomes + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = p + } - -- -- table :: Event t (Maybe (Table.Out t)) - -- table <- R.dyn . R.ffor incomes . Loadable.view $ \incomes -> - -- Table.view $ Table.In - -- { Table._in_currentUser = _in_currentUser input - -- , Table._in_currency = _in_currency input - -- , Table._in_incomes = incomes - -- } + return (table, pages) return () diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 6d69c19..9b2129f 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -26,7 +26,7 @@ import qualified View.Income.Form as Form data In t = In { _in_currentUser :: UserId , _in_currency :: Currency - , _in_incomes :: Dynamic t [Income] + , _in_incomes :: [Income] } data Out t = Out @@ -40,7 +40,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel - , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date + , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input , Table._in_cell = cell [] (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In -- cgit v1.2.3 From a267f0bb4566389342c3244d3c082dc2453f4615 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 09:22:12 +0100 Subject: Show users in income table --- client/client.cabal | 1 + client/src/Component/Appearing.hs | 10 ++++++++++ client/src/View/App.hs | 3 +-- client/src/View/Income/Income.hs | 24 ++++++------------------ client/src/View/Income/Table.hs | 3 ++- server/server.cabal | 1 + server/src/Design/Appearing.hs | 25 +++++++++++++++++++++++++ server/src/Design/Global.hs | 2 ++ 8 files changed, 48 insertions(+), 21 deletions(-) create mode 100644 client/src/Component/Appearing.hs create mode 100644 server/src/Design/Appearing.hs diff --git a/client/client.cabal b/client/client.cabal index 8648d57..cac06d5 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -45,6 +45,7 @@ Executable client , uri-bytestring other-modules: + Component.Appearing Component.Button Component.ConfirmDialog Component.Form diff --git a/client/src/Component/Appearing.hs b/client/src/Component/Appearing.hs new file mode 100644 index 0000000..e0144ca --- /dev/null +++ b/client/src/Component/Appearing.hs @@ -0,0 +1,10 @@ +module Component.Appearing + ( view + ) where + +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +view :: forall t m a. MonadWidget t m => m a -> m a +view = + R.divClass "g-Appearing" diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 1e26417..d305d00 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -67,11 +67,10 @@ signedWidget init route = do } IncomeRoute -> do - incomeInit <- Income.init Income.view $ Income.In { Income._in_currentUser = _init_currentUser init , Income._in_currency = _init_currency init - , Income._in_init = incomeInit + , Income._in_users = _init_users init } NotFoundRoute -> diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index fedf3d8..d31775a 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -1,20 +1,18 @@ {-# LANGUAGE ExplicitForAll #-} module View.Income.Income - ( init - , view + ( view , In(..) ) where -import qualified Data.Text as T import Data.Aeson (FromJSON) import qualified Data.Maybe as Maybe -import Prelude hiding (init) +import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, Income (..), - IncomesAndCount (..), UserId) + IncomesAndCount (..), User, UserId) import qualified Component.Pages as Pages import Loadable (Loadable (..)) @@ -27,22 +25,11 @@ import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table data In t = In - { _in_currentUser :: UserId + { _in_users :: [User] + , _in_currentUser :: UserId , _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) } -init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) -init = do - users <- AjaxUtil.getNow "api/users" - incomes <- AjaxUtil.getNow "api/incomes" - payments <- AjaxUtil.getNow "api/payments" - return $ do - us <- users - is <- incomes - ps <- payments - return $ Init <$> us <*> is <*> ps - view :: forall t m. MonadWidget t m => In t -> m () view input = do rec @@ -69,6 +56,7 @@ view input = do { Table._in_currentUser = _in_currentUser input , Table._in_currency = _in_currency input , Table._in_incomes = incomes + , Table._in_users = _in_users input } pages <- Pages.view $ Pages.In diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 9b2129f..32ab27b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -27,6 +27,7 @@ data In t = In { _in_currentUser :: UserId , _in_currency :: Currency , _in_incomes :: [Income] + , _in_users :: [User] } data Out t = Out @@ -41,7 +42,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input - , Table._in_cell = cell [] (_in_currency input) + , Table._in_cell = cell (_in_users input) (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In { Form._in_operation = Form.Clone income diff --git a/server/server.cabal b/server/server.cabal index c7b4f2b..b170a18 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -65,6 +65,7 @@ Executable server Controller.Payment Controller.User Cookie + Design.Appearing Design.Color Design.Constants Design.Errors diff --git a/server/src/Design/Appearing.hs b/server/src/Design/Appearing.hs new file mode 100644 index 0000000..79b94b3 --- /dev/null +++ b/server/src/Design/Appearing.hs @@ -0,0 +1,25 @@ +module Design.Appearing + ( design + ) where + +import Clay + +design :: Css +design = do + + appearKeyframe + + ".g-Appearing" ? do + appearAnimation + +appearAnimation :: Css +appearAnimation = do + animationName "appear" + animationDuration (sec 0.2) + animationTimingFunction easeIn + +appearKeyframe :: Css +appearKeyframe = keyframes + "appear" + [ (0, "opacity" -: "0") + ] diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index f9884bd..df41cfd 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -6,6 +6,7 @@ import Clay import Clay.Color as C import Data.Text.Lazy (Text) +import qualified Design.Appearing as Appearing import qualified Design.Color as Color import qualified Design.Constants as Constants import qualified Design.Errors as Errors @@ -22,6 +23,7 @@ globalDesign = renderWith compact [] global global :: Css global = do ".errors" ? Errors.design + Appearing.design Modal.design ".tooltip" ? Tooltip.design Views.design -- cgit v1.2.3 From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:28:42 +0100 Subject: Show income header --- client/src/View/Income/Header.hs | 35 ++++++++------------- client/src/View/Income/Income.hs | 29 +++++++++++------- client/src/View/Income/Reducer.hs | 8 ++--- common/common.cabal | 4 ++- common/src/Common/Model.hs | 3 +- common/src/Common/Model/IncomeHeader.hs | 18 +++++++++++ common/src/Common/Model/IncomePage.hs | 18 +++++++++++ common/src/Common/Model/IncomesAndCount.hs | 16 ---------- server/src/Controller/Income.hs | 49 +++++++++++++++++++++--------- server/src/Job/WeeklyReport.hs | 2 +- server/src/Main.hs | 7 ++--- server/src/Persistence/Income.hs | 23 ++++++++------ 12 files changed, 125 insertions(+), 87 deletions(-) create mode 100644 common/src/Common/Model/IncomeHeader.hs create mode 100644 common/src/Common/Model/IncomePage.hs delete mode 100644 common/src/Common/Model/IncomesAndCount.hs diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 8e82525..8451ee4 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -5,13 +5,15 @@ module View.Income.Header ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Time.Clock as Clock import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), User (..)) +import Common.Model (Currency, Income (..), + IncomeHeader (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -23,9 +25,9 @@ import qualified View.Income.Form as Form import View.Income.Init (Init (..)) data In t = In - { _in_init :: Init + { _in_users :: [User] + , _in_header :: IncomeHeader , _in_currency :: Currency - , _in_incomes :: Dynamic t [Income] } data Out t = Out @@ -38,11 +40,11 @@ view input = currentTime <- liftIO Clock.getCurrentTime - R.dyn . R.ffor useIncomesFrom $ \case - (Nothing, _) -> + case _incomeHeader_since $ _in_header input of + Nothing -> R.blank - (Just since, incomes) -> + Just since -> R.el "div" $ do R.el "h1" $ do @@ -50,15 +52,13 @@ view input = R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) R.el "ul" $ - flip mapM_ (_init_users init) $ \user -> + flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) -> R.el "li" $ - R.text $ do - let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes + R.text $ T.intercalate " " - [ _user_name user + [ Maybe.fromMaybe "" . fmap _user_name $ CM.findUser userId (_in_users input) , "−" - , Format.price (_in_currency input) $ - CM.cumulativeIncomesSince currentTime since userIncomes + , Format.price (_in_currency input) amount ] R.divClass "titleButton" $ do @@ -78,14 +78,3 @@ view input = return $ Out { _out_add = addIncome } - - where - init = _in_init input - - useIncomesFrom = R.ffor (_in_incomes input) $ \incomes -> - ( CM.useIncomesFrom - (map _user_id $_init_users init) - incomes - (_init_payments init) - , incomes - ) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d31775a..d82ab4d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -11,15 +11,15 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Income (..), - IncomesAndCount (..), User, UserId) +import Common.Model (Currency, Income (..), IncomePage (..), + User, UserId) import qualified Component.Pages as Pages import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil --- import qualified View.Income.Header as Header +import qualified View.Income.Header as Header import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table @@ -36,22 +36,29 @@ view input = do incomes <- Reducer.reducer $ Reducer.In { Reducer._in_newPage = newPage , Reducer._in_currentPage = currentPage - , Reducer._in_addIncome = addIncome + , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome] , Reducer._in_editIncome = editIncome , Reducer._in_deleteIncome = deleteIncome } - let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . snd + newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) currentPage <- R.holdDyn 1 newPage - addIncome <- eventFromResult $ Table._out_add . fst - editIncome <- eventFromResult $ Table._out_edit . fst - deleteIncome <- eventFromResult $ Table._out_delete . fst + headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(IncomesAndCount incomes count) -> do + flip Loadable.view is $ \(IncomePage header incomes count) -> do + header <- Header.view $ Header.In + { Header._in_users = _in_users input + , Header._in_header = header + , Header._in_currency = _in_currency input + } + table <- Table.view $ Table.In { Table._in_currentUser = _in_currentUser input , Table._in_currency = _in_currency input @@ -65,6 +72,6 @@ view input = do , Pages._in_page = p } - return (table, pages) + return (header, table, pages) return () diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 5b346cb..092d9b3 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -9,7 +9,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (IncomesAndCount) +import Common.Model (IncomePage) import Loadable (Loadable (..)) import qualified Loadable as Loadable @@ -28,9 +28,9 @@ data In t a b c = In data Action = LoadPage Int - | GetResult (Either Text IncomesAndCount) + | GetResult (Either Text IncomePage) -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomesAndCount)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) reducer input = do postBuild <- R.getPostBuild @@ -60,7 +60,7 @@ reducer input = do where pageUrl p = - "api/v2/incomes?page=" + "api/incomes?page=" <> (T.pack . show $ p) <> "&perPage=" <> (T.pack . show $ perPage) diff --git a/common/common.cabal b/common/common.cabal index 9f3f65b..651673f 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -24,6 +24,7 @@ Library Build-depends: aeson , base >= 4.11 && < 5 + , containers , text , time , validation @@ -60,7 +61,8 @@ Library Common.Model.EditPaymentForm Common.Model.Frequency Common.Model.Income - Common.Model.IncomesAndCount + Common.Model.IncomeHeader + Common.Model.IncomePage Common.Model.Init Common.Model.InitResult Common.Model.Payer diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 3a5a627..313f26b 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -12,7 +12,8 @@ import Common.Model.EditPaymentForm as X import Common.Model.Email as X import Common.Model.Frequency as X import Common.Model.Income as X -import Common.Model.IncomesAndCount as X +import Common.Model.IncomeHeader as X +import Common.Model.IncomePage as X import Common.Model.Init as X import Common.Model.InitResult as X import Common.Model.Payer as X diff --git a/common/src/Common/Model/IncomeHeader.hs b/common/src/Common/Model/IncomeHeader.hs new file mode 100644 index 0000000..a1defdf --- /dev/null +++ b/common/src/Common/Model/IncomeHeader.hs @@ -0,0 +1,18 @@ +module Common.Model.IncomeHeader + ( IncomeHeader(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +data IncomeHeader = IncomeHeader + { _incomeHeader_since :: Maybe UTCTime + , _incomeHeader_byUser :: Map UserId Int + } deriving (Show, Generic) + +instance FromJSON IncomeHeader +instance ToJSON IncomeHeader diff --git a/common/src/Common/Model/IncomePage.hs b/common/src/Common/Model/IncomePage.hs new file mode 100644 index 0000000..c3f478e --- /dev/null +++ b/common/src/Common/Model/IncomePage.hs @@ -0,0 +1,18 @@ +module Common.Model.IncomePage + ( IncomePage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Income (Income) +import Common.Model.IncomeHeader (IncomeHeader) + +data IncomePage = IncomePage + { _incomePage_header :: IncomeHeader + , _incomePage_incomes :: [Income] + , _incomePage_totalCount :: Int + } deriving (Show, Generic) + +instance FromJSON IncomePage +instance ToJSON IncomePage diff --git a/common/src/Common/Model/IncomesAndCount.hs b/common/src/Common/Model/IncomesAndCount.hs deleted file mode 100644 index 4365180..0000000 --- a/common/src/Common/Model/IncomesAndCount.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Common.Model.IncomesAndCount - ( IncomesAndCount(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Income (Income) - -data IncomesAndCount = IncomesAndCount - { _incomesAndCount_incomes :: [Income] - , _incomesAndCount_count :: Int - } deriving (Show, Generic) - -instance FromJSON IncomesAndCount -instance ToJSON IncomesAndCount diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 3272cbf..d8d3d89 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,42 +1,61 @@ module Controller.Income ( list - , listv2 , create , edit , delete ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), IncomeId, - IncomesAndCount (..), User (..)) + EditIncomeForm (..), Income (..), + IncomeHeader (..), IncomeId, + IncomePage (..), User (..)) +import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure import qualified Validation.Income as IncomeValidation -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.list) >>= json - ) - -listv2 :: Int -> Int -> ActionM () -listv2 page perPage = - Secure.loggedAction (\_ -> +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do count <- IncomePersistence.count - incomes <- IncomePersistence.listv2 page perPage - return $ IncomesAndCount incomes count - ) >>= json + + users <- UserPersistence.list + allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all + allIncomes <- IncomePersistence.listAll + + let since = + CM.useIncomesFrom (map _user_id users) allIncomes allPayments + + let byUser = + case since of + Just s -> + M.fromList . flip map users $ \user -> + ( _user_id user + , CM.cumulativeIncomesSince currentTime s $ + filter ((==) (_user_id user) . _income_userId) allIncomes + ) + + Nothing -> + M.empty + + incomes <- IncomePersistence.list page perPage + return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 203c4e8..1a478dc 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do Nothing -> return () Just lastExecution -> do (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list + (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now diff --git a/server/src/Main.hs b/server/src/Main.hs index 00e8d1c..40b53b6 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -54,13 +54,10 @@ main = do paymentId <- S.param "id" Payment.delete paymentId - S.get "/api/v2/incomes" $ do + S.get "/api/incomes" $ do page <- S.param "page" perPage <- S.param "perPage" - Income.listv2 page perPage - - S.get "/api/incomes" $ - Income.list + Income.list page perPage S.post "/api/income" $ S.jsonData >>= Income.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index de55a18..4ae3228 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,7 +1,7 @@ module Persistence.Income ( count , list - , listv2 + , listAll , create , edit , delete @@ -43,15 +43,8 @@ count = SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" ) -list :: Query [Income] -list = - Query (\conn -> - map (\(Row i) -> i) <$> - SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" - ) - -listv2 :: Int -> Int -> Query [Income] -listv2 page perPage = +list :: Int -> Int -> Query [Income] +list page perPage = Query (\conn -> map (\(Row i) -> i) <$> SQLite.query @@ -60,6 +53,16 @@ listv2 page perPage = (perPage, (page - 1) * perPage) ) +listAll :: Query [Income] +listAll = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" + ) + +-- firstIncomeByUser +-- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id; + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do -- cgit v1.2.3 From 182f3d3fea9985c0e403087fe253981c68e57102 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:33:20 +0100 Subject: Fix payment page --- client/src/View/Payment/Payment.hs | 2 +- server/src/Controller/Income.hs | 7 +++++++ server/src/Main.hs | 3 +++ 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index f86acd8..e72577f 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -29,7 +29,7 @@ init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) init = do users <- AjaxUtil.getNow "api/users" payments <- AjaxUtil.getNow "api/payments" - incomes <- AjaxUtil.getNow "api/incomes" + incomes <- AjaxUtil.getNow "api/deprecated/incomes" categories <- AjaxUtil.getNow "api/categories" paymentCategories <- AjaxUtil.getNow "api/paymentCategories" return $ do diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index d8d3d89..4a41bd3 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income ( list + , deprecatedList , create , edit , delete @@ -58,6 +59,12 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) +deprecatedList :: ActionM () +deprecatedList = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ IncomePersistence.listAll) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Main.hs b/server/src/Main.hs index 40b53b6..b2672e4 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -59,6 +59,9 @@ main = do perPage <- S.param "perPage" Income.list page perPage + S.get "/api/deprecated/incomes" $ do + Income.deprecatedList + S.post "/api/income" $ S.jsonData >>= Income.create -- cgit v1.2.3 From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 15:47:11 +0100 Subject: Fetch the first payment date instead of every payment to get cumulative income --- client/client.cabal | 1 - client/src/Util/Date.hs | 12 ------ client/src/View/Income/Header.hs | 4 +- common/src/Common/Model/IncomeHeader.hs | 12 +++--- common/src/Common/Model/Payer.hs | 71 ++++++++++++++++++--------------- server/src/Controller/Income.hs | 4 +- server/src/Persistence/Payment.hs | 16 ++++++++ 7 files changed, 64 insertions(+), 56 deletions(-) delete mode 100644 client/src/Util/Date.hs diff --git a/client/client.cabal b/client/client.cabal index cac06d5..04c8543 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -60,7 +60,6 @@ Executable client Model.Route Util.Ajax Util.Css - Util.Date Util.Either Util.List Util.Reflex diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs deleted file mode 100644 index 8fad881..0000000 --- a/client/src/Util/Date.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Util.Date - ( utcToLocalDay - ) where - -import Data.Time.Calendar (Day) -import Data.Time.Clock (UTCTime) -import qualified Data.Time.LocalTime as LocalTime - -utcToLocalDay :: UTCTime -> IO Day -utcToLocalDay time = do - timezone <- LocalTime.getCurrentTimeZone - return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 8451ee4..9e1c5b6 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -20,7 +20,6 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal -import qualified Util.Date as DateUtil import qualified View.Income.Form as Form import View.Income.Init (Init (..)) @@ -48,8 +47,7 @@ view input = R.el "div" $ do R.el "h1" $ do - day <- liftIO $ DateUtil.utcToLocalDay since - R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day)) + R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since)) R.el "ul" $ flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) -> diff --git a/common/src/Common/Model/IncomeHeader.hs b/common/src/Common/Model/IncomeHeader.hs index a1defdf..87c7aae 100644 --- a/common/src/Common/Model/IncomeHeader.hs +++ b/common/src/Common/Model/IncomeHeader.hs @@ -2,15 +2,15 @@ module Common.Model.IncomeHeader ( IncomeHeader(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Map (Map) -import Data.Time.Clock (UTCTime) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) -import Common.Model.User (UserId) +import Common.Model.User (UserId) data IncomeHeader = IncomeHeader - { _incomeHeader_since :: Maybe UTCTime + { _incomeHeader_since :: Maybe Day , _incomeHeader_byUser :: Map UserId Int } deriving (Show, Generic) diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs index 40228d5..3c816c8 100644 --- a/common/src/Common/Model/Payer.hs +++ b/common/src/Common/Model/Payer.hs @@ -9,6 +9,7 @@ import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Time (NominalDiffTime, UTCTime (..)) import qualified Data.Time as Time +import Data.Time.Calendar (Day) import Common.Model.Income (Income (..)) import Common.Model.Payment (Payment (..)) @@ -36,10 +37,11 @@ data ExceedingPayer = ExceedingPayer getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] getExceedingPayers currentTime users incomes payments = let userIds = map _user_id users - payers = getPayers currentTime userIds incomes payments + payers = getPayers userIds incomes payments exceedingPayersOnPreIncome = exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - mbSince = useIncomesFrom userIds incomes payments + firstPayment = safeHead . List.sort . map _payment_date $ payments + mbSince = useIncomesFrom userIds incomes firstPayment in case mbSince of Just since -> let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers @@ -54,25 +56,30 @@ getExceedingPayers currentTime users incomes payments = _ -> exceedingPayersOnPreIncome -useIncomesFrom :: [UserId] -> [Income] -> [Payment] -> Maybe UTCTime -useIncomesFrom userIds incomes payments = - let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments - mbIncomeTime = incomeDefinedForAll userIds incomes - in case (firstPaymentTime, mbIncomeTime) of - (Just t1, Just t2) -> Just (max t1 t2) - _ -> Nothing +useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day +useIncomesFrom userIds incomes firstPayment = + case (firstPayment, incomeDefinedForAll userIds incomes) of + (Just d1, Just d2) -> Just (max d1 d2) + _ -> Nothing -paymentTime :: Payment -> UTCTime -paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date +dayUTCTime :: Day -> UTCTime +dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) -getPayers :: UTCTime -> [UserId] -> [Income] -> [Payment] -> [Payer] -getPayers currentTime userIds incomes payments = +getPayers :: [UserId] -> [Income] -> [Payment] -> [Payer] +getPayers userIds incomes payments = let incomesDefined = incomeDefinedForAll userIds incomes in flip map userIds (\userId -> Payer { _payer_userId = userId , _payer_preIncomePayments = totalPayments - (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + (\p -> + case incomesDefined of + Just d -> + _payment_date p < d + + Nothing -> + True + ) userId payments , _payer_postIncomePayments = @@ -80,7 +87,7 @@ getPayers currentTime userIds incomes payments = (\p -> case incomesDefined of Nothing -> False - Just t -> paymentTime p >= t + Just t -> _payment_date p >= t ) userId payments @@ -104,7 +111,7 @@ exceedingPayersFromAmounts userAmounts = $ userAmounts where mbMinAmount = safeMinimum . map snd $ userAmounts -getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer getPostPaymentPayer currentTime since payer = PostPaymentPayer { _postPaymentPayer_userId = _payer_userId payer @@ -120,35 +127,35 @@ getFinalDiff maxRatio payer = truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) in postIncomeDiff + _postPaymentPayer_preIncomePayments payer -incomeDefinedForAll :: [UserId] -> [Income] -> Maybe UTCTime +incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day incomeDefinedForAll userIds incomes = let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes else Nothing -cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int cumulativeIncomesSince currentTime since incomes = getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) -getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] -getOrderedIncomesSince time incomes = - let mbStarterIncome = getIncomeAt time incomes - orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes +getOrderedIncomesSince :: Day -> [Income] -> [Income] +getOrderedIncomesSince since incomes = + let mbStarterIncome = getIncomeAt since incomes + orderedIncomesSince = filter (\income -> _income_date income >= since) incomes in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince -getIncomeAt :: UTCTime -> [Income] -> Maybe Income -getIncomeAt time incomes = +getIncomeAt :: Day -> [Income] -> Maybe Income +getIncomeAt day incomes = case incomes of [x] -> - if incomeTime x < time - then Just $ x { _income_date = utctDay time } + if _income_date x < day + then Just $ x { _income_date = day } else Nothing x1 : x2 : xs -> - if incomeTime x1 < time && incomeTime x2 >= time - then Just $ x1 { _income_date = utctDay time } - else getIncomeAt time (x2 : xs) + if _income_date x1 < day && _income_date x2 >= day + then Just $ x1 { _income_date = day } + else getIncomeAt day (x2 : xs) [] -> Nothing @@ -171,7 +178,7 @@ getIncomesWithDuration currentTime incomes = (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) incomeTime :: Income -> UTCTime -incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date +incomeTime = dayUTCTime . _income_date durationIncome :: (NominalDiffTime, Int) -> Int durationIncome (duration, income) = diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 4a41bd3..127e3b3 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -37,11 +37,11 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all + firstPayment <- PaymentPersistence.firstPunctualDay allIncomes <- IncomePersistence.listAll let since = - CM.useIncomesFrom (map _user_id users) allIncomes allPayments + CM.useIncomesFrom (map _user_id users) allIncomes firstPayment let byUser = case since of diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index bcd7eb8..eb238d4 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,6 +1,7 @@ module Persistence.Payment ( Payment(..) , find + , firstPunctualDay , listActive , listPunctual , listActiveMonthlyOrderedByName @@ -60,6 +61,21 @@ find paymentId = SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) ) +data DayRow = DayRow Day + +instance FromRow DayRow where + fromRow = DayRow <$> SQLite.field + +firstPunctualDay :: Query (Maybe Day) +firstPunctualDay = + Query (\conn -> do + fmap (\(DayRow d) -> d) . listToMaybe <$> + SQLite.query + conn + "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1" + (Only (FrequencyField Punctual)) + ) + listActive :: Query [Payment] listActive = Query (\conn -> do -- cgit v1.2.3 From 4c79ca374e030454f62a467fb4f2197d372e9bc1 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 15:53:46 +0100 Subject: Fix select input style --- client/src/Component/Select.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 375ae06..70f5f58 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -35,7 +35,7 @@ view input = do rec let containerAttr = R.ffor showedError (\e -> M.singleton "class" $ T.intercalate " " - [ "input" + [ "input selectInput" , if Maybe.isJust e then "error" else "" ]) -- cgit v1.2.3 From 58f6c4e25f5f20f1b608242c83786e2f13947804 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 16:09:30 +0100 Subject: Delay modal event to let time for the modal to disappear --- client/src/Component/Modal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 50af469..b0533e2 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -71,7 +71,8 @@ view input = do let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn - return content + -- Delay the event in order to let time for the modal to disappear + R.delay (0.3 :: NominalDiffTime) content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = -- cgit v1.2.3 From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 6 Nov 2019 19:44:15 +0100 Subject: Show the payment table with server side paging --- client/client.cabal | 6 +- client/src/Component/Modal.hs | 2 +- client/src/Component/Table.hs | 21 +- client/src/View/App.hs | 7 +- client/src/View/Income/Form.hs | 18 +- client/src/View/Income/Table.hs | 8 +- client/src/View/Payment/Add.hs | 55 ----- client/src/View/Payment/Clone.hs | 61 ------ client/src/View/Payment/Delete.hs | 58 ------ client/src/View/Payment/Edit.hs | 56 ----- client/src/View/Payment/Form.hs | 137 ++++++++---- client/src/View/Payment/Header.hs | 8 +- client/src/View/Payment/Pages.hs | 87 -------- client/src/View/Payment/Payment.hs | 367 ++++++++++++++++++--------------- client/src/View/Payment/Reducer.hs | 66 ++++++ client/src/View/Payment/Table.hs | 315 +++++++++++----------------- common/common.cabal | 1 + common/src/Common/Model.hs | 1 + common/src/Common/Model/PaymentPage.hs | 18 ++ server/src/Controller/Payment.hs | 19 +- server/src/Design/View/Header.hs | 1 - server/src/Design/View/SignIn.hs | 2 +- server/src/Design/View/Table.hs | 11 + server/src/Main.hs | 9 +- server/src/Persistence/Income.hs | 3 - server/src/Persistence/Payment.hs | 25 ++- 26 files changed, 596 insertions(+), 766 deletions(-) delete mode 100644 client/src/View/Payment/Add.hs delete mode 100644 client/src/View/Payment/Clone.hs delete mode 100644 client/src/View/Payment/Delete.hs delete mode 100644 client/src/View/Payment/Edit.hs delete mode 100644 client/src/View/Payment/Pages.hs create mode 100644 client/src/View/Payment/Reducer.hs create mode 100644 common/src/Common/Model/PaymentPage.hs diff --git a/client/client.cabal b/client/client.cabal index 04c8543..75c2c1b 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -75,14 +75,10 @@ Executable client View.Income.Reducer View.Income.Table View.NotFound - View.Payment.Add - View.Payment.Clone - View.Payment.Delete - View.Payment.Edit View.Payment.Form View.Payment.Header View.Payment.Init - View.Payment.Pages View.Payment.Payment + View.Payment.Reducer View.Payment.Table View.SignIn diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index b0533e2..08f2e74 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -72,7 +72,7 @@ view input = do let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn -- Delay the event in order to let time for the modal to disappear - R.delay (0.3 :: NominalDiffTime) content + R.delay (0.5 :: NominalDiffTime) content getAttributes :: Text -> LM.Map Text Text getAttributes modalClass = diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 3b9ec24..2869c2d 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -4,7 +4,7 @@ module Component.Table , Out(..) ) where -import qualified Data.Map as M +import qualified Data.Map as M import Data.Text (Text) import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R @@ -14,23 +14,23 @@ import qualified Component.Modal as Modal import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data In m t h r a = In +data In m t h r a b c = In { _in_headerLabel :: h -> Text , _in_rows :: [r] - , _in_cell :: h -> r -> Text + , _in_cell :: h -> r -> m () , _in_cloneModal :: r -> Modal.Content t m a - , _in_editModal :: r -> Modal.Content t m a - , _in_deleteModal :: r -> Modal.Content t m a + , _in_editModal :: r -> Modal.Content t m b + , _in_deleteModal :: r -> Modal.Content t m c , _in_isOwner :: r -> Bool } -data Out t a = Out +data Out t a b c = Out { _out_add :: Event t a - , _out_edit :: Event t a - , _out_delete :: Event t a + , _out_edit :: Event t b + , _out_delete :: Event t c } -view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a) +view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c) view input = R.divClass "table" $ do rec @@ -49,8 +49,7 @@ view input = R.divClass "row" $ do flip mapM_ [minBound..] $ \header -> R.divClass "cell" $ - R.text $ - _in_cell input header row + _in_cell input header row cloneButton <- R.divClass "cell button" $ diff --git a/client/src/View/App.hs b/client/src/View/App.hs index d305d00..2b346af 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -58,15 +58,14 @@ widget initResult = signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case - RootRoute -> do - paymentInit <- Payment.init + RootRoute -> Payment.view $ Payment.In { Payment._in_currentUser = _init_currentUser init , Payment._in_currency = _init_currency init - , Payment._in_init = paymentInit + , Payment._in_users = _init_users init } - IncomeRoute -> do + IncomeRoute -> Income.view $ Income.In { Income._in_currentUser = _init_currentUser init , Income._in_currency = _init_currency init diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index a4f7de8..ff6e55e 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -27,7 +27,7 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Util.Ajax as Ajax -data In t = In +data In = In { _in_operation :: Operation } @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income view input cancel = do rec @@ -94,14 +94,14 @@ view input cancel = do amount = case op of - New -> "" - Clone income -> T.pack . show . _income_amount $ income - Edit income -> T.pack . show . _income_amount $ income + New -> "" + Clone i -> T.pack . show . _income_amount $ i + Edit i -> T.pack . show . _income_amount $ i date currentDay = case op of - Edit income -> _income_date income - _ -> currentDay + Edit i -> _income_date i + _ -> currentDay ajax = case op of @@ -115,5 +115,5 @@ view input cancel = do mkPayload = case op of - Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b - _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b + Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateIncomeForm a b diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index 32ab27b..c623acb 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -80,14 +80,14 @@ headerLabel UserHeader = Msg.get Msg.Income_Name headerLabel DateHeader = Msg.get Msg.Income_Date headerLabel AmountHeader = Msg.get Msg.Income_Amount -cell :: [User] -> Currency -> Header -> Income -> Text +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m () cell users currency header income = case header of UserHeader -> - Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users DateHeader -> - Format.longDay . _income_date $ income + R.text . Format.longDay . _income_date $ income AmountHeader -> - Format.price currency . _income_amount $ income + R.text . Format.price currency . _income_amount $ income diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs deleted file mode 100644 index e983465..0000000 --- a/client/src/View/Payment/Add.hs +++ /dev/null @@ -1,55 +0,0 @@ -module View.Payment.Add - ( view - , In(..) - ) where - -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CreatePaymentForm (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_frequency :: Dynamic t Frequency - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - formOutput <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - frequency <- _in_frequency input - return $ Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_Add - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = "" - , Form._in_cost = "" - , Form._in_date = currentDay - , Form._in_category = -1 - , Form._in_frequency = frequency - , Form._in_mkPayload = CreatePaymentForm - , Form._in_ajax = Ajax.post - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) - - return (hide, addPayment) diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs deleted file mode 100644 index 82b0c27..0000000 --- a/client/src/View/Payment/Clone.hs +++ /dev/null @@ -1,61 +0,0 @@ -module View.Payment.Clone - ( In(..) - , view - ) where - -import qualified Control.Monad as Monad -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Time.Clock as Time -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - CreatePaymentForm (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_show :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_payment :: Dynamic t Payment - , _in_category :: Dynamic t CategoryId - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay - - form <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - payment <- _in_payment input - category <- _in_category input - return . Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = _payment_name payment - , Form._in_cost = T.pack . show . _payment_cost $ payment - , Form._in_date = currentDay - , Form._in_category = category - , Form._in_frequency = _payment_frequency payment - , Form._in_mkPayload = CreatePaymentForm - , Form._in_ajax = Ajax.post - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> form) - clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form) - - return $ - ( hide - , clonePayment - ) diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs deleted file mode 100644 index e5e7219..0000000 --- a/client/src/View/Payment/Delete.hs +++ /dev/null @@ -1,58 +0,0 @@ -module View.Payment.Delete - ( In(..) - , view - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Payment (..)) -import qualified Common.Msg as Msg -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.WaitFor as WaitFor - -data In t = In - { _in_payment :: Dynamic t Payment - } - -view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment -view input _ = - R.divClass "delete" $ do - R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm - - R.divClass "deleteContent" $ do - - (confirm, cancel) <- R.divClass "buttons" $ do - - cancel <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo)) - { Button._in_class = R.constDyn "undo" }) - - rec - confirm <- Button._out_clic <$> (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm)) - { Button._in_class = R.constDyn "confirm" - , Button._in_submit = True - , Button._in_waiting = waiting - }) - - let url = - R.ffor (_in_payment input) (\id -> - T.concat ["/api/payment/", T.pack . show $ _payment_id id] - ) - - (result, waiting) <- WaitFor.waitFor - (Ajax.delete url) - confirm - - return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel) - - return $ - ( R.leftmost [ cancel, () <$ confirm ] - , R.tag (R.current $ _in_payment input) confirm - ) diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs deleted file mode 100644 index 5cb4537..0000000 --- a/client/src/View/Payment/Edit.hs +++ /dev/null @@ -1,56 +0,0 @@ -module View.Payment.Edit - ( In(..) - , view - ) where - -import qualified Control.Monad as Monad -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), CategoryId, - EditPaymentForm (..), Frequency (..), - Payment (..), PaymentCategory (..), - SavedPayment (..)) -import qualified Common.Msg as Msg -import qualified Component.Modal as Modal -import qualified Util.Ajax as Ajax -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Form as Form - -data In t = In - { _in_show :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - , _in_payment :: Dynamic t Payment - , _in_category :: Dynamic t CategoryId - } - -view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment -view input cancel = do - - formOutput <- R.dyn $ do - paymentCategories <- _in_paymentCategories input - payment <- _in_payment input - category <- _in_category input - return . Form.view $ Form.In - { Form._in_cancel = cancel - , Form._in_headerLabel = Msg.get Msg.Payment_EditLong - , Form._in_categories = _in_categories input - , Form._in_paymentCategories = paymentCategories - , Form._in_name = _payment_name payment - , Form._in_cost = T.pack . show . _payment_cost $ payment - , Form._in_date = _payment_date payment - , Form._in_category = category - , Form._in_frequency = _payment_frequency payment - , Form._in_mkPayload = EditPaymentForm (_payment_id payment) - , Form._in_ajax = Ajax.put - } - - hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput) - editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput) - - return $ - ( hide - , editPayment - ) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 29768aa..99b0848 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -1,10 +1,12 @@ module View.Payment.Form ( view , In(..) - , Out(..) + , Operation(..) ) where -import Data.Aeson (ToJSON) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson import qualified Data.List as L import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M @@ -13,6 +15,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock import Data.Validation (Validation) import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) @@ -20,103 +23,98 @@ import qualified Reflex.Dom as R import qualified Text.Read as T import Common.Model (Category (..), CategoryId, + CreatePaymentForm (..), + EditPaymentForm (..), Frequency (..), Payment (..), PaymentCategory (..), SavedPayment (..)) import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation + import qualified Component.Input as Input +import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Component.Select as Select +import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil -data In m t a = In - { _in_cancel :: Event t () - , _in_headerLabel :: Text - , _in_categories :: [Category] +data In = In + { _in_categories :: [Category] , _in_paymentCategories :: [PaymentCategory] - , _in_name :: Text - , _in_cost :: Text - , _in_date :: Day - , _in_category :: CategoryId - , _in_frequency :: Frequency - , _in_mkPayload :: Text -> Text -> Text -> CategoryId -> Frequency -> a - , _in_ajax :: Text -> Event t a -> m (Event t (Either Text SavedPayment)) + , _in_operation :: Operation } -data Out t = Out - { _output_hide :: Event t () - , _output_addPayment :: Event t SavedPayment - } +data Operation + = New Frequency + | Clone Payment + | Edit Payment -view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t) -view input = do +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view input cancel = do rec let reset = R.leftmost [ "" <$ ModalForm._out_cancel modalForm , "" <$ ModalForm._out_validate modalForm - , "" <$ _in_cancel input + , "" <$ cancel ] modalForm <- ModalForm.view $ ModalForm.In - { ModalForm._in_headerLabel = _in_headerLabel input - , ModalForm._in_ajax = _in_ajax input "/api/payment" + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/payment" , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) } - return $ Out - { _output_hide = ModalForm._out_hide modalForm - , _output_addPayment = ModalForm._out_validate modalForm - } + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) where + form :: Event t String -> Event t () - -> m (Dynamic t (Validation (NonEmpty Text) a)) + -> m (Dynamic t (Validation (NonEmpty Text) Value)) form reset confirm = do name <- Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Name - , Input._in_initialValue = _in_name input + , Input._in_initialValue = name , Input._in_validation = PaymentValidation.name }) - (_in_name input <$ reset) + (name <$ reset) confirm cost <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Cost - , Input._in_initialValue = _in_cost input + , Input._in_initialValue = cost , Input._in_validation = PaymentValidation.cost }) - (_in_cost input <$ reset) + (cost <$ reset) confirm) - let initialDate = T.pack . Calendar.showGregorian . _in_date $ input + d <- date date <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = initialDate + , Input._in_initialValue = d , Input._in_inputType = "date" , Input._in_hasResetButton = False , Input._in_validation = PaymentValidation.date }) - (initialDate <$ reset) + (d <$ reset) confirm) let setCategory = R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) $ \name -> - findCategory name (_in_paymentCategories input) + R.ffor (Input._out_raw name) findCategory category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category - , Select._in_initialValue = _in_category input + , Select._in_initialValue = category , Select._in_value = setCategory , Select._in_values = R.constDyn categories - , Select._in_reset = _in_category input <$ reset + , Select._in_reset = category <$ reset , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) , Select._in_validate = confirm }) @@ -126,12 +124,12 @@ view input = do c <- cost d <- date cat <- category - return ((_in_mkPayload input) + return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success (_in_frequency input)) + <*> V.Success frequency) frequencies = M.fromList @@ -142,7 +140,58 @@ view input = do categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) -findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId -findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + op = _in_operation input + + name = + case op of + New _ -> "" + Clone p -> _payment_name p + Edit p -> _payment_name p + + cost = + case op of + New _ -> "" + Clone p -> T.pack . show . _payment_cost $ p + Edit p -> T.pack . show . _payment_cost $ p + + date = do + currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay + return . T.pack . Calendar.showGregorian $ + case op of + New _ -> currentDay + Clone p -> currentDay + Edit p -> _payment_date p + + category = + case op of + New _ -> -1 + Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) + + frequency = + case op of + New f -> f + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p + + headerLabel = + case op of + New _ -> Msg.get Msg.Payment_Add + Clone _ -> Msg.get Msg.Payment_CloneLong + Edit _ -> Msg.get Msg.Payment_EditLong + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + mkPayload = + case op of + Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e + _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e + + findCategory :: Text -> Maybe CategoryId + findCategory paymentName = + fmap _paymentCategory_category + . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) + $ (_in_paymentCategories input) diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 00987a3..c8ca347 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -32,7 +32,7 @@ import qualified Component.Input as Input import qualified Component.Modal as Modal import qualified Component.Select as Select import qualified Util.List as L -import qualified View.Payment.Add as Add +import qualified View.Payment.Form as Form import View.Payment.Init (Init (..)) data In t = In @@ -120,11 +120,7 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen Modal.view $ Modal.In { Modal._in_show = addPayment - , Modal._in_content = Add.view $ Add.In - { Add._in_categories = categories - , Add._in_paymentCategories = paymentCategories - , Add._in_frequency = frequency - } + , Modal._in_content = \_ -> return (R.never, R.never) -- TODO } searchLine diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs deleted file mode 100644 index 9a1902c..0000000 --- a/client/src/View/Payment/Pages.hs +++ /dev/null @@ -1,87 +0,0 @@ -module View.Payment.Pages - ( view - , In(..) - , Out(..) - ) where - -import qualified Data.Text as T -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import qualified Component.Button as Button - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon - -data In t = In - { _in_total :: Dynamic t Int - , _in_perPage :: Int - , _in_reset :: Event t () - } - -data Out t = Out - { _out_currentPage :: Dynamic t Int - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = do - currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset - - return $ Out - { _out_currentPage = currentPage - } - - where - total = _in_total input - perPage = _in_perPage input - reset = _in_reset input - -pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int) -pageButtons total perPage reset = do - R.divClass "pages" $ do - rec - currentPage <- R.holdDyn 1 . R.leftmost $ - [ firstPageClic - , previousPageClic - , pageClic - , nextPageClic - , lastPageClic - , 1 <$ reset - ] - - firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar - - previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft - - pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> - pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) - - nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight - - lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar - - return currentPage - - where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage) - pageEvent = R.switch . R.current . fmap R.leftmost - noCurrentPage = R.constDyn Nothing - -range :: Int -> Int -> [Int] -range currentPage maxPage = [start..end] - where sidePages = 2 - start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) - end = min maxPage (start + sidePages * 2) - -pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) -pageButton currentPage page content = do - clic <- Button._out_clic <$> (Button.view $ Button.In - { Button._in_class = do - cp <- currentPage - p <- page - if cp == Just p then "page current" else "page" - , Button._in_content = content - , Button._in_waiting = R.never - , Button._in_tabIndex = Nothing - , Button._in_submit = False - }) - return . fmap fst $ R.attach (R.current page) clic diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index e72577f..bf0186f 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -1,181 +1,218 @@ module View.Payment.Payment - ( init - , view + ( view , In(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, SavedPayment (..), User, - UserId) -import qualified Common.Util.Text as T - -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Pages as Pages -import qualified View.Payment.Table as Table - -init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init)) -init = do - users <- AjaxUtil.getNow "api/users" - payments <- AjaxUtil.getNow "api/payments" - incomes <- AjaxUtil.getNow "api/deprecated/incomes" - categories <- AjaxUtil.getNow "api/categories" - paymentCategories <- AjaxUtil.getNow "api/paymentCategories" - return $ do - us <- users - ps <- payments - is <- incomes - cs <- categories - pcs <- paymentCategories - return $ Init <$> us <*> ps <*> is <*> cs <*> pcs - +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.Header as Header +import View.Payment.Init (Init (..)) +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId + , _in_users :: [User] , _in_currency :: Currency - , _in_init :: Dynamic t (Loadable Init) } view :: forall t m. MonadWidget t m => In t -> m () view input = do - R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> - - R.elClass "main" "payment" $ do - rec - let addPayment = R.leftmost - [ Header._out_addPayment header - , Table._out_addPayment table - ] - - paymentsPerPage = 7 - - payments <- reducePayments - (_init_payments init) - (_savedPayment_payment <$> addPayment) - (_savedPayment_payment <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - paymentCategories <- reducePaymentCategories - (_init_paymentCategories init) - payments - (_savedPayment_paymentCategory <$> addPayment) - (_savedPayment_paymentCategory <$> Table._out_editPayment table) - (Table._out_deletePayment table) - - (searchNameEvent, searchName) <- - debounceSearchName (Header._out_searchName header) - - let searchPayments = - getSearchPayments searchName (Header._out_searchFrequency header) payments - - header <- Header.view $ Header.In - { Header._in_init = init - , Header._in_currency = _in_currency input - , Header._in_payments = payments - , Header._in_searchPayments = searchPayments - , Header._in_paymentCategories = paymentCategories - } - - table <- Table.view $ Table.In - { Table._in_init = init - , Table._in_currency = _in_currency input - , Table._in_currentUser = _in_currentUser input - , Table._in_currentPage = Pages._out_currentPage pages - , Table._in_payments = searchPayments - , Table._in_perPage = paymentsPerPage - , Table._in_paymentCategories = paymentCategories - } - - pages <- Pages.view $ Pages.In - { Pages._in_total = length <$> searchPayments - , Pages._in_perPage = paymentsPerPage - , Pages._in_reset = R.leftmost $ - [ () <$ searchNameEvent - , () <$ Header._out_addPayment header - ] - } - - pure () + + categoriesEvent <- (AjaxUtil.getNow "api/categories") + + R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + + rec + payments <- Reducer.reducer $ Reducer.In + { Reducer._in_newPage = newPage + , Reducer._in_currentPage = currentPage + , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + , Reducer._in_editPayment = editPayment + , Reducer._in_deletePayment = deletePayment + } + + let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result + + newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + currentPage <- R.holdDyn 1 newPage + -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) + let headerAddPayment = R.never + tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> + flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + table <- Table.view $ Table.In + { Table._in_users = _in_users input + , Table._in_currentUser = _in_currentUser input + , Table._in_categories = categories + , Table._in_currency = _in_currency input + , Table._in_payments = payments + , Table._in_paymentCategories = paymentCategories + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = p + } + + return ((), table, pages) + + return () return () -debounceSearchName - :: forall t m. MonadWidget t m - => Dynamic t Text - -> m (Event t Text, Dynamic t Text) -debounceSearchName searchName = do - event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) - dynamic <- R.holdDyn "" event - return (event, dynamic) - -reducePayments - :: forall t m. MonadWidget t m - => [Payment] - -> Event t Payment -- add payment - -> Event t Payment -- edit payment - -> Event t Payment -- delete payment - -> m (Dynamic t [Payment]) -reducePayments initPayments addPayment editPayment deletePayment = - R.foldDyn id initPayments $ R.leftmost - [ (:) <$> addPayment - , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) - , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) - ] - -reducePaymentCategories - :: forall t m. MonadWidget t m - => [PaymentCategory] - -> Dynamic t [Payment] -- payments - -> Event t PaymentCategory -- add payment category - -> Event t PaymentCategory -- edit payment category - -> Event t Payment -- delete payment - -> m (Dynamic t [PaymentCategory]) -reducePaymentCategories - initPaymentCategories - payments - addPaymentCategory - editPaymentCategory - deletePayment - = - R.foldDyn id initPaymentCategories $ R.leftmost - [ (:) <$> addPaymentCategory - , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) - , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) - ] - where - deletePaymentName = - R.attachWithMaybe - (\ps p -> - if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then - Nothing - else - Just (_payment_name p)) - (R.current payments) - deletePayment - lowerName = T.toLower . _payment_name - -getSearchPayments - :: forall t. Reflex t - => Dynamic t Text - -> Dynamic t Frequency - -> Dynamic t [Payment] - -> Dynamic t [Payment] -getSearchPayments name frequency payments = do - n <- name - f <- frequency - ps <- payments - pure $ flip filter ps (\p -> - ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) - && (_payment_frequency p == f) - )) + +-- view :: forall t m. MonadWidget t m => In t -> m () +-- view input = do +-- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> +-- +-- R.elClass "main" "payment" $ do +-- rec +-- let addPayment = R.leftmost +-- -- [ Header._out_addPayment header +-- [ Table2._out_addPayment table +-- ] +-- +-- paymentsPerPage = 7 +-- +-- payments <- reducePayments +-- (_init_payments init) +-- (_savedPayment_payment <$> addPayment) +-- (_savedPayment_payment <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- paymentCategories <- reducePaymentCategories +-- (_init_paymentCategories init) +-- payments +-- (_savedPayment_paymentCategory <$> addPayment) +-- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) +-- (Table2._out_deletePayment table) +-- +-- -- (searchNameEvent, searchName) <- +-- -- debounceSearchName (Header._out_searchName header) +-- +-- -- let searchPayments = +-- -- getSearchPayments searchName (Header._out_searchFrequency header) payments +-- +-- -- header <- Header.view $ Header.In +-- -- { Header._in_init = init +-- -- , Header._in_currency = _in_currency input +-- -- , Header._in_payments = payments +-- -- , Header._in_searchPayments = searchPayments +-- -- , Header._in_paymentCategories = paymentCategories +-- -- } +-- +-- table <- Table2.view $ Table2.In +-- { Table2._in_init = init +-- , Table2._in_currency = _in_currency input +-- , Table2._in_currentUser = _in_currentUser input +-- , Table2._in_currentPage = Pages2._out_currentPage pages +-- , Table2._in_payments = payments +-- , Table2._in_perPage = paymentsPerPage +-- , Table2._in_paymentCategories = paymentCategories +-- } +-- +-- pages <- Pages2.view $ Pages2.In +-- { Pages2._in_total = length <$> payments +-- , Pages2._in_perPage = paymentsPerPage +-- , Pages2._in_reset = R.never +-- -- [ () <$ searchNameEvent +-- -- [ () <$ Header._out_addPayment header +-- -- ] +-- } +-- +-- pure () +-- +-- return () +-- +-- -- debounceSearchName +-- -- :: forall t m. MonadWidget t m +-- -- => Dynamic t Text +-- -- -> m (Event t Text, Dynamic t Text) +-- -- debounceSearchName searchName = do +-- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) +-- -- dynamic <- R.holdDyn "" event +-- -- return (event, dynamic) +-- +-- reducePayments +-- :: forall t m. MonadWidget t m +-- => [Payment] +-- -> Event t Payment -- add payment +-- -> Event t Payment -- edit payment +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [Payment]) +-- reducePayments initPayments addPayment editPayment deletePayment = +-- R.foldDyn id initPayments $ R.leftmost +-- [ (:) <$> addPayment +-- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) +-- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) +-- ] +-- +-- reducePaymentCategories +-- :: forall t m. MonadWidget t m +-- => [PaymentCategory] +-- -> Dynamic t [Payment] -- payments +-- -> Event t PaymentCategory -- add payment category +-- -> Event t PaymentCategory -- edit payment category +-- -> Event t Payment -- delete payment +-- -> m (Dynamic t [PaymentCategory]) +-- reducePaymentCategories +-- initPaymentCategories +-- payments +-- addPaymentCategory +-- editPaymentCategory +-- deletePayment +-- = +-- R.foldDyn id initPaymentCategories $ R.leftmost +-- [ (:) <$> addPaymentCategory +-- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) +-- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) +-- ] +-- where +-- deletePaymentName = +-- R.attachWithMaybe +-- (\ps p -> +-- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then +-- Nothing +-- else +-- Just (_payment_name p)) +-- (R.current payments) +-- deletePayment +-- lowerName = T.toLower . _payment_name +-- +-- -- getSearchPayments +-- -- :: forall t. Reflex t +-- -- => Dynamic t Text +-- -- -> Dynamic t Frequency +-- -- -> Dynamic t [Payment] +-- -- -> Dynamic t [Payment] +-- -- getSearchPayments name frequency payments = do +-- -- n <- name +-- -- f <- frequency +-- -- ps <- payments +-- -- pure $ flip filter ps (\p -> +-- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) +-- -- && (_payment_frequency p == f) +-- -- )) diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs new file mode 100644 index 0000000..0c70f8a --- /dev/null +++ b/client/src/View/Payment/Reducer.hs @@ -0,0 +1,66 @@ +module View.Payment.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (PaymentPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_newPage :: Event t Int + , _in_currentPage :: Dynamic t Int + , _in_addPayment :: Event t a + , _in_editPayment :: Event t b + , _in_deletePayment :: Event t c + } + +data Action + = LoadPage Int + | GetResult (Either Text PaymentPage) + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer input = do + + postBuild <- R.getPostBuild + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_newPage input + , 1 <$ _in_addPayment input + , R.tag (R.current $ _in_currentPage input) (_in_editPayment input) + , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.foldDyn + (\action _ -> case action of + LoadPage _ -> Loading + GetResult (Left err) -> Error err + GetResult (Right payments) -> Loaded payments + ) + Loading + (R.leftmost + [ LoadPage <$> loadPage + , GetResult <$> getResult + ]) + + where + pageUrl p = + "api/payments?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 0793836..dde5168 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -4,209 +4,146 @@ module View.Payment.Table , Out(..) ) where -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Category (..), Currency, - Frequency (Punctual), Payment (..), - PaymentCategory (..), SavedPayment, - User (..), UserId) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format -import qualified Component.Button as Button -import qualified Component.Modal as Modal -import qualified View.Payment.Clone as Clone -import qualified View.Payment.Delete as Delete -import qualified View.Payment.Edit as Edit -import View.Payment.Init (Init (..)) - -import qualified Util.Reflex as ReflexUtil -import qualified View.Icon as Icon +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, Payment (..), + PaymentCategory (..), SavedPayment, + User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Payment.Form as Form data In t = In - { _in_init :: Init - , _in_currency :: Currency + { _in_users :: [User] , _in_currentUser :: UserId - , _in_currentPage :: Dynamic t Int - , _in_payments :: Dynamic t [Payment] - , _in_perPage :: Int - , _in_paymentCategories :: Dynamic t [PaymentCategory] , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] + , _in_paymentCategories :: [PaymentCategory] } data Out t = Out - { _out_addPayment :: Event t SavedPayment - , _out_editPayment :: Event t SavedPayment - , _out_deletePayment :: Event t Payment + { _out_add :: Event t SavedPayment + , _out_edit :: Event t SavedPayment + , _out_delete :: Event t Payment } view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do - R.divClass "table" $ do - - (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do - R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name - R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost - R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User - R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category - R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - - result <- - (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories)) - - return $ - ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result - , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result - ) - - ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $ - R.text $ Msg.get Msg.Payment_Empty - - return $ Out - { _out_addPayment = addPayment - , _out_editPayment = editPayment - , _out_deletePayment = deletePayment - } - - where - init = _in_init input - currency = _in_currency input - currentUser = _in_currentUser input - currentPage = _in_currentPage input - payments = _in_payments input - paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage - paymentCategories = _in_paymentCategories input - -getPaymentRange :: Int -> [Payment] -> Int -> [Payment] -getPaymentRange perPage payments currentPage = - take perPage - . drop ((currentPage - 1) * perPage) - . reverse - . L.sortOn _payment_date - $ payments - -paymentRow - :: forall t m. MonadWidget t m - => Init - -> Currency - -> UserId - -> Dynamic t [PaymentCategory] - -> Dynamic t Payment - -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment) -paymentRow init currency currentUser paymentCategories payment = - R.divClass "row" $ do - - R.divClass "cell name" $ - R.dynText $ fmap _payment_name payment - - R.divClass "cell cost" $ - R.dynText $ fmap (Format.price currency . _payment_cost) payment - - let user = R.ffor payment (\p -> - CM.findUser (_payment_user p) (_init_users init)) - - R.divClass "cell user" $ - R.dynText $ flip fmap user $ \mbUser -> case mbUser of - Just u -> _user_name u - _ -> "" - - let category = do - p <- payment - pcs <- paymentCategories - return $ findCategory (_init_categories init) pcs (_payment_name p) - - R.divClass "cell category" $ do - - let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of - Just c -> M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - Nothing -> M.singleton "display" "none" - - R.elDynAttr "span" attrs $ - R.dynText $ R.ffor category $ \case - Just c -> _category_name c - _ -> "" - - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment - R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment - - let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category - - clonePayment <- - R.divClass "cell button" $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.clone) - - paymentCloned <- - Modal.view $ Modal.In - { Modal._in_show = clonePayment - , Modal._in_content = - Clone.view $ Clone.In - { Clone._in_show = clonePayment - , Clone._in_categories = _init_categories init - , Clone._in_paymentCategories = paymentCategories - , Clone._in_payment = payment - , Clone._in_category = categoryId - } - } - let isFromCurrentUser = - R.ffor - payment - (\p -> _payment_user p == currentUser) - - editPayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - Button.defaultIn Icon.edit) - - paymentEdited <- - Modal.view $ Modal.In - { Modal._in_show = editPayment - , Modal._in_content = - Edit.view $ Edit.In - { Edit._in_show = editPayment - , Edit._in_categories = _init_categories init - , Edit._in_paymentCategories = paymentCategories - , Edit._in_payment = payment - , Edit._in_category = categoryId - } + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_cell = + cell + (_in_users input) + (_in_categories input) + (_in_paymentCategories input) + (_in_currency input) + , Table._in_cloneModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Clone payment } - - deletePayment <- - R.divClass "cell button" $ - ReflexUtil.divVisibleIf isFromCurrentUser $ - Button._out_clic <$> (Button.view $ - (Button.defaultIn Icon.delete) - { Button._in_class = R.constDyn "deletePayment" - }) - - paymentDeleted <- - Modal.view $ Modal.In - { Modal._in_show = deletePayment - , Modal._in_content = - Delete.view $ Delete.In - { Delete._in_payment = payment - } + , Table._in_editModal = \payment -> + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.Edit payment } - - return $ (paymentCloned, paymentEdited, paymentDeleted) + , Table._in_deleteModal = \payment -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Payment_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) + e + return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | CostHeader + | UserHeader + | CategoryHeader + | DateHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Payment_Name +headerLabel CostHeader = Msg.get Msg.Payment_Cost +headerLabel UserHeader = Msg.get Msg.Payment_User +headerLabel CategoryHeader = Msg.get Msg.Payment_Category +headerLabel DateHeader = Msg.get Msg.Payment_Date + +cell + :: forall t m. MonadWidget t m + => [User] + -> [Category] + -> [PaymentCategory] + -> Currency + -> Header + -> Payment + -> m () +cell users categories paymentCategories currency header payment = + case header of + NameHeader -> + R.text $ _payment_name payment + + CostHeader -> + R.text . Format.price currency . _payment_cost $ payment + + UserHeader -> + R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users + + CategoryHeader -> + let + category = + findCategory categories paymentCategories (_payment_name payment) + + attrs = + case category of + Just c -> + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + + Nothing -> + M.singleton "display" "none" + in + R.elAttr "span" attrs $ + R.text $ + Maybe.fromMaybe "" (_category_name <$> category) + + DateHeader -> + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/common/common.cabal b/common/common.cabal index 651673f..4a6d728 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -67,3 +67,4 @@ Library Common.Model.InitResult Common.Model.Payer Common.Model.PaymentCategory + Common.Model.PaymentPage diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 313f26b..bc626d5 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -19,6 +19,7 @@ import Common.Model.InitResult as X import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X +import Common.Model.PaymentPage as X import Common.Model.SavedPayment as X import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs new file mode 100644 index 0000000..31039c7 --- /dev/null +++ b/common/src/Common/Model/PaymentPage.hs @@ -0,0 +1,18 @@ +module Common.Model.PaymentPage + ( PaymentPage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Payment (Payment) +import Common.Model.PaymentCategory (PaymentCategory) + +data PaymentPage = PaymentPage + { _paymentPage_payments :: [Payment] + , _paymentPage_paymentCategories :: [PaymentCategory] + , _paymentPage_totalCount :: Int + } deriving (Show, Generic) + +instance FromJSON PaymentPage +instance ToJSON PaymentPage diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 30b63ff..01702cb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment - ( list + ( deprecatedList + , list , listPaymentCategories , create , edit @@ -15,6 +16,7 @@ import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), Payment (..), PaymentId, + PaymentPage (..), SavedPayment (..), User (..)) import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper @@ -27,12 +29,23 @@ import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure import qualified Validation.Payment as PaymentValidation -list :: ActionM () -list = +deprecatedList :: ActionM () +deprecatedList = Secure.loggedAction (\_ -> (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- PaymentPersistence.count + payments <- PaymentPersistence.listActivePage page perPage + paymentCategories <- PaymentCategoryPersistence.list + return $ PaymentPage payments paymentCategories count + ) >>= json + ) + listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 59e0e51..609d8fc 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -25,7 +25,6 @@ design = do ".title" <> ".item" ? headerPadding ".title" ? do - height (pct 100) textAlign (alignSide sideLeft) Media.mobile $ fontSize (px 22) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs index a39276e..42c9621 100644 --- a/server/src/Design/View/SignIn.hs +++ b/server/src/Design/View/SignIn.hs @@ -13,7 +13,7 @@ import qualified Design.Helper as Helper design :: Css design = do let inputHeight = 50 - maxWidth (px 550) + width (px 350) sym2 padding (rem 0) (rem 2) marginTop (px 100) marginLeft auto diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs index 1c4e806..c77cb7c 100644 --- a/server/src/Design/View/Table.hs +++ b/server/src/Design/View/Table.hs @@ -67,6 +67,17 @@ design = do ".refund" & color Color.mossGreen + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + ".cell.button" & do position relative textAlign (alignSide sideCenter) diff --git a/server/src/Main.hs b/server/src/Main.hs index b2672e4..a4d8635 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -41,8 +41,13 @@ main = do S.get "/api/users"$ User.list - S.get "/api/payments" $ - Payment.list + S.get "/api/deprecated/payments" $ + Payment.deprecatedList + + S.get "/api/payments" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Payment.list page perPage S.post "/api/payment" $ S.jsonData >>= Payment.create diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 4ae3228..cb2ef10 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -60,9 +60,6 @@ listAll = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) --- firstIncomeByUser --- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id; - create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index eb238d4..e01753f 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,8 +1,9 @@ module Persistence.Payment - ( Payment(..) + ( count , find , firstPunctualDay , listActive + , listActivePage , listPunctual , listActiveMonthlyOrderedByName , create @@ -54,6 +55,18 @@ instance ToRow InsertRow where , toField (_payment_createdAt p) ] +data Count = Count Int + +instance FromRow Count where + fromRow = Count <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (\[Count n] -> n) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL" + ) + find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do @@ -83,6 +96,16 @@ listActive = SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" ) +listActivePage :: Int -> Int -> Query [Payment] +listActivePage page perPage = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.query + conn + "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + listPunctual :: Query [Payment] listPunctual = Query (\conn -> do -- cgit v1.2.3 From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 7 Nov 2019 07:59:41 +0100 Subject: Show payment header infos --- client/client.cabal | 5 +- client/src/View/Payment/Header.hs | 187 ------------------------------ client/src/View/Payment/HeaderForm.hs | 78 +++++++++++++ client/src/View/Payment/HeaderInfos.hs | 96 +++++++++++++++ client/src/View/Payment/Init.hs | 13 --- client/src/View/Payment/Payment.hs | 53 +++++---- common/common.cabal | 2 + common/src/Common/Model.hs | 2 + common/src/Common/Model/ExceedingPayer.hs | 16 +++ common/src/Common/Model/Payer.hs | 25 ++-- common/src/Common/Model/PaymentHeader.hs | 18 +++ common/src/Common/Model/PaymentPage.hs | 4 +- server/server.cabal | 5 +- server/src/Controller/Payment.hs | 54 ++++++--- server/src/Design/Modal.hs | 8 +- server/src/Design/View/Payment.hs | 6 +- server/src/Design/View/Payment/Delete.hs | 35 ------ server/src/Design/View/Payment/Header.hs | 45 +++---- server/src/Design/View/Payment/Pages.hs | 54 --------- server/src/Design/View/Payment/Table.hs | 35 ------ server/src/Design/Views.hs | 2 +- server/src/Main.hs | 3 - server/src/Persistence/Payment.hs | 21 +++- server/src/Util/List.hs | 13 +++ 24 files changed, 346 insertions(+), 434 deletions(-) delete mode 100644 client/src/View/Payment/Header.hs create mode 100644 client/src/View/Payment/HeaderForm.hs create mode 100644 client/src/View/Payment/HeaderInfos.hs delete mode 100644 client/src/View/Payment/Init.hs create mode 100644 common/src/Common/Model/ExceedingPayer.hs create mode 100644 common/src/Common/Model/PaymentHeader.hs delete mode 100644 server/src/Design/View/Payment/Delete.hs delete mode 100644 server/src/Design/View/Payment/Pages.hs delete mode 100644 server/src/Design/View/Payment/Table.hs create mode 100644 server/src/Util/List.hs diff --git a/client/client.cabal b/client/client.cabal index 75c2c1b..78ea7d3 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -61,7 +61,6 @@ Executable client Util.Ajax Util.Css Util.Either - Util.List Util.Reflex Util.Router Util.Validation @@ -76,8 +75,8 @@ Executable client View.Income.Table View.NotFound View.Payment.Form - View.Payment.Header - View.Payment.Init + View.Payment.HeaderForm + View.Payment.HeaderInfos View.Payment.Payment View.Payment.Reducer View.Payment.Table diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs deleted file mode 100644 index c8ca347..0000000 --- a/client/src/View/Payment/Header.hs +++ /dev/null @@ -1,187 +0,0 @@ -module View.Payment.Header - ( view - , In(..) - , Out(..) - ) where - -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import qualified Data.List as L hiding (groupBy) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import qualified Data.Time as Time -import qualified Data.Validation as V -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Category, Currency, - ExceedingPayer (..), Frequency (..), - Income (..), Payment (..), - PaymentCategory, SavedPayment (..), - User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Common.View.Format as Format - -import qualified Component.Button as Button -import qualified Component.Input as Input -import qualified Component.Modal as Modal -import qualified Component.Select as Select -import qualified Util.List as L -import qualified View.Payment.Form as Form -import View.Payment.Init (Init (..)) - -data In t = In - { _in_init :: Init - , _in_currency :: Currency - , _in_payments :: Dynamic t [Payment] - , _in_searchPayments :: Dynamic t [Payment] - , _in_paymentCategories :: Dynamic t [PaymentCategory] - } - -data Out t = Out - { _out_searchName :: Dynamic t Text - , _out_searchFrequency :: Dynamic t Frequency - , _out_addPayment :: Event t SavedPayment - } - -view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = - R.divClass "header" $ do - rec - addPayment <- - payerAndAdd - incomes - payments - users - categories - paymentCategories - currency - searchFrequency - let resetSearchName = fmap (const ()) $ addPayment - (searchName, searchFrequency) <- searchLine resetSearchName - - infos (_in_searchPayments input) users currency - - return $ Out - { _out_searchName = searchName - , _out_searchFrequency = searchFrequency - , _out_addPayment = addPayment - } - where - init = _in_init input - incomes = _init_incomes init - initPayments = _init_payments init - payments = _in_payments input - users = _init_users init - categories = _init_categories init - currency = _in_currency input - paymentCategories = _in_paymentCategories input - -payerAndAdd - :: forall t m. MonadWidget t m - => [Income] - -> Dynamic t [Payment] - -> [User] - -> [Category] - -> Dynamic t [PaymentCategory] - -> Currency - -> Dynamic t Frequency - -> m (Event t SavedPayment) -payerAndAdd incomes payments users categories paymentCategories currency frequency = do - time <- liftIO Time.getCurrentTime - R.divClass "payerAndAdd" $ do - - let exceedingPayers = - R.ffor payments $ \ps -> - CM.getExceedingPayers time users incomes $ - filter ((==) Punctual . _payment_frequency) ps - - R.divClass "exceedingPayers" $ - R.simpleList exceedingPayers $ \exceedingPayer -> - R.elClass "span" "exceedingPayer" $ do - R.elClass "span" "userName" $ - R.dynText . R.ffor exceedingPayer $ \ep -> - fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users - R.elClass "span" "amount" $ do - R.text "+ " - R.dynText . R.ffor exceedingPayer $ \ep -> - Format.price currency $ _exceedingPayer_amount ep - - addPayment <- Button._out_clic <$> - (Button.view $ - (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) - { Button._in_class = R.constDyn "addPayment" - }) - - Modal.view $ Modal.In - { Modal._in_show = addPayment - , Modal._in_content = \_ -> return (R.never, R.never) -- TODO - } - -searchLine - :: forall t m. MonadWidget t m - => Event t () - -> m (Dynamic t Text, Dynamic t Frequency) -searchLine reset = do - R.divClass "searchLine" $ do - searchName <- Input._out_raw <$> (Input.view - ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) - ("" <$ reset) - R.never) - - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - searchFrequency <- Select._out_raw <$> (Select.view $ Select.In - { Select._in_label = "" - , Select._in_initialValue = Punctual - , Select._in_value = R.never - , Select._in_values = R.constDyn frequencies - , Select._in_reset = R.never - , Select._in_isValid = V.Success - , Select._in_validate = R.never - }) - - return (searchName, searchFrequency) - -infos - :: forall t m. MonadWidget t m - => Dynamic t [Payment] - -> [User] - -> Currency -> m () -infos payments users currency = - R.divClass "infos" $ do - - R.elClass "span" "total" $ do - R.dynText $ do - ps <- payments - let paymentCount = length ps - total = sum . map _payment_cost $ ps - pure . Msg.get $ Msg.Payment_Worth - (T.intercalate " " - [ (Format.number paymentCount) - , if paymentCount > 1 - then Msg.get Msg.Payment_Many - else Msg.get Msg.Payment_One - ]) - (Format.price currency total) - - R.elClass "span" "partition" . R.dynText $ do - ps <- payments - let totalByUser = - L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ ps - pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> - Msg.get $ Msg.Payment_By - (fromMaybe "" . fmap _user_name $ CM.findUser userId users) - (Format.price currency userTotal) diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..07a6b81 --- /dev/null +++ b/client/src/View/Payment/HeaderForm.hs @@ -0,0 +1,78 @@ +module View.Payment.HeaderForm + ( view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, Currency, ExceedingPayer (..), + Frequency (..), Income (..), Payment (..), + PaymentCategory, SavedPayment (..), + User (..)) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.Select as Select +import qualified View.Payment.Form as Form + +data In t = In + { _in_reset :: Event t () + , _in_categories :: [Category] + , _in_paymentCategories :: [PaymentCategory] + } + +data Out = Out + { _out_name :: Event t Text + , _out_frequency :: Event t Frequency + , _out_addPayment :: Event t SavedPayment + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + R.divClass "g-HeaderForm" $ do + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + searchFrequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + addPaymentButton <- Button._out_clic <$> + (Button.view $ + (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add)) + { Button._in_class = R.constDyn "addPayment" + }) + + addPayment <- Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_paymentCategories = _in_paymentCategories input + , Form._in_operation = Form.New searchFrequency + } + } + + return $ Out + { _out_name = searchName + , _out_frequency = searchFrequency + , _out_addPayment = addPayment + } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..12facc4 --- /dev/null +++ b/client/src/View/Payment/HeaderInfos.hs @@ -0,0 +1,96 @@ +module View.Payment.HeaderInfos + ( view + , In(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.List as L hiding (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time as Time +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, ExceedingPayer (..), + Payment (..), PaymentHeader (..), + SavedPayment (..), User (..), UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Util.List as L + +data In t = In + { _in_users :: [User] + , _in_currency :: Currency + , _in_header :: PaymentHeader + , _in_paymentCount :: Int + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = + R.divClass "g-HeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) + + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) + + where + header = _in_header input + +exceedingPayers + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> [ExceedingPayer] + -> m () +exceedingPayers users currency payers = + R.divClass "g-HeaderInfos__ExceedingPayers" $ + flip mapM_ payers $ \payer -> + R.elClass "span" "exceedingPayer" $ do + R.elClass "span" "userName" $ + R.text $ + fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users + R.elClass "span" "amount" $ do + R.text "+ " + R.text . Format.price currency $ _exceedingPayer_amount payer + +infos + :: forall t m. MonadWidget t m + => [User] + -> Currency + -> Map UserId Int + -> Int + -> m () +infos users currency repartition paymentCount = + R.divClass "g-HeaderInfos__Repartition" $ do + + R.elClass "span" "total" $ do + R.text $ + Msg.get $ Msg.Payment_Worth + (T.intercalate " " + [ (Format.number paymentCount) + , if paymentCount > 1 + then Msg.get Msg.Payment_Many + else Msg.get Msg.Payment_One + ]) + (Format.price currency (M.foldl (+) 0 repartition)) + + R.elClass "span" "partition" . R.text $ + let totalByUser = + L.sortBy (\(_, t1) (_, t2) -> compare t2 t1) + . M.toList + $ repartition + in T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) -> + Msg.get $ Msg.Payment_By + (fromMaybe "" . fmap _user_name $ CM.findUser userId users) + (Format.price currency userTotal) diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs deleted file mode 100644 index d9f85c8..0000000 --- a/client/src/View/Payment/Init.hs +++ /dev/null @@ -1,13 +0,0 @@ -module View.Payment.Init - ( Init(..) - ) where - -import Common.Model (Category, Income, Payment, PaymentCategory, User) - -data Init = Init - { _init_users :: [User] - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - } deriving (Show) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index bf0186f..f47b627 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -3,29 +3,29 @@ module View.Payment.Payment , In(..) ) where -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime) -import Prelude hiding (init) -import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User, UserId) -import qualified Common.Util.Text as T - -import qualified Component.Pages as Pages -import Loadable (Loadable (..)) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime) +import Prelude hiding (init) +import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Frequency, Income (..), + Payment (..), PaymentCategory (..), + PaymentId, PaymentPage (..), + SavedPayment (..), User, UserId) +import qualified Common.Util.Text as T + +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) import qualified Loadable -import qualified Util.Ajax as AjaxUtil -import qualified Util.Reflex as ReflexUtil -import qualified View.Payment.Header as Header -import View.Payment.Init (Init (..)) -import qualified View.Payment.Reducer as Reducer -import qualified View.Payment.Table as Table +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderInfos as HeaderInfos +-- import qualified View.Payment.HeaderForm as HeaderForm +import qualified View.Payment.Reducer as Reducer +import qualified View.Payment.Table as Table data In t = In { _in_currentUser :: UserId @@ -61,7 +61,14 @@ view input = do deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do + flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do + HeaderInfos.view $ HeaderInfos.In + { HeaderInfos._in_users = _in_users input + , HeaderInfos._in_currency = _in_currency input + , HeaderInfos._in_header = header + , HeaderInfos._in_paymentCount = count + } + table <- Table.view $ Table.In { Table._in_users = _in_users input , Table._in_currentUser = _in_currentUser input diff --git a/common/common.cabal b/common/common.cabal index 4a6d728..75d6cc8 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -59,6 +59,7 @@ Library Common.Model.EditIncome Common.Model.EditIncomeForm Common.Model.EditPaymentForm + Common.Model.ExceedingPayer Common.Model.Frequency Common.Model.Income Common.Model.IncomeHeader @@ -67,4 +68,5 @@ Library Common.Model.InitResult Common.Model.Payer Common.Model.PaymentCategory + Common.Model.PaymentHeader Common.Model.PaymentPage diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index bc626d5..fdeac36 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -10,6 +10,7 @@ import Common.Model.EditIncome as X import Common.Model.EditIncomeForm as X import Common.Model.EditPaymentForm as X import Common.Model.Email as X +import Common.Model.ExceedingPayer as X import Common.Model.Frequency as X import Common.Model.Income as X import Common.Model.IncomeHeader as X @@ -19,6 +20,7 @@ import Common.Model.InitResult as X import Common.Model.Payer as X import Common.Model.Payment as X import Common.Model.PaymentCategory as X +import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X import Common.Model.SavedPayment as X import Common.Model.SignInForm as X diff --git a/common/src/Common/Model/ExceedingPayer.hs b/common/src/Common/Model/ExceedingPayer.hs new file mode 100644 index 0000000..171b6ff --- /dev/null +++ b/common/src/Common/Model/ExceedingPayer.hs @@ -0,0 +1,16 @@ +module Common.Model.ExceedingPayer + ( ExceedingPayer(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.User (UserId) + +data ExceedingPayer = ExceedingPayer + { _exceedingPayer_userId :: UserId + , _exceedingPayer_amount :: Int + } deriving (Show, Generic) + +instance FromJSON ExceedingPayer +instance ToJSON ExceedingPayer diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs index 3c816c8..39a5788 100644 --- a/common/src/Common/Model/Payer.hs +++ b/common/src/Common/Model/Payer.hs @@ -1,19 +1,19 @@ module Common.Model.Payer - ( ExceedingPayer(..) - , getExceedingPayers + ( getExceedingPayers , useIncomesFrom , cumulativeIncomesSince ) where -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time -import Data.Time.Calendar (Day) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time +import Data.Time.Calendar (Day) -import Common.Model.Income (Income (..)) -import Common.Model.Payment (Payment (..)) -import Common.Model.User (User (..), UserId) +import Common.Model.ExceedingPayer (ExceedingPayer (..)) +import Common.Model.Income (Income (..)) +import Common.Model.Payment (Payment (..)) +import Common.Model.User (User (..), UserId) data Payer = Payer { _payer_userId :: UserId @@ -29,11 +29,6 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -data ExceedingPayer = ExceedingPayer - { _exceedingPayer_userId :: UserId - , _exceedingPayer_amount :: Int - } deriving (Show) - getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] getExceedingPayers currentTime users incomes payments = let userIds = map _user_id users diff --git a/common/src/Common/Model/PaymentHeader.hs b/common/src/Common/Model/PaymentHeader.hs new file mode 100644 index 0000000..a522cd8 --- /dev/null +++ b/common/src/Common/Model/PaymentHeader.hs @@ -0,0 +1,18 @@ +module Common.Model.PaymentHeader + ( PaymentHeader(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import GHC.Generics (Generic) + +import Common.Model.ExceedingPayer (ExceedingPayer) +import Common.Model.User (UserId) + +data PaymentHeader = PaymentHeader + { _paymentHeader_exceedingPayers :: [ExceedingPayer] + , _paymentHeader_repartition :: Map UserId Int + } deriving (Show, Generic) + +instance FromJSON PaymentHeader +instance ToJSON PaymentHeader diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 31039c7..76c7511 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -7,9 +7,11 @@ import GHC.Generics (Generic) import Common.Model.Payment (Payment) import Common.Model.PaymentCategory (PaymentCategory) +import Common.Model.PaymentHeader (PaymentHeader) data PaymentPage = PaymentPage - { _paymentPage_payments :: [Payment] + { _paymentPage_header :: PaymentHeader + , _paymentPage_payments :: [Payment] , _paymentPage_paymentCategories :: [PaymentCategory] , _paymentPage_totalCount :: Int } deriving (Show, Generic) diff --git a/server/server.cabal b/server/server.cabal index b170a18..b4d9e08 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -80,12 +80,8 @@ Executable server Design.View.NotFound Design.View.Pages Design.View.Payment - Design.View.Payment.Add - Design.View.Payment.Delete Design.View.Payment.Form Design.View.Payment.Header - Design.View.Payment.Pages - Design.View.Payment.Table Design.View.SignIn Design.View.Stat Design.View.Table @@ -117,6 +113,7 @@ Executable server Resource Secure SendMail + Util.List Util.Time Validation.Income Validation.Payment diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 01702cb..f685f2e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,6 +1,5 @@ module Controller.Payment - ( deprecatedList - , list + ( list , listPaymentCategories , create , edit @@ -8,48 +7,69 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status -import Web.Scotty hiding (delete) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), - Payment (..), PaymentId, - PaymentPage (..), + Frequency (Punctual), + Payment (..), PaymentHeader (..), + PaymentId, PaymentPage (..), SavedPayment (..), User (..)) +import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreatePayment (CreatePayment (..)) import Model.EditPayment (EditPayment (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import qualified Persistence.User as UserPersistence import qualified Secure +import qualified Util.List as L import qualified Validation.Payment as PaymentValidation -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentPersistence.listActive) >>= json - ) - list :: Int -> Int -> ActionM () list page perPage = - Secure.loggedAction (\_ -> + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do count <- PaymentPersistence.count payments <- PaymentPersistence.listActivePage page perPage paymentCategories <- PaymentCategoryPersistence.list - return $ PaymentPage payments paymentCategories count - ) >>= json + + users <- UserPersistence.list + incomes <- IncomePersistence.listAll + allPayments <- PaymentPersistence.listActive Punctual + + let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + + repartition = + M.fromList + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ allPayments + + header = PaymentHeader + { _paymentHeader_exceedingPayers = exceedingPayers + , _paymentHeader_repartition = repartition + } + + return $ PaymentPage header payments paymentCategories count) >>= S.json ) listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json + (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -100,7 +120,7 @@ delete paymentId = _ -> return False if deleted then - status Status.ok200 + S.status Status.ok200 else - status Status.badRequest400 + S.status Status.badRequest400 ) diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index 4020eb0..1195e10 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -3,11 +3,9 @@ module Design.Modal ) where import Clay -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) -import qualified Design.View.Payment.Add as Add -import qualified Design.View.Payment.Delete as Delete -import qualified Design.View.Payment.Form as Form +import qualified Design.View.Payment.Form as Form design :: Css design = do @@ -47,9 +45,7 @@ design = do sym borderRadius (px 5) boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15) - ".add" ? Add.design ".form" ? Form.design - ".delete" ? Delete.design ".paymentModal" & do ".radioGroup" ? ".title" ? display none diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 0d59fa0..27b4ef3 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -5,11 +5,7 @@ module Design.View.Payment import Clay import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Pages as Pages -import qualified Design.View.Payment.Table as Table design :: Css design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design + ".g-HeaderInfos" ? Header.design diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs deleted file mode 100644 index f3d7e3f..0000000 --- a/server/src/Design/View/Payment/Delete.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.View.Payment.Delete - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper - -design :: Css -design = do - ".deleteHeader" ? do - backgroundColor Color.chestnutRose - fontSize (px 18) - color Color.white - sym padding (px 20) - textAlign (alignSide sideCenter) - borderRadius (px 5) (px 5) (px 0) (px 0) - - ".deleteContent" ? do - sym padding (px 20) - - ".buttons" ? do - display flex - justifyContent spaceAround - marginTop (em 1.5) - - ".confirm" ? - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - ".undo" ? - Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten - - (".confirm" <> ".undo") ? - width (px 90) diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 9111374..49c1a09 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -8,45 +8,36 @@ import Clay import qualified Design.Color as Color import qualified Design.Constants as Constants -import qualified Design.Helper as Helper import qualified Design.Media as Media design :: Css design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) marginLeft (pct Constants.blockPercentMargin) marginRight (pct Constants.blockPercentMargin) - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex + ".g-HeaderInfos__ExceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) marginBottom (em 1) - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) + Media.mobile $ do + textAlign (alignSide sideCenter) - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) + ".userName" ? marginRight (px 8) - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) + -- ".addPayment" ? do + -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + -- Media.mobile $ width (pct 100) - ".searchLine" ? do + ".g-HeaderForm" ? do marginBottom (em 1) Media.mobile $ textAlign (alignSide sideCenter) @@ -62,7 +53,7 @@ design = do ".selectInput" ? do Media.tabletDesktop $ display inlineBlock - ".infos" ? do + ".g-HeaderInfos__Repartition" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) Media.mobile $ lineHeight (px 25) diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs deleted file mode 100644 index 2028c1b..0000000 --- a/server/src/Design/View/Payment/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Design.View.Payment.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Helper as Helper -import qualified Design.Media as Media - -design :: Css -design = do - display flex - justifyContent center - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - svg ? "path" ? ("fill" -: Color.toString Color.dustyGray) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs deleted file mode 100644 index 67828c9..0000000 --- a/server/src/Design/View/Payment/Table.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.View.Payment.Table - ( design - ) where - -import Clay - -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 5c9e307..d36a728 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -20,7 +20,7 @@ import qualified Design.View.Table as Table design :: Css design = do header ? Header.design - ".payment" ? Payment.design + Payment.design ".signIn" ? SignIn.design ".stat" ? Stat.design ".notfound" ? NotFound.design diff --git a/server/src/Main.hs b/server/src/Main.hs index a4d8635..5068d10 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -41,9 +41,6 @@ main = do S.get "/api/users"$ User.list - S.get "/api/deprecated/payments" $ - Payment.deprecatedList - S.get "/api/payments" $ do page <- S.param "page" perPage <- S.param "perPage" diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index e01753f..7835c98 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -89,11 +89,14 @@ firstPunctualDay = (Only (FrequencyField Punctual)) ) -listActive :: Query [Payment] -listActive = +listActive :: Frequency -> Query [Payment] +listActive frequency = Query (\conn -> do map (\(Row p) -> p) <$> - SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + SQLite.query + conn + "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?" + (Only (FrequencyField frequency)) ) listActivePage :: Int -> Int -> Query [Payment] @@ -102,8 +105,16 @@ listActivePage page perPage = map (\(Row p) -> p) <$> SQLite.query conn - "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" - (perPage, (page - 1) * perPage) + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY date DESC" + , "LIMIT ?" + , "OFFSET ?" + ] + ) + (FrequencyField Punctual, perPage, (page - 1) * perPage) ) listPunctual :: Query [Payment] diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs new file mode 100644 index 0000000..4e22ba8 --- /dev/null +++ b/server/src/Util/List.hs @@ -0,0 +1,13 @@ +module Util.List + ( groupBy + ) where + +import Control.Arrow ((&&&)) +import Data.Function (on) +import qualified Data.List as L + +groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] +groupBy f = + map (f . head &&& id) + . L.groupBy ((==) `on` f) + . L.sortBy (compare `on` f) -- cgit v1.2.3 From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 18:08:28 +0100 Subject: Optimize and refactor payments --- client/src/Loadable.hs | 3 +- client/src/Util/Ajax.hs | 5 +- client/src/Util/Either.hs | 2 +- client/src/Util/List.hs | 13 -- client/src/View/Payment/Form.hs | 52 +++---- client/src/View/Payment/HeaderForm.hs | 69 +++++---- client/src/View/Payment/HeaderInfos.hs | 28 ++-- client/src/View/Payment/Payment.hs | 177 ++++----------------- client/src/View/Payment/Reducer.hs | 83 ++++++++-- client/src/View/Payment/Table.hs | 31 ++-- common/common.cabal | 3 - common/src/Common/Message/Translation.hs | 2 +- common/src/Common/Model.hs | 3 - common/src/Common/Model/Payer.hs | 202 ------------------------ common/src/Common/Model/Payment.hs | 2 + common/src/Common/Model/PaymentCategory.hs | 25 --- common/src/Common/Model/PaymentPage.hs | 17 +- common/src/Common/Model/SavedPayment.hs | 17 -- common/src/Common/Util/Text.hs | 1 + default.nix | 2 + server/migrations/2.sql | 21 +++ server/server.cabal | 6 +- server/src/Controller/Category.hs | 27 ++-- server/src/Controller/Income.hs | 17 +- server/src/Controller/Payment.hs | 137 ++++++++--------- server/src/Design/Form.hs | 1 - server/src/Design/View/Payment.hs | 6 +- server/src/Design/View/Payment/Header.hs | 68 -------- server/src/Design/View/Payment/HeaderForm.hs | 40 +++++ server/src/Design/View/Payment/HeaderInfos.hs | 50 ++++++ server/src/Job/WeeklyReport.hs | 23 ++- server/src/Main.hs | 14 +- server/src/Model/SignIn.hs | 4 +- server/src/Payer.hs | 170 ++++++++++++++++++++ server/src/Persistence/Category.hs | 10 +- server/src/Persistence/Income.hs | 59 ++++++- server/src/Persistence/Payment.hs | 214 +++++++++++++++++++------- server/src/Persistence/PaymentCategory.hs | 89 ----------- server/src/Persistence/User.hs | 4 +- server/src/Util/List.hs | 13 -- server/src/View/Mail/WeeklyReport.hs | 22 +-- 41 files changed, 823 insertions(+), 909 deletions(-) delete mode 100644 client/src/Util/List.hs delete mode 100644 common/src/Common/Model/Payer.hs delete mode 100644 common/src/Common/Model/PaymentCategory.hs delete mode 100644 common/src/Common/Model/SavedPayment.hs delete mode 100644 server/src/Design/View/Payment/Header.hs create mode 100644 server/src/Design/View/Payment/HeaderForm.hs create mode 100644 server/src/Design/View/Payment/HeaderInfos.hs create mode 100644 server/src/Payer.hs delete mode 100644 server/src/Persistence/PaymentCategory.hs delete mode 100644 server/src/Util/List.hs diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index f57b99c..2b9008a 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -16,6 +16,7 @@ data Loadable t = Loading | Error Text | Loaded t + deriving Show instance Functor Loadable where fmap f Loading = Loading @@ -46,6 +47,6 @@ fromEvent = Loading view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) -view _ (Loading) = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing +view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing view _ (Error e) = R.text e >> return Nothing view f (Loaded x) = Just <$> f x diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 47f4f3c..dc56701 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -16,6 +16,7 @@ import qualified Data.Map.Lazy as LM import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Time.Clock (NominalDiffTime) import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, XhrRequest, XhrRequestConfig (..), XhrResponse, @@ -28,7 +29,9 @@ import qualified Loadable getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a)) getNow url = do postBuild <- R.getPostBuild - get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent + get (url <$ postBuild) + >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise + >>= Loadable.fromEvent get :: forall t m a. (MonadWidget t m, FromJSON a) diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs index 2910d95..e76bc8a 100644 --- a/client/src/Util/Either.hs +++ b/client/src/Util/Either.hs @@ -2,6 +2,6 @@ module Util.Either ( eitherToMaybe ) where -eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe :: forall a b. Either a b -> Maybe b eitherToMaybe (Right b) = Just b eitherToMaybe _ = Nothing diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs deleted file mode 100644 index 4e22ba8..0000000 --- a/client/src/Util/List.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Util.List - ( groupBy - ) where - -import Control.Arrow ((&&&)) -import Data.Function (on) -import qualified Data.List as L - -groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] -groupBy f = - map (f . head &&& id) - . L.groupBy ((==) `on` f) - . L.sortBy (compare `on` f) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 99b0848..6c3c1e8 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -4,6 +4,7 @@ module View.Payment.Form , Operation(..) ) where +import Control.Monad (join) import Control.Monad.IO.Class (liftIO) import Data.Aeson (Value) import qualified Data.Aeson as Aeson @@ -13,6 +14,7 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar import qualified Data.Time.Clock as Clock @@ -25,9 +27,7 @@ import qualified Text.Read as T import Common.Model (Category (..), CategoryId, CreatePaymentForm (..), EditPaymentForm (..), - Frequency (..), Payment (..), - PaymentCategory (..), - SavedPayment (..)) + Frequency (..), Payment (..)) import qualified Common.Msg as Msg import qualified Common.Util.Time as TimeUtil import qualified Common.Validation.Payment as PaymentValidation @@ -37,20 +37,20 @@ import qualified Component.Modal as Modal import qualified Component.ModalForm as ModalForm import qualified Component.Select as Select import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil -data In = In - { _in_categories :: [Category] - , _in_paymentCategories :: [PaymentCategory] - , _in_operation :: Operation +data In t = In + { _in_categories :: [Category] + , _in_operation :: Operation t } -data Operation - = New Frequency +data Operation t + = New (Dynamic t Frequency) | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment view input cancel = do rec let reset = R.leftmost @@ -105,9 +105,10 @@ view input cancel = do (d <$ reset) confirm) - let setCategory = - R.fmapMaybe id . R.updated $ - R.ffor (Input._out_raw name) findCategory + setCategory <- + R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) + >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) category <- Select._out_value <$> (Select.view $ Select.In { Select._in_label = Msg.get Msg.Payment_Category @@ -124,12 +125,13 @@ view input cancel = do c <- cost d <- date cat <- category + f <- frequency return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success frequency) + <*> V.Success f) frequencies = M.fromList @@ -140,6 +142,12 @@ view input cancel = do categories = M.fromList . flip map (_in_categories input) $ \c -> (_category_id c, _category_name c) + category = + case op of + New _ -> -1 + Clone p -> _payment_category p + Edit p -> _payment_category p + op = _in_operation input name = @@ -162,17 +170,11 @@ view input cancel = do Clone p -> currentDay Edit p -> _payment_date p - category = - case op of - New _ -> -1 - Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) - Edit p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p) - frequency = case op of New f -> f - Clone p -> _payment_frequency p - Edit p -> _payment_frequency p + Clone p -> R.constDyn $ _payment_frequency p + Edit p -> R.constDyn $ _payment_frequency p headerLabel = case op of @@ -189,9 +191,3 @@ view input cancel = do case op of Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e - - findCategory :: Text -> Maybe CategoryId - findCategory paymentName = - fmap _paymentCategory_category - . L.find ((==) (T.toLower paymentName) . _paymentCategory_name) - $ (_in_paymentCategories input) diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 07a6b81..c8ca4d9 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -1,5 +1,7 @@ module View.Payment.HeaderForm ( view + , In(..) + , Out(..) ) where import qualified Data.Map as M @@ -8,10 +10,8 @@ import qualified Data.Validation as V import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category, Currency, ExceedingPayer (..), - Frequency (..), Income (..), Payment (..), - PaymentCategory, SavedPayment (..), - User (..)) +import Common.Model (Category, Currency, Frequency (..), + Income (..), Payment (..), User (..)) import qualified Common.Msg as Msg import qualified Component.Button as Button @@ -21,39 +21,43 @@ import qualified Component.Select as Select import qualified View.Payment.Form as Form data In t = In - { _in_reset :: Event t () - , _in_categories :: [Category] - , _in_paymentCategories :: [PaymentCategory] + { _in_reset :: Event t () + , _in_categories :: [Category] } -data Out = Out - { _out_name :: Event t Text +data Out t = Out + { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t SavedPayment + , _out_addPayment :: Event t Payment } view :: forall t m. MonadWidget t m => In t -> m (Out t) -view input = do - R.divClass "g-HeaderForm" $ do - searchName <- Input._out_raw <$> (Input.view - ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) - ("" <$ _in_reset input) - R.never) +view input = + R.divClass "g-PaymentHeaderForm" $ do - let frequencies = M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] + (searchName, frequency) <- R.el "div" $ do - searchFrequency <- Select._out_raw <$> (Select.view $ Select.In - { Select._in_label = "" - , Select._in_initialValue = Punctual - , Select._in_value = R.never - , Select._in_values = R.constDyn frequencies - , Select._in_reset = R.never - , Select._in_isValid = V.Success - , Select._in_validate = R.never - }) + searchName <- Input._out_raw <$> (Input.view + ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name }) + ("" <$ _in_reset input) + R.never) + + let frequencies = M.fromList + [ (Punctual, Msg.get Msg.Payment_PunctualMale) + , (Monthly, Msg.get Msg.Payment_MonthlyMale) + ] + + frequency <- Select._out_raw <$> (Select.view $ Select.In + { Select._in_label = "" + , Select._in_initialValue = Punctual + , Select._in_value = R.never + , Select._in_values = R.constDyn frequencies + , Select._in_reset = R.never + , Select._in_isValid = V.Success + , Select._in_validate = R.never + }) + + return (searchName, frequency) addPaymentButton <- Button._out_clic <$> (Button.view $ @@ -66,13 +70,12 @@ view input = do , Modal._in_content = Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input - , Form._in_operation = Form.New searchFrequency + , Form._in_operation = Form.New frequency } } return $ Out - { _out_name = searchName - , _out_frequency = searchFrequency + { _out_search = R.updated searchName + , _out_frequency = R.updated frequency , _out_addPayment = addPayment } diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs index 12facc4..f84ee1f 100644 --- a/client/src/View/Payment/HeaderInfos.hs +++ b/client/src/View/Payment/HeaderInfos.hs @@ -16,13 +16,11 @@ import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), Payment (..), PaymentHeader (..), - SavedPayment (..), User (..), UserId) + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import qualified Util.List as L - data In t = In { _in_users :: [User] , _in_currency :: Currency @@ -32,17 +30,17 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = - R.divClass "g-HeaderInfos" $ do - exceedingPayers - (_in_users input) - (_in_currency input) - (_paymentHeader_exceedingPayers header) + R.divClass "g-PaymentHeaderInfos" $ do + exceedingPayers + (_in_users input) + (_in_currency input) + (_paymentHeader_exceedingPayers header) - infos - (_in_users input) - (_in_currency input) - (_paymentHeader_repartition header) - (_in_paymentCount input) + infos + (_in_users input) + (_in_currency input) + (_paymentHeader_repartition header) + (_in_paymentCount input) where header = _in_header input @@ -54,7 +52,7 @@ exceedingPayers -> [ExceedingPayer] -> m () exceedingPayers users currency payers = - R.divClass "g-HeaderInfos__ExceedingPayers" $ + R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $ flip mapM_ payers $ \payer -> R.elClass "span" "exceedingPayer" $ do R.elClass "span" "userName" $ @@ -72,7 +70,7 @@ infos -> Int -> m () infos users currency repartition paymentCount = - R.divClass "g-HeaderInfos__Repartition" $ do + R.divClass "g-PaymentHeaderInfos__Repartition" $ do R.elClass "span" "total" $ do R.text $ diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index f47b627..6bc1614 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -3,6 +3,7 @@ module View.Payment.Payment , In(..) ) where +import Control.Monad.IO.Class (liftIO) import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -12,9 +13,8 @@ import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex) import qualified Reflex.Dom as R import Common.Model (Currency, Frequency, Income (..), - Payment (..), PaymentCategory (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User, UserId) + Payment (..), PaymentId, + PaymentPage (..), User, UserId) import qualified Common.Util.Text as T import qualified Component.Pages as Pages @@ -22,8 +22,8 @@ import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil +import qualified View.Payment.HeaderForm as HeaderForm import qualified View.Payment.HeaderInfos as HeaderInfos --- import qualified View.Payment.HeaderForm as HeaderForm import qualified View.Payment.Reducer as Reducer import qualified View.Payment.Table as Table @@ -36,15 +36,16 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categoriesEvent <- (AjaxUtil.getNow "api/categories") + categories <- AjaxUtil.getNow "api/categories" - R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do + R.dyn . R.ffor categories . Loadable.view $ \categories -> do rec payments <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = newPage - , Reducer._in_currentPage = currentPage - , Reducer._in_addPayment = R.leftmost [headerAddPayment, tableAddPayment] + { Reducer._in_page = page + , Reducer._in_search = HeaderForm._out_search form + , Reducer._in_frequency = HeaderForm._out_frequency form + , Reducer._in_addPayment = addPayment , Reducer._in_editPayment = editPayment , Reducer._in_deletePayment = deletePayment } @@ -52,16 +53,25 @@ view input = do let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - currentPage <- R.holdDyn 1 newPage - -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) - let headerAddPayment = R.never + let addPayment = + R.leftmost + [ tableAddPayment + , HeaderForm._out_addPayment form + ] + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do + form <- HeaderForm.view $ HeaderForm.In + { HeaderForm._in_reset = () <$ addPayment + , HeaderForm._in_categories = categories + } + + result <- R.dyn . R.ffor payments $ + Loadable.view $ \(PaymentPage page header payments count) -> do + HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input , HeaderInfos._in_currency = _in_currency input @@ -75,13 +85,12 @@ view input = do , Table._in_categories = categories , Table._in_currency = _in_currency input , Table._in_payments = payments - , Table._in_paymentCategories = paymentCategories } pages <- Pages.view $ Pages.In { Pages._in_total = R.constDyn count , Pages._in_perPage = Reducer.perPage - , Pages._in_page = p + , Pages._in_page = page } return ((), table, pages) @@ -89,137 +98,3 @@ view input = do return () return () - - --- view :: forall t m. MonadWidget t m => In t -> m () --- view input = do --- R.dyn . R.ffor (_in_init input) . Loadable.view $ \init -> --- --- R.elClass "main" "payment" $ do --- rec --- let addPayment = R.leftmost --- -- [ Header._out_addPayment header --- [ Table2._out_addPayment table --- ] --- --- paymentsPerPage = 7 --- --- payments <- reducePayments --- (_init_payments init) --- (_savedPayment_payment <$> addPayment) --- (_savedPayment_payment <$> Table2._out_editPayment table) --- (Table2._out_deletePayment table) --- --- paymentCategories <- reducePaymentCategories --- (_init_paymentCategories init) --- payments --- (_savedPayment_paymentCategory <$> addPayment) --- (_savedPayment_paymentCategory <$> Table2._out_editPayment table) --- (Table2._out_deletePayment table) --- --- -- (searchNameEvent, searchName) <- --- -- debounceSearchName (Header._out_searchName header) --- --- -- let searchPayments = --- -- getSearchPayments searchName (Header._out_searchFrequency header) payments --- --- -- header <- Header.view $ Header.In --- -- { Header._in_init = init --- -- , Header._in_currency = _in_currency input --- -- , Header._in_payments = payments --- -- , Header._in_searchPayments = searchPayments --- -- , Header._in_paymentCategories = paymentCategories --- -- } --- --- table <- Table2.view $ Table2.In --- { Table2._in_init = init --- , Table2._in_currency = _in_currency input --- , Table2._in_currentUser = _in_currentUser input --- , Table2._in_currentPage = Pages2._out_currentPage pages --- , Table2._in_payments = payments --- , Table2._in_perPage = paymentsPerPage --- , Table2._in_paymentCategories = paymentCategories --- } --- --- pages <- Pages2.view $ Pages2.In --- { Pages2._in_total = length <$> payments --- , Pages2._in_perPage = paymentsPerPage --- , Pages2._in_reset = R.never --- -- [ () <$ searchNameEvent --- -- [ () <$ Header._out_addPayment header --- -- ] --- } --- --- pure () --- --- return () --- --- -- debounceSearchName --- -- :: forall t m. MonadWidget t m --- -- => Dynamic t Text --- -- -> m (Event t Text, Dynamic t Text) --- -- debounceSearchName searchName = do --- -- event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName) --- -- dynamic <- R.holdDyn "" event --- -- return (event, dynamic) --- --- reducePayments --- :: forall t m. MonadWidget t m --- => [Payment] --- -> Event t Payment -- add payment --- -> Event t Payment -- edit payment --- -> Event t Payment -- delete payment --- -> m (Dynamic t [Payment]) --- reducePayments initPayments addPayment editPayment deletePayment = --- R.foldDyn id initPayments $ R.leftmost --- [ (:) <$> addPayment --- , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id)) --- , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id)) --- ] --- --- reducePaymentCategories --- :: forall t m. MonadWidget t m --- => [PaymentCategory] --- -> Dynamic t [Payment] -- payments --- -> Event t PaymentCategory -- add payment category --- -> Event t PaymentCategory -- edit payment category --- -> Event t Payment -- delete payment --- -> m (Dynamic t [PaymentCategory]) --- reducePaymentCategories --- initPaymentCategories --- payments --- addPaymentCategory --- editPaymentCategory --- deletePayment --- = --- R.foldDyn id initPaymentCategories $ R.leftmost --- [ (:) <$> addPaymentCategory --- , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name)) --- , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name)) --- ] --- where --- deletePaymentName = --- R.attachWithMaybe --- (\ps p -> --- if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then --- Nothing --- else --- Just (_payment_name p)) --- (R.current payments) --- deletePayment --- lowerName = T.toLower . _payment_name --- --- -- getSearchPayments --- -- :: forall t. Reflex t --- -- => Dynamic t Text --- -- -> Dynamic t Frequency --- -- -> Dynamic t [Payment] --- -- -> Dynamic t [Payment] --- -- getSearchPayments name frequency payments = do --- -- n <- name --- -- f <- frequency --- -- ps <- payments --- -- pure $ flip filter ps (\p -> --- -- ( (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p)) --- -- && (_payment_frequency p == f) --- -- )) diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 0c70f8a..0b6c041 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -2,14 +2,16 @@ module View.Payment.Reducer ( perPage , reducer , In(..) + , Params(..) ) where import Data.Text (Text) import qualified Data.Text as T +import Data.Time (NominalDiffTime) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (PaymentPage) +import Common.Model (Frequency (..), PaymentPage) import Loadable (Loadable (..)) import qualified Loadable as Loadable @@ -19,48 +21,99 @@ perPage :: Int perPage = 7 data In t a b c = In - { _in_newPage :: Event t Int - , _in_currentPage :: Dynamic t Int + { _in_page :: Event t Int + , _in_search :: Event t Text + , _in_frequency :: Event t Frequency , _in_addPayment :: Event t a , _in_editPayment :: Event t b , _in_deletePayment :: Event t c } data Action - = LoadPage Int + = LoadPage | GetResult (Either Text PaymentPage) +data Params = Params + { _params_page :: Int + , _params_search :: Text + , _params_frequency :: Frequency + } deriving (Show) + +initParams = Params 1 "" Punctual + +data Msg + = Page Int + | Search Text + | Frequency Common.Model.Frequency + | ResetSearch + deriving Show + reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) reducer input = do postBuild <- R.getPostBuild - let loadPage = + debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input) + + params <- R.foldDynMaybe + (\msg params -> case msg of + Page page -> + Just $ params { _params_page = page } + + Search "" -> + if _params_search params == "" then + Nothing + + else + Just $ initParams { _params_frequency = _params_frequency params } + + Search search -> + Just $ params { _params_search = search, _params_page = _params_page initParams } + + Frequency frequency -> + Just $ params { _params_frequency = frequency } + + ResetSearch -> + Just $ initParams { _params_frequency = _params_frequency params } + ) + initParams + (R.leftmost + [ Page <$> _in_page input + , Search <$> debouncedSearch + , Frequency <$> _in_frequency input + , ResetSearch <$ _in_addPayment input + ]) + + let paramsEvent = R.leftmost - [ 1 <$ postBuild - , _in_newPage input - , 1 <$ _in_addPayment input - , R.tag (R.current $ _in_currentPage input) (_in_editPayment input) - , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input) + [ initParams <$ postBuild + , R.updated params + , R.tag (R.current params) (_in_editPayment input) + , R.tag (R.current params) (_in_deletePayment input) ] - getResult <- AjaxUtil.get $ fmap pageUrl loadPage + getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) + R.foldDyn (\action _ -> case action of - LoadPage _ -> Loading + LoadPage -> Loading GetResult (Left err) -> Error err GetResult (Right payments) -> Loaded payments ) Loading (R.leftmost - [ LoadPage <$> loadPage + [ LoadPage <$ paramsEvent , GetResult <$> getResult ]) where - pageUrl p = + pageUrl (Params page search frequency) = "api/payments?page=" - <> (T.pack . show $ p) + <> (T.pack . show $ page) <> "&perPage=" <> (T.pack . show $ perPage) + <> "&search=" + <> search + <> "&frequency=" + <> (T.pack $ show frequency) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index dde5168..59ac890 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -13,7 +13,6 @@ import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Category (..), Currency, Payment (..), - PaymentCategory (..), SavedPayment, User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -26,17 +25,16 @@ import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form data In t = In - { _in_users :: [User] - , _in_currentUser :: UserId - , _in_categories :: [Category] - , _in_currency :: Currency - , _in_payments :: [Payment] - , _in_paymentCategories :: [PaymentCategory] + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_categories :: [Category] + , _in_currency :: Currency + , _in_payments :: [Payment] } data Out t = Out - { _out_add :: Event t SavedPayment - , _out_edit :: Event t SavedPayment + { _out_add :: Event t Payment + , _out_edit :: Event t Payment , _out_delete :: Event t Payment } @@ -50,18 +48,15 @@ view input = do cell (_in_users input) (_in_categories input) - (_in_paymentCategories input) (_in_currency input) , Table._in_cloneModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input , Form._in_operation = Form.Clone payment } , Table._in_editModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input - , Form._in_paymentCategories = _in_paymentCategories input , Form._in_operation = Form.Edit payment } , Table._in_deleteModal = \payment -> @@ -101,12 +96,11 @@ cell :: forall t m. MonadWidget t m => [User] -> [Category] - -> [PaymentCategory] -> Currency -> Header -> Payment -> m () -cell users categories paymentCategories currency header payment = +cell users categories currency header payment = case header of NameHeader -> R.text $ _payment_name payment @@ -120,7 +114,7 @@ cell users categories paymentCategories currency header payment = CategoryHeader -> let category = - findCategory categories paymentCategories (_payment_name payment) + L.find ((== (_payment_category payment)) . _category_id) categories attrs = case category of @@ -144,10 +138,3 @@ cell users categories paymentCategories currency header payment = R.elClass "span" "longDate" $ R.text . Format.longDay . _payment_date $ payment - -findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category -findCategory categories paymentCategories paymentName = do - paymentCategory <- L.find - ((== T.toLower paymentName) . _paymentCategory_name) - paymentCategories - L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/common/common.cabal b/common/common.cabal index 75d6cc8..17a0ee1 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -35,7 +35,6 @@ Library Common.Model.CreatePaymentForm Common.Model.Email Common.Model.Payment - Common.Model.SavedPayment Common.Model.SignInForm Common.Model.User Common.Msg @@ -66,7 +65,5 @@ Library Common.Model.IncomePage Common.Model.Init Common.Model.InitResult - Common.Model.Payer - Common.Model.PaymentCategory Common.Model.PaymentHeader Common.Model.PaymentPage diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 25e9f4b..a86a371 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -702,7 +702,7 @@ m l WeeklyReport_Title = m l NotFound_Message = case l of English -> "There is nothing here!" - French -> "Vous vous êtes perdu." + French -> "Il n’y a rien à voir ici." m l NotFound_LinkMessage = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index fdeac36..00d30f6 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -17,11 +17,8 @@ import Common.Model.IncomeHeader as X import Common.Model.IncomePage as X import Common.Model.Init as X import Common.Model.InitResult as X -import Common.Model.Payer as X import Common.Model.Payment as X -import Common.Model.PaymentCategory as X import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X -import Common.Model.SavedPayment as X import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/Payer.hs b/common/src/Common/Model/Payer.hs deleted file mode 100644 index 39a5788..0000000 --- a/common/src/Common/Model/Payer.hs +++ /dev/null @@ -1,202 +0,0 @@ -module Common.Model.Payer - ( getExceedingPayers - , useIncomesFrom - , cumulativeIncomesSince - ) where - -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time -import Data.Time.Calendar (Day) - -import Common.Model.ExceedingPayer (ExceedingPayer (..)) -import Common.Model.Income (Income (..)) -import Common.Model.Payment (Payment (..)) -import Common.Model.User (User (..), UserId) - -data Payer = Payer - { _payer_userId :: UserId - , _payer_preIncomePayments :: Int - , _payer_postIncomePayments :: Int - , _payer_incomes :: [Income] - } - -data PostPaymentPayer = PostPaymentPayer - { _postPaymentPayer_userId :: UserId - , _postPaymentPayer_preIncomePayments :: Int - , _postPaymentPayer_cumulativeIncome :: Int - , _postPaymentPayer_ratio :: Float - } - -getExceedingPayers :: UTCTime -> [User] -> [Income] -> [Payment] -> [ExceedingPayer] -getExceedingPayers currentTime users incomes payments = - let userIds = map _user_id users - payers = getPayers userIds incomes payments - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - firstPayment = safeHead . List.sort . map _payment_date $ payments - mbSince = useIncomesFrom userIds incomes firstPayment - in case mbSince of - Just since -> - let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day -useIncomesFrom userIds incomes firstPayment = - case (firstPayment, incomeDefinedForAll userIds incomes) of - (Just d1, Just d2) -> Just (max d1 d2) - _ -> Nothing - -dayUTCTime :: Day -> UTCTime -dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) - -getPayers :: [UserId] -> [Income] -> [Payment] -> [Payer] -getPayers userIds incomes payments = - let incomesDefined = incomeDefinedForAll userIds incomes - in flip map userIds (\userId -> Payer - { _payer_userId = userId - , _payer_preIncomePayments = - totalPayments - (\p -> - case incomesDefined of - Just d -> - _payment_date p < d - - Nothing -> - True - ) - userId - payments - , _payer_postIncomePayments = - totalPayments - (\p -> - case incomesDefined of - Nothing -> False - Just t -> _payment_date p >= t - ) - userId - payments - , _payer_incomes = filter ((==) userId . _income_userId) incomes - } - ) - -exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] -exceedingPayersFromAmounts userAmounts = - case mbMinAmount of - Nothing -> - [] - Just minAmount -> - filter (\payer -> _exceedingPayer_amount payer > 0) - . map (\userAmount -> - ExceedingPayer - { _exceedingPayer_userId = fst userAmount - , _exceedingPayer_amount = snd userAmount - minAmount - } - ) - $ userAmounts - where mbMinAmount = safeMinimum . map snd $ userAmounts - -getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = - PostPaymentPayer - { _postPaymentPayer_userId = _payer_userId payer - , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer - , _postPaymentPayer_cumulativeIncome = cumulativeIncome - , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) - } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) - -getFinalDiff :: Float -> PostPaymentPayer -> Int -getFinalDiff maxRatio payer = - let postIncomeDiff = - truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) - in postIncomeDiff + _postPaymentPayer_preIncomePayments payer - -incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (safeHead . List.sortOn _income_date) userIncomes - in if all Maybe.isJust firstIncomes - then safeHead . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: Day -> [Income] -> [Income] -getOrderedIncomesSince since incomes = - let mbStarterIncome = getIncomeAt since incomes - orderedIncomesSince = filter (\income -> _income_date income >= since) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: Day -> [Income] -> Maybe Income -getIncomeAt day incomes = - case incomes of - [x] -> - if _income_date x < day - then Just $ x { _income_date = day } - else Nothing - x1 : x2 : xs -> - if _income_date x1 < day && _income_date x2 >= day - then Just $ x1 { _income_date = day } - else getIncomeAt day (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = dayUTCTime . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x : _) = Just x - -safeMinimum :: (Ord a) => [a] -> Maybe a -safeMinimum [] = Nothing -safeMinimum xs = Just . minimum $ xs - -safeMaximum :: (Ord a) => [a] -> Maybe a -safeMaximum [] = Nothing -safeMaximum xs = Just . maximum $ xs - -totalPayments :: (Payment -> Bool) -> UserId -> [Payment] -> Int -totalPayments paymentFilter userId payments = - sum - . map _payment_cost - . filter (\payment -> paymentFilter payment && _payment_user payment == userId) - $ payments diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index 37a090d..c232fc7 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -10,6 +10,7 @@ import Data.Time (UTCTime) import Data.Time.Calendar (Day) import GHC.Generics (Generic) +import Common.Model.Category (CategoryId) import Common.Model.Frequency import Common.Model.User (UserId) @@ -21,6 +22,7 @@ data Payment = Payment , _payment_name :: Text , _payment_cost :: Int , _payment_date :: Day + , _payment_category :: CategoryId , _payment_frequency :: Frequency , _payment_createdAt :: UTCTime , _payment_editedAt :: Maybe UTCTime diff --git a/common/src/Common/Model/PaymentCategory.hs b/common/src/Common/Model/PaymentCategory.hs deleted file mode 100644 index 2a559ce..0000000 --- a/common/src/Common/Model/PaymentCategory.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Common.Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -type PaymentCategoryId = Int64 - -data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId - , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON PaymentCategory -instance ToJSON PaymentCategory diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 76c7511..3b18bb6 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -2,18 +2,17 @@ module Common.Model.PaymentPage ( PaymentPage(..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.PaymentHeader (PaymentHeader) +import Common.Model.Payment (Payment) +import Common.Model.PaymentHeader (PaymentHeader) data PaymentPage = PaymentPage - { _paymentPage_header :: PaymentHeader - , _paymentPage_payments :: [Payment] - , _paymentPage_paymentCategories :: [PaymentCategory] - , _paymentPage_totalCount :: Int + { _paymentPage_page :: Int + , _paymentPage_header :: PaymentHeader + , _paymentPage_payments :: [Payment] + , _paymentPage_totalCount :: Int } deriving (Show, Generic) instance FromJSON PaymentPage diff --git a/common/src/Common/Model/SavedPayment.hs b/common/src/Common/Model/SavedPayment.hs deleted file mode 100644 index f45c479..0000000 --- a/common/src/Common/Model/SavedPayment.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Common.Model.SavedPayment - ( SavedPayment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) - -data SavedPayment = SavedPayment - { _savedPayment_payment :: Payment - , _savedPayment_paymentCategory :: PaymentCategory - } deriving (Show, Generic) - -instance FromJSON SavedPayment -instance ToJSON SavedPayment diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index d7f1db4..0f9c187 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,6 +1,7 @@ module Common.Util.Text ( search , formatSearch + , unaccent ) where import Data.Text (Text) diff --git a/default.nix b/default.nix index 977af02..7969fc7 100644 --- a/default.nix +++ b/default.nix @@ -4,6 +4,8 @@ let reflex-platform = import (pkgs.fetchFromGitHub { owner = "reflex-frp"; repo = "reflex-platform"; + + # Mon Jul 29 15:48:55 2019 -0400 rev = "51e02339704b7502e63bccf10a72fa4dda744b17"; sha256 = "1mkimidf755968xzbm3z222xgpdvgg6xmmrfppv1hw0rap5w53iw"; }) {}; diff --git a/server/migrations/2.sql b/server/migrations/2.sql index 1c829ec..efed046 100644 --- a/server/migrations/2.sql +++ b/server/migrations/2.sql @@ -21,3 +21,24 @@ DELETE FROM payment_category WHERE name NOT IN (SELECT DISTINCT lower(name) FROM payment); + +-- Add category id to payment table + +PRAGMA foreign_keys = 0; + +ALTER TABLE payment ADD COLUMN "category" INTEGER NOT NULL REFERENCES "category" DEFAULT -1; + +PRAGMA foreign_keys = 1; + +UPDATE + payment +SET + category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) +WHERE + EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) + +DELETE FROM payment WHERE category = -1; + +-- Remove + +DROP TABLE payment_category diff --git a/server/server.cabal b/server/server.cabal index b4d9e08..7056b3f 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -81,7 +81,8 @@ Executable server Design.View.Pages Design.View.Payment Design.View.Payment.Form - Design.View.Payment.Header + Design.View.Payment.HeaderForm + Design.View.Payment.HeaderInfos Design.View.SignIn Design.View.Stat Design.View.Table @@ -104,16 +105,15 @@ Executable server Model.Query Model.SignIn Model.UUID + Payer Persistence.Category Persistence.Frequency Persistence.Income Persistence.Payment - Persistence.PaymentCategory Persistence.User Resource Secure SendMail - Util.List Util.Time Validation.Income Validation.Payment diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index e536caa..8fbc8c8 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -5,19 +5,18 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty hiding (delete) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) -import qualified Common.Msg as Msg +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) +import qualified Common.Msg as Msg -import Json (jsonId) -import qualified Model.Query as Query -import qualified Persistence.Category as CategoryPersistence -import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import Json (jsonId) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Secure list :: ActionM () @@ -45,10 +44,8 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId - if null paymentCategories - then CategoryPersistence.delete categoryId - else return False + -- TODO: delete only if no payment has this category + CategoryPersistence.delete categoryId if deleted then status ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 127e3b3..75d0133 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,6 +1,5 @@ module Controller.Income ( list - , deprecatedList , create , edit , delete @@ -17,12 +16,12 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), Income (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) -import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query +import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -37,18 +36,18 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - firstPayment <- PaymentPersistence.firstPunctualDay - allIncomes <- IncomePersistence.listAll + paymentRange <- PaymentPersistence.getRange + allIncomes <- IncomePersistence.listAll -- TODO optimize let since = - CM.useIncomesFrom (map _user_id users) allIncomes firstPayment + Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) let byUser = case since of Just s -> M.fromList . flip map users $ \user -> ( _user_id user - , CM.cumulativeIncomesSince currentTime s $ + , Payer.cumulativeIncomesSince currentTime s $ filter ((==) (_user_id user) . _income_userId) allIncomes ) @@ -59,12 +58,6 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.listAll) >>= json - ) - create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index f685f2e..d4d086e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,75 +1,70 @@ module Controller.Payment ( list - , listPaymentCategories , create , edit , delete + , searchCategory ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) -import qualified Network.HTTP.Types.Status as Status -import Web.Scotty (ActionM) -import qualified Web.Scotty as S +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation (Failure, Success)) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (Category (..), - CreatePaymentForm (..), - EditPaymentForm (..), - Frequency (Punctual), - Payment (..), PaymentHeader (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Controller.Helper as ControllerHelper -import Model.CreatePayment (CreatePayment (..)) -import Model.EditPayment (EditPayment (..)) -import qualified Model.Query as Query -import qualified Persistence.Category as CategoryPersistence -import qualified Persistence.Income as IncomePersistence -import qualified Persistence.Payment as PaymentPersistence -import qualified Persistence.PaymentCategory as PaymentCategoryPersistence -import qualified Persistence.User as UserPersistence +import Common.Model (Category (..), CreatePaymentForm (..), + EditPaymentForm (..), Frequency, + PaymentHeader (..), PaymentId, + PaymentPage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) +import qualified Model.Query as Query +import qualified Payer as Payer +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Util.List as L -import qualified Validation.Payment as PaymentValidation +import qualified Validation.Payment as PaymentValidation -list :: Int -> Int -> ActionM () -list page perPage = +list :: Frequency -> Int -> Int -> Text -> ActionM () +list frequency page perPage search = Secure.loggedAction (\_ -> do currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do - count <- PaymentPersistence.count - payments <- PaymentPersistence.listActivePage page perPage - paymentCategories <- PaymentCategoryPersistence.list + count <- PaymentPersistence.count frequency search + payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll - allPayments <- PaymentPersistence.listActive Punctual + incomes <- IncomePersistence.listAll -- TODO optimize + + paymentRange <- PaymentPersistence.getRange + + searchRepartition <- + case paymentRange of + Just (from, to) -> + PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to) + Nothing -> + return M.empty - let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - repartition = - M.fromList - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ allPayments + let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers - , _paymentHeader_repartition = repartition + , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage header payments paymentCategories count) >>= S.json - ) - -listPaymentCategories :: ActionM () -listPaymentCategories = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json + return $ PaymentPage page header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -78,10 +73,8 @@ create form = (liftIO . Query.run $ do cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.createPayment cs form of - Success (CreatePayment name cost date category frequency) -> do - pc <- PaymentCategoryPersistence.save name category - p <- PaymentPersistence.create (_user_id user) name cost date frequency - return . Right $ SavedPayment p pc + Success (CreatePayment name cost date category frequency) -> + Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -94,14 +87,11 @@ edit form = cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return . Right $ SavedPayment new pc - Nothing -> - return . Left $ Msg.get Msg.Error_PaymentEdit + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + if Maybe.isJust editedPayment then + return . Right $ editedPayment + else + return . Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -109,18 +99,13 @@ edit form = delete :: PaymentId -> ActionM () delete paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ do - payment <- PaymentPersistence.find paymentId - case payment of - Just p | _payment_user p == _user_id user -> do - PaymentPersistence.delete (_user_id user) paymentId - PaymentCategoryPersistence.deleteIfUnused (_payment_name p) - return True - _ -> - return False - if deleted then - S.status Status.ok200 - else - S.status Status.badRequest400 + Secure.loggedAction (\user -> + liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId + ) + +searchCategory :: Text -> ActionM () +searchCategory paymentName = + Secure.loggedAction (\_ -> do + (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) + >>= S.json ) diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs index 506343d..5713bfe 100644 --- a/server/src/Design/Form.hs +++ b/server/src/Design/Form.hs @@ -77,7 +77,6 @@ design = do backgroundColor transparent ".selectInput" ? do - marginBottom (em 2) ".label" ? do color Color.silver diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 27b4ef3..d563f5d 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,8 +4,10 @@ module Design.View.Payment import Clay -import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.HeaderForm as HeaderForm +import qualified Design.View.Payment.HeaderInfos as HeaderInfos design :: Css design = do - ".g-HeaderInfos" ? Header.design + HeaderForm.design + HeaderInfos.design diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs deleted file mode 100644 index 49c1a09..0000000 --- a/server/src/Design/View/Payment/Header.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Design.View.Payment.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 2) - Media.mobileTablet $ marginBottom (em 1) - marginLeft (pct Constants.blockPercentMargin) - marginRight (pct Constants.blockPercentMargin) - - ".g-HeaderInfos__ExceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - marginBottom (em 1) - - Media.mobile $ do - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - -- ".addPayment" ? do - -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - -- Media.mobile $ width (pct 100) - - ".g-HeaderForm" ? do - marginBottom (em 1) - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".selectInput" ? do - Media.tabletDesktop $ display inlineBlock - - ".g-HeaderInfos__Repartition" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/Payment/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs new file mode 100644 index 0000000..6081443 --- /dev/null +++ b/server/src/Design/View/Payment/HeaderForm.hs @@ -0,0 +1,40 @@ +module Design.View.Payment.HeaderForm + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderForm" ? do + marginBottom (em 2) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + display flex + justifyContent spaceBetween + alignItems center + Media.mobile $ flexDirection column + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".selectInput" ? do + Media.tabletDesktop $ display inlineBlock + Media.mobile $ marginBottom (em 2) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + flexShrink 0 diff --git a/server/src/Design/View/Payment/HeaderInfos.hs b/server/src/Design/View/Payment/HeaderInfos.hs new file mode 100644 index 0000000..acb393b --- /dev/null +++ b/server/src/Design/View/Payment/HeaderInfos.hs @@ -0,0 +1,50 @@ +module Design.View.Payment.HeaderInfos + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + + ".g-PaymentHeaderInfos" ? do + Media.desktop $ marginBottom (em 2) + Media.mobileTablet $ marginBottom (em 1) + marginLeft (pct Constants.blockPercentMargin) + marginRight (pct Constants.blockPercentMargin) + + ".g-PaymentHeaderInfos__ExceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + marginBottom (em 1) + + Media.mobile $ do + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".g-PaymentHeaderInfos__Repartition" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 1a478dc..34bbd3a 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -15,11 +15,26 @@ import qualified View.Mail.WeeklyReport as WeeklyReport weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime weeklyReport conf mbLastExecution = do now <- getCurrentTime + case mbLastExecution of - Nothing -> return () + Nothing -> + return () + Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list - _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now) + (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + users <- UserPersistence.list + paymentRange <- PaymentPersistence.getRange + weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekIncomes <- IncomePersistence.listModifiedSince lastExecution + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users + return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + + _ <- + SendMail.sendMail + conf + (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + return () + return now diff --git a/server/src/Main.hs b/server/src/Main.hs index 5068d10..f4d75a0 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -42,9 +42,15 @@ main = do User.list S.get "/api/payments" $ do + frequency <- S.param "frequency" page <- S.param "page" perPage <- S.param "perPage" - Payment.list page perPage + search <- S.param "search" + Payment.list (read frequency) page perPage search + + S.get "/api/payment/category" $ do + name <- S.param "name" + Payment.searchCategory name S.post "/api/payment" $ S.jsonData >>= Payment.create @@ -61,9 +67,6 @@ main = do perPage <- S.param "perPage" Income.list page perPage - S.get "/api/deprecated/incomes" $ do - Income.deprecatedList - S.post "/api/income" $ S.jsonData >>= Income.create @@ -74,9 +77,6 @@ main = do incomeId <- S.param "id" Income.delete incomeId - S.get "/api/paymentCategories" $ - Payment.listPaymentCategories - S.get "/api/categories" $ Category.list diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index 0cc4a03..bcdce61 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -7,7 +7,7 @@ module Model.SignIn ) where import Data.Int (Int64) -import Data.Maybe (listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (UTCTime) @@ -47,7 +47,7 @@ createSignInToken signInEmail = getSignIn :: Text -> Query (Maybe SignIn) getSignIn signInToken = Query (\conn -> do - listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) + Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) ) signInTokenToUsed :: SignInId -> Query () diff --git a/server/src/Payer.hs b/server/src/Payer.hs new file mode 100644 index 0000000..d913afe --- /dev/null +++ b/server/src/Payer.hs @@ -0,0 +1,170 @@ +module Payer + ( getExceedingPayers + , useIncomesFrom + , cumulativeIncomesSince + ) where + +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Time (NominalDiffTime, UTCTime (..)) +import qualified Data.Time as Time +import Data.Time.Calendar (Day) + +import Common.Model (ExceedingPayer (..), Income (..), + User (..), UserId) + +data Payer = Payer + { _payer_userId :: UserId + , _payer_preIncomePayments :: Int + , _payer_postIncomePayments :: Int + , _payer_incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _postPaymentPayer_userId :: UserId + , _postPaymentPayer_preIncomePayments :: Int + , _postPaymentPayer_cumulativeIncome :: Int + , _postPaymentPayer_ratio :: Float + } + +getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] +getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = + let userIds = map _user_id users + payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers + mbSince = useIncomesFrom userIds incomes firstPayment + in case mbSince of + Just since -> + let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day +useIncomesFrom userIds incomes firstPayment = + case (firstPayment, incomeDefinedForAll userIds incomes) of + (Just d1, Just d2) -> Just (max d1 d2) + _ -> Nothing + +dayUTCTime :: Day -> UTCTime +dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) + +getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds incomes preIncomeRepartition postIncomeRepartition = + flip map userIds (\userId -> Payer + { _payer_userId = userId + , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition + , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition + , _payer_incomes = filter ((==) userId . _income_userId) incomes + } + ) + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> _exceedingPayer_amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _exceedingPayer_userId = fst userAmount + , _exceedingPayer_amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _postPaymentPayer_userId = _payer_userId payer + , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer + , _postPaymentPayer_cumulativeIncome = cumulativeIncome + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) + in postIncomeDiff + _postPaymentPayer_preIncomePayments payer + +incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds + firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes + in if all Maybe.isJust firstIncomes + then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: Day -> [Income] -> [Income] +getOrderedIncomesSince since incomes = + let mbStarterIncome = getIncomeAt since incomes + orderedIncomesSince = filter (\income -> _income_date income >= since) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: Day -> [Income] -> Maybe Income +getIncomeAt day incomes = + case incomes of + [x] -> + if _income_date x < day + then Just $ x { _income_date = day } + else Nothing + x1 : x2 : xs -> + if _income_date x1 < day && _income_date x2 >= day + then Just $ x1 { _income_date = day } + else getIncomeAt day (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = dayUTCTime . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 2afe5db..00cf0a5 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -5,7 +5,7 @@ module Persistence.Category , delete ) where -import Data.Maybe (isJust, listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) @@ -48,9 +48,9 @@ create categoryName categoryColor = edit :: CategoryId -> Text -> Text -> Query Bool edit categoryId categoryName categoryColor = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if isJust mbCategory + if Maybe.isJust mbCategory then do now <- getCurrentTime SQLite.execute @@ -65,9 +65,9 @@ edit categoryId categoryName categoryColor = delete :: CategoryId -> Query Bool delete categoryId = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if isJust mbCategory + if Maybe.isJust mbCategory then do now <- getCurrentTime SQLite.execute diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cb2ef10..ba7ad19 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -2,17 +2,22 @@ module Persistence.Income ( count , list , listAll + , listModifiedSince , create , edit , delete + , definedForAll ) where -import Data.Maybe (listToMaybe) +import qualified Data.List as L +import qualified Data.Maybe as Maybe +import qualified Data.Text as T import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) +import Prelude hiding (id, until) import Common.Model (Income (..), IncomeId, PaymentId, UserId) @@ -31,15 +36,15 @@ instance FromRow Row where SQLite.field <*> SQLite.field) -data Count = Count Int +data CountRow = CountRow Int -instance FromRow Count where - fromRow = Count <$> SQLite.field +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field count :: Query Int count = Query (\conn -> - (\[Count n] -> n) <$> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL" ) @@ -60,6 +65,23 @@ listAll = SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" ) +listModifiedSince :: UTCTime -> Query [Income] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM income" + , "WHERE" + , "created_at >= ?" + , "OR edited_at >= ?" + , "OR deleted_at >= ?" + ]) + (Only since) + ) + create :: UserId -> Day -> Int -> Query Income create userId date amount = Query (\conn -> do @@ -83,7 +105,7 @@ create userId date amount = edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) edit userId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$> + mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) case mbIncome of Just income -> @@ -114,3 +136,26 @@ delete userId paymentId = "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" (paymentId, userId) ) + +data UserDayRow = UserDayRow (UserId, Day) + +instance FromRow UserDayRow where + fromRow = do + user <- SQLite.field + day <- SQLite.field + return $ UserDayRow (user, day) + +definedForAll :: [UserId] -> Query (Maybe Day) +definedForAll users = + Query (\conn -> + (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$> + SQLite.query_ + conn + "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;" + ) + where + fromRows rows = + if L.sort users == L.sort (map fst rows) then + Maybe.listToMaybe . L.sort . map snd $ rows + else + Nothing diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 7835c98..f75925d 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -1,33 +1,57 @@ module Persistence.Payment ( count , find - , firstPunctualDay - , listActive + , getRange , listActivePage - , listPunctual + , listModifiedSince , listActiveMonthlyOrderedByName , create , createMany , edit , delete + , searchCategory + , repartition + , getPreAndPostPaymentRepartition ) where -import Data.Maybe (listToMaybe) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) import Database.SQLite.Simple (FromRow (fromRow), Only (Only), ToRow) import qualified Database.SQLite.Simple as SQLite import Database.SQLite.Simple.ToField (ToField (toField)) -import Prelude hiding (id) +import Prelude hiding (id, until) -import Common.Model (Frequency (..), Payment (..), - PaymentId, UserId) +import Common.Model (CategoryId, Frequency (..), + Payment (..), PaymentId, + User (..), UserId) import Model.Query (Query (Query)) import Persistence.Frequency (FrequencyField (..)) +import qualified Persistence.Income as IncomePersistence + + + +fields :: Text +fields = T.intercalate "," $ + [ "id" + , "user_id" + , "name" + , "cost" + , "date" + , "category" + , "frequency" + , "created_at" + , "edited_at" + , "deleted_at" + ] newtype Row = Row Payment @@ -38,6 +62,7 @@ instance FromRow Row where SQLite.field <*> SQLite.field <*> SQLite.field <*> + SQLite.field <*> (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*> SQLite.field <*> SQLite.field <*> @@ -51,6 +76,7 @@ instance ToRow InsertRow where , toField (_payment_name p) , toField (_payment_cost p) , toField (_payment_date p) + , toField (_payment_category p) , toField (FrequencyField (_payment_frequency p)) , toField (_payment_createdAt p) ] @@ -60,73 +86,94 @@ data Count = Count Int instance FromRow Count where fromRow = Count <$> SQLite.field -count :: Query Int -count = +count :: Frequency -> Text -> Query Int +count frequency search = Query (\conn -> (\[Count n] -> n) <$> - SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL" + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT COUNT(*)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" + ]) + (FrequencyField frequency, "%" <> search <> "%") ) find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do - fmap (\(Row p) -> p) . listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + SQLite.query + conn + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?") + (Only paymentId) ) -data DayRow = DayRow Day +data RangeRow = RangeRow (Day, Day) -instance FromRow DayRow where - fromRow = DayRow <$> SQLite.field +instance FromRow RangeRow where + fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field -firstPunctualDay :: Query (Maybe Day) -firstPunctualDay = +getRange :: Query (Maybe (Day, Day)) +getRange = Query (\conn -> do - fmap (\(DayRow d) -> d) . listToMaybe <$> + fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1" + (SQLite.Query $ T.intercalate " " + [ "SELECT MIN(date), MAX(date)" + , "FROM payment" + , "WHERE" + , "frequency = ?" + , "AND deleted_at IS NULL" + ]) (Only (FrequencyField Punctual)) ) -listActive :: Frequency -> Query [Payment] -listActive frequency = - Query (\conn -> do - map (\(Row p) -> p) <$> - SQLite.query - conn - "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?" - (Only (FrequencyField frequency)) - ) - -listActivePage :: Int -> Int -> Query [Payment] -listActivePage page perPage = +listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] +listActivePage frequency page perPage search = Query (\conn -> map (\(Row p) -> p) <$> SQLite.query conn (SQLite.Query $ T.intercalate " " - [ "SELECT *" + [ "SELECT" + , fields , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" , "ORDER BY date DESC" , "LIMIT ?" , "OFFSET ?" ] ) - (FrequencyField Punctual, perPage, (page - 1) * perPage) + (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage) ) -listPunctual :: Query [Payment] -listPunctual = - Query (\conn -> do - map (\(Row p) -> p) <$> +listModifiedSince :: UTCTime -> Query [Payment] +listModifiedSince since = + Query (\conn -> + map (\(Row i) -> i) <$> SQLite.query conn - (SQLite.Query "SELECT * FROM payment WHERE frequency = ?") - (Only (FrequencyField Punctual)) + (SQLite.Query . T.intercalate " " $ + [ "SELECT *" + , "FROM payment" + , "WHERE" + , "created_at >= ?" + , "OR edited_at >= ?" + , "OR deleted_at >= ?" + ]) + (Only since) ) + listActiveMonthlyOrderedByName :: Query [Payment] listActiveMonthlyOrderedByName = Query (\conn -> do @@ -134,7 +181,8 @@ listActiveMonthlyOrderedByName = SQLite.query conn (SQLite.Query $ T.intercalate " " - [ "SELECT *" + [ "SELECT" + , fields , "FROM payment" , "WHERE deleted_at IS NULL AND frequency = ?" , "ORDER BY name DESC" @@ -142,17 +190,17 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment -create userId name cost date frequency = +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment +create userId name cost date category frequency = Query (\conn -> do time <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) - (userId, name, cost, date, FrequencyField frequency, time) + (userId, name, cost, date, category, FrequencyField frequency, time) paymentId <- SQLite.lastInsertRowId conn return $ Payment { _payment_id = paymentId @@ -160,6 +208,7 @@ create userId name cost date frequency = , _payment_name = name , _payment_cost = cost , _payment_date = date + , _payment_category = category , _payment_frequency = frequency , _payment_createdAt = time , _payment_editedAt = Nothing @@ -173,19 +222,19 @@ createMany payments = SQLite.executeMany conn (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" + [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment)) -edit userId paymentId name cost date frequency = +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment) +edit userId paymentId name cost date category frequency = Query (\conn -> do - mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> + mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT * FROM payment WHERE id = ? and user_id = ?" + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") (paymentId, userId) case mbPayment of Just payment -> do @@ -200,6 +249,7 @@ edit userId paymentId name cost date frequency = , " name = ?," , " cost = ?," , " date = ?," + , " category = ?," , " frequency = ?" , "WHERE" , " id = ?" @@ -209,16 +259,18 @@ edit userId paymentId name cost date frequency = , name , cost , date + , category , FrequencyField frequency , paymentId , userId ) - return . Just . (,) payment $ Payment + return . Just $ Payment { _payment_id = paymentId , _payment_user = userId , _payment_name = name , _payment_cost = cost , _payment_date = date + , _payment_category = category , _payment_frequency = frequency , _payment_createdAt = _payment_createdAt payment , _payment_editedAt = Just now @@ -236,3 +288,59 @@ delete userId paymentId = "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" (paymentId, userId) ) + +data CategoryIdRow = CategoryIdRow CategoryId + +instance FromRow CategoryIdRow where + fromRow = CategoryIdRow <$> SQLite.field + +searchCategory :: Text -> Query (Maybe CategoryId) +searchCategory paymentName = + Query (\conn -> + fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> + SQLite.query + conn + "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (Only $ "%" <> paymentName <> "%") + ) + +data UserCostRow = UserCostRow (UserId, Int) + +instance FromRow UserCostRow where + fromRow = do + user <- SQLite.field + cost <- SQLite.field + return $ UserCostRow (user, cost) + +repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) +repartition frequency search from to = + Query (\conn -> + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query + conn + (SQLite.Query . T.intercalate " " $ + [ "SELECT user_id, SUM(cost)" + , "FROM payment" + , "WHERE" + , "deleted_at IS NULL" + , "AND frequency = ?" + , "AND name LIKE ?" + , "AND date >= ?" + , "AND date < ?" + , "GROUP BY user_id" + ]) + (FrequencyField frequency, "%" <> search <> "%", from, to) + ) + +getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) +getPreAndPostPaymentRepartition paymentRange users = do + case paymentRange of + Just (from, to) -> do + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + (,) + <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll)) + <*> (case incomeDefinedForAll of + Just d -> repartition Punctual "" d (Calendar.addDays 1 to) + Nothing -> return M.empty) + + Nothing -> + return (M.empty, M.empty) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs deleted file mode 100644 index 46be7f5..0000000 --- a/server/src/Persistence/PaymentCategory.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Persistence.PaymentCategory - ( list - , listByCategory - , save - , deleteIfUnused - ) where - -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory (..)) - -import Model.Query (Query (Query)) - -newtype Row = Row PaymentCategory - -instance FromRow Row where - fromRow = Row <$> (PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field) - -list :: Query [PaymentCategory] -list = - Query (\conn -> do - map (\(Row pc) -> pc) <$> - SQLite.query_ conn "SELECT * from payment_category" - ) - -listByCategory :: CategoryId -> Query [PaymentCategory] -listByCategory cat = - Query (\conn -> do - map (\(Row pc) -> pc) <$> - SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) - ) - -save :: Text -> CategoryId -> Query PaymentCategory -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only formattedNewName)) - case paymentCategory of - Just pc -> - do - SQLite.execute - conn - "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" - (categoryId, now, formattedNewName) - return $ PaymentCategory - (_paymentCategory_id pc) - formattedNewName - categoryId - (_paymentCategory_createdAt pc) - (Just now) - Nothing -> - do - SQLite.execute - conn - "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" - (formattedNewName, categoryId, now) - paymentCategoryId <- SQLite.lastInsertRowId conn - return $ PaymentCategory - paymentCategoryId - formattedNewName - categoryId - now - Nothing - ) - where - formattedNewName = T.toLower newName - -deleteIfUnused :: Text -> Query () -deleteIfUnused name = - Query (\conn -> - SQLite.execute - conn - "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)" - (name, name) - ) >> return () diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 4ec2dcf..3c3a2b1 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -3,7 +3,7 @@ module Persistence.User , get ) where -import Data.Maybe (listToMaybe) +import qualified Data.Maybe as Maybe import Data.Text (Text) import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -32,6 +32,6 @@ list = get :: Text -> Query (Maybe User) get userEmail = Query (\conn -> do - fmap (\(Row u) -> u) . listToMaybe <$> + fmap (\(Row u) -> u) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) ) diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs deleted file mode 100644 index 4e22ba8..0000000 --- a/server/src/Util/List.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Util.List - ( groupBy - ) where - -import Control.Arrow ((&&&)) -import Data.Function (on) -import qualified Data.List as L - -groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])] -groupBy f = - map (f . head &&& id) - . L.groupBy ((==) `on` f) - . L.sortBy (compare `on` f) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 7e88d98..1f637bc 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,6 +9,7 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Common.Model (ExceedingPayer (..), Income (..), @@ -23,10 +24,11 @@ import Model.IncomeResource (IncomeResource (..)) import Model.Mail (Mail (Mail)) import qualified Model.Mail as M import Model.PaymentResource (PaymentResource (..)) +import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = +mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail +mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -35,24 +37,24 @@ mail conf users payments incomes start end = , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users payments incomes start end + , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end } -body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text -body conf users payments incomes start end = +body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text +body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments) + [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where - paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments + paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text -exceedingPayers conf time users incomes payments = +exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text +exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = T.intercalate "\n" . map formatPayer $ payers where - payers = CM.getExceedingPayers time users incomes payments + payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users -- cgit v1.2.3 From 3c67fcf1d524811a18f0c4db3ef6eed1270b9a12 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 19:55:22 +0100 Subject: Hide date from monthly payments --- client/src/View/Payment/Form.hs | 51 +++++++++++++++++++--------------- client/src/View/Payment/HeaderForm.hs | 20 +++++++------ client/src/View/Payment/Payment.hs | 3 +- client/src/View/Payment/Table.hs | 40 ++++++++++++++++---------- common/src/Common/Model/PaymentPage.hs | 2 ++ server/src/Controller/Payment.hs | 2 +- 6 files changed, 70 insertions(+), 48 deletions(-) diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 6c3c1e8..99dce13 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -43,10 +43,11 @@ import qualified Util.Validation as ValidationUtil data In t = In { _in_categories :: [Category] , _in_operation :: Operation t + , _in_frequency :: Frequency } data Operation t - = New (Dynamic t Frequency) + = New | Clone Payment | Edit Payment @@ -92,18 +93,23 @@ view input cancel = do (cost <$ reset) confirm) - d <- date - - date <- Input._out_raw <$> (Input.view - (Input.defaultIn - { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = d - , Input._in_inputType = "date" - , Input._in_hasResetButton = False - , Input._in_validation = PaymentValidation.date - }) - (d <$ reset) - confirm) + currentDate <- date + + date <- + case frequency of + Punctual -> do + Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Payment_Date + , Input._in_initialValue = currentDate + , Input._in_inputType = "date" + , Input._in_hasResetButton = False + , Input._in_validation = PaymentValidation.date + }) + (currentDate <$ reset) + confirm) + Monthly -> + return . R.constDyn $ currentDate setCategory <- R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) @@ -125,13 +131,12 @@ view input cancel = do c <- cost d <- date cat <- category - f <- frequency return (mkPayload <$> ValidationUtil.nelError n <*> V.Success c <*> V.Success d <*> ValidationUtil.nelError cat - <*> V.Success f) + <*> V.Success frequency) frequencies = M.fromList @@ -144,7 +149,7 @@ view input cancel = do category = case op of - New _ -> -1 + New -> -1 Clone p -> _payment_category p Edit p -> _payment_category p @@ -152,13 +157,13 @@ view input cancel = do name = case op of - New _ -> "" + New -> "" Clone p -> _payment_name p Edit p -> _payment_name p cost = case op of - New _ -> "" + New -> "" Clone p -> T.pack . show . _payment_cost $ p Edit p -> T.pack . show . _payment_cost $ p @@ -166,19 +171,19 @@ view input cancel = do currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay return . T.pack . Calendar.showGregorian $ case op of - New _ -> currentDay + New -> currentDay Clone p -> currentDay Edit p -> _payment_date p frequency = case op of - New f -> f - Clone p -> R.constDyn $ _payment_frequency p - Edit p -> R.constDyn $ _payment_frequency p + New -> _in_frequency input + Clone p -> _payment_frequency p + Edit p -> _payment_frequency p headerLabel = case op of - New _ -> Msg.get Msg.Payment_Add + New -> Msg.get Msg.Payment_Add Clone _ -> Msg.get Msg.Payment_CloneLong Edit _ -> Msg.get Msg.Payment_EditLong diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index c8ca4d9..0ee0cd3 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -18,6 +18,7 @@ import qualified Component.Button as Button import qualified Component.Input as Input import qualified Component.Modal as Modal import qualified Component.Select as Select +import qualified Util.Reflex as ReflexUtil import qualified View.Payment.Form as Form data In t = In @@ -65,14 +66,17 @@ view input = { Button._in_class = R.constDyn "addPayment" }) - addPayment <- Modal.view $ Modal.In - { Modal._in_show = addPaymentButton - , Modal._in_content = - Form.view $ Form.In - { Form._in_categories = _in_categories input - , Form._in_operation = Form.New frequency - } - } + addPayment <- + (R.dyn . R.ffor frequency $ \frequency -> + Modal.view $ Modal.In + { Modal._in_show = addPaymentButton + , Modal._in_content = + Form.view $ Form.In + { Form._in_categories = _in_categories input + , Form._in_operation = Form.New + , Form._in_frequency = frequency + } + }) >>= ReflexUtil.flatten return $ Out { _out_search = R.updated searchName diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 6bc1614..a34d2f4 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -70,7 +70,7 @@ view input = do } result <- R.dyn . R.ffor payments $ - Loadable.view $ \(PaymentPage page header payments count) -> do + Loadable.view $ \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input @@ -85,6 +85,7 @@ view input = do , Table._in_categories = categories , Table._in_currency = _in_currency input , Table._in_payments = payments + , Table._in_frequency = frequency } pages <- Pages.view $ Pages.In diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 59ac890..f9215bc 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -12,7 +12,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Currency, Payment (..), +import Common.Model (Category (..), Currency, + Frequency (..), Payment (..), User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -30,6 +31,7 @@ data In t = In , _in_categories :: [Category] , _in_currency :: Currency , _in_payments :: [Payment] + , _in_frequency :: Frequency } data Out t = Out @@ -42,22 +44,25 @@ view :: forall t m. MonadWidget t m => In t -> m (Out t) view input = do table <- Table.view $ Table.In - { Table._in_headerLabel = headerLabel + { Table._in_headerLabel = headerLabel (_in_frequency input) , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input , Table._in_cell = cell (_in_users input) (_in_categories input) + (_in_frequency input) (_in_currency input) , Table._in_cloneModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input , Form._in_operation = Form.Clone payment + , Form._in_frequency = _in_frequency input } , Table._in_editModal = \payment -> Form.view $ Form.In { Form._in_categories = _in_categories input , Form._in_operation = Form.Edit payment + , Form._in_frequency = _in_frequency input } , Table._in_deleteModal = \payment -> ConfirmDialog.view $ ConfirmDialog.In @@ -85,22 +90,24 @@ data Header | DateHeader deriving (Eq, Show, Bounded, Enum) -headerLabel :: Header -> Text -headerLabel NameHeader = Msg.get Msg.Payment_Name -headerLabel CostHeader = Msg.get Msg.Payment_Cost -headerLabel UserHeader = Msg.get Msg.Payment_User -headerLabel CategoryHeader = Msg.get Msg.Payment_Category -headerLabel DateHeader = Msg.get Msg.Payment_Date +headerLabel :: Frequency -> Header -> Text +headerLabel _ NameHeader = Msg.get Msg.Payment_Name +headerLabel _ CostHeader = Msg.get Msg.Payment_Cost +headerLabel _ UserHeader = Msg.get Msg.Payment_User +headerLabel _ CategoryHeader = Msg.get Msg.Payment_Category +headerLabel Punctual DateHeader = Msg.get Msg.Payment_Date +headerLabel Monthly DateHeader = "" cell :: forall t m. MonadWidget t m => [User] -> [Category] + -> Frequency -> Currency -> Header -> Payment -> m () -cell users categories currency header payment = +cell users categories frequency currency header payment = case header of NameHeader -> R.text $ _payment_name payment @@ -132,9 +139,12 @@ cell users categories currency header payment = Maybe.fromMaybe "" (_category_name <$> category) DateHeader -> - do - R.elClass "span" "shortDate" $ - R.text . Format.shortDay . _payment_date $ payment - - R.elClass "span" "longDate" $ - R.text . Format.longDay . _payment_date $ payment + if frequency == Punctual then + do + R.elClass "span" "shortDate" $ + R.text . Format.shortDay . _payment_date $ payment + + R.elClass "span" "longDate" $ + R.text . Format.longDay . _payment_date $ payment + else + R.blank diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 3b18bb6..94203a2 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -5,11 +5,13 @@ module Common.Model.PaymentPage import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) +import Common.Model.Frequency (Frequency) import Common.Model.Payment (Payment) import Common.Model.PaymentHeader (PaymentHeader) data PaymentPage = PaymentPage { _paymentPage_page :: Int + , _paymentPage_frequency :: Frequency , _paymentPage_header :: PaymentHeader , _paymentPage_payments :: [Payment] , _paymentPage_totalCount :: Int diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index d4d086e..c860810 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -64,7 +64,7 @@ list frequency page perPage search = , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage page header payments count) >>= S.json + return $ PaymentPage page frequency header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () -- cgit v1.2.3 From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Nov 2019 16:19:53 +0100 Subject: Compute cumulative income with a DB query --- client/src/Loadable.hs | 37 ++++++++++ client/src/View/Income/Income.hs | 15 ++-- client/src/View/Income/Reducer.hs | 40 +++++----- client/src/View/Payment/Form.hs | 1 + client/src/View/Payment/Payment.hs | 18 ++--- client/src/View/Payment/Reducer.hs | 30 ++++---- common/src/Common/Model/IncomePage.hs | 3 +- server/server.cabal | 1 + server/src/Controller/Income.hs | 28 +++---- server/src/Controller/Payment.hs | 16 ++-- server/src/Design/Global.hs | 6 +- server/src/Design/Loadable.hs | 29 ++++++++ server/src/Design/View/Table.hs | 3 + server/src/Design/Views.hs | 16 ++-- server/src/Job/WeeklyReport.hs | 17 ++++- server/src/Payer.hs | 135 +++++++--------------------------- server/src/Persistence/Income.hs | 58 ++++++++++++--- server/src/Persistence/Payment.hs | 12 ++- server/src/View/Mail/WeeklyReport.hs | 21 +++--- 19 files changed, 262 insertions(+), 224 deletions(-) create mode 100644 server/src/Design/Loadable.hs diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 2b9008a..9a14b3f 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -1,9 +1,12 @@ module Loadable ( Loadable (..) + , Loadable2 (..) , fromEvent , view + , view2 ) where +import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R @@ -50,3 +53,37 @@ view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing view _ (Error e) = R.text e >> return Nothing view f (Loaded x) = Just <$> f x + +data Loadable2 t a = Loadable2 + { _loadable_isLoading :: Dynamic t Bool + , _loadable_value :: Dynamic t (Maybe a) + } + +view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b)) +view2 (Loadable2 isLoading value) f = + withLoader isLoading $ + R.dyn . R.ffor value . viewMaybe $ f + + where + viewMaybe _ Nothing = return Nothing + viewMaybe f (Just x) = Just <$> f x + +withLoader + :: forall t m a. MonadWidget t m + => Dynamic t Bool + -> m a + -> m a +withLoader isLoading block = + R.divClass "g-Loadable" $ do + R.elDynAttr "div" (spinnerAttrs <$> isLoading) $ + R.divClass "spinner" R.blank + R.elDynAttr "div" (blockAttrs <$> isLoading) $ + block + where + spinnerAttrs l = M.singleton "class" $ + "g-Loadable__Spinner" + <> (if l then " g-Loadable__Spinner--Loading" else "") + + blockAttrs l = M.singleton "class" $ + "g-Loadable__Content" + <> (if l then " g-Loadable__Content--Loading" else "") diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index d82ab4d..fa2585d 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -19,6 +19,7 @@ import Loadable (Loadable (..)) import qualified Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer @@ -33,9 +34,8 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do rec - incomes <- Reducer.reducer $ Reducer.In - { Reducer._in_newPage = newPage - , Reducer._in_currentPage = currentPage + incomePage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page , Reducer._in_addIncome = R.leftmost [headerAddIncome, tableAddIncome] , Reducer._in_editIncome = editIncome , Reducer._in_deleteIncome = deleteIncome @@ -44,15 +44,14 @@ view input = do let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result - newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - currentPage <- R.holdDyn 1 newPage + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a) tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) -> - flip Loadable.view is $ \(IncomePage header incomes count) -> do + result <- Loadable.view2 incomePage $ + \(IncomePage page header incomes count) -> do header <- Header.view $ Header.In { Header._in_users = _in_users input , Header._in_header = header @@ -69,7 +68,7 @@ view input = do pages <- Pages.view $ Pages.In { Pages._in_total = R.constDyn count , Pages._in_perPage = Reducer.perPage - , Pages._in_page = p + , Pages._in_page = page } return (header, table, pages) diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 092d9b3..391890f 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -11,53 +11,51 @@ import qualified Reflex.Dom as R import Common.Model (IncomePage) -import Loadable (Loadable (..)) -import qualified Loadable as Loadable +import Loadable (Loadable2 (..)) import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil perPage :: Int perPage = 7 data In t a b c = In - { _in_newPage :: Event t Int - , _in_currentPage :: Dynamic t Int + { _in_page :: Event t Int , _in_addIncome :: Event t a , _in_editIncome :: Event t b , _in_deleteIncome :: Event t c } -data Action - = LoadPage Int - | GetResult (Either Text IncomePage) - -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage) reducer input = do postBuild <- R.getPostBuild + currentPage <- R.holdDyn 1 (_in_page input) + let loadPage = R.leftmost [ 1 <$ postBuild - , _in_newPage input + , _in_page input , 1 <$ _in_addIncome input - , R.tag (R.current $ _in_currentPage input) (_in_editIncome input) - , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input) + , R.tag (R.current currentPage) (_in_editIncome input) + , R.tag (R.current currentPage) (_in_deleteIncome input) ] getResult <- AjaxUtil.get $ fmap pageUrl loadPage - R.foldDyn - (\action _ -> case action of - LoadPage _ -> Loading - GetResult (Left err) -> Error err - GetResult (Right incomes) -> Loaded incomes - ) - Loading + isLoading <- R.holdDyn + True (R.leftmost - [ LoadPage <$> loadPage - , GetResult <$> getResult + [ True <$ loadPage + , False <$ getResult ]) + incomePage <- R.holdDyn + Nothing + (fmap EitherUtil.eitherToMaybe getResult) + + return $ Loadable2 isLoading incomePage + where pageUrl p = "api/incomes?page=" diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 99dce13..064b5b3 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -113,6 +113,7 @@ view input cancel = do setCategory <- R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) + >>= (return . R.ffilter (\name -> T.length name >= 3)) >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index a34d2f4..a97c3df 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -41,7 +41,7 @@ view input = do R.dyn . R.ffor categories . Loadable.view $ \categories -> do rec - payments <- Reducer.reducer $ Reducer.In + paymentPage <- Reducer.reducer $ Reducer.In { Reducer._in_page = page , Reducer._in_search = HeaderForm._out_search form , Reducer._in_frequency = HeaderForm._out_frequency form @@ -50,7 +50,7 @@ view input = do , Reducer._in_deletePayment = deletePayment } - let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result let addPayment = @@ -59,18 +59,18 @@ view input = do , HeaderForm._out_addPayment form ] - page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) - tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) - editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) - deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + page <- eventFromResult $ Pages._out_newPage . snd + tableAddPayment <- eventFromResult $ Table._out_add . fst + editPayment <- eventFromResult $ Table._out_edit . fst + deletePayment <- eventFromResult $ Table._out_delete . fst form <- HeaderForm.view $ HeaderForm.In { HeaderForm._in_reset = () <$ addPayment , HeaderForm._in_categories = categories } - result <- R.dyn . R.ffor payments $ - Loadable.view $ \(PaymentPage page frequency header payments count) -> do + result <- Loadable.view2 paymentPage $ + \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In { HeaderInfos._in_users = _in_users input @@ -94,7 +94,7 @@ view input = do , Pages._in_page = page } - return ((), table, pages) + return (table, pages) return () diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 0b6c041..d221ff0 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -13,9 +13,9 @@ import qualified Reflex.Dom as R import Common.Model (Frequency (..), PaymentPage) -import Loadable (Loadable (..)) -import qualified Loadable as Loadable +import Loadable (Loadable2 (..)) import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil perPage :: Int perPage = 7 @@ -29,10 +29,6 @@ data In t a b c = In , _in_deletePayment :: Event t c } -data Action - = LoadPage - | GetResult (Either Text PaymentPage) - data Params = Params { _params_page :: Int , _params_search :: Text @@ -48,7 +44,7 @@ data Msg | ResetSearch deriving Show -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage) reducer input = do postBuild <- R.getPostBuild @@ -94,19 +90,19 @@ reducer input = do getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) - - R.foldDyn - (\action _ -> case action of - LoadPage -> Loading - GetResult (Left err) -> Error err - GetResult (Right payments) -> Loaded payments - ) - Loading + isLoading <- R.holdDyn + True (R.leftmost - [ LoadPage <$ paramsEvent - , GetResult <$> getResult + [ True <$ paramsEvent + , False <$ getResult ]) + paymentPage <- R.holdDyn + Nothing + (fmap EitherUtil.eitherToMaybe getResult) + + return $ Loadable2 isLoading paymentPage + where pageUrl (Params page search frequency) = "api/payments?page=" diff --git a/common/src/Common/Model/IncomePage.hs b/common/src/Common/Model/IncomePage.hs index c3f478e..0572141 100644 --- a/common/src/Common/Model/IncomePage.hs +++ b/common/src/Common/Model/IncomePage.hs @@ -9,7 +9,8 @@ import Common.Model.Income (Income) import Common.Model.IncomeHeader (IncomeHeader) data IncomePage = IncomePage - { _incomePage_header :: IncomeHeader + { _incomePage_page :: Int + , _incomePage_header :: IncomeHeader , _incomePage_incomes :: [Income] , _incomePage_totalCount :: Int } deriving (Show, Generic) diff --git a/server/server.cabal b/server/server.cabal index 7056b3f..c9ab2c7 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -72,6 +72,7 @@ Executable server Design.Form Design.Global Design.Helper + Design.Loadable Design.Media Design.Modal Design.Tooltip diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 75d0133..784a2db 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -13,7 +13,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), Income (..), + EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) @@ -21,7 +21,6 @@ import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query -import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -36,26 +35,19 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - paymentRange <- PaymentPersistence.getRange - allIncomes <- IncomePersistence.listAll -- TODO optimize - - let since = - Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) + let userIds = _user_id <$> users - let byUser = - case since of - Just s -> - M.fromList . flip map users $ \user -> - ( _user_id user - , Payer.cumulativeIncomesSince currentTime s $ - filter ((==) (_user_id user) . _income_userId) allIncomes - ) + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll - Nothing -> - M.empty + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty incomes <- IncomePersistence.list page perPage - return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c860810..42a4436 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -11,7 +11,6 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import Web.Scotty (ActionM) import qualified Web.Scotty as S @@ -36,16 +35,23 @@ import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () list frequency page perPage search = - Secure.loggedAction (\_ -> do - currentTime <- liftIO Clock.getCurrentTime + Secure.loggedAction (\_ -> (liftIO . Query.run $ do count <- PaymentPersistence.count frequency search payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll -- TODO optimize paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty searchRepartition <- case paymentRange of @@ -57,7 +63,7 @@ list frequency page perPage search = (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index df41cfd..ebd7084 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -12,6 +12,7 @@ import qualified Design.Constants as Constants import qualified Design.Errors as Errors import qualified Design.Form as Form import qualified Design.Helper as Helper +import qualified Design.Loadable as Loadable import qualified Design.Media as Media import qualified Design.Modal as Modal import qualified Design.Tooltip as Tooltip @@ -28,6 +29,7 @@ global = do ".tooltip" ? Tooltip.design Views.design Form.design + Loadable.design spinKeyframes appearKeyframe @@ -92,14 +94,14 @@ global = do h1 ? do color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) + lineHeight (em 1.3) Media.desktop $ fontSize (px 24) Media.tablet $ fontSize (px 22) Media.mobile $ fontSize (px 20) ul ? do + "margin-top" -: "1vh" "margin-bottom" -: "3vh" "margin-left" -: "1vh" li do - (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do + (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do users <- UserPersistence.list paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty weekPayments <- PaymentPersistence.listModifiedSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) + return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) _ <- SendMail.sendMail conf - (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now) + (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now) return () diff --git a/server/src/Payer.hs b/server/src/Payer.hs index d913afe..ab8312e 100644 --- a/server/src/Payer.hs +++ b/server/src/Payer.hs @@ -1,25 +1,17 @@ module Payer ( getExceedingPayers - , useIncomesFrom - , cumulativeIncomesSince ) where -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Time (NominalDiffTime, UTCTime (..)) -import qualified Data.Time as Time -import Data.Time.Calendar (Day) +import Data.Map (Map) +import qualified Data.Map as M -import Common.Model (ExceedingPayer (..), Income (..), - User (..), UserId) +import Common.Model (ExceedingPayer (..), User (..), UserId) data Payer = Payer { _payer_userId :: UserId , _payer_preIncomePayments :: Int , _payer_postIncomePayments :: Int - , _payer_incomes :: [Income] + , _payer_income :: Int } data PostPaymentPayer = PostPaymentPayer @@ -29,43 +21,29 @@ data PostPaymentPayer = PostPaymentPayer , _postPaymentPayer_ratio :: Float } -getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer] -getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment = +getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer] +getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition = let userIds = map _user_id users - payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition - exceedingPayersOnPreIncome = - exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers - mbSince = useIncomesFrom userIds incomes firstPayment - in case mbSince of - Just since -> - let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers - mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers - in case mbMaxRatio of - Just maxRatio -> - exceedingPayersFromAmounts - . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) - $ postPaymentPayers - Nothing -> - exceedingPayersOnPreIncome - _ -> - exceedingPayersOnPreIncome - -useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day -useIncomesFrom userIds incomes firstPayment = - case (firstPayment, incomeDefinedForAll userIds incomes) of - (Just d1, Just d2) -> Just (max d1 d2) - _ -> Nothing - -dayUTCTime :: Day -> UTCTime -dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0) - -getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer] -getPayers userIds incomes preIncomeRepartition postIncomeRepartition = + payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition + postPaymentPayers = map getPostPaymentPayer payers + mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p)) + $ postPaymentPayers + Nothing -> + exceedingPayersFromAmounts + . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) + $ payers + +getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer] +getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition = flip map userIds (\userId -> Payer { _payer_userId = userId , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition - , _payer_incomes = filter ((==) userId . _income_userId) incomes + , _payer_income = M.findWithDefault 0 userId cumulativeIncome } ) @@ -85,15 +63,14 @@ exceedingPayersFromAmounts userAmounts = $ userAmounts where mbMinAmount = safeMinimum . map snd $ userAmounts -getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer -getPostPaymentPayer currentTime since payer = +getPostPaymentPayer :: Payer -> PostPaymentPayer +getPostPaymentPayer payer = PostPaymentPayer { _postPaymentPayer_userId = _payer_userId payer , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer - , _postPaymentPayer_cumulativeIncome = cumulativeIncome - , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome) + , _postPaymentPayer_cumulativeIncome = _payer_income payer + , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer) } - where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer) getFinalDiff :: Float -> PostPaymentPayer -> Int getFinalDiff maxRatio payer = @@ -101,66 +78,6 @@ getFinalDiff maxRatio payer = truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer) in postIncomeDiff + _postPaymentPayer_preIncomePayments payer -incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day -incomeDefinedForAll userIds incomes = - let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds - firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes - in if all Maybe.isJust firstIncomes - then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes - else Nothing - -cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int -cumulativeIncomesSince currentTime since incomes = - getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) - -getOrderedIncomesSince :: Day -> [Income] -> [Income] -getOrderedIncomesSince since incomes = - let mbStarterIncome = getIncomeAt since incomes - orderedIncomesSince = filter (\income -> _income_date income >= since) incomes - in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince - -getIncomeAt :: Day -> [Income] -> Maybe Income -getIncomeAt day incomes = - case incomes of - [x] -> - if _income_date x < day - then Just $ x { _income_date = day } - else Nothing - x1 : x2 : xs -> - if _income_date x1 < day && _income_date x2 >= day - then Just $ x1 { _income_date = day } - else getIncomeAt day (x2 : xs) - [] -> - Nothing - -getCumulativeIncome :: UTCTime -> [Income] -> Int -getCumulativeIncome currentTime incomes = - sum - . map durationIncome - . getIncomesWithDuration currentTime - . List.sortOn incomeTime - $ incomes - -getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] -getIncomesWithDuration currentTime incomes = - case incomes of - [] -> - [] - [income] -> - [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] - (income1 : income2 : xs) -> - (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) - -incomeTime :: Income -> UTCTime -incomeTime = dayUTCTime . _income_date - -durationIncome :: (NominalDiffTime, Int) -> Int -durationIncome (duration, income) = - truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) - -nominalDay :: NominalDiffTime -nominalDay = 86400 - safeMinimum :: (Ord a) => [a] -> Maybe a safeMinimum [] = Nothing safeMinimum xs = Just . minimum $ xs diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index ba7ad19..e689505 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,21 +1,24 @@ module Persistence.Income ( count , list - , listAll , listModifiedSince , create , edit , delete , definedForAll + , getCumulativeIncome ) where import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M import qualified Data.Maybe as Maybe import qualified Data.Text as T import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)), + Only (Only)) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id, until) @@ -58,13 +61,6 @@ list page perPage = (perPage, (page - 1) * perPage) ) -listAll :: Query [Income] -listAll = - Query (\conn -> - map (\(Row i) -> i) <$> - SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL" - ) - listModifiedSince :: UTCTime -> Query [Income] listModifiedSince since = Query (\conn -> @@ -79,7 +75,7 @@ listModifiedSince since = , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) create :: UserId -> Day -> Int -> Query Income @@ -156,6 +152,46 @@ definedForAll users = where fromRows rows = if L.sort users == L.sort (map fst rows) then - Maybe.listToMaybe . L.sort . map snd $ rows + Maybe.listToMaybe . reverse . L.sort . map snd $ rows else Nothing + +getCumulativeIncome :: Day -> Day -> Query (Map UserId Int) +getCumulativeIncome start end = + Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters) + where + query = + T.intercalate "\n" $ + [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM (" + , " SELECT" + , " I1.user_id," + , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count" + , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1" + , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2" + , " ON I2.date > I1.date AND I2.user_id == I1.user_id" + , " GROUP BY I1.date, I1.user_id" + , ") GROUP BY user_id" + ] + + selectBoundedIncomes op param = + T.intercalate "\n" $ + [ " SELECT user_id, date, amount FROM (" + , " SELECT" + , " i.user_id, " <> param <> " AS date, i.amount" + , " FROM" + , " (SELECT id, MAX(date) AS max_date" + , " FROM income" + , " WHERE date <= " <> param <> " AND deleted_at IS NULL" + , " GROUP BY user_id) AS m" + , " INNER JOIN income AS i" + , " ON i.id = m.id AND i.date = m.max_date" + , " ) UNION" + , " SELECT user_id, date, amount" + , " FROM income" + , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL" + ] + + parameters = + [ ":start" := start + , ":end" := end + ] diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index f75925d..953f0ae 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -163,14 +163,14 @@ listModifiedSince since = SQLite.query conn (SQLite.Query . T.intercalate " " $ - [ "SELECT *" + [ "SELECT " <> fields , "FROM payment" , "WHERE" , "created_at >= ?" , "OR edited_at >= ?" , "OR deleted_at >= ?" ]) - (Only since) + (since, since, since) ) @@ -300,7 +300,13 @@ searchCategory paymentName = fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> SQLite.query conn - "SELECT category FROM payment WHERE name LIKE ? LIMIT 1" + (SQLite.Query . T.intercalate " " $ + [ "SELECT category" + , "FROM payment" + , "WHERE deleted_at is NULL AND name LIKE ?" + , "ORDER BY edited_at, created_at" + , "LIMIT 1" + ]) (Only $ "%" <> paymentName <> "%") ) diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs index 1f637bc..3fe224f 100644 --- a/server/src/View/Mail/WeeklyReport.hs +++ b/server/src/View/Mail/WeeklyReport.hs @@ -9,7 +9,6 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Common.Model (ExceedingPayer (..), Income (..), @@ -27,8 +26,8 @@ import Model.PaymentResource (PaymentResource (..)) import qualified Payer as Payer import Resource (Status (..), groupByStatus, statuses) -mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = +mail :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail +mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = Mail { M.from = Conf.noReplyMail conf , M.to = map _user_email users @@ -37,24 +36,24 @@ mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPay , " − " , Msg.get Msg.WeeklyReport_Title ] - , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end + , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end } -body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text -body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end = +body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text +body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end = T.intercalate "\n" $ - [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment + [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition , operations conf users paymentsGroupedByStatus incomesGroupedByStatus ] where paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments - incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes + incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes -exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text -exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment = +exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text +exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition = T.intercalate "\n" . map formatPayer $ payers where - payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment + payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition formatPayer p = T.concat [ " * " , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users -- cgit v1.2.3 From e622e8fdd2e40b4306b5cc724d8dfb76bf976242 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 25 Nov 2019 08:17:59 +0100 Subject: Remove Loadable2 --- client/src/Loadable.hs | 62 ++++++++++++++++++++----------- client/src/View/Income/Income.hs | 2 +- client/src/View/Income/Reducer.hs | 19 ++++------ client/src/View/Payment/Payment.hs | 4 +- client/src/View/Payment/Reducer.hs | 19 ++++------ common/src/Common/Model/ExceedingPayer.hs | 2 +- common/src/Common/Model/Income.hs | 2 +- common/src/Common/Model/IncomeHeader.hs | 2 +- common/src/Common/Model/IncomePage.hs | 2 +- common/src/Common/Model/Payment.hs | 2 +- common/src/Common/Model/PaymentHeader.hs | 2 +- common/src/Common/Model/PaymentPage.hs | 2 +- 12 files changed, 65 insertions(+), 55 deletions(-) diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs index 9a14b3f..4806b08 100644 --- a/client/src/Loadable.hs +++ b/client/src/Loadable.hs @@ -1,9 +1,9 @@ module Loadable ( Loadable (..) - , Loadable2 (..) + , fromEither , fromEvent - , view - , view2 + , viewHideValueWhileLoading + , viewShowValueWhileLoading ) where import qualified Data.Map as M @@ -19,7 +19,7 @@ data Loadable t = Loading | Error Text | Loaded t - deriving Show + deriving (Eq, Show) instance Functor Loadable where fmap f Loading = Loading @@ -40,6 +40,10 @@ instance Monad Loadable where (Error e) >>= f = Error e (Loaded x) >>= f = f x +fromEither :: forall a b. Either Text b -> Loadable b +fromEither (Left err) = Error err +fromEither (Right value) = Loaded value + fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a)) fromEvent = R.foldDyn @@ -49,24 +53,38 @@ fromEvent = ) Loading -view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) -view _ Loading = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing -view _ (Error e) = R.text e >> return Nothing -view f (Loaded x) = Just <$> f x +viewHideValueWhileLoading :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b) +viewHideValueWhileLoading f loadable = + case loadable of + Loading -> + (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing -data Loadable2 t a = Loadable2 - { _loadable_isLoading :: Dynamic t Bool - , _loadable_value :: Dynamic t (Maybe a) - } + Error err -> + R.text err >> return Nothing -view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b)) -view2 (Loadable2 isLoading value) f = - withLoader isLoading $ - R.dyn . R.ffor value . viewMaybe $ f + Loaded x -> + Just <$> f x - where - viewMaybe _ Nothing = return Nothing - viewMaybe f (Just x) = Just <$> f x +viewShowValueWhileLoading + :: forall t m a b. (MonadWidget t m, Eq a) + => Dynamic t (Loadable a) + -> (a -> m b) + -> m (Event t (Maybe b)) +viewShowValueWhileLoading loadable f = do + + value <- + (R.foldDyn + (\l v1 -> + case l of + Loaded v2 -> Just v2 + _ -> v1) + Nothing + (R.updated loadable)) >>= R.holdUniqDyn + + withLoader (fmap ((==) Loading) loadable) $ + R.dyn . R.ffor value $ \case + Nothing -> return Nothing + Just x -> Just <$> f x withLoader :: forall t m a. MonadWidget t m @@ -75,10 +93,12 @@ withLoader -> m a withLoader isLoading block = R.divClass "g-Loadable" $ do + res <- R.elDynAttr "div" (blockAttrs <$> isLoading) $ + block R.elDynAttr "div" (spinnerAttrs <$> isLoading) $ R.divClass "spinner" R.blank - R.elDynAttr "div" (blockAttrs <$> isLoading) $ - block + return res + where spinnerAttrs l = M.singleton "class" $ "g-Loadable__Spinner" diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index fa2585d..e83ba80 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -50,7 +50,7 @@ view input = do editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) - result <- Loadable.view2 incomePage $ + result <- Loadable.viewShowValueWhileLoading incomePage $ \(IncomePage page header incomes count) -> do header <- Header.view $ Header.In { Header._in_users = _in_users input diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs index 391890f..ea9f664 100644 --- a/client/src/View/Income/Reducer.hs +++ b/client/src/View/Income/Reducer.hs @@ -11,7 +11,8 @@ import qualified Reflex.Dom as R import Common.Model (IncomePage) -import Loadable (Loadable2 (..)) +import Loadable (Loadable (..)) +import qualified Loadable as Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Either as EitherUtil @@ -25,7 +26,7 @@ data In t a b c = In , _in_deleteIncome :: Event t c } -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage)) reducer input = do postBuild <- R.getPostBuild @@ -43,19 +44,13 @@ reducer input = do getResult <- AjaxUtil.get $ fmap pageUrl loadPage - isLoading <- R.holdDyn - True + R.holdDyn + Loading (R.leftmost - [ True <$ loadPage - , False <$ getResult + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult ]) - incomePage <- R.holdDyn - Nothing - (fmap EitherUtil.eitherToMaybe getResult) - - return $ Loadable2 isLoading incomePage - where pageUrl p = "api/incomes?page=" diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index a97c3df..8d0fee1 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -38,7 +38,7 @@ view input = do categories <- AjaxUtil.getNow "api/categories" - R.dyn . R.ffor categories . Loadable.view $ \categories -> do + R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do rec paymentPage <- Reducer.reducer $ Reducer.In @@ -69,7 +69,7 @@ view input = do , HeaderForm._in_categories = categories } - result <- Loadable.view2 paymentPage $ + result <- Loadable.viewShowValueWhileLoading paymentPage $ \(PaymentPage page frequency header payments count) -> do HeaderInfos.view $ HeaderInfos.In diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index d221ff0..7468097 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -13,7 +13,8 @@ import qualified Reflex.Dom as R import Common.Model (Frequency (..), PaymentPage) -import Loadable (Loadable2 (..)) +import Loadable (Loadable (..)) +import qualified Loadable as Loadable import qualified Util.Ajax as AjaxUtil import qualified Util.Either as EitherUtil @@ -44,7 +45,7 @@ data Msg | ResetSearch deriving Show -reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage) +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage)) reducer input = do postBuild <- R.getPostBuild @@ -90,19 +91,13 @@ reducer input = do getResult <- AjaxUtil.get (pageUrl <$> paramsEvent) - isLoading <- R.holdDyn - True + R.holdDyn + Loading (R.leftmost - [ True <$ paramsEvent - , False <$ getResult + [ Loading <$ paramsEvent + , Loadable.fromEither <$> getResult ]) - paymentPage <- R.holdDyn - Nothing - (fmap EitherUtil.eitherToMaybe getResult) - - return $ Loadable2 isLoading paymentPage - where pageUrl (Params page search frequency) = "api/payments?page=" diff --git a/common/src/Common/Model/ExceedingPayer.hs b/common/src/Common/Model/ExceedingPayer.hs index 171b6ff..b7d3efb 100644 --- a/common/src/Common/Model/ExceedingPayer.hs +++ b/common/src/Common/Model/ExceedingPayer.hs @@ -10,7 +10,7 @@ import Common.Model.User (UserId) data ExceedingPayer = ExceedingPayer { _exceedingPayer_userId :: UserId , _exceedingPayer_amount :: Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON ExceedingPayer instance ToJSON ExceedingPayer diff --git a/common/src/Common/Model/Income.hs b/common/src/Common/Model/Income.hs index 0423704..57d07f1 100644 --- a/common/src/Common/Model/Income.hs +++ b/common/src/Common/Model/Income.hs @@ -21,7 +21,7 @@ data Income = Income , _income_createdAt :: UTCTime , _income_editedAt :: Maybe UTCTime , _income_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON Income instance ToJSON Income diff --git a/common/src/Common/Model/IncomeHeader.hs b/common/src/Common/Model/IncomeHeader.hs index 87c7aae..7e712e8 100644 --- a/common/src/Common/Model/IncomeHeader.hs +++ b/common/src/Common/Model/IncomeHeader.hs @@ -12,7 +12,7 @@ import Common.Model.User (UserId) data IncomeHeader = IncomeHeader { _incomeHeader_since :: Maybe Day , _incomeHeader_byUser :: Map UserId Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON IncomeHeader instance ToJSON IncomeHeader diff --git a/common/src/Common/Model/IncomePage.hs b/common/src/Common/Model/IncomePage.hs index 0572141..977b0ea 100644 --- a/common/src/Common/Model/IncomePage.hs +++ b/common/src/Common/Model/IncomePage.hs @@ -13,7 +13,7 @@ data IncomePage = IncomePage , _incomePage_header :: IncomeHeader , _incomePage_incomes :: [Income] , _incomePage_totalCount :: Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON IncomePage instance ToJSON IncomePage diff --git a/common/src/Common/Model/Payment.hs b/common/src/Common/Model/Payment.hs index c232fc7..733a145 100644 --- a/common/src/Common/Model/Payment.hs +++ b/common/src/Common/Model/Payment.hs @@ -27,7 +27,7 @@ data Payment = Payment , _payment_createdAt :: UTCTime , _payment_editedAt :: Maybe UTCTime , _payment_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON Payment instance ToJSON Payment diff --git a/common/src/Common/Model/PaymentHeader.hs b/common/src/Common/Model/PaymentHeader.hs index a522cd8..35f5e1a 100644 --- a/common/src/Common/Model/PaymentHeader.hs +++ b/common/src/Common/Model/PaymentHeader.hs @@ -12,7 +12,7 @@ import Common.Model.User (UserId) data PaymentHeader = PaymentHeader { _paymentHeader_exceedingPayers :: [ExceedingPayer] , _paymentHeader_repartition :: Map UserId Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON PaymentHeader instance ToJSON PaymentHeader diff --git a/common/src/Common/Model/PaymentPage.hs b/common/src/Common/Model/PaymentPage.hs index 94203a2..88d9715 100644 --- a/common/src/Common/Model/PaymentPage.hs +++ b/common/src/Common/Model/PaymentPage.hs @@ -15,7 +15,7 @@ data PaymentPage = PaymentPage , _paymentPage_header :: PaymentHeader , _paymentPage_payments :: [Payment] , _paymentPage_totalCount :: Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON PaymentPage instance ToJSON PaymentPage -- cgit v1.2.3 From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 8 Dec 2019 11:39:37 +0100 Subject: Add category page --- client/client.cabal | 5 ++ client/src/Component/ConfirmDialog.hs | 6 +- client/src/Component/Modal.hs | 8 +- client/src/Component/ModalForm.hs | 10 +-- client/src/Component/Table.hs | 18 ++-- client/src/Component/Tag.hs | 27 ++++++ client/src/Model/Route.hs | 1 + client/src/Util/Ajax.hs | 28 +++++- client/src/View/App.hs | 43 ++++++---- client/src/View/Category/Category.hs | 92 ++++++++++++++++++++ client/src/View/Category/Form.hs | 117 ++++++++++++++++++++++++++ client/src/View/Category/Reducer.hs | 59 +++++++++++++ client/src/View/Category/Table.hs | 91 ++++++++++++++++++++ client/src/View/Header.hs | 5 ++ client/src/View/Income/Form.hs | 2 +- client/src/View/Income/Header.hs | 3 +- client/src/View/Income/Income.hs | 1 - client/src/View/Income/Init.hs | 11 --- client/src/View/Income/Table.hs | 11 ++- client/src/View/Payment/Form.hs | 2 +- client/src/View/Payment/HeaderForm.hs | 2 +- client/src/View/Payment/Payment.hs | 2 +- client/src/View/Payment/Table.hs | 30 +++---- client/src/View/SignIn.hs | 2 +- common/common.cabal | 6 +- common/src/Common/Model.hs | 45 +++++----- common/src/Common/Model/Category.hs | 2 +- common/src/Common/Model/CategoryPage.hs | 17 ++++ common/src/Common/Model/CreateCategory.hs | 14 --- common/src/Common/Model/CreateCategoryForm.hs | 15 ++++ common/src/Common/Model/EditCategory.hs | 17 ---- common/src/Common/Model/EditCategoryForm.hs | 18 ++++ common/src/Common/Validation/Atomic.hs | 5 ++ common/src/Common/Validation/Category.hs | 15 ++++ server/server.cabal | 4 +- server/src/Controller/Category.hs | 66 +++++++++++---- server/src/Controller/Helper.hs | 11 ++- server/src/Controller/Income.hs | 16 ++-- server/src/Controller/Payment.hs | 17 ++-- server/src/Json.hs | 16 ---- server/src/Main.hs | 9 +- server/src/Model/CreateCategory.hs | 10 +++ server/src/Model/EditCategory.hs | 13 +++ server/src/Persistence/Category.hs | 34 ++++++-- server/src/Persistence/Income.hs | 45 +++------- server/src/Persistence/Payment.hs | 48 +++-------- server/src/Validation/Category.hs | 27 ++++++ 47 files changed, 778 insertions(+), 268 deletions(-) create mode 100644 client/src/Component/Tag.hs create mode 100644 client/src/View/Category/Category.hs create mode 100644 client/src/View/Category/Form.hs create mode 100644 client/src/View/Category/Reducer.hs create mode 100644 client/src/View/Category/Table.hs delete mode 100644 client/src/View/Income/Init.hs create mode 100644 common/src/Common/Model/CategoryPage.hs delete mode 100644 common/src/Common/Model/CreateCategory.hs create mode 100644 common/src/Common/Model/CreateCategoryForm.hs delete mode 100644 common/src/Common/Model/EditCategory.hs create mode 100644 common/src/Common/Model/EditCategoryForm.hs create mode 100644 common/src/Common/Validation/Category.hs delete mode 100644 server/src/Json.hs create mode 100644 server/src/Model/CreateCategory.hs create mode 100644 server/src/Model/EditCategory.hs create mode 100644 server/src/Validation/Category.hs diff --git a/client/client.cabal b/client/client.cabal index 78ea7d3..227aed2 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -56,6 +56,7 @@ Executable client Component.Pages Component.Select Component.Table + Component.Tag Loadable Model.Route Util.Ajax @@ -73,6 +74,10 @@ Executable client View.Income.Income View.Income.Reducer View.Income.Table + View.Category.Form + View.Category.Category + View.Category.Reducer + View.Category.Table View.NotFound View.Payment.Form View.Payment.HeaderForm diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs index 50e30ed..cf26593 100644 --- a/client/src/Component/ConfirmDialog.hs +++ b/client/src/Component/ConfirmDialog.hs @@ -13,12 +13,12 @@ import qualified Component.Modal as Modal import qualified Util.Either as EitherUtil import qualified Util.WaitFor as WaitFor -data In t m a = In +data In t m = In { _in_header :: Text - , _in_confirm :: Event t () -> m (Event t a) + , _in_confirm :: Event t () -> m (Event t ()) } -view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a +view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m view input _ = R.divClass "confirm" $ do R.divClass "confirmHeader" $ diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 08f2e74..46d3f64 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -20,14 +20,14 @@ import qualified Reflex.Dom.Class as R import qualified Util.Reflex as ReflexUtil -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent) -type Content t m a = Event t () -> m (Event t (), Event t a) +type Content t m = Event t () -> m (Event t (), Event t ()) -data In t m a = In +data In t m = In { _in_show :: Event t () - , _in_content :: Content t m a + , _in_content :: Content t m } -view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a) +view :: forall t m a. MonadWidget t m => In t m -> m (Event t ()) view input = do rec let show = Show <$ (_in_show input) diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs index f5bf287..c56ff88 100644 --- a/client/src/Component/ModalForm.hs +++ b/client/src/Component/ModalForm.hs @@ -20,20 +20,20 @@ import qualified Util.Either as EitherUtil import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data In m t a b e = In +data In m t a e = In { _in_headerLabel :: Text , _in_form :: m (Dynamic t (Validation e a)) - , _in_ajax :: Event t a -> m (Event t (Either Text b)) + , _in_ajax :: Event t a -> m (Event t (Either Text ())) } -data Out t a = Out +data Out t = Out { _out_hide :: Event t () , _out_cancel :: Event t () , _out_confirm :: Event t () - , _out_validate :: Event t a + , _out_validate :: Event t () } -view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b) +view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t) view input = R.divClass "form" $ do R.divClass "formHeader" $ diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index 2869c2d..f82cfa6 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -14,23 +14,23 @@ import qualified Component.Modal as Modal import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon -data In m t h r a b c = In +data In m t h r = In { _in_headerLabel :: h -> Text , _in_rows :: [r] , _in_cell :: h -> r -> m () - , _in_cloneModal :: r -> Modal.Content t m a - , _in_editModal :: r -> Modal.Content t m b - , _in_deleteModal :: r -> Modal.Content t m c + , _in_cloneModal :: r -> Modal.Content t m + , _in_editModal :: r -> Modal.Content t m + , _in_deleteModal :: r -> Modal.Content t m , _in_isOwner :: r -> Bool } -data Out t a b c = Out - { _out_add :: Event t a - , _out_edit :: Event t b - , _out_delete :: Event t c +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } -view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h) => In m t h r a b c-> m (Out t a b c) +view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In m t h r -> m (Out t) view input = R.divClass "table" $ do rec diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs new file mode 100644 index 0000000..f75b8d3 --- /dev/null +++ b/client/src/Component/Tag.hs @@ -0,0 +1,27 @@ +module Component.Tag + ( In(..) + , view + ) where + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R + +data In = In + { _in_text :: Text + , _in_color :: Text + } + +view :: forall t m a. MonadWidget t m => In -> m () +view input = + R.elAttr "span" attrs $ + R.text $ _in_text input + + where + attrs = + M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _in_color input ]) + ] diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs index 420fe05..63e5d10 100644 --- a/client/src/Model/Route.hs +++ b/client/src/Model/Route.hs @@ -5,5 +5,6 @@ module Model.Route data Route = RootRoute | IncomeRoute + | CategoryRoute | NotFoundRoute deriving (Eq, Show) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index dc56701..dcfd402 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -2,7 +2,9 @@ module Util.Ajax ( getNow , get , post + , postAndParseResult , put + , putAndParseResult , delete ) where @@ -42,20 +44,38 @@ get url = R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String "")) post + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +post url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "POST" url <$> input) + +postAndParseResult :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -post url input = +postAndParseResult url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "POST" url <$> input) put + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text ())) +put url input = + fmap checkResult <$> + R.performRequestAsync (jsonRequest "PUT" url <$> input) + +putAndParseResult :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b) => Text -> Event t a -> m (Event t (Either Text b)) -put url input = +putAndParseResult url input = fmap getJsonResult <$> R.performRequestAsync (jsonRequest "PUT" url <$> input) @@ -69,6 +89,10 @@ delete url fire = do (R.performRequestAsync $ R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire) +checkResult :: XhrResponse -> Either Text () +checkResult response = + () <$ getResult response + getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a getJsonResult response = case getResult response of diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 2b346af..460d499 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,22 +2,23 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), InitResult (..), - UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Router as Router -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), InitResult (..), + UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = @@ -72,6 +73,13 @@ signedWidget init route = do , Income._in_users = _init_users init } + CategoryRoute -> + Category.view $ Category.In + { Category._in_currentUser = _init_currentUser init + , Category._in_currency = _init_currency init + , Category._in_users = _init_users init + } + NotFoundRoute -> NotFound.view @@ -87,5 +95,8 @@ getRoute = do ["income"] -> IncomeRoute + ["category"] -> + CategoryRoute + _ -> NotFoundRoute diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs new file mode 100644 index 0000000..77a331a --- /dev/null +++ b/client/src/View/Category/Category.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ExplicitForAll #-} + +module View.Category.Category + ( view + , In(..) + ) where + +import Data.Aeson (FromJSON) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category, CategoryPage (..), Currency, + User, UserId) +import qualified Common.Msg as Msg + +import qualified Component.Button as Button +import qualified Component.Modal as Modal +import qualified Component.Pages as Pages +import Loadable (Loadable (..)) +import qualified Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Reflex as ReflexUtil +import qualified Util.Reflex as ReflexUtil +import qualified View.Category.Form as Form +import qualified View.Category.Reducer as Reducer +import qualified View.Category.Table as Table + +data In t = In + { _in_users :: [User] + , _in_currentUser :: UserId + , _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In t -> m () +view input = do + rec + categoryPage <- Reducer.reducer $ Reducer.In + { Reducer._in_page = page + , Reducer._in_addCategory = R.leftmost [ headerAddCategory, tableAddCategory ] + , Reducer._in_editCategory = editCategory + , Reducer._in_deleteCategory = deleteCategory + } + + let eventFromResult :: forall a. ((Event t (), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a) + eventFromResult op = ReflexUtil.flatten $ (Maybe.fromMaybe R.never . fmap op) <$> result + + page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c) + headerAddCategory <- eventFromResult $ (\(a, _, _) -> a) + tableAddCategory <- eventFromResult $ Table._out_add . (\(_, b, _) -> b) + editCategory <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b) + deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) + + result <- Loadable.viewShowValueWhileLoading categoryPage $ + \(CategoryPage page categories count) -> do + header <- headerView + + table <- Table.view $ Table.In + { Table._in_currentUser = _in_currentUser input + , Table._in_currency = _in_currency input + , Table._in_categories = categories + , Table._in_users = _in_users input + } + + pages <- Pages.view $ Pages.In + { Pages._in_total = R.constDyn count + , Pages._in_perPage = Reducer.perPage + , Pages._in_page = page + } + + return (header, table, pages) + + return () + +headerView :: forall t m. MonadWidget t m => m (Event t ()) +headerView = + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Form.hs b/client/src/View/Category/Form.hs new file mode 100644 index 0000000..d91fc2e --- /dev/null +++ b/client/src/View/Category/Form.hs @@ -0,0 +1,117 @@ +module View.Category.Form + ( view + , In(..) + , Operation(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value) +import qualified Data.Aeson as Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Time +import Data.Validation (Validation) +import qualified Data.Validation as V +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), + CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Msg as Msg +import qualified Common.Util.Time as TimeUtil +import qualified Common.Validation.Category as CategoryValidation +import qualified Component.Input as Input +import qualified Component.Modal as Modal +import qualified Component.ModalForm as ModalForm +import qualified Util.Ajax as Ajax + +data In = In + { _in_operation :: Operation + } + +data Operation + = New + | Clone Category + | Edit Category + +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m +view input cancel = do + + rec + let reset = R.leftmost + [ "" <$ ModalForm._out_cancel modalForm + , "" <$ ModalForm._out_validate modalForm + , "" <$ cancel + ] + + modalForm <- ModalForm.view $ ModalForm.In + { ModalForm._in_headerLabel = headerLabel + , ModalForm._in_ajax = ajax "/api/category" + , ModalForm._in_form = form reset (ModalForm._out_confirm modalForm) + } + + return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm) + + where + + form + :: Event t String + -> Event t () + -> m (Dynamic t (Validation Text Value)) + form reset confirm = do + name <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Name + , Input._in_initialValue = name + , Input._in_validation = CategoryValidation.name + }) + (name <$ reset) + confirm) + + color <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.Category_Color + , Input._in_initialValue = color + , Input._in_inputType = "color" + , Input._in_hasResetButton = False + , Input._in_validation = CategoryValidation.color + }) + (color <$ reset) + confirm) + + return $ do + n <- name + c <- color + return . V.Success $ mkPayload n c + + op = _in_operation input + + name = + case op of + New -> "" + Clone c -> _category_name c + Edit c -> _category_name c + + color = + case op of + New -> "" + Clone c -> _category_color c + Edit c -> _category_color c + + ajax = + case op of + Edit _ -> Ajax.put + _ -> Ajax.post + + headerLabel = + case op of + Edit _ -> Msg.get Msg.Category_Edit + _ -> Msg.get Msg.Category_Add + + mkPayload = + case op of + Edit i -> \a b -> Aeson.toJSON $ EditCategoryForm (_category_id i) a b + _ -> \a b -> Aeson.toJSON $ CreateCategoryForm a b diff --git a/client/src/View/Category/Reducer.hs b/client/src/View/Category/Reducer.hs new file mode 100644 index 0000000..5ad0ddb --- /dev/null +++ b/client/src/View/Category/Reducer.hs @@ -0,0 +1,59 @@ +module View.Category.Reducer + ( perPage + , reducer + , In(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (CategoryPage) + +import Loadable (Loadable (..)) +import qualified Loadable as Loadable +import qualified Util.Ajax as AjaxUtil +import qualified Util.Either as EitherUtil + +perPage :: Int +perPage = 7 + +data In t a b c = In + { _in_page :: Event t Int + , _in_addCategory :: Event t a + , _in_editCategory :: Event t b + , _in_deleteCategory :: Event t c + } + +reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable CategoryPage)) +reducer input = do + + postBuild <- R.getPostBuild + + currentPage <- R.holdDyn 1 (_in_page input) + + let loadPage = + R.leftmost + [ 1 <$ postBuild + , _in_page input + , 1 <$ _in_addCategory input + , R.tag (R.current currentPage) (_in_editCategory input) + , R.tag (R.current currentPage) (_in_deleteCategory input) + ] + + getResult <- AjaxUtil.get $ fmap pageUrl loadPage + + R.holdDyn + Loading + (R.leftmost + [ Loading <$ loadPage + , Loadable.fromEither <$> getResult + ]) + + where + pageUrl p = + "api/categories?page=" + <> (T.pack . show $ p) + <> "&perPage=" + <> (T.pack . show $ perPage) diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs new file mode 100644 index 0000000..fbe76e9 --- /dev/null +++ b/client/src/View/Category/Table.hs @@ -0,0 +1,91 @@ +module View.Category.Table + ( view + , In(..) + , Out(..) + ) where + +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Category (..), Currency, User (..), + UserId) +import qualified Common.Model as CM +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +import qualified Component.ConfirmDialog as ConfirmDialog +import qualified Component.Table as Table +import qualified Component.Tag as Tag +import qualified Util.Ajax as Ajax +import qualified Util.Either as EitherUtil +import qualified View.Category.Form as Form + +data In t = In + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_users :: [User] + } + +data Out t = Out + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () + } + +view :: forall t m. MonadWidget t m => In t -> m (Out t) +view input = do + + table <- Table.view $ Table.In + { Table._in_headerLabel = headerLabel + , Table._in_rows = _in_categories input + , Table._in_cell = cell (_in_users input) (_in_currency input) + , Table._in_cloneModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Clone category + } + , Table._in_editModal = \category -> + Form.view $ Form.In + { Form._in_operation = Form.Edit category + } + , Table._in_deleteModal = \category -> + ConfirmDialog.view $ ConfirmDialog.In + { ConfirmDialog._in_header = Msg.get Msg.Category_DeleteConfirm + , ConfirmDialog._in_confirm = \e -> do + res <- Ajax.delete + (R.constDyn $ T.concat ["/api/category/", T.pack . show $ _category_id category]) + e + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res + } + , Table._in_isOwner = const True + } + + return $ Out + { _out_add = Table._out_add table + , _out_edit = Table._out_edit table + , _out_delete = Table._out_delete table + } + +data Header + = NameHeader + | ColorHeader + deriving (Eq, Show, Bounded, Enum) + +headerLabel :: Header -> Text +headerLabel NameHeader = Msg.get Msg.Category_Name +headerLabel ColorHeader = Msg.get Msg.Category_Color + +cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Category -> m () +cell users currency header category = + case header of + NameHeader -> + R.text $ _category_name category + + ColorHeader -> + Tag.view $ Tag.In + { Tag._in_text = _category_name category + , Tag._in_color = _category_color category + } diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 3f58dd5..5910f52 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -63,6 +63,11 @@ links route = do (R.ffor route (attrs IncomeRoute)) (Msg.get Msg.Income_Title) + Link.view + "/category" + (R.ffor route (attrs CategoryRoute)) + (Msg.get Msg.Category_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs index ff6e55e..59f6a0d 100644 --- a/client/src/View/Income/Form.hs +++ b/client/src/View/Income/Form.hs @@ -36,7 +36,7 @@ data Operation | Clone Income | Edit Income -view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income +view :: forall t m a. MonadWidget t m => In -> Modal.Content t m view input cancel = do rec diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs index 9e1c5b6..a26e16a 100644 --- a/client/src/View/Income/Header.hs +++ b/client/src/View/Income/Header.hs @@ -21,7 +21,6 @@ import qualified Common.View.Format as Format import qualified Component.Button as Button import qualified Component.Modal as Modal import qualified View.Income.Form as Form -import View.Income.Init (Init (..)) data In t = In { _in_users :: [User] @@ -30,7 +29,7 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income + { _out_add :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs index e83ba80..7be8091 100644 --- a/client/src/View/Income/Income.hs +++ b/client/src/View/Income/Income.hs @@ -21,7 +21,6 @@ import qualified Util.Ajax as AjaxUtil import qualified Util.Reflex as ReflexUtil import qualified Util.Reflex as ReflexUtil import qualified View.Income.Header as Header -import View.Income.Init (Init (..)) import qualified View.Income.Reducer as Reducer import qualified View.Income.Table as Table diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs deleted file mode 100644 index 4f3ef99..0000000 --- a/client/src/View/Income/Init.hs +++ /dev/null @@ -1,11 +0,0 @@ -module View.Income.Init - ( Init(..) - ) where - -import Common.Model (Income, Payment, User) - -data Init = Init - { _init_users :: [User] - , _init_incomes :: [Income] - , _init_payments :: [Payment] - } deriving (Show) diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c623acb..c7f172b 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -4,7 +4,6 @@ module View.Income.Table , Out(..) ) where -import qualified Data.List as L import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T @@ -31,9 +30,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Income - , _out_edit :: Event t Income - , _out_delete :: Event t Income + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -41,7 +40,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel - , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input + , Table._in_rows = _in_incomes input , Table._in_cell = cell (_in_users input) (_in_currency input) , Table._in_cloneModal = \income -> Form.view $ Form.In @@ -58,7 +57,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income]) e - return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId } diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs index 064b5b3..6c31fad 100644 --- a/client/src/View/Payment/Form.hs +++ b/client/src/View/Payment/Form.hs @@ -51,7 +51,7 @@ data Operation t | Clone Payment | Edit Payment -view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment +view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m view input cancel = do rec let reset = R.leftmost diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs index 0ee0cd3..1915841 100644 --- a/client/src/View/Payment/HeaderForm.hs +++ b/client/src/View/Payment/HeaderForm.hs @@ -29,7 +29,7 @@ data In t = In data Out t = Out { _out_search :: Event t Text , _out_frequency :: Event t Frequency - , _out_addPayment :: Event t Payment + , _out_addPayment :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs index 8d0fee1..26444d7 100644 --- a/client/src/View/Payment/Payment.hs +++ b/client/src/View/Payment/Payment.hs @@ -36,7 +36,7 @@ data In t = In view :: forall t m. MonadWidget t m => In t -> m () view input = do - categories <- AjaxUtil.getNow "api/categories" + categories <- AjaxUtil.getNow "api/allCategories" R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f9215bc..6744d3a 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -21,6 +21,7 @@ import qualified Common.View.Format as Format import qualified Component.ConfirmDialog as ConfirmDialog import qualified Component.Table as Table +import qualified Component.Tag as Tag import qualified Util.Ajax as Ajax import qualified Util.Either as EitherUtil import qualified View.Payment.Form as Form @@ -35,9 +36,9 @@ data In t = In } data Out t = Out - { _out_add :: Event t Payment - , _out_edit :: Event t Payment - , _out_delete :: Event t Payment + { _out_add :: Event t () + , _out_edit :: Event t () + , _out_delete :: Event t () } view :: forall t m. MonadWidget t m => In t -> m (Out t) @@ -45,7 +46,7 @@ view input = do table <- Table.view $ Table.In { Table._in_headerLabel = headerLabel (_in_frequency input) - , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input + , Table._in_rows = _in_payments input , Table._in_cell = cell (_in_users input) @@ -71,7 +72,7 @@ view input = do res <- Ajax.delete (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment]) e - return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res + return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user } @@ -122,21 +123,12 @@ cell users categories frequency currency header payment = let category = L.find ((== (_payment_category payment)) . _category_id) categories - - attrs = - case category of - Just c -> - M.fromList - [ ("class", "tag") - , ("style", T.concat [ "background-color: ", _category_color c ]) - ] - - Nothing -> - M.singleton "display" "none" in - R.elAttr "span" attrs $ - R.text $ - Maybe.fromMaybe "" (_category_name <$> category) + Maybe.fromMaybe R.blank . flip fmap category $ \c -> + Tag.view $ Tag.In + { Tag._in_text = _category_name c + , Tag._in_color = _category_color c + } DateHeader -> if frequency == Punctual then diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index a589fc3..0a3b576 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -50,7 +50,7 @@ view signInMessage = let form = SignInForm <$> Input._out_raw input (signInResult, waiting) <- WaitFor.waitFor - (Ajax.post "/api/askSignIn") + (Ajax.postAndParseResult "/api/askSignIn") (ValidationUtil.fireMaybe ((\f -> f <$ SignInValidation.signIn f) <$> form) validate) diff --git a/common/common.cabal b/common/common.cabal index 17a0ee1..fdede8f 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -31,6 +31,7 @@ Library Exposed-modules: Common.Model + Common.Model.CreateCategoryForm Common.Model.CreateIncomeForm Common.Model.CreatePaymentForm Common.Model.Email @@ -42,6 +43,7 @@ Library Common.Util.Time Common.Util.Validation Common.Validation.Atomic + Common.Validation.Category Common.Validation.Income Common.Validation.Payment Common.Validation.SignIn @@ -52,9 +54,9 @@ Library Common.Message.Lang Common.Message.Translation Common.Model.Category - Common.Model.CreateCategory + Common.Model.CategoryPage Common.Model.Currency - Common.Model.EditCategory + Common.Model.EditCategoryForm Common.Model.EditIncome Common.Model.EditIncomeForm Common.Model.EditPaymentForm diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 00d30f6..73cbf6c 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -1,24 +1,25 @@ module Common.Model (module X) where -import Common.Model.Category as X -import Common.Model.CreateCategory as X -import Common.Model.CreateIncomeForm as X -import Common.Model.CreatePaymentForm as X -import Common.Model.Currency as X -import Common.Model.EditCategory as X -import Common.Model.EditIncome as X -import Common.Model.EditIncomeForm as X -import Common.Model.EditPaymentForm as X -import Common.Model.Email as X -import Common.Model.ExceedingPayer as X -import Common.Model.Frequency as X -import Common.Model.Income as X -import Common.Model.IncomeHeader as X -import Common.Model.IncomePage as X -import Common.Model.Init as X -import Common.Model.InitResult as X -import Common.Model.Payment as X -import Common.Model.PaymentHeader as X -import Common.Model.PaymentPage as X -import Common.Model.SignInForm as X -import Common.Model.User as X +import Common.Model.Category as X +import Common.Model.CategoryPage as X +import Common.Model.CreateCategoryForm as X +import Common.Model.CreateIncomeForm as X +import Common.Model.CreatePaymentForm as X +import Common.Model.Currency as X +import Common.Model.EditCategoryForm as X +import Common.Model.EditIncome as X +import Common.Model.EditIncomeForm as X +import Common.Model.EditPaymentForm as X +import Common.Model.Email as X +import Common.Model.ExceedingPayer as X +import Common.Model.Frequency as X +import Common.Model.Income as X +import Common.Model.IncomeHeader as X +import Common.Model.IncomePage as X +import Common.Model.Init as X +import Common.Model.InitResult as X +import Common.Model.Payment as X +import Common.Model.PaymentHeader as X +import Common.Model.PaymentPage as X +import Common.Model.SignInForm as X +import Common.Model.User as X diff --git a/common/src/Common/Model/Category.hs b/common/src/Common/Model/Category.hs index db1da53..cc3f795 100644 --- a/common/src/Common/Model/Category.hs +++ b/common/src/Common/Model/Category.hs @@ -18,7 +18,7 @@ data Category = Category , _category_createdAt :: UTCTime , _category_editedAt :: Maybe UTCTime , _category_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance FromJSON Category instance ToJSON Category diff --git a/common/src/Common/Model/CategoryPage.hs b/common/src/Common/Model/CategoryPage.hs new file mode 100644 index 0000000..476b4ce --- /dev/null +++ b/common/src/Common/Model/CategoryPage.hs @@ -0,0 +1,17 @@ +module Common.Model.CategoryPage + ( CategoryPage(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +import Common.Model.Category (Category) + +data CategoryPage = CategoryPage + { _categoryPage_page :: Int + , _categoryPage_categories :: [Category] + , _categoryPage_totalCount :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON CategoryPage +instance ToJSON CategoryPage diff --git a/common/src/Common/Model/CreateCategory.hs b/common/src/Common/Model/CreateCategory.hs deleted file mode 100644 index 51bd2a0..0000000 --- a/common/src/Common/Model/CreateCategory.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Common.Model.CreateCategory - ( CreateCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data CreateCategory = CreateCategory - { _createCategory_name :: Text - , _createCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/common/src/Common/Model/CreateCategoryForm.hs b/common/src/Common/Model/CreateCategoryForm.hs new file mode 100644 index 0000000..4668ef4 --- /dev/null +++ b/common/src/Common/Model/CreateCategoryForm.hs @@ -0,0 +1,15 @@ +module Common.Model.CreateCategoryForm + ( CreateCategoryForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data CreateCategoryForm = CreateCategoryForm + { _createCategoryForm_name :: Text + , _createCategoryForm_color :: Text + } deriving (Show, Generic) + +instance FromJSON CreateCategoryForm +instance ToJSON CreateCategoryForm diff --git a/common/src/Common/Model/EditCategory.hs b/common/src/Common/Model/EditCategory.hs deleted file mode 100644 index 8b9d9eb..0000000 --- a/common/src/Common/Model/EditCategory.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Common.Model.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text - , _editCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/common/src/Common/Model/EditCategoryForm.hs b/common/src/Common/Model/EditCategoryForm.hs new file mode 100644 index 0000000..a2ceca0 --- /dev/null +++ b/common/src/Common/Model/EditCategoryForm.hs @@ -0,0 +1,18 @@ +module Common.Model.EditCategoryForm + ( EditCategoryForm(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) + +data EditCategoryForm = EditCategoryForm + { _editCategoryForm_id :: CategoryId + , _editCategoryForm_name :: Text + , _editCategoryForm_color :: Text + } deriving (Show, Generic) + +instance FromJSON EditCategoryForm +instance ToJSON EditCategoryForm diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs index 3516668..2a356df 100644 --- a/common/src/Common/Validation/Atomic.hs +++ b/common/src/Common/Validation/Atomic.hs @@ -4,6 +4,7 @@ module Common.Validation.Atomic , number , nonNullNumber , day + , color ) where import Data.Text (Text) @@ -45,3 +46,7 @@ day str = case Time.parseDay str of Just d -> V.Success d Nothing -> V.Failure $ Msg.get Msg.Form_InvalidDate + +-- TODO: validate +color :: Text -> Validation Text Text +color str = V.Success str diff --git a/common/src/Common/Validation/Category.hs b/common/src/Common/Validation/Category.hs new file mode 100644 index 0000000..f9e6ab4 --- /dev/null +++ b/common/src/Common/Validation/Category.hs @@ -0,0 +1,15 @@ +module Common.Validation.Category + ( name + , color + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import qualified Common.Validation.Atomic as Atomic + +name :: Text -> Validation Text Text +name = Atomic.nonEmpty + +color :: Text -> Validation Text Text +color = Atomic.color diff --git a/server/server.cabal b/server/server.cabal index c9ab2c7..cc6172d 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -94,10 +94,11 @@ Executable server Job.Model Job.MonthlyPayment Job.WeeklyReport - Json LoginSession + Model.CreateCategory Model.CreateIncome Model.CreatePayment + Model.EditCategory Model.EditIncome Model.EditPayment Model.IncomeResource @@ -116,6 +117,7 @@ Executable server Secure SendMail Util.Time + Validation.Category Validation.Income Validation.Payment View.Mail.SignIn diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 8fbc8c8..36ce3fc 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( list + ( listAll + , list , create , edit , delete @@ -7,37 +8,68 @@ module Controller.Category import Control.Monad.IO.Class (liftIO) import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) +import Common.Model (CategoryId, CategoryPage (..), + CreateCategoryForm (..), + EditCategoryForm (..)) import qualified Common.Msg as Msg -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence import qualified Secure +import qualified Validation.Category as CategoryValidation -list :: ActionM () -list = +listAll :: ActionM () +listAll = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.list) >>= json + (liftIO . Query.run $ CategoryPersistence.listAll) >>= json ) -create :: CreateCategory -> ActionM () -create (CreateCategory name color) = +list :: Int -> Int -> ActionM () +list page perPage = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId + (liftIO . Query.run $ do + categories <- CategoryPersistence.list page perPage + count <- CategoryPersistence.count + return $ CategoryPage page categories count + ) >>= json ) -edit :: EditCategory -> ActionM () -edit (EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color - if updated - then status ok200 - else status badRequest400 +create :: CreateCategoryForm -> ActionM () +create form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.createCategory form of + Success (CreateCategory name color) -> do + Right <$> (CategoryPersistence.create name color) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditCategoryForm -> ActionM () +edit form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.editCategory form of + Success (EditCategory categoryId name color) -> + do + isSuccess <- CategoryPersistence.edit categoryId name color + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_CategoryEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest ) delete :: CategoryId -> ActionM () diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs index fd0d2bb..dc9cbc4 100644 --- a/server/src/Controller/Helper.hs +++ b/server/src/Controller/Helper.hs @@ -1,17 +1,16 @@ module Controller.Helper - ( jsonOrBadRequest + ( okOrBadRequest ) where -import Data.Aeson (ToJSON) import Data.Text (Text) import qualified Data.Text.Lazy as LT import qualified Network.HTTP.Types.Status as Status import Web.Scotty (ActionM) import qualified Web.Scotty as S -jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () -jsonOrBadRequest (Left message) = do +okOrBadRequest :: Either Text () -> ActionM () +okOrBadRequest (Left message) = do S.status Status.badRequest400 S.text (LT.fromStrict message) -jsonOrBadRequest (Right a) = - S.json a +okOrBadRequest (Right ()) = + S.status Status.ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 784a2db..96ccbbc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -8,7 +8,7 @@ module Controller.Income import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) @@ -16,6 +16,7 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) +import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -60,7 +61,7 @@ create form = Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditIncomeForm -> ActionM () @@ -68,12 +69,17 @@ edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do case IncomeValidation.editIncome form of - Success (EditIncome incomeId amount date) -> do - Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + Success (EditIncome incomeId amount date) -> + do + isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_IncomeEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: IncomeId -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 42a4436..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -8,7 +8,6 @@ module Controller.Payment import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M -import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar import Data.Validation (Validation (Failure, Success)) @@ -77,30 +76,30 @@ create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.createPayment cs form of Success (CreatePayment name cost date category frequency) -> Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditPaymentForm -> ActionM () edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency - if Maybe.isJust editedPayment then - return . Right $ editedPayment + isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + return $ if isSuccess then + Right () else - return . Left $ Msg.get Msg.Error_PaymentEdit + Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: PaymentId -> ActionM () diff --git a/server/src/Json.hs b/server/src/Json.hs deleted file mode 100644 index 6d40305..0000000 --- a/server/src/Json.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Json - ( jsonObject - , jsonId - ) where - -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Data.Int (Int64) -import Data.Text (Text) -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/server/src/Main.hs b/server/src/Main.hs index f4d75a0..0b80de0 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -77,8 +77,13 @@ main = do incomeId <- S.param "id" Income.delete incomeId - S.get "/api/categories" $ - Category.list + S.get "/api/allCategories" $ do + Category.listAll + + S.get "/api/categories" $ do + page <- S.param "page" + perPage <- S.param "perPage" + Category.list page perPage S.post "/api/category" $ S.jsonData >>= Category.create diff --git a/server/src/Model/CreateCategory.hs b/server/src/Model/CreateCategory.hs new file mode 100644 index 0000000..dae061b --- /dev/null +++ b/server/src/Model/CreateCategory.hs @@ -0,0 +1,10 @@ +module Model.CreateCategory + ( CreateCategory(..) + ) where + +import Data.Text (Text) + +data CreateCategory = CreateCategory + { _createCategory_name :: Text + , _createCategory_color :: Text + } deriving (Show) diff --git a/server/src/Model/EditCategory.hs b/server/src/Model/EditCategory.hs new file mode 100644 index 0000000..8ee26ac --- /dev/null +++ b/server/src/Model/EditCategory.hs @@ -0,0 +1,13 @@ +module Model.EditCategory + ( EditCategory(..) + ) where + +import Data.Text (Text) + +import Common.Model (CategoryId) + +data EditCategory = EditCategory + { _editCategory_id :: CategoryId + , _editCategory_name :: Text + , _editCategory_color :: Text + } deriving (Show) diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 00cf0a5..2934b28 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -1,5 +1,7 @@ module Persistence.Category - ( list + ( count + , list + , listAll , create , edit , delete @@ -27,14 +29,37 @@ instance FromRow Row where SQLite.field <*> SQLite.field) -list :: Query [Category] -list = +data CountRow = CountRow Int + +instance FromRow CountRow where + fromRow = CountRow <$> SQLite.field + +count :: Query Int +count = + Query (\conn -> + (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$> + SQLite.query_ conn "SELECT COUNT(*) FROM category WHERE deleted_at IS NULL" + ) + + +list :: Int -> Int -> Query [Category] +list page perPage = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query + conn + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?" + (perPage, (page - 1) * perPage) + ) + +listAll :: Query [Category] +listAll = Query (\conn -> map (\(Row c) -> c) <$> SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" ) -create :: Text -> Text -> Query CategoryId +create :: Text -> Text -> Query () create categoryName categoryColor = Query (\conn -> do now <- getCurrentTime @@ -42,7 +67,6 @@ create categoryName categoryColor = conn "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn ) edit :: CategoryId -> Text -> Text -> Query Bool diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index e689505..cd98814 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -78,7 +78,7 @@ listModifiedSince since = (since, since, since) ) -create :: UserId -> Day -> Int -> Query Income +create :: UserId -> Day -> Int -> Query () create userId date amount = Query (\conn -> do createdAt <- getCurrentTime @@ -86,42 +86,23 @@ create userId date amount = conn "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" (userId, date, amount, createdAt) - incomeId <- SQLite.lastInsertRowId conn - return $ Income - { _income_id = incomeId - , _income_userId = userId - , _income_date = date - , _income_amount = amount - , _income_createdAt = createdAt - , _income_editedAt = Nothing - , _income_deletedAt = Nothing - } ) -edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income) +edit :: UserId -> IncomeId -> Day -> Int -> Query Bool edit userId incomeId incomeDate incomeAmount = Query (\conn -> do - mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> + income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - do - currentTime <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" - (currentTime, incomeDate, incomeAmount, incomeId, userId) - return . Just $ Income - { _income_id = incomeId - , _income_userId = userId - , _income_date = incomeDate - , _income_amount = incomeAmount - , _income_createdAt = _income_createdAt income - , _income_editedAt = Just currentTime - , _income_deletedAt = Nothing - } - Nothing -> - return Nothing + if Maybe.isJust income then + do + currentTime <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" + (currentTime, incomeDate, incomeAmount, incomeId, userId) + return True + else + return False ) delete :: UserId -> PaymentId -> Query () diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index 953f0ae..da877ff 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -190,30 +190,17 @@ listActiveMonthlyOrderedByName = (Only (FrequencyField Monthly)) ) -create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment +create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () create userId name cost date category frequency = Query (\conn -> do - time <- getCurrentTime + currentTime <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" , "VALUES (?, ?, ?, ?, ?, ?, ?)" ]) - (userId, name, cost, date, category, FrequencyField frequency, time) - paymentId <- SQLite.lastInsertRowId conn - return $ Payment - { _payment_id = paymentId - , _payment_user = userId - , _payment_name = name - , _payment_cost = cost - , _payment_date = date - , _payment_category = category - , _payment_frequency = frequency - , _payment_createdAt = time - , _payment_editedAt = Nothing - , _payment_deletedAt = Nothing - } + (userId, name, cost, date, category, FrequencyField frequency, currentTime) ) createMany :: [Payment] -> Query () @@ -228,17 +215,17 @@ createMany payments = (map InsertRow payments) ) -edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment) +edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Bool edit userId paymentId name cost date category frequency = Query (\conn -> do - mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> + payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> SQLite.query conn (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") (paymentId, userId) - case mbPayment of - Just payment -> do - now <- getCurrentTime + if Maybe.isJust payment then + do + currentTime <- getCurrentTime SQLite.execute conn (SQLite.Query $ T.intercalate " " @@ -255,7 +242,7 @@ edit userId paymentId name cost date category frequency = , " id = ?" , " AND user_id = ?" ]) - ( now + ( currentTime , name , cost , date @@ -264,20 +251,9 @@ edit userId paymentId name cost date category frequency = , paymentId , userId ) - return . Just $ Payment - { _payment_id = paymentId - , _payment_user = userId - , _payment_name = name - , _payment_cost = cost - , _payment_date = date - , _payment_category = category - , _payment_frequency = frequency - , _payment_createdAt = _payment_createdAt payment - , _payment_editedAt = Just now - , _payment_deletedAt = Nothing - } - Nothing -> - return Nothing + return True + else + return False ) delete :: UserId -> PaymentId -> Query () diff --git a/server/src/Validation/Category.hs b/server/src/Validation/Category.hs new file mode 100644 index 0000000..12f2117 --- /dev/null +++ b/server/src/Validation/Category.hs @@ -0,0 +1,27 @@ +module Validation.Category + ( createCategory + , editCategory + ) where + +import Data.Text (Text) +import Data.Validation (Validation) +import qualified Data.Validation as V + +import Common.Model (CreateCategoryForm (..), + EditCategoryForm (..)) +import qualified Common.Validation.Category as CategoryValidation +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) + +createCategory :: CreateCategoryForm -> Validation Text CreateCategory +createCategory form = + CreateCategory + <$> CategoryValidation.name (_createCategoryForm_name form) + <*> CategoryValidation.color (_createCategoryForm_color form) + +editCategory :: EditCategoryForm -> Validation Text EditCategory +editCategory form = + EditCategory + <$> V.Success (_editCategoryForm_id form) + <*> CategoryValidation.name (_editCategoryForm_name form) + <*> CategoryValidation.color (_editCategoryForm_color form) -- cgit v1.2.3 From 1dfb85d3fd56d163fc854a8b3cf659d0ac39f639 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 17:25:29 +0100 Subject: Search payments by cost too --- server/server.cabal | 1 + server/src/Job/WeeklyReport.hs | 2 +- server/src/Persistence/Payment.hs | 160 ++++++++++++++++++++++---------------- server/src/Persistence/Util.hs | 11 +++ 4 files changed, 107 insertions(+), 67 deletions(-) create mode 100644 server/src/Persistence/Util.hs diff --git a/server/server.cabal b/server/server.cabal index cc6172d..d38949d 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -113,6 +113,7 @@ Executable server Persistence.Income Persistence.Payment Persistence.User + Persistence.Util Resource Secure SendMail diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs index 16be396..ff80ddf 100644 --- a/server/src/Job/WeeklyReport.hs +++ b/server/src/Job/WeeklyReport.hs @@ -35,7 +35,7 @@ weeklyReport conf mbLastExecution = do _ -> return M.empty - weekPayments <- PaymentPersistence.listModifiedSince lastExecution + weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution weekIncomes <- IncomePersistence.listModifiedSince lastExecution (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index da877ff..a0cd580 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -3,7 +3,7 @@ module Persistence.Payment , find , getRange , listActivePage - , listModifiedSince + , listModifiedPunctualSince , listActiveMonthlyOrderedByName , create , createMany @@ -23,8 +23,8 @@ import Data.Time.Calendar (Day) import qualified Data.Time.Calendar as Calendar import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only), - ToRow) +import Database.SQLite.Simple (FromRow (fromRow), + NamedParam ((:=)), ToRow) import qualified Database.SQLite.Simple as SQLite import Database.SQLite.Simple.ToField (ToField (toField)) import Prelude hiding (id, until) @@ -32,11 +32,12 @@ import Prelude hiding (id, until) import Common.Model (CategoryId, Frequency (..), Payment (..), PaymentId, User (..), UserId) +import qualified Common.Util.Text as TextUtil import Model.Query (Query (Query)) import Persistence.Frequency (FrequencyField (..)) import qualified Persistence.Income as IncomePersistence - +import qualified Persistence.Util as PersistenceUtil fields :: Text @@ -90,27 +91,30 @@ count :: Frequency -> Text -> Query Int count frequency search = Query (\conn -> (\[Count n] -> n) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT COUNT(*)" , "FROM payment" , "WHERE" , "deleted_at IS NULL" - , "AND frequency = ?" - , "AND name LIKE ?" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" ]) - (FrequencyField frequency, "%" <> search <> "%") + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + ] ) find :: PaymentId -> Query (Maybe Payment) find paymentId = Query (\conn -> do fmap (\(Row p) -> p) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn - (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?") - (Only paymentId) + (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = :id") + [ "id" := paymentId + ] ) data RangeRow = RangeRow (Day, Day) @@ -122,23 +126,24 @@ getRange :: Query (Maybe (Day, Day)) getRange = Query (\conn -> do fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT MIN(date), MAX(date)" , "FROM payment" , "WHERE" - , "frequency = ?" + , "frequency = :frequency" , "AND deleted_at IS NULL" ]) - (Only (FrequencyField Punctual)) + [ ":frequency" := FrequencyField Punctual + ] ) listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] listActivePage frequency page perPage search = Query (\conn -> map (\(Row p) -> p) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT" @@ -146,31 +151,36 @@ listActivePage frequency page perPage search = , "FROM payment" , "WHERE" , "deleted_at IS NULL" - , "AND frequency = ?" - , "AND name LIKE ?" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" , "ORDER BY date DESC" - , "LIMIT ?" - , "OFFSET ?" + , "LIMIT :limit" + , "OFFSET :offset" ] ) - (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] ) -listModifiedSince :: UTCTime -> Query [Payment] -listModifiedSince since = +listModifiedPunctualSince :: UTCTime -> Query [Payment] +listModifiedPunctualSince since = Query (\conn -> map (\(Row i) -> i) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT " <> fields , "FROM payment" , "WHERE" - , "created_at >= ?" - , "OR edited_at >= ?" - , "OR deleted_at >= ?" + , "frequency = :frequency" + , "AND (created_at >= :since OR edited_at >= :since OR deleted_at >= :since)" ]) - (since, since, since) + [ ":frequency" := FrequencyField Punctual + , ":since" := since + ] ) @@ -178,29 +188,37 @@ listActiveMonthlyOrderedByName :: Query [Payment] listActiveMonthlyOrderedByName = Query (\conn -> do map (\(Row p) -> p) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query $ T.intercalate " " [ "SELECT" , fields , "FROM payment" - , "WHERE deleted_at IS NULL AND frequency = ?" + , "WHERE deleted_at IS NULL AND frequency = :frequency" , "ORDER BY name DESC" ]) - (Only (FrequencyField Monthly)) + [ ":frequency" := FrequencyField Monthly + ] ) create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query () create userId name cost date category frequency = Query (\conn -> do currentTime <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn (SQLite.Query $ T.intercalate " " [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?, ?)" + , "VALUES (:userId, :name, :cost, :date, :category, :frequency, :currentTime)" ]) - (userId, name, cost, date, category, FrequencyField frequency, currentTime) + [ ":userId" := userId + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":currentTime" := currentTime + ] ) createMany :: [Payment] -> Query () @@ -219,38 +237,41 @@ edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> edit userId paymentId name cost date category frequency = Query (\conn -> do payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn - (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?") - (paymentId, userId) + (SQLite.Query $ + "SELECT " <> fields <> " FROM payment WHERE id = :paymentId and user_id = :userId") + [ ":paymentId" := paymentId + , ":userId" := userId + ] if Maybe.isJust payment then do currentTime <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn (SQLite.Query $ T.intercalate " " [ "UPDATE" , " payment" , "SET" - , " edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " category = ?," - , " frequency = ?" + , " edited_at = :editedAt," + , " name = :name," + , " cost = :cost," + , " date = :date," + , " category = :category," + , " frequency = :frequency" , "WHERE" - , " id = ?" - , " AND user_id = ?" + , " id = :id" + , " AND user_id = :userId" ]) - ( currentTime - , name - , cost - , date - , category - , FrequencyField frequency - , paymentId - , userId - ) + [ ":editedAt" := currentTime + , ":name" := name + , ":cost" := cost + , ":date" := date + , ":category" := category + , ":frequency" := FrequencyField frequency + , ":id" := paymentId + , ":userId" := userId + ] return True else return False @@ -259,10 +280,12 @@ edit userId paymentId name cost date category frequency = delete :: UserId -> PaymentId -> Query () delete userId paymentId = Query (\conn -> - SQLite.execute + SQLite.executeNamed conn - "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" - (paymentId, userId) + "UPDATE payment SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := paymentId + , ":userId" := userId + ] ) data CategoryIdRow = CategoryIdRow CategoryId @@ -274,16 +297,17 @@ searchCategory :: Text -> Query (Maybe CategoryId) searchCategory paymentName = Query (\conn -> fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT category" , "FROM payment" - , "WHERE deleted_at is NULL AND name LIKE ?" + , "WHERE deleted_at is NULL AND name LIKE :name" , "ORDER BY edited_at, created_at" , "LIMIT 1" ]) - (Only $ "%" <> paymentName <> "%") + [ ":name" := "%" <> paymentName <> "%" + ] ) data UserCostRow = UserCostRow (UserId, Int) @@ -297,20 +321,24 @@ instance FromRow UserCostRow where repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int) repartition frequency search from to = Query (\conn -> - M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query + M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT user_id, SUM(cost)" , "FROM payment" , "WHERE" , "deleted_at IS NULL" - , "AND frequency = ?" - , "AND name LIKE ?" - , "AND date >= ?" - , "AND date < ?" + , "AND frequency = :frequency" + , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)" + , "AND date >= :from" + , "AND date < :to" , "GROUP BY user_id" ]) - (FrequencyField frequency, "%" <> search <> "%", from, to) + [ ":frequency" := FrequencyField frequency + , ":search" := "%" <> TextUtil.formatSearch search <> "%" + , ":from" := from + , ":to" := to + ] ) getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int) diff --git a/server/src/Persistence/Util.hs b/server/src/Persistence/Util.hs new file mode 100644 index 0000000..b7496c6 --- /dev/null +++ b/server/src/Persistence/Util.hs @@ -0,0 +1,11 @@ +module Persistence.Util + ( formatKeyForSearch + ) where + +import Data.Text (Text) + +formatKeyForSearch :: Text -> Text +formatKeyForSearch key = + "replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(" + <> key + <> "), 'à', 'a'), 'â', 'a'), 'ç', 'c'), 'è', 'e'), 'é', 'e'), 'ê', 'e'), 'ë', 'e'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ù', 'u'), 'û', 'u'), 'ü', 'u')" -- cgit v1.2.3 From da2a0c13aa89705c65fdb9df2f496fb4eea29654 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 19:22:45 +0100 Subject: Allow to remove only unused categories --- client/src/Component/Input.hs | 2 +- client/src/Component/Table.hs | 9 +++-- client/src/View/Category/Category.hs | 34 +++++++++--------- client/src/View/Category/Table.hs | 16 +++++---- client/src/View/Income/Table.hs | 3 +- client/src/View/Payment/Table.hs | 3 +- common/src/Common/Model/CategoryPage.hs | 9 ++--- common/src/Common/Validation/Atomic.hs | 9 +++-- server/src/Controller/Category.hs | 5 +-- server/src/Persistence/Category.hs | 64 +++++++++++++++++++++------------ server/src/Persistence/Payment.hs | 14 ++++++++ 11 files changed, 107 insertions(+), 61 deletions(-) diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 37020da..bcff377 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -57,7 +57,7 @@ view input reset validate = do ] inputAttr = R.ffor value (\v -> - if T.null v && _in_inputType input /= "date" + if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color" then M.empty else M.singleton "class" "filled") diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs index f82cfa6..1482f91 100644 --- a/client/src/Component/Table.hs +++ b/client/src/Component/Table.hs @@ -21,7 +21,8 @@ data In m t h r = In , _in_cloneModal :: r -> Modal.Content t m , _in_editModal :: r -> Modal.Content t m , _in_deleteModal :: r -> Modal.Content t m - , _in_isOwner :: r -> Bool + , _in_canEdit :: r -> Bool + , _in_canDelete :: r -> Bool } data Out t = Out @@ -62,8 +63,6 @@ view input = , Modal._in_content = _in_cloneModal input row } - let isOwner = _in_isOwner input row - let visibleIf cond = R.elAttr "div" @@ -71,7 +70,7 @@ view input = editButton <- R.divClass "cell button" $ - visibleIf isOwner $ + visibleIf (_in_canEdit input row) $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.edit) @@ -83,7 +82,7 @@ view input = deleteButton <- R.divClass "cell button" $ - visibleIf isOwner $ + visibleIf (_in_canDelete input row) $ Button._out_clic <$> (Button.view $ Button.defaultIn Icon.delete) diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs index 77a331a..5b41bb6 100644 --- a/client/src/View/Category/Category.hs +++ b/client/src/View/Category/Category.hs @@ -53,13 +53,14 @@ view input = do deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b) result <- Loadable.viewShowValueWhileLoading categoryPage $ - \(CategoryPage page categories count) -> do + \(CategoryPage page categories usedCategories count) -> do header <- headerView table <- Table.view $ Table.In { Table._in_currentUser = _in_currentUser input , Table._in_currency = _in_currency input , Table._in_categories = categories + , Table._in_usedCategories = usedCategories , Table._in_users = _in_users input } @@ -75,18 +76,19 @@ view input = do headerView :: forall t m. MonadWidget t m => m (Event t ()) headerView = - R.divClass "titleButton" $ do - R.el "h1" $ - R.text $ - Msg.get Msg.Category_Title - - addCategory <- Button._out_clic <$> - (Button.view . Button.defaultIn . R.text $ - Msg.get Msg.Category_Add) - - addCategory <- Modal.view $ Modal.In - { Modal._in_show = addCategory - , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } - } - - return addCategory + R.divClass "withMargin" $ + R.divClass "titleButton" $ do + R.el "h1" $ + R.text $ + Msg.get Msg.Category_Title + + addCategory <- Button._out_clic <$> + (Button.view . Button.defaultIn . R.text $ + Msg.get Msg.Category_Add) + + addCategory <- Modal.view $ Modal.In + { Modal._in_show = addCategory + , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New } + } + + return addCategory diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs index fbe76e9..90d013d 100644 --- a/client/src/View/Category/Table.hs +++ b/client/src/View/Category/Table.hs @@ -10,8 +10,8 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Currency, User (..), - UserId) +import Common.Model (Category (..), CategoryId, Currency, + User (..), UserId) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -24,10 +24,11 @@ import qualified Util.Either as EitherUtil import qualified View.Category.Form as Form data In t = In - { _in_currentUser :: UserId - , _in_currency :: Currency - , _in_categories :: [Category] - , _in_users :: [User] + { _in_currentUser :: UserId + , _in_currency :: Currency + , _in_categories :: [Category] + , _in_usedCategories :: [CategoryId] + , _in_users :: [User] } data Out t = Out @@ -60,7 +61,8 @@ view input = do e return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } - , Table._in_isOwner = const True + , Table._in_canEdit = const True + , Table._in_canDelete = not . flip elem (_in_usedCategories input) . _category_id } return $ Out diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs index c7f172b..7b7940d 100644 --- a/client/src/View/Income/Table.hs +++ b/client/src/View/Income/Table.hs @@ -59,7 +59,8 @@ view input = do e return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } - , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId + , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId + , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId } return $ Out diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 6744d3a..bfa0fb9 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -74,7 +74,8 @@ view input = do e return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res } - , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user + , Table._in_canEdit = (== (_in_currentUser input)) . _payment_user + , Table._in_canDelete = (== (_in_currentUser input)) . _payment_user } return $ Out diff --git a/common/src/Common/Model/CategoryPage.hs b/common/src/Common/Model/CategoryPage.hs index 476b4ce..e20f49f 100644 --- a/common/src/Common/Model/CategoryPage.hs +++ b/common/src/Common/Model/CategoryPage.hs @@ -5,12 +5,13 @@ module Common.Model.CategoryPage import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) -import Common.Model.Category (Category) +import Common.Model.Category (Category, CategoryId) data CategoryPage = CategoryPage - { _categoryPage_page :: Int - , _categoryPage_categories :: [Category] - , _categoryPage_totalCount :: Int + { _categoryPage_page :: Int + , _categoryPage_categories :: [Category] + , _categoryPage_usedCategories :: [CategoryId] + , _categoryPage_totalCount :: Int } deriving (Eq, Show, Generic) instance FromJSON CategoryPage diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs index 2a356df..4bb7cad 100644 --- a/common/src/Common/Validation/Atomic.hs +++ b/common/src/Common/Validation/Atomic.hs @@ -7,6 +7,7 @@ module Common.Validation.Atomic , color ) where +import qualified Data.Char as Char import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day) @@ -47,6 +48,10 @@ day str = Just d -> V.Success d Nothing -> V.Failure $ Msg.get Msg.Form_InvalidDate --- TODO: validate color :: Text -> Validation Text Text -color str = V.Success str +color str = + if T.take 1 str == "#" && T.all Char.isHexDigit (T.drop 1 str) then + V.Success str + + else + V.Failure (Msg.get Msg.Form_InvalidColor) diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 36ce3fc..371ba78 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -22,6 +22,7 @@ import Model.CreateCategory (CreateCategory (..)) import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Payment as PaymentPersistence import qualified Secure import qualified Validation.Category as CategoryValidation @@ -36,8 +37,9 @@ list page perPage = Secure.loggedAction (\_ -> (liftIO . Query.run $ do categories <- CategoryPersistence.list page perPage + usedCategories <- PaymentPersistence.usedCategories count <- CategoryPersistence.count - return $ CategoryPage page categories count + return $ CategoryPage page categories usedCategories count ) >>= json ) @@ -76,7 +78,6 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - -- TODO: delete only if no payment has this category CategoryPersistence.delete categoryId if deleted then diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs index 2934b28..b0a6fca 100644 --- a/server/src/Persistence/Category.hs +++ b/server/src/Persistence/Category.hs @@ -10,7 +10,7 @@ module Persistence.Category import qualified Data.Maybe as Maybe import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) @@ -46,10 +46,12 @@ list :: Int -> Int -> Query [Category] list page perPage = Query (\conn -> map (\(Row c) -> c) <$> - SQLite.query + SQLite.queryNamed conn - "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?" - (perPage, (page - 1) * perPage) + "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY name LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] ) listAll :: Query [Category] @@ -60,43 +62,61 @@ listAll = ) create :: Text -> Text -> Query () -create categoryName categoryColor = +create name color = Query (\conn -> do - now <- getCurrentTime - SQLite.execute + currentTime <- getCurrentTime + SQLite.executeNamed conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) + "INSERT INTO category (name, color, created_at) VALUES (:name, :color, :created_at)" + [ ":name" := name + , ":color" := color + , ":created_at" := currentTime + ] ) edit :: CategoryId -> Text -> Text -> Query Bool -edit categoryId categoryName categoryColor = +edit id name color = Query (\conn -> do mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + (SQLite.queryNamed conn "SELECT * FROM category WHERE id = :id" [ ":id" := id ]) if Maybe.isJust mbCategory then do - now <- getCurrentTime - SQLite.execute + currentTime <- getCurrentTime + SQLite.executeNamed conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) + "UPDATE category SET edited_at = :editedAt, name = :name, color = :color WHERE id = :id" + [ ":editedAt" := currentTime + , ":name" := name + , ":color" := color + , ":id" := id + ] return True else return False ) +data BoolRow = BoolRow Int + +instance FromRow BoolRow where + fromRow = BoolRow <$> SQLite.field + delete :: CategoryId -> Query Bool -delete categoryId = +delete id = Query (\conn -> do - mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) - if Maybe.isJust mbCategory + mbPayment <- (fmap (\(BoolRow b) -> b) . Maybe.listToMaybe) <$> + (SQLite.queryNamed + conn + "SELECT true FROM payment WHERE category = :id AND deleted_at IS NULL" + [ ":id" := id ]) + if Maybe.isNothing mbPayment then do - now <- getCurrentTime - SQLite.execute + currentTime <- getCurrentTime + SQLite.executeNamed conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + "UPDATE category SET deleted_at = :deletedAt WHERE id = :id AND deleted_at IS NULL" + [ ":deletedAt" := currentTime + , ":id" := id + ] return True else return False diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index a0cd580..b3eb141 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -12,6 +12,7 @@ module Persistence.Payment , searchCategory , repartition , getPreAndPostPaymentRepartition + , usedCategories ) where import Data.Map (Map) @@ -310,6 +311,19 @@ searchCategory paymentName = ] ) +usedCategories :: Query [CategoryId] +usedCategories = + Query (\conn -> do + map (\(CategoryIdRow p) -> p) <$> + SQLite.query_ + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT DISTINCT category" + , "FROM payment" + , "WHERE deleted_at IS NULL" + ]) + ) + data UserCostRow = UserCostRow (UserId, Int) instance FromRow UserCostRow where -- cgit v1.2.3 From cdb0ae1aeb22d7d7c36acb9d580f3723aa469829 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 19:26:08 +0100 Subject: Go to page 1 when switching the search frequency --- client/src/View/Payment/Reducer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs index 7468097..3fe59b2 100644 --- a/client/src/View/Payment/Reducer.hs +++ b/client/src/View/Payment/Reducer.hs @@ -68,7 +68,7 @@ reducer input = do Just $ params { _params_search = search, _params_page = _params_page initParams } Frequency frequency -> - Just $ params { _params_frequency = frequency } + Just $ params { _params_frequency = frequency, _params_page = _params_page initParams } ResetSearch -> Just $ initParams { _params_frequency = _params_frequency params } -- cgit v1.2.3 From fff99e6fb1c03235e219a94ce52acf5a50d3fb62 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 5 Jan 2020 16:03:48 +0100 Subject: Use named parameters instead of positional parameters in persistence queries --- server/src/Persistence/Income.hs | 56 ++++++++++++++++++++++++---------------- server/src/Persistence/User.hs | 9 ++++--- 2 files changed, 40 insertions(+), 25 deletions(-) diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index cd98814..76cb952 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -17,8 +17,7 @@ import qualified Data.Text as T import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)), - Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id, until) @@ -55,63 +54,76 @@ list :: Int -> Int -> Query [Income] list page perPage = Query (\conn -> map (\(Row i) -> i) <$> - SQLite.query + SQLite.queryNamed conn - "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?" - (perPage, (page - 1) * perPage) + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT :limit OFFSET :offset" + [ ":limit" := perPage + , ":offset" := (page - 1) * perPage + ] ) listModifiedSince :: UTCTime -> Query [Income] listModifiedSince since = Query (\conn -> map (\(Row i) -> i) <$> - SQLite.query + SQLite.queryNamed conn (SQLite.Query . T.intercalate " " $ [ "SELECT *" , "FROM income" , "WHERE" - , "created_at >= ?" - , "OR edited_at >= ?" - , "OR deleted_at >= ?" + , "created_at >= :since" + , "OR edited_at >= :since" + , "OR deleted_at >= :since" ]) - (since, since, since) + [ ":since" := since ] ) create :: UserId -> Day -> Int -> Query () create userId date amount = Query (\conn -> do createdAt <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (userId, date, amount, createdAt) + "INSERT INTO income (user_id, date, amount, created_at) VALUES (:userId, :date, :amount, :createdAt)" + [ ":userId" := userId + , ":date" := date + , ":amount" := amount + , ":createdAt" := createdAt + ] ) edit :: UserId -> IncomeId -> Day -> Int -> Query Bool -edit userId incomeId incomeDate incomeAmount = +edit userId id date amount = Query (\conn -> do income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$> - SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + SQLite.queryNamed conn "SELECT * FROM income WHERE id = :id" [ ":id" := id ] if Maybe.isJust income then do currentTime <- getCurrentTime - SQLite.execute + SQLite.executeNamed conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?" - (currentTime, incomeDate, incomeAmount, incomeId, userId) + "UPDATE income SET edited_at = :editedAt, date = :date, amount = :amount WHERE id = :id AND user_id = :userId" + [ ":editedAt" := currentTime + , ":date" := date + , ":amount" := amount + , ":id" := id + , ":userId" := userId + ] return True else return False ) delete :: UserId -> PaymentId -> Query () -delete userId paymentId = +delete userId id = Query (\conn -> - SQLite.execute + SQLite.executeNamed conn - "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?" - (paymentId, userId) + "UPDATE income SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId" + [ ":id" := id + , ":userId" := userId + ] ) data UserDayRow = UserDayRow (UserId, Day) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 3c3a2b1..89eb57d 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -5,7 +5,7 @@ module Persistence.User import qualified Data.Maybe as Maybe import Data.Text (Text) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite import Prelude hiding (id) @@ -30,8 +30,11 @@ list = ) get :: Text -> Query (Maybe User) -get userEmail = +get email = Query (\conn -> do fmap (\(Row u) -> u) . Maybe.listToMaybe <$> - SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + SQLite.queryNamed + conn + "SELECT * FROM user WHERE email = :email LIMIT 1" + [ ":email" := email ] ) -- cgit v1.2.3 From bc48d7428607c84003658d5b88d41cf923d010fd Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 18 Jan 2020 16:18:26 +0100 Subject: Add deploy command --- Makefile | 21 ++- README.md | 6 +- server/migrations/2.sql | 4 +- validation/src/Data/Validation.hs | 375 ++++++++++++++++++++++++++++++++++++++ validation/validation.cabal | 2 +- 5 files changed, 397 insertions(+), 11 deletions(-) create mode 100644 validation/src/Data/Validation.hs diff --git a/Makefile b/Makefile index 5c615b3..5097b56 100644 --- a/Makefile +++ b/Makefile @@ -4,11 +4,6 @@ start: stop: @tmux kill-session -t sharedCost -dist: - @nix-build -o result-server -A ghc.server - @nix-build -o result-client -A ghcjs.client - @nix-shell -p closurecompiler --command 'closure-compiler result-client/bin/client.jsexe/all.js --js_output_file public/javascript/main.js' - clean: clean-server clean-client build: build-server build-client cp-client @@ -49,3 +44,19 @@ run-server: watch-server: @nix-shell -A shells.ghc --run "nodemon --delay 0.2 --watch ./server --watch ./common --ext hs --exec '(tput reset && make build-server-inside && make run-server) || :'" + +# Deploy +# ------ + +deploy: + @make clean + @nix-build -o result-server -A ghc.server + @nix-build -o result-client -A ghcjs.client + @nix-shell -p closurecompiler --command 'closure-compiler result-client/bin/client.jsexe/all.js --js_output_file public/javascript/main.js' + @rm -rf bundle + @mkdir bundle + @cp application.conf bundle + @cp -r public bundle + @cp result-server/bin/server bundle + @rsync -avzhr bundle/ guyonvarch.me:servers/shared-cost + @rm -rf bundle diff --git a/README.md b/README.md index c83a18b..2037cae 100644 --- a/README.md +++ b/README.md @@ -41,10 +41,10 @@ Later, stop the environment with: ./make stop ``` -## Dist +## Deploy -``` -make dist +```bash +make deploy ``` ## Configuration diff --git a/server/migrations/2.sql b/server/migrations/2.sql index efed046..c1d502f 100644 --- a/server/migrations/2.sql +++ b/server/migrations/2.sql @@ -35,10 +35,10 @@ UPDATE SET category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) WHERE - EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)) + EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name)); DELETE FROM payment WHERE category = -1; -- Remove -DROP TABLE payment_category +DROP TABLE payment_category; diff --git a/validation/src/Data/Validation.hs b/validation/src/Data/Validation.hs new file mode 100644 index 0000000..e30202f --- /dev/null +++ b/validation/src/Data/Validation.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +#endif + +-- | A data type similar to @Data.Either@ that accumulates failures. +module Data.Validation +( + -- * Data type + Validation(..) + -- * Constructing validations +, validate +, validationNel +, fromEither +, liftError + -- * Functions on validations +, validation +, toEither +, orElse +, valueOr +, ensure +, codiagonal +, validationed +, bindValidation + -- * Prisms + -- | These prisms are useful for writing code which is polymorphic in its + -- choice of Either or Validation. This choice can then be made later by a + -- user, depending on their needs. + -- + -- An example of this style of usage can be found + -- +, _Failure +, _Success + -- * Isomorphisms +, Validate(..) +, revalidate +) where + +import Control.Applicative (Applicative (pure, (<*>)), (<$>)) +import Control.DeepSeq (NFData (rnf)) +import Control.Lens (over, under) +import Control.Lens.Getter ((^.)) +import Control.Lens.Iso (Iso, Swapped (..), from, iso) +import Control.Lens.Prism (Prism, prism) +import Control.Lens.Review (( # )) +import Data.Bifoldable (Bifoldable (bifoldr)) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Bitraversable (Bitraversable (bitraverse)) +import Data.Data (Data) +import Data.Either (Either (Left, Right), either) +import Data.Eq (Eq) +import Data.Foldable (Foldable (foldr)) +import Data.Function (id, ($), (.)) +import Data.Functor (Functor (fmap)) +import Data.Functor.Alt (Alt (())) +import Data.Functor.Apply (Apply ((<.>))) +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Ord (Ord) +import Data.Semigroup (Semigroup ((<>))) +import Data.Traversable (Traversable (traverse)) +import Data.Typeable (Typeable) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (Generic) +#endif +import Prelude (Maybe (..), Show) + + +-- | An @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However, +-- the 'Applicative' instance for @Validation@ /accumulates/ errors using a 'Semigroup' on @err@. +-- In contrast, the @Applicative@ for @Either@ returns only the first error. +-- +-- A consequence of this is that @Validation@ has no 'Data.Functor.Bind.Bind' or 'Control.Monad.Monad' instance. This is because +-- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the +-- @Applicative@'s 'Control.Applicative.<*>' +-- +-- An example of typical usage can be found . +-- +data Validation err a = + Failure err + | Success a + deriving ( + Eq, Ord, Show, Data, Typeable +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif + ) + +instance Functor (Validation err) where + fmap _ (Failure e) = + Failure e + fmap f (Success a) = + Success (f a) + {-# INLINE fmap #-} + +instance Semigroup err => Apply (Validation err) where + Failure e1 <.> b = Failure $ case b of + Failure e2 -> e1 <> e2 + Success _ -> e1 + Success _ <.> Failure e2 = + Failure e2 + Success f <.> Success a = + Success (f a) + {-# INLINE (<.>) #-} + +instance Semigroup err => Applicative (Validation err) where + pure = + Success + (<*>) = + (<.>) + +-- | For two errors, this instance reports only the last of them. +instance Alt (Validation err) where + Failure _ x = + x + Success a _ = + Success a + {-# INLINE () #-} + +instance Foldable (Validation err) where + foldr f x (Success a) = + f a x + foldr _ x (Failure _) = + x + {-# INLINE foldr #-} + +instance Traversable (Validation err) where + traverse f (Success a) = + Success <$> f a + traverse _ (Failure e) = + pure (Failure e) + {-# INLINE traverse #-} + +instance Bifunctor Validation where + bimap f _ (Failure e) = + Failure (f e) + bimap _ g (Success a) = + Success (g a) + {-# INLINE bimap #-} + + +instance Bifoldable Validation where + bifoldr _ g x (Success a) = + g a x + bifoldr f _ x (Failure e) = + f e x + {-# INLINE bifoldr #-} + +instance Bitraversable Validation where + bitraverse _ g (Success a) = + Success <$> g a + bitraverse f _ (Failure e) = + Failure <$> f e + {-# INLINE bitraverse #-} + +appValidation :: + (err -> err -> err) + -> Validation err a + -> Validation err a + -> Validation err a +appValidation m (Failure e1) (Failure e2) = + Failure (e1 `m` e2) +appValidation _ (Failure _) (Success a2) = + Success a2 +appValidation _ (Success a1) (Failure _) = + Success a1 +appValidation _ (Success a1) (Success _) = + Success a1 +{-# INLINE appValidation #-} + +instance Semigroup e => Semigroup (Validation e a) where + (<>) = + appValidation (<>) + {-# INLINE (<>) #-} + +instance Monoid e => Monoid (Validation e a) where + mappend = + appValidation mappend + {-# INLINE mappend #-} + mempty = + Failure mempty + {-# INLINE mempty #-} + +instance Swapped Validation where + swapped = + iso + (\v -> case v of + Failure e -> Success e + Success a -> Failure a) + (\v -> case v of + Failure a -> Success a + Success e -> Failure e) + {-# INLINE swapped #-} + +instance (NFData e, NFData a) => NFData (Validation e a) where + rnf v = + case v of + Failure e -> rnf e + Success a -> rnf a + +-- | 'validate's an @a@ producing an updated optional value, returning +-- @e@ in the empty case. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- validate :: e -> (a -> Maybe b) -> a -> Validation e b +-- @ +validate :: Validate v => e -> (a -> Maybe b) -> a -> v e b +validate e p a = case p a of + Nothing -> _Failure # e + Just b -> _Success # b + +-- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since +-- they are a common semigroup to use. +validationNel :: Either e a -> Validation (NonEmpty e) a +validationNel = liftError pure + +-- | Converts from 'Either' to 'Validation'. +fromEither :: Either e a -> Validation e a +fromEither = liftError id + +-- | 'liftError' is useful for converting an 'Either' to an 'Validation' +-- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'. +liftError :: (b -> e) -> Either b a -> Validation e a +liftError f = either (Failure . f) Success + +-- | 'validation' is the catamorphism for @Validation@. +validation :: (e -> c) -> (a -> c) -> Validation e a -> c +validation ec ac v = case v of + Failure e -> ec e + Success a -> ac a + +-- | Converts from 'Validation' to 'Either'. +toEither :: Validation e a -> Either e a +toEither = validation Left Right + +-- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- orElse :: Validation e a -> a -> a +-- @ +orElse :: Validate v => v e a -> a -> a +orElse v a = case v ^. _Validation of + Failure _ -> a + Success x -> x + +-- | Return the @a@ or run the given function over the @e@. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- valueOr :: (e -> a) -> Validation e a -> a +-- @ +valueOr :: Validate v => (e -> a) -> v e a -> a +valueOr ea v = case v ^. _Validation of + Failure e -> ea e + Success a -> a + +-- | 'codiagonal' gets the value out of either side. +codiagonal :: Validation a a -> a +codiagonal = valueOr id + +-- | 'ensure' ensures that a validation remains unchanged upon failure, +-- updating a successful validation with an optional value that could fail +-- with @e@ otherwise. +-- +-- This can be thought of as having the less general type: +-- +-- @ +-- ensure :: e -> (a -> Maybe b) -> Validation e a -> Validation e b +-- @ +ensure :: Validate v => e -> (a -> Maybe b) -> v e a -> v e b +ensure e p = + over _Validation $ \v -> case v of + Failure x -> Failure x + Success a -> validate e p a + +-- | Run a function on anything with a Validate instance (usually Either) +-- as if it were a function on Validation +-- +-- This can be thought of as having the type +-- +-- @(Either e a -> Either e' a') -> Validation e a -> Validation e' a'@ +validationed :: Validate v => (v e a -> v e' a') -> Validation e a -> Validation e' a' +validationed f = under _Validation f + +-- | @bindValidation@ binds through an Validation, which is useful for +-- composing Validations sequentially. Note that despite having a bind +-- function of the correct type, Validation is not a monad. +-- The reason is, this bind does not accumulate errors, so it does not +-- agree with the Applicative instance. +-- +-- There is nothing wrong with using this function, it just does not make a +-- valid @Monad@ instance. +bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b +bindValidation v f = case v of + Failure e -> Failure e + Success a -> f a + +-- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic +-- to Validation, and hence isomorphic to Either. +class Validate f where + _Validation :: + Iso (f e a) (f g b) (Validation e a) (Validation g b) + + _Either :: + Iso (f e a) (f g b) (Either e a) (Either g b) + _Either = + iso + (\x -> case x ^. _Validation of + Failure e -> Left e + Success a -> Right a) + (\x -> _Validation # case x of + Left e -> Failure e + Right a -> Success a) + {-# INLINE _Either #-} + +instance Validate Validation where + _Validation = + id + {-# INLINE _Validation #-} + _Either = + iso + (\x -> case x of + Failure e -> Left e + Success a -> Right a) + (\x -> case x of + Left e -> Failure e + Right a -> Success a) + {-# INLINE _Either #-} + +instance Validate Either where + _Validation = + iso + fromEither + toEither + {-# INLINE _Validation #-} + _Either = + id + {-# INLINE _Either #-} + +-- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'Validation'. +_Failure :: + Validate f => + Prism (f e1 a) (f e2 a) e1 e2 +_Failure = + prism + (\x -> _Either # Left x) + (\x -> case x ^. _Either of + Left e -> Right e + Right a -> Left (_Either # Right a)) +{-# INLINE _Failure #-} + +-- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'Validation'. +_Success :: + Validate f => + Prism (f e a) (f e b) a b +_Success = + prism + (\x -> _Either # Right x) + (\x -> case x ^. _Either of + Left e -> Left (_Either # Left e) + Right a -> Right a) +{-# INLINE _Success #-} + +-- | 'revalidate' converts between any two instances of 'Validate'. +revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t) +revalidate = _Validation . from _Validation diff --git a/validation/validation.cabal b/validation/validation.cabal index 6e2458b..60e5444 100644 --- a/validation/validation.cabal +++ b/validation/validation.cabal @@ -1,7 +1,7 @@ name: validation version: 1 license: BSD3 -license-file: LICENCE +license-file: LICENSE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> , Nick Partridge , Queensland Functional Programming Lab synopsis: A data-type like Either but with an accumulating Applicative -- cgit v1.2.3 From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- README.md | 6 +- client/src/Component/Button.hs | 2 +- client/src/Main.hs | 10 +-- client/src/Util/Validation.hs | 11 --- client/src/View/App.hs | 61 +++++++-------- client/src/View/Header.hs | 52 ++++++------- client/src/View/SignIn.hs | 71 +++++++++-------- common/common.cabal | 2 +- common/src/Common/Message/Key.hs | 11 +-- common/src/Common/Message/Translation.hs | 74 ++---------------- common/src/Common/Model.hs | 2 +- common/src/Common/Model/InitResult.hs | 18 ----- common/src/Common/Model/Password.hs | 12 +++ common/src/Common/Model/SignInForm.hs | 3 +- common/src/Common/Validation/Atomic.hs | 12 ++- common/src/Common/Validation/SignIn.hs | 14 ++-- server/migrations/3.sql | 5 ++ server/server.cabal | 4 +- server/src/Controller/Index.hs | 128 ++++++++++--------------------- server/src/Main.hs | 8 +- server/src/Model/HashedPassword.hs | 27 +++++++ server/src/Model/SignIn.hs | 60 +-------------- server/src/Persistence/User.hs | 48 ++++++++++-- server/src/Secure.hs | 27 ++----- server/src/Validation/SignIn.hs | 16 ++++ server/src/View/Mail/SignIn.hs | 21 ----- server/src/View/Page.hs | 9 ++- 27 files changed, 296 insertions(+), 418 deletions(-) delete mode 100644 common/src/Common/Model/InitResult.hs create mode 100644 common/src/Common/Model/Password.hs create mode 100644 server/migrations/3.sql create mode 100644 server/src/Model/HashedPassword.hs create mode 100644 server/src/Validation/SignIn.hs delete mode 100644 server/src/View/Mail/SignIn.hs diff --git a/README.md b/README.md index 2037cae..8c736d4 100644 --- a/README.md +++ b/README.md @@ -25,14 +25,16 @@ Init the database with migration scripts: ```bash sqlite3 database < server/migrations/1.sql +sqlite3 database < server/migrations/2.sql +sqlite3 database < server/migrations/3.sql ``` Inside the tmux session, add some users with sqlite after the migration is done: ``` sqlite3 database -insert into user(creation, email, name) values (datetime('now'), 'john@mail.com', 'John'); -insert into user(creation, email, name) values (datetime('now'), 'lisa@mail.com', 'Lisa'); +insert into user(creation, email, name, password) values (datetime('now'), 'john@mail.com', 'John', '$2y$14$1QqyMA8vknmSVBq9BcGi6upZISLwsP2aPXx5JZOMPVzaZ8gorrsq.'); +insert into user(creation, email, name, password) values (datetime('now'), 'lisa@mail.com', 'Lisa', '$2y$14$1QqyMA8vknmSVBq9BcGi6upZISLwsP2aPXx5JZOMPVzaZ8gorrsq.'); ``` Later, stop the environment with: diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs index 6faecef..153a61b 100644 --- a/client/src/Component/Button.hs +++ b/client/src/Component/Button.hs @@ -22,7 +22,7 @@ data In t m = In , _in_submit :: Bool } -defaultIn :: MonadWidget t m => m () -> In t m +defaultIn :: forall t m. MonadWidget t m => m () -> In t m defaultIn content = In { _in_class = R.constDyn "" , _in_content = content diff --git a/client/src/Main.hs b/client/src/Main.hs index d6f89cd..c71b0f0 100644 --- a/client/src/Main.hs +++ b/client/src/Main.hs @@ -14,7 +14,7 @@ import JSDOM.Types (HTMLElement (..), JSM, import qualified JSDOM.Types as Dom import Prelude hiding (error, init) -import Common.Model (InitResult (InitError)) +import Common.Model (Init) import qualified Common.Msg as Msg import qualified View.App as App @@ -24,7 +24,7 @@ main = do initResult <- readInit App.widget initResult -readInit :: JSM InitResult +readInit :: JSM (Maybe Init) readInit = do document <- Dom.currentDocumentUnchecked initNode <- Dom.getElementById document ("init" :: JSString) @@ -34,8 +34,6 @@ readInit = do text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node) return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of Just init -> init - Nothing -> initParseError + Nothing -> Nothing _ -> - return initParseError - - where initParseError = InitError $ Msg.get Msg.SignIn_ParseError + return Nothing diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs index f9545a4..50f2468 100644 --- a/client/src/Util/Validation.hs +++ b/client/src/Util/Validation.hs @@ -3,7 +3,6 @@ module Util.Validation , toMaybe , maybeError , fireValidation - , fireMaybe ) where import Control.Monad (join) @@ -35,13 +34,3 @@ fireValidation value validate = R.fmapMaybe (Validation.validation (const Nothing) Just) (R.tag (R.current value) validate) - -fireMaybe - :: forall t a b. Reflex t - => Dynamic t (Maybe a) - -> Event t b - -> Event t a -fireMaybe value validate = - R.fmapMaybe - id - (R.tag (R.current value) validate) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 460d499..b0b89fb 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -4,14 +4,14 @@ module View.App import qualified Data.Text as T import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, MonadWidget) +import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Currency, Init (..), InitResult (..), - UserId) +import Common.Model (Currency, Init (..), UserId) import qualified Common.Msg as Msg import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil import qualified Util.Router as Router import qualified View.Category.Category as Category import qualified View.Header as Header @@ -20,43 +20,40 @@ import qualified View.NotFound as NotFound import qualified View.Payment.Payment as Payment import qualified View.SignIn as SignIn -widget :: InitResult -> IO () -widget initResult = +widget :: Maybe Init -> IO () +widget init = R.mainWidget $ R.divClass "app" $ do route <- getRoute - header <- Header.view $ Header.In - { Header._in_initResult = initResult - , Header._in_isInitSuccess = - case initResult of - InitSuccess _ -> True - _ -> False - , Header._in_route = route - } - - let signOut = - Header._out_signOut header - - mainContent = - case initResult of - InitSuccess init -> - signedWidget init route - - InitEmpty -> - SignIn.view SignIn.EmptyMessage + rec + header <- Header.view $ Header.In + { Header._in_init = initState + , Header._in_route = route + } - InitError error -> - SignIn.view (SignIn.ErrorMessage error) + initState <- + R.foldDyn + const + init + (R.leftmost $ + [ initEvent + , Nothing <$ (Header._out_signOut header) + ]) - signOutContent = - SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess) + initEvent <- + (R.dyn . R.ffor initState $ \case + Nothing -> do + signIn <- SignIn.view + return (Just <$> SignIn._out_success signIn) - _ <- R.widgetHold (mainContent) (signOutContent <$ signOut) + Just i -> do + signedWidget i route + return R.never) >>= ReflexUtil.flatten - R.blank + return () -signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m () +signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m () signedWidget init route = do R.dyn . R.ffor route $ \case RootRoute -> @@ -85,7 +82,7 @@ signedWidget init route = do return () -getRoute :: MonadWidget t m => m (Dynamic t Route) +getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route) getRoute = do r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never return . R.ffor r $ \case diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 5910f52..f91c408 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -6,6 +6,7 @@ module View.Header import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Time (NominalDiffTime) @@ -13,7 +14,7 @@ import Prelude hiding (error, init) import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..), InitResult (..), User (..)) +import Common.Model (Init (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Component.Button as Button @@ -24,9 +25,8 @@ import qualified Util.Reflex as ReflexUtil import qualified View.Icon as Icon data In t = In - { _in_initResult :: InitResult - , _in_isInitSuccess :: Bool - , _in_route :: Dynamic t Route + { _in_init :: Dynamic t (Maybe Init) + , _in_route :: Dynamic t Route } data Out t = Out @@ -40,12 +40,11 @@ view input = R.divClass "title" $ R.text $ Msg.get Msg.App_Title + let showLinks = Maybe.isJust <$> _in_init input + signOut <- R.el "div" $ do - rec - showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut) - ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) - signOut <- nameSignOut $ _in_initResult input - return signOut + ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input) + (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten return $ Out { _out_signOut = signOut @@ -76,23 +75,24 @@ links route = do , ("current", linkRoute == currentRoute) ] -nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) -nameSignOut initResult = case initResult of - InitSuccess init -> do - rec - attr <- R.holdDyn - (M.singleton "class" "nameSignOut") - (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) - - signOut <- R.elDynAttr "nameSignOut" attr $ do - case CM.findUser (_init_currentUser init) (_init_users init) of - Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank - signOutButton - - return signOut - _ -> - return R.never +nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ()) +nameSignOut init = + case init of + Just init -> do + rec + attr <- R.holdDyn + (M.singleton "class" "nameSignOut") + (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) + + signOut <- R.elDynAttr "nameSignOut" attr $ do + case CM.findUser (_init_currentUser init) (_init_users init) of + Just user -> R.divClass "name" $ R.text (_user_name user) + Nothing -> R.blank + signOutButton + + return signOut + _ -> + return R.never signOutButton :: forall t m. MonadWidget t m => m (Event t ()) signOutButton = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 0a3b576..e68755f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,17 +1,16 @@ module View.SignIn - ( SignInMessage (..) - , view + ( view + , Out(..) ) where import qualified Data.Either as Either import qualified Data.Maybe as Maybe import Data.Text (Text) -import Data.Validation (Validation) -import Prelude hiding (error) +import qualified Data.Validation as V import Reflex.Dom (Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (SignInForm (SignInForm)) +import Common.Model (Init, SignInForm (SignInForm)) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -22,22 +21,32 @@ import qualified Util.Ajax as Ajax import qualified Util.Validation as ValidationUtil import qualified Util.WaitFor as WaitFor -data SignInMessage = - SuccessMessage Text - | ErrorMessage Text - | EmptyMessage +data Out t = Out + { _out_success :: Event t Init + } -view :: forall t m. MonadWidget t m => SignInMessage -> m () -view signInMessage = - R.divClass "signIn" $ +view :: forall t m. MonadWidget t m => m (Out t) +view = do + signInResult <- R.divClass "signIn" $ Form.view $ do rec - input <- (Input.view + let resetForm = ("" <$ R.ffilter Either.isRight signInResult) + + email <- Input._out_raw <$> (Input.view (Input.defaultIn { Input._in_label = Msg.get Msg.SignIn_EmailLabel , Input._in_validation = SignInValidation.email }) - ("" <$ R.ffilter Either.isRight signInResult) + resetForm + validate) + + password <- Input._out_raw <$> (Input.view + (Input.defaultIn + { Input._in_label = Msg.get Msg.SignIn_PasswordLabel + , Input._in_validation = SignInValidation.password + , Input._in_inputType = "password" + }) + resetForm validate) validate <- Button._out_clic <$> (Button.view $ @@ -47,27 +56,27 @@ view signInMessage = , Button._in_submit = True }) - let form = SignInForm <$> Input._out_raw input + let form = do + e <- email + p <- password + return . V.Success $ SignInForm e p (signInResult, waiting) <- WaitFor.waitFor - (Ajax.postAndParseResult "/api/askSignIn") - (ValidationUtil.fireMaybe - ((\f -> f <$ SignInValidation.signIn f) <$> form) - validate) + (Ajax.postAndParseResult "/api/signIn") + (ValidationUtil.fireValidation form validate) - showSignInResult signInMessage signInResult + showSignInResult signInResult -showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m () -showSignInResult signInMessage signInResult = do - _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult - R.blank + return signInResult - where showInitResult (SuccessMessage success) = showSuccess success - showInitResult (ErrorMessage error) = showError error - showInitResult EmptyMessage = R.blank + return $ Out + { _out_success = R.filterRight signInResult + } - showResult (Left error) = showError error - showResult (Right success) = showSuccess success +showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m () +showSignInResult signInResult = do + _ <- R.widgetHold R.blank $ showResult <$> signInResult + R.blank - showError = R.divClass "error" . R.text - showSuccess = R.divClass "success" . R.text + where showResult (Left error) = R.divClass "error" . R.text $ error + showResult (Right _) = R.blank diff --git a/common/common.cabal b/common/common.cabal index fdede8f..d09e29b 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -35,6 +35,7 @@ Library Common.Model.CreateIncomeForm Common.Model.CreatePaymentForm Common.Model.Email + Common.Model.Password Common.Model.Payment Common.Model.SignInForm Common.Model.User @@ -66,6 +67,5 @@ Library Common.Model.IncomeHeader Common.Model.IncomePage Common.Model.Init - Common.Model.InitResult Common.Model.PaymentHeader Common.Model.PaymentPage diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 2561156..b778a8f 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -118,16 +118,9 @@ data Key = | SignIn_Button | SignIn_DisconnectSuccess - | SignIn_EmailInvalid + | SignIn_InvalidCredentials | SignIn_EmailLabel - | SignIn_EmailSendFail - | SignIn_EmailSent - | SignIn_LinkExpired - | SignIn_LinkInvalid - | SignIn_LinkUsed - | SignIn_MailTitle - | SignIn_MailBody Text Text - | SignIn_ParseError + | SignIn_PasswordLabel | Statistic_Title | Statistic_ByMonthsAndMean Text diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index a86a371..e74c801 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -517,80 +517,20 @@ m l SignIn_DisconnectSuccess = English -> "You have successfully disconnected" French -> "Vous êtes à présent déconnecté." -m l SignIn_EmailInvalid = +m l SignIn_InvalidCredentials = case l of - English -> "Your email is not valid." - French -> "Votre courriel n’est pas valide." + English -> "Your credentials are not valid." + French -> "Vos identifiants de connexion ne sont pas valides." m l SignIn_EmailLabel = case l of English -> "Email" French -> "Courriel" -m l SignIn_EmailSendFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." - -m l SignIn_EmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." - -m l SignIn_LinkExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignIn_LinkInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - -m l SignIn_LinkUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignIn_MailTitle = - case l of - English -> T.concat [ "Sign in to ", m l App_Title ] - French -> T.concat [ "Connexion à ", m l App_Title ] - -m l (SignIn_MailBody name url) = - T.intercalate - "\n" - ( case l of - English -> - [ T.concat [ "Hi ", name, "," ] - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l App_Title - , ":" - ] - , url - , "" - , "See you soon!" - ] - French -> - [ T.concat [ "Salut ", name, "," ] - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l App_Title - , ":" - ] - , url - , "" - , "À très vite !" - ] - ) - -m l SignIn_ParseError = - case l of - English -> "Error while reading initial data." - French -> "Erreur lors de la lecture des données initiales." +m l SignIn_PasswordLabel = + case l of + English -> "Password" + French -> "Mot de passe" m l (Statistic_ByMonthsAndMean amount) = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 73cbf6c..c11d6ef 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -17,7 +17,7 @@ import Common.Model.Income as X import Common.Model.IncomeHeader as X import Common.Model.IncomePage as X import Common.Model.Init as X -import Common.Model.InitResult as X +import Common.Model.Password as X import Common.Model.Payment as X import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X diff --git a/common/src/Common/Model/InitResult.hs b/common/src/Common/Model/InitResult.hs deleted file mode 100644 index f4c08a9..0000000 --- a/common/src/Common/Model/InitResult.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Common.Model.InitResult - ( InitResult(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Init (Init) - -data InitResult = - InitSuccess Init - | InitError Text - | InitEmpty - deriving (Show, Generic) - -instance FromJSON InitResult -instance ToJSON InitResult diff --git a/common/src/Common/Model/Password.hs b/common/src/Common/Model/Password.hs new file mode 100644 index 0000000..1b51a47 --- /dev/null +++ b/common/src/Common/Model/Password.hs @@ -0,0 +1,12 @@ +module Common.Model.Password + ( Password(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +newtype Password = Password Text deriving (Show, Generic) + +instance FromJSON Password +instance ToJSON Password diff --git a/common/src/Common/Model/SignInForm.hs b/common/src/Common/Model/SignInForm.hs index 2b8c955..7a25935 100644 --- a/common/src/Common/Model/SignInForm.hs +++ b/common/src/Common/Model/SignInForm.hs @@ -7,7 +7,8 @@ import Data.Text (Text) import GHC.Generics (Generic) data SignInForm = SignInForm - { _signIn_email :: Text + { _signInForm_email :: Text + , _signInForm_password :: Text } deriving (Show, Generic) instance FromJSON SignInForm diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs index 4bb7cad..9c21e14 100644 --- a/common/src/Common/Validation/Atomic.hs +++ b/common/src/Common/Validation/Atomic.hs @@ -1,10 +1,11 @@ module Common.Validation.Atomic - ( nonEmpty + ( color + , day , minLength - , number + , nonEmpty , nonNullNumber - , day - , color + , number + , password ) where import qualified Data.Char as Char @@ -55,3 +56,6 @@ color str = else V.Failure (Msg.get Msg.Form_InvalidColor) + +password :: Text -> Validation Text Text +password = minLength 8 diff --git a/common/src/Common/Validation/SignIn.hs b/common/src/Common/Validation/SignIn.hs index 18ceb44..ac9cc37 100644 --- a/common/src/Common/Validation/SignIn.hs +++ b/common/src/Common/Validation/SignIn.hs @@ -1,19 +1,17 @@ module Common.Validation.SignIn - ( signIn - , email + ( email + , password ) where import Data.Text (Text) import Data.Validation (Validation) import Common.Model.Email (Email (..)) -import Common.Model.SignInForm (SignInForm (..)) +import Common.Model.Password (Password (..)) import qualified Common.Validation.Atomic as Atomic -import qualified Data.Validation as Validation - -signIn :: SignInForm -> Maybe Email -signIn (SignInForm str) = - Validation.validation (const Nothing) Just . email $ str email :: Text -> Validation Text Email email = fmap Email . Atomic.minLength 5 + +password :: Text -> Validation Text Password +password = fmap Password . Atomic.minLength 8 diff --git a/server/migrations/3.sql b/server/migrations/3.sql new file mode 100644 index 0000000..a3d8a13 --- /dev/null +++ b/server/migrations/3.sql @@ -0,0 +1,5 @@ +DROP TABLE sign_in; + +ALTER TABLE user ADD COLUMN "password" TEXT NOT NULL DEFAULT "password"; + +ALTER TABLE user ADD COLUMN "sign_in_token" TEXT NULL; diff --git a/server/server.cabal b/server/server.cabal index d38949d..7ef5328 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -25,6 +25,7 @@ Executable server aeson , base >= 4.11 && < 5 , base64-bytestring + , bcrypt , blaze-builder , blaze-html , bytestring @@ -101,6 +102,7 @@ Executable server Model.EditCategory Model.EditIncome Model.EditPayment + Model.HashedPassword Model.IncomeResource Model.Mail Model.PaymentResource @@ -121,6 +123,6 @@ Executable server Validation.Category Validation.Income Validation.Payment - View.Mail.SignIn + Validation.SignIn View.Mail.WeeklyReport View.Page diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 3788685..4f4ae77 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,120 +1,76 @@ module Controller.Index ( get - , askSignIn - , trySignIn + , signIn , signOut ) where import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as Json import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status -import Prelude hiding (error) +import Prelude hiding (error, init) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), Init (..), - InitResult (..), SignInForm (..), +import Common.Model (Init (..), SignInForm (..), User (..)) -import Common.Msg (Key) import qualified Common.Msg as Msg -import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession +import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn +import Model.SignIn (SignIn (..)) import qualified Persistence.User as UserPersistence -import qualified Secure -import qualified SendMail -import qualified View.Mail.SignIn as SignIn +import qualified Validation.SignIn as SignInValidation import View.Page (page) get :: Conf -> ActionM () get conf = do - initResult <- do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of + init <- do + mbToken <- LoginSession.get + case mbToken of Nothing -> - return InitEmpty - Just user -> do - users <- liftIO . Query.run $ UserPersistence.list - return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) - S.html $ page initResult + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init -askSignIn :: Conf -> SignInForm -> ActionM () -askSignIn conf form = +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = case SignInValidation.signIn form of - Nothing -> - textKey Status.badRequest400 Msg.SignIn_EmailInvalid - Just (Email email) -> do - maybeUser <- liftIO . Query.run $ UserPersistence.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "/api/signIn/", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized - where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init -trySignIn :: Conf -> Text -> ActionM () -trySignIn conf token = do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - S.html $ page (InitError $ Msg.get errorKey) - Right _ -> - S.redirect "/" - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of Nothing -> - return . Left $ Msg.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Msg.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Msg.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - UserPersistence.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Msg.Secure_Unauthorized - Just user -> Right user + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) Nothing -> return Nothing - Just token -> do - liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status Status.ok200 diff --git a/server/src/Main.hs b/server/src/Main.hs index 0b80de0..324557e 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -28,12 +28,8 @@ main = do S.middleware . staticPolicy $ noDots >-> addBase "public" - S.post "/api/askSignIn" $ - S.jsonData >>= Index.askSignIn conf - - S.get "/api/signIn/:signInToken" $ do - signInToken <- S.param "signInToken" - Index.trySignIn conf signInToken + S.post "/api/signIn" $ + S.jsonData >>= Index.signIn conf S.post "/api/signOut" $ Index.signOut conf diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs new file mode 100644 index 0000000..c71e372 --- /dev/null +++ b/server/src/Model/HashedPassword.hs @@ -0,0 +1,27 @@ +module Model.HashedPassword + ( hash + , check + , HashedPassword(..) + ) where + +import qualified Crypto.BCrypt as BCrypt +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Common.Model.Password (Password (..)) + +newtype HashedPassword = HashedPassword Text deriving (Show) + +hash :: Password -> IO (Maybe HashedPassword) +hash (Password p) = do + hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p) + case hashed of + Nothing -> + return Nothing + + Just h -> + return . Just . HashedPassword . TE.decodeUtf8 $ h + +check :: Password -> HashedPassword -> Bool +check (Password p) (HashedPassword h) = + BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p) diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs index bcdce61..a217bae 100644 --- a/server/src/Model/SignIn.hs +++ b/server/src/Model/SignIn.hs @@ -1,64 +1,10 @@ module Model.SignIn ( SignIn(..) - , createSignInToken - , getSignIn - , signInTokenToUsed - , isLastTokenValid ) where -import Data.Int (Int64) -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock (UTCTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Model.Query (Query (Query)) -import Model.UUID (generateUUID) - -type SignInId = Int64 +import Common.Model (Email, Password) data SignIn = SignIn - { id :: SignInId - , token :: Text - , creation :: UTCTime - , email :: Text - , isUsed :: Bool + { _signIn_email :: Email + , _signIn_password :: Password } deriving Show - -instance FromRow SignIn where - fromRow = SignIn <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -createSignInToken :: Text -> Query Text -createSignInToken signInEmail = - Query (\conn -> do - now <- getCurrentTime - signInToken <- generateUUID - SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) - return signInToken - ) - -getSignIn :: Text -> Query (Maybe SignIn) -getSignIn signInToken = - Query (\conn -> do - Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) - ) - -signInTokenToUsed :: SignInId -> Query () -signInTokenToUsed tokenId = - Query (\conn -> - SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) - ) - -isLastTokenValid :: SignIn -> Query Bool -isLastTokenValid signIn = - Query (\conn -> do - [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) - return . maybe False (== (token signIn)) $ lastToken - ) diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs index 89eb57d..12145ac 100644 --- a/server/src/Persistence/User.hs +++ b/server/src/Persistence/User.hs @@ -1,17 +1,21 @@ module Persistence.User ( list , get + , checkPassword + , createSignInToken ) where import qualified Data.Maybe as Maybe import Data.Text (Text) import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=))) import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) -import Common.Model (User (..)) +import Common.Model (Email (..), Password (..), User (..)) +import Model.HashedPassword (HashedPassword (..)) +import qualified Model.HashedPassword as HashedPassword import Model.Query (Query (Query)) +import qualified Model.UUID as UUID newtype Row = Row User @@ -26,15 +30,49 @@ list :: Query [User] list = Query (\conn -> do map (\(Row u) -> u) <$> - SQLite.query_ conn "SELECT * from user ORDER BY creation DESC" + SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC" ) get :: Text -> Query (Maybe User) -get email = +get token = Query (\conn -> do fmap (\(Row u) -> u) . Maybe.listToMaybe <$> SQLite.queryNamed conn - "SELECT * FROM user WHERE email = :email LIMIT 1" + "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1" + [ ":sign_in_token" := token ] + ) + +data HashedPasswordRow = HashedPasswordRow HashedPassword + +instance FromRow HashedPasswordRow where + fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field) + +checkPassword :: Email -> Password -> Query Bool +checkPassword (Email email) password = + Query (\conn -> do + hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$> + SQLite.queryNamed + conn + "SELECT password FROM user WHERE email = :email LIMIT 1" [ ":email" := email ] + case hashedPassword of + Just h -> + return (HashedPassword.check password h) + + Nothing -> + return False + ) + +createSignInToken :: Email -> Query Text +createSignInToken (Email email) = + Query (\conn -> do + token <- UUID.generateUUID + SQLite.executeNamed + conn + "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email" + [ ":sign_in_token" := token + , ":email" := email + ] + return token ) diff --git a/server/src/Secure.hs b/server/src/Secure.hs index 4fb2333..a30941f 100644 --- a/server/src/Secure.hs +++ b/server/src/Secure.hs @@ -1,21 +1,17 @@ module Secure ( loggedAction - , getUserFromToken ) where import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) +import qualified Data.Text.Lazy as TL +import qualified Network.HTTP.Types.Status as HTTP import Web.Scotty import Common.Model (User) import qualified Common.Msg as Msg import qualified LoginSession -import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn import qualified Persistence.User as UserPersistence loggedAction :: (User -> ActionM ()) -> ActionM () @@ -23,22 +19,13 @@ loggedAction action = do maybeToken <- LoginSession.get case maybeToken of Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token + maybeUser <- liftIO . Query.run . UserPersistence.get $ token case maybeUser of Just user -> action user Nothing -> do - status forbidden403 - html . fromStrict . Msg.get $ Msg.Secure_Unauthorized + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized Nothing -> do - status forbidden403 - html . fromStrict . Msg.get $ Msg.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - UserPersistence.get (SignIn.email signIn) - Nothing -> - return Nothing + status HTTP.forbidden403 + html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs new file mode 100644 index 0000000..dc86122 --- /dev/null +++ b/server/src/Validation/SignIn.hs @@ -0,0 +1,16 @@ +module Validation.SignIn + ( signIn + ) where + +import Data.Text (Text) +import Data.Validation (Validation) + +import Common.Model (SignInForm (..)) +import qualified Common.Validation.SignIn as SignInValidation +import Model.SignIn (SignIn (..)) + +signIn :: SignInForm -> Validation Text SignIn +signIn form = + SignIn + <$> SignInValidation.email (_signInForm_email form) + <*> SignInValidation.password (_signInForm_password form) diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs deleted file mode 100644 index 3c5469f..0000000 --- a/server/src/View/Mail/SignIn.hs +++ /dev/null @@ -1,21 +0,0 @@ -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import Common.Model (User (..)) -import qualified Common.Msg as Msg - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Msg.get Msg.SignIn_MailTitle - , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url) - } diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index f47c544..4ada5f7 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -6,6 +6,7 @@ import Data.Aeson (encode) import qualified Data.Aeson.Types as Json import Data.Text.Internal.Lazy (Text) import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (init) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -14,20 +15,20 @@ import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes import qualified Text.Blaze.Html5.Attributes as A -import Common.Model (InitResult) +import Common.Model (Init) import qualified Common.Msg as Msg import Design.Global (globalDesign) -page :: InitResult -> Text -page initResult = +page :: Maybe Init -> Text +page init = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" H.title (toHtml $ Msg.get Msg.App_Title) script ! src "/javascript/main.js" $ "" - jsonScript "init" initResult + jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" H.style $ toHtml globalDesign -- cgit v1.2.3 From 209008f155068835077719eeec942a9b979b3a04 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 16:14:09 +0100 Subject: Keep button size while waiting --- server/src/Design/Global.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index ebd7084..c67db7c 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -132,7 +132,7 @@ global = do ".waiting" & do ".content" ? do - display none + opacity 0 svg # ".loader" ? do display block spinAnimation -- cgit v1.2.3 From 5a13317efdaa2a8594a138b07ddd45eab40a8322 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 16:30:01 +0100 Subject: Return the css at /css/main.css instead of inlined --- server/src/Main.hs | 5 +++++ server/src/View/Page.hs | 4 +--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/server/src/Main.hs b/server/src/Main.hs index 324557e..999f973 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -14,6 +14,7 @@ import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment import qualified Controller.User as User +import qualified Design.Global as Design import Job.Daemon (runDaemons) main :: IO () @@ -28,6 +29,10 @@ main = do S.middleware . staticPolicy $ noDots >-> addBase "public" + S.get "/css/main.css" $ do + S.setHeader "Content-Type" "text/css" + S.text Design.globalDesign + S.post "/api/signIn" $ S.jsonData >>= Index.signIn conf diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index 4ada5f7..bac6b8a 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -18,8 +18,6 @@ import qualified Text.Blaze.Html5.Attributes as A import Common.Model (Init) import qualified Common.Msg as Msg -import Design.Global (globalDesign) - page :: Maybe Init -> Text page init = renderHtml . docTypeHtml $ do @@ -30,8 +28,8 @@ page init = script ! src "/javascript/main.js" $ "" jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" + link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" - H.style $ toHtml globalDesign H.body $ do H.div ! A.class_ "spinner" $ "" -- cgit v1.2.3 From d20d7ceec2a14f79ebb06555a71d424aeaa90e54 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 16:31:55 +0100 Subject: Show conf at server startup --- server/src/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/server/src/Main.hs b/server/src/Main.hs index 999f973..25fffb3 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -20,6 +20,7 @@ import Job.Daemon (runDaemons) main :: IO () main = do conf <- Conf.get "application.conf" + putStrLn . show $ conf _ <- runDaemons conf S.scotty (Conf.port conf) $ do -- cgit v1.2.3 From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 20 Jan 2020 19:47:23 +0100 Subject: Show payment stats --- client/client.cabal | 2 + client/src/Model/Route.hs | 1 + client/src/View/App.hs | 43 +++++++------ client/src/View/Header.hs | 5 ++ client/src/View/Statistics/Chart.hs | 102 +++++++++++++++++++++++++++++++ client/src/View/Statistics/Statistics.hs | 67 ++++++++++++++++++++ common/common.cabal | 1 + common/src/Common/Message/Key.hs | 6 +- common/src/Common/Message/Translation.hs | 6 +- common/src/Common/Model.hs | 1 + common/src/Common/Model/PaymentStats.hs | 10 +++ common/src/Common/View/Format.hs | 52 ++++++++++------ server/server.cabal | 2 + server/src/Controller/Payment.hs | 9 +++ server/src/Design/View/Stat.hs | 4 ++ server/src/Design/Views.hs | 2 +- server/src/Main.hs | 3 + server/src/Persistence/Payment.hs | 19 ++++++ server/src/Statistics.hs | 34 +++++++++++ server/src/View/Page.hs | 1 + 20 files changed, 326 insertions(+), 44 deletions(-) create mode 100644 client/src/View/Statistics/Chart.hs create mode 100644 client/src/View/Statistics/Statistics.hs create mode 100644 common/src/Common/Model/PaymentStats.hs create mode 100644 server/src/Statistics.hs diff --git a/client/client.cabal b/client/client.cabal index 227aed2..cf2c5a1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -86,3 +86,5 @@ Executable client View.Payment.Reducer View.Payment.Table View.SignIn + View.Statistics.Chart + View.Statistics.Statistics diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs index 63e5d10..f92e9be 100644 --- a/client/src/Model/Route.hs +++ b/client/src/Model/Route.hs @@ -6,5 +6,6 @@ data Route = RootRoute | IncomeRoute | CategoryRoute + | StatisticsRoute | NotFoundRoute deriving (Eq, Show) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index b0b89fb..71f0234 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,23 +2,24 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Reflex as ReflexUtil -import qualified Util.Router as Router -import qualified View.Category.Category as Category -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn +import qualified View.Statistics.Statistics as Statistics widget :: Maybe Init -> IO () widget init = @@ -77,6 +78,11 @@ signedWidget init route = do , Category._in_users = _init_users init } + StatisticsRoute -> + Statistics.view $ Statistics.In + { Statistics._in_currency = _init_currency init + } + NotFoundRoute -> NotFound.view @@ -95,5 +101,8 @@ getRoute = do ["category"] -> CategoryRoute + ["statistics"] -> + StatisticsRoute + _ -> NotFoundRoute diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index f91c408..ff9f40a 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -67,6 +67,11 @@ links route = do (R.ffor route (attrs CategoryRoute)) (Msg.get Msg.Category_Title) + Link.view + "/statistics" + (R.ffor route (attrs StatisticsRoute)) + (Msg.get Msg.Statistics_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Statistics/Chart.hs b/client/src/View/Statistics/Chart.hs new file mode 100644 index 0000000..63df2a1 --- /dev/null +++ b/client/src/View/Statistics/Chart.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} + +module View.Statistics.Chart + ( view + , In(..) + , Dataset(..) + ) where + +import qualified Control.Concurrent as Concurrent +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import qualified Data.Aeson as AE +import qualified Data.Map as M +import Data.Text (Text) +import Language.Javascript.JSaddle (JSString, JSVal) +import qualified Language.Javascript.JSaddle.Value as JSValue +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R +-- import GHCJS.Foreign.Callback + + +#ifdef __GHCJS__ +foreign import javascript unsafe "new Chart(document.getElementById($1), $2);" drawChart :: JSString -> JSVal -> IO () +#else +drawChart = error "drawChart: only available from JavaScript" +#endif + +data In = In + { _in_title :: Text + , _in_labels :: [Text] + , _in_datasets :: [Dataset] + } + +data Dataset = Dataset + { _dataset_label :: Text + , _dataset_data :: [Int] + , _dataset_color :: Text + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + R.divClass "g-Chart" $ + R.elAttr "canvas" (M.singleton "id" "chart") $ + R.blank + + liftIO $ Concurrent.forkIO $ do + Concurrent.threadDelay 500000 + config <- JSValue.valMakeJSON (configToJson input) + drawChart "chart" config + + return () + +configToJson (In title labels datasets) = + AE.object + [ "type" .= AE.String "line" + , "data" .= + AE.object + [ "labels" .= labels + , "datasets" .= map datasetToJson datasets + ] + , "options" .= + AE.object + [ "responsive" .= True + , "title" .= + AE.object + [ "display" .= True + , "text" .= title + ] + , "tooltips" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= False + ] + , "hover" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= True + ] + , "scales" .= + AE.object + [ "yAxes" .= + [ [ AE.object + [ "ticks" .= + AE.object + [ "beginAtZero" .= True ] + ] + ] + ] + ] + ] + ] + +datasetToJson (Dataset label data_ color) = + AE.object + [ "label" .= label + , "data" .= data_ + , "fill" .= False + , "backgroundColor" .= color + , "borderColor" .= color + ] diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs new file mode 100644 index 0000000..71f93d4 --- /dev/null +++ b/client/src/View/Statistics/Statistics.hs @@ -0,0 +1,67 @@ +module View.Statistics.Statistics + ( view + , In(..) + ) where + +import Control.Monad (void) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Loadable (Loadable) +import qualified Loadable +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R +import qualified Util.Ajax as AjaxUtil +import qualified View.Statistics.Chart as Chart + +import Common.Model (Category (..), Currency, PaymentStats) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +data In = In + { _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + + categories <- AjaxUtil.getNow "api/allCategories" + statistics <- AjaxUtil.getNow "api/statistics" + let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ Msg.get Msg.Statistics_Title + + void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $ + stats (_in_currency input) + +stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m () +stats currency (categories, stats) = + Chart.view $ Chart.In + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth) + , Chart._in_labels = map (Format.monthAndYear . fst) stats + , Chart._in_datasets = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_Total + , Chart._dataset_data = totalSeries + , Chart._dataset_color = "#555555" + } : (map categoryDataset categories) + } + + where + averageEachMonth = + Format.price currency $ sum totalSeries `div` length stats + + totalSeries = + map (sum . map snd . M.toList . snd) stats + + categoryDataset category = + Chart.Dataset + { Chart._dataset_label = _category_name category + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . snd) stats + , Chart._dataset_color = _category_color category + } diff --git a/common/common.cabal b/common/common.cabal index d09e29b..020a987 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -69,3 +69,4 @@ Library Common.Model.Init Common.Model.PaymentHeader Common.Model.PaymentPage + Common.Model.PaymentStats diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index b778a8f..9b60a16 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -122,9 +122,9 @@ data Key = | SignIn_EmailLabel | SignIn_PasswordLabel - | Statistic_Title - | Statistic_ByMonthsAndMean Text - | Statistic_Total + | Statistics_Title + | Statistics_ByMonthsAndMean Text + | Statistics_Total | WeeklyReport_Empty | WeeklyReport_IncomesCreated Int diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index e74c801..2640da3 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -532,19 +532,19 @@ m l SignIn_PasswordLabel = English -> "Password" French -> "Mot de passe" -m l (Statistic_ByMonthsAndMean amount) = +m l (Statistics_ByMonthsAndMean amount) = case l of English -> T.concat [ "Payments by category by month months (", amount, "on average)" ] French -> T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] -m l Statistic_Title = +m l Statistics_Title = case l of English -> "Statistics" French -> "Statistiques" -m l Statistic_Total = +m l Statistics_Total = case l of English -> "Total" French -> "Total" diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index c11d6ef..319d109 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -21,5 +21,6 @@ import Common.Model.Password as X import Common.Model.Payment as X import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X +import Common.Model.PaymentStats as X import Common.Model.SignInForm as X import Common.Model.User as X diff --git a/common/src/Common/Model/PaymentStats.hs b/common/src/Common/Model/PaymentStats.hs new file mode 100644 index 0000000..2dea640 --- /dev/null +++ b/common/src/Common/Model/PaymentStats.hs @@ -0,0 +1,10 @@ +module Common.Model.PaymentStats + ( PaymentStats + ) where + +import Data.Map (Map) +import Data.Time.Calendar (Day) + +import Common.Model.Category (CategoryId) + +type PaymentStats = [(Day, Map CategoryId Int)] diff --git a/common/src/Common/View/Format.hs b/common/src/Common/View/Format.hs index 0597d17..5d879fa 100644 --- a/common/src/Common/View/Format.hs +++ b/common/src/Common/View/Format.hs @@ -3,15 +3,18 @@ module Common.View.Format , longDay , price , number + , monthAndYear ) where -import Data.List (intersperse) -import Data.Maybe (fromMaybe) +import qualified Data.List as L +import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Calendar (Day, toGregorian) +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar import Common.Model (Currency (..)) +import Common.Msg (Key) import qualified Common.Msg as Msg shortDay :: Day -> Text @@ -20,29 +23,38 @@ shortDay date = day month (fromIntegral year) - where (year, month, day) = toGregorian date + where (year, month, day) = Calendar.toGregorian date longDay :: Day -> Text longDay date = Msg.get $ Msg.Date_Long day - (fromMaybe "−" . fmap Msg.get . monthToKey $ month) + (Maybe.fromMaybe "−" . fmap Msg.get . monthToKey $ month) (fromIntegral year) - where (year, month, day) = toGregorian date + where (year, month, day) = Calendar.toGregorian date - monthToKey 1 = Just Msg.Month_January - monthToKey 2 = Just Msg.Month_February - monthToKey 3 = Just Msg.Month_March - monthToKey 4 = Just Msg.Month_April - monthToKey 5 = Just Msg.Month_May - monthToKey 6 = Just Msg.Month_June - monthToKey 7 = Just Msg.Month_July - monthToKey 8 = Just Msg.Month_August - monthToKey 9 = Just Msg.Month_September - monthToKey 10 = Just Msg.Month_October - monthToKey 11 = Just Msg.Month_November - monthToKey 12 = Just Msg.Month_December - monthToKey _ = Nothing +monthAndYear :: Day -> Text +monthAndYear date = + T.intercalate " " + [ Maybe.fromMaybe "" . fmap ((\t -> T.concat [t, " "]) . Msg.get) . monthToKey $ month + , T.pack . show $ year + ] + where (year, month, _) = Calendar.toGregorian date + +monthToKey :: Int -> Maybe Key +monthToKey 1 = Just Msg.Month_January +monthToKey 2 = Just Msg.Month_February +monthToKey 3 = Just Msg.Month_March +monthToKey 4 = Just Msg.Month_April +monthToKey 5 = Just Msg.Month_May +monthToKey 6 = Just Msg.Month_June +monthToKey 7 = Just Msg.Month_July +monthToKey 8 = Just Msg.Month_August +monthToKey 9 = Just Msg.Month_September +monthToKey 10 = Just Msg.Month_October +monthToKey 11 = Just Msg.Month_November +monthToKey 12 = Just Msg.Month_December +monthToKey _ = Nothing price :: Currency -> Int -> Text price (Currency currency) amount = T.concat [ number amount, " ", currency ] @@ -53,7 +65,7 @@ number n = . (++) (if n < 0 then "-" else "") . reverse . concat - . intersperse " " + . L.intersperse " " . group 3 . reverse . show diff --git a/server/server.cabal b/server/server.cabal index 7ef5328..4f513f4 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -38,6 +38,7 @@ Executable server , filepath , http-conduit , http-types + , jsaddle , mime-mail , monad-logger , mtl @@ -119,6 +120,7 @@ Executable server Resource Secure SendMail + Statistics Util.Time Validation.Category Validation.Income diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index d6aa34f..80c717f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -4,6 +4,7 @@ module Controller.Payment , edit , delete , searchCategory + , statistics ) where import Control.Monad.IO.Class (liftIO) @@ -30,6 +31,7 @@ import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence import qualified Secure +import qualified Statistics import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () @@ -114,3 +116,10 @@ searchCategory paymentName = (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) >>= S.json ) + +statistics :: ActionM () +statistics = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + S.json (Statistics.compute payments) + ) diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs index 4d7021e..2e4ecad 100644 --- a/server/src/Design/View/Stat.hs +++ b/server/src/Design/View/Stat.hs @@ -11,3 +11,7 @@ design = do ".exceedingPayers" ? ".userName" ? marginRight (px 5) ".mean" ? marginBottom (em 1.5) + + ".g-Chart" ? do + width (pct 75) + sym2 margin (px 0) auto diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs index 270bb8e..4552796 100644 --- a/server/src/Design/Views.hs +++ b/server/src/Design/Views.hs @@ -22,7 +22,7 @@ design = do header ? Header.design Payment.design ".signIn" ? SignIn.design - ".stat" ? Stat.design + Stat.design ".notfound" ? NotFound.design Table.design Pages.design diff --git a/server/src/Main.hs b/server/src/Main.hs index 25fffb3..64de511 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -97,6 +97,9 @@ main = do categoryId <- S.param "id" Category.delete categoryId + S.get "/api/statistics" $ do + Payment.statistics + S.notFound $ do S.status Status.ok200 Index.get conf diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs index b3eb141..573d57f 100644 --- a/server/src/Persistence/Payment.hs +++ b/server/src/Persistence/Payment.hs @@ -2,6 +2,7 @@ module Persistence.Payment ( count , find , getRange + , listAllPunctual , listActivePage , listModifiedPunctualSince , listActiveMonthlyOrderedByName @@ -140,6 +141,24 @@ getRange = ] ) +listAllPunctual :: Query [Payment] +listAllPunctual = + Query (\conn -> + map (\(Row p) -> p) <$> + SQLite.queryNamed + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT" + , fields + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = :frequency" + , "ORDER BY date" + ]) + [ ":frequency" := FrequencyField Punctual + ] + ) + + listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment] listActivePage frequency page perPage search = Query (\conn -> diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs new file mode 100644 index 0000000..371fba2 --- /dev/null +++ b/server/src/Statistics.hs @@ -0,0 +1,34 @@ +module Statistics + ( compute + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Time.Calendar as Calendar + +import Common.Model (Payment (..), PaymentStats) + +compute :: [Payment] -> PaymentStats +compute payments = + + M.toList $ foldl + (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m) + M.empty + payments + + where + + initMonthStats = + M.fromList + . map (\category -> (category, 0)) + . L.nub + $ map _payment_category payments + + alter p Nothing = Just (addPayment p initMonthStats) + alter p (Just monthStats) = Just (addPayment p monthStats) + + addPayment p monthStats = M.adjust ((+) (_payment_cost p)) (_payment_category p) monthStats + + startOfMonth day = + let (y, m, _) = Calendar.toGregorian day + in Calendar.fromGregorian y m 1 diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs index bac6b8a..ae7a266 100644 --- a/server/src/View/Page.hs +++ b/server/src/View/Page.hs @@ -26,6 +26,7 @@ page init = meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" H.title (toHtml $ Msg.get Msg.App_Title) script ! src "/javascript/main.js" $ "" + script ! src "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ "" jsonScript "init" init link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css" -- cgit v1.2.3 From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 27 Jan 2020 22:07:18 +0100 Subject: Show total incom by month in statistics --- client/src/View/Statistics/Statistics.hs | 54 +++++++++++++++++++++----------- common/common.cabal | 2 +- common/src/Common/Message/Key.hs | 5 +-- common/src/Common/Message/Translation.hs | 17 ++++++---- common/src/Common/Model.hs | 2 +- common/src/Common/Model/PaymentStats.hs | 10 ------ common/src/Common/Model/Stats.hs | 23 ++++++++++++++ server/server.cabal | 1 + server/src/Controller/Payment.hs | 9 ------ server/src/Controller/Statistics.hs | 21 +++++++++++++ server/src/Main.hs | 3 +- server/src/Persistence/Income.hs | 13 +++++++- server/src/Statistics.hs | 35 ++++++++++++++++++--- 13 files changed, 141 insertions(+), 54 deletions(-) delete mode 100644 common/src/Common/Model/PaymentStats.hs create mode 100644 common/src/Common/Model/Stats.hs create mode 100644 server/src/Controller/Statistics.hs diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs index 71f93d4..d931b2b 100644 --- a/client/src/View/Statistics/Statistics.hs +++ b/client/src/View/Statistics/Statistics.hs @@ -16,7 +16,8 @@ import qualified Reflex.Dom as R import qualified Util.Ajax as AjaxUtil import qualified View.Statistics.Chart as Chart -import Common.Model (Category (..), Currency, PaymentStats) +import Common.Model (Category (..), Currency, Income, + MonthStats (..), Stats, User (..)) import qualified Common.Msg as Msg import qualified Common.View.Format as Format @@ -27,41 +28,58 @@ data In = In view :: forall t m. MonadWidget t m => In -> m () view input = do + users <- AjaxUtil.getNow "api/users" categories <- AjaxUtil.getNow "api/allCategories" statistics <- AjaxUtil.getNow "api/statistics" - let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics + + let loadable = (\u c s -> (,,) <$> u <*> c <*> s) <$> users <*> categories <*> statistics R.divClass "withMargin" $ R.divClass "titleButton" $ R.el "h1" $ R.text $ Msg.get Msg.Statistics_Title - void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $ + void . R.dyn . R.ffor loadable . Loadable.viewHideValueWhileLoading $ stats (_in_currency input) -stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m () -stats currency (categories, stats) = +stats :: forall t m. MonadWidget t m => Currency -> ([User], [Category], Stats) -> m () +stats currency (users, categories, stats) = Chart.view $ Chart.In - { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth) - , Chart._in_labels = map (Format.monthAndYear . fst) stats - , Chart._in_datasets = - Chart.Dataset - { Chart._dataset_label = Msg.get Msg.Statistics_Total - , Chart._dataset_data = totalSeries - , Chart._dataset_color = "#555555" - } : (map categoryDataset categories) + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averagePayment averageIncome) + , Chart._in_labels = map (Format.monthAndYear . _monthStats_start) stats + , Chart._in_datasets = totalIncomeDataset : totalPaymentDataset : (map categoryDataset categories) } where - averageEachMonth = - Format.price currency $ sum totalSeries `div` length stats + averageIncome = + Format.price currency $ sum totalIncomes `div` length stats + + totalIncomeDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalIncomes + , Chart._dataset_data = totalIncomes + , Chart._dataset_color = "#222222" + } + + totalIncomes = + map (sum . map snd . M.toList . _monthStats_incomeByUser) stats + + averagePayment = + Format.price currency $ sum totalPayments `div` length stats + + totalPaymentDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalPayments + , Chart._dataset_data = totalPayments + , Chart._dataset_color = "#555555" + } - totalSeries = - map (sum . map snd . M.toList . snd) stats + totalPayments = + map (sum . map snd . M.toList . _monthStats_paymentsByCategory) stats categoryDataset category = Chart.Dataset { Chart._dataset_label = _category_name category - , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . snd) stats + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . _monthStats_paymentsByCategory) stats , Chart._dataset_color = _category_color category } diff --git a/common/common.cabal b/common/common.cabal index 020a987..dffc8d0 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -69,4 +69,4 @@ Library Common.Model.Init Common.Model.PaymentHeader Common.Model.PaymentPage - Common.Model.PaymentStats + Common.Model.Stats diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index 9b60a16..f3b0837 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -123,8 +123,9 @@ data Key = | SignIn_PasswordLabel | Statistics_Title - | Statistics_ByMonthsAndMean Text - | Statistics_Total + | Statistics_ByMonthsAndMean Text Text + | Statistics_TotalPayments + | Statistics_TotalIncomes | WeeklyReport_Empty | WeeklyReport_IncomesCreated Int diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 2640da3..4ba9ffc 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -532,22 +532,27 @@ m l SignIn_PasswordLabel = English -> "Password" French -> "Mot de passe" -m l (Statistics_ByMonthsAndMean amount) = +m l (Statistics_ByMonthsAndMean paymentMean incomeMean ) = case l of English -> - T.concat [ "Payments by category by month months (", amount, "on average)" ] + T.concat [ "Payments by category (mean ", paymentMean, ") and income (mean ", incomeMean, ") by month" ] French -> - T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] + T.concat [ "Paiements par catégorie (moy. ", paymentMean, ") et revenu (moy. ", incomeMean, ") par mois" ] m l Statistics_Title = case l of English -> "Statistics" French -> "Statistiques" -m l Statistics_Total = +m l Statistics_TotalPayments = case l of - English -> "Total" - French -> "Total" + English -> "Payment total" + French -> "Total des payment" + +m l Statistics_TotalIncomes = + case l of + English -> "Income total" + French -> "Total des revenus" m l WeeklyReport_Empty = case l of diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs index 319d109..979d876 100644 --- a/common/src/Common/Model.hs +++ b/common/src/Common/Model.hs @@ -21,6 +21,6 @@ import Common.Model.Password as X import Common.Model.Payment as X import Common.Model.PaymentHeader as X import Common.Model.PaymentPage as X -import Common.Model.PaymentStats as X import Common.Model.SignInForm as X +import Common.Model.Stats as X import Common.Model.User as X diff --git a/common/src/Common/Model/PaymentStats.hs b/common/src/Common/Model/PaymentStats.hs deleted file mode 100644 index 2dea640..0000000 --- a/common/src/Common/Model/PaymentStats.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Common.Model.PaymentStats - ( PaymentStats - ) where - -import Data.Map (Map) -import Data.Time.Calendar (Day) - -import Common.Model.Category (CategoryId) - -type PaymentStats = [(Day, Map CategoryId Int)] diff --git a/common/src/Common/Model/Stats.hs b/common/src/Common/Model/Stats.hs new file mode 100644 index 0000000..86e6ab9 --- /dev/null +++ b/common/src/Common/Model/Stats.hs @@ -0,0 +1,23 @@ +module Common.Model.Stats + ( Stats + , MonthStats(..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Time.Calendar (Day) +import GHC.Generics (Generic) + +import Common.Model.Category (CategoryId) +import Common.Model.User (UserId) + +type Stats = [MonthStats] + +data MonthStats = MonthStats + { _monthStats_start :: Day + , _monthStats_paymentsByCategory :: Map CategoryId Int + , _monthStats_incomeByUser :: Map UserId Int + } deriving (Eq, Show, Generic) + +instance FromJSON MonthStats +instance ToJSON MonthStats diff --git a/server/server.cabal b/server/server.cabal index 4f513f4..5427385 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -65,6 +65,7 @@ Executable server Controller.Income Controller.Index Controller.Payment + Controller.Statistics Controller.User Cookie Design.Appearing diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 80c717f..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -4,7 +4,6 @@ module Controller.Payment , edit , delete , searchCategory - , statistics ) where import Control.Monad.IO.Class (liftIO) @@ -31,7 +30,6 @@ import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Statistics import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () @@ -116,10 +114,3 @@ searchCategory paymentName = (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) >>= S.json ) - -statistics :: ActionM () -statistics = - Secure.loggedAction (\_ -> do - payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual - S.json (Statistics.compute payments) - ) diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs new file mode 100644 index 0000000..500c93c --- /dev/null +++ b/server/src/Controller/Statistics.hs @@ -0,0 +1,21 @@ +module Controller.Statistics + ( paymentsAndIncomes + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Statistics + +paymentsAndIncomes :: ActionM () +paymentsAndIncomes = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + incomes <- liftIO $ Query.run IncomePersistence.listAll + S.json (Statistics.paymentsAndIncomes payments incomes) + ) diff --git a/server/src/Main.hs b/server/src/Main.hs index 64de511..659a0fa 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -13,6 +13,7 @@ import qualified Controller.Category as Category import qualified Controller.Income as Income import qualified Controller.Index as Index import qualified Controller.Payment as Payment +import qualified Controller.Statistics as Statistics import qualified Controller.User as User import qualified Design.Global as Design import Job.Daemon (runDaemons) @@ -98,7 +99,7 @@ main = do Category.delete categoryId S.get "/api/statistics" $ do - Payment.statistics + Statistics.paymentsAndIncomes S.notFound $ do S.status Status.ok200 diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs index 76cb952..1b5364c 100644 --- a/server/src/Persistence/Income.hs +++ b/server/src/Persistence/Income.hs @@ -1,5 +1,6 @@ module Persistence.Income - ( count + ( listAll + , count , list , listModifiedSince , create @@ -43,6 +44,16 @@ data CountRow = CountRow Int instance FromRow CountRow where fromRow = CountRow <$> SQLite.field +listAll :: Query [Income] +listAll = + Query (\conn -> + map (\(Row i) -> i) <$> + SQLite.query_ + conn + "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC" + ) + + count :: Query Int count = Query (\conn -> diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs index 371fba2..e463aac 100644 --- a/server/src/Statistics.hs +++ b/server/src/Statistics.hs @@ -1,23 +1,44 @@ module Statistics - ( compute + ( paymentsAndIncomes ) where +import Control.Arrow ((&&&)) import qualified Data.List as L +import Data.Map (Map) import qualified Data.Map as M +import qualified Data.Maybe as Maybe import qualified Data.Time.Calendar as Calendar -import Common.Model (Payment (..), PaymentStats) +import Common.Model (Income (..), MonthStats (..), Payment (..), + Stats) -compute :: [Payment] -> PaymentStats -compute payments = +paymentsAndIncomes :: [Payment] -> [Income] -> Stats +paymentsAndIncomes payments incomes = - M.toList $ foldl + map toMonthStat . M.toList $ foldl (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m) M.empty payments where + toMonthStat (start, paymentsByCategory) = + MonthStats start paymentsByCategory (incomesAt start) + + incomesAt day = + M.map (incomeAt day) lastToFirstIncomesByUser + + incomeAt day lastToFirstIncome = + Maybe.maybe 0 _income_amount + . Maybe.listToMaybe + . dropWhile (\i -> _income_date i > day) + $ lastToFirstIncome + + lastToFirstIncomesByUser = + M.map (reverse . L.sortOn _income_date) + . groupBy _income_userId + $ incomes + initMonthStats = M.fromList . map (\category -> (category, 0)) @@ -32,3 +53,7 @@ compute payments = startOfMonth day = let (y, m, _) = Calendar.toGregorian day in Calendar.fromGregorian y m 1 + +groupBy :: Ord k => (a -> k) -> [a] -> Map k [a] +groupBy key = + M.fromListWith (++) . map (key &&& pure) -- cgit v1.2.3 From 6a04e640955051616c3ad0874605830c448f2d75 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 27 Jan 2020 22:33:07 +0100 Subject: Fix translation typo --- common/src/Common/Message/Translation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 4ba9ffc..222e669 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -547,7 +547,7 @@ m l Statistics_Title = m l Statistics_TotalPayments = case l of English -> "Payment total" - French -> "Total des payment" + French -> "Total des paiements" m l Statistics_TotalIncomes = case l of -- cgit v1.2.3