aboutsummaryrefslogtreecommitdiff
path: root/src/server/Model
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/Model')
-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
16 files changed, 377 insertions, 34 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-16 05:14:18 +0000