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