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/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 ++--
 16 files changed, 377 insertions(+), 34 deletions(-)
 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

(limited to 'src/server/Model')

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