From cfca18262c1ff48dcb683ddab7d03cf8e55573ff Mon Sep 17 00:00:00 2001
From: Joris
Date: Fri, 24 Mar 2017 09:21:04 +0000
Subject: Features/categories

---
 src/server/Controller/Category.hs        |  54 +++++++++++++++
 src/server/Controller/Index.hs           |  10 +--
 src/server/Controller/Payment.hs         |  21 ++++--
 src/server/Controller/User.hs            |  11 +--
 src/server/Design/Constants.hs           |   6 +-
 src/server/Design/Dialog.hs              |   7 +-
 src/server/Design/Form.hs                |  36 +++++++++-
 src/server/Design/Helper.hs              |   5 +-
 src/server/Design/LoggedIn.hs            |  29 +++++++-
 src/server/Design/LoggedIn/Home/Table.hs |  13 ++--
 src/server/Design/LoggedIn/Income.hs     |  29 --------
 src/server/Design/LoggedIn/Table.hs      |   3 +-
 src/server/Design/Media.hs               |   4 +-
 src/server/Job/WeeklyReport.hs           |   4 +-
 src/server/Main.hs                       |  25 +++++--
 src/server/Model/Category.hs             |  56 +++++++++++++++
 src/server/Model/Database.hs             |  14 ++++
 src/server/Model/Income.hs               |   9 ++-
 src/server/Model/Init.hs                 |  25 ++++---
 src/server/Model/Json/Category.hs        |  20 ++++++
 src/server/Model/Json/CreateCategory.hs  |  17 +++++
 src/server/Model/Json/CreatePayment.hs   |   2 +
 src/server/Model/Json/EditCategory.hs    |  20 ++++++
 src/server/Model/Json/EditPayment.hs     |   3 +-
 src/server/Model/Json/Init.hs            |   4 ++
 src/server/Model/Json/PaymentCategory.hs |  19 +++++
 src/server/Model/Message/Key.hs          |  29 +++++++-
 src/server/Model/Message/Translations.hs | 115 ++++++++++++++++++++++++++++++-
 src/server/Model/Payment.hs              |  11 +--
 src/server/Model/PaymentCategory.hs      |  55 +++++++++++++++
 src/server/Model/User.hs                 |  12 ++--
 src/server/Utils/Text.hs                 |  41 +++++++++++
 src/server/View/Mail/WeeklyReport.hs     |   4 +-
 33 files changed, 598 insertions(+), 115 deletions(-)
 create mode 100644 src/server/Controller/Category.hs
 delete mode 100644 src/server/Design/LoggedIn/Income.hs
 create mode 100644 src/server/Model/Category.hs
 create mode 100644 src/server/Model/Json/Category.hs
 create mode 100644 src/server/Model/Json/CreateCategory.hs
 create mode 100644 src/server/Model/Json/EditCategory.hs
 create mode 100644 src/server/Model/Json/PaymentCategory.hs
 create mode 100644 src/server/Model/PaymentCategory.hs
 create mode 100644 src/server/Utils/Text.hs

(limited to 'src/server')

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
     ]
-- 
cgit v1.2.3