aboutsummaryrefslogtreecommitdiff
path: root/src/server/Model
diff options
context:
space:
mode:
authorJoris2020-01-30 11:35:31 +0000
committerJoris2020-01-30 11:35:31 +0000
commit960fa7cb7ae4c57d01306f78cd349f3a8337d0ab (patch)
tree5077cc720525fb025e4dba65a9a8b631862cbcc8 /src/server/Model
parent14bdbc8c937f5d0b35c61350dba28cb41c3737cd (diff)
parent6a04e640955051616c3ad0874605830c448f2d75 (diff)
Merge branch 'with-ghcjs' into 'master'
Use Haskell on the frontend See merge request guyonvarch/shared-cost!2
Diffstat (limited to 'src/server/Model')
-rw-r--r--src/server/Model/Category.hs90
-rw-r--r--src/server/Model/Frequency.hs33
-rw-r--r--src/server/Model/Income.hs111
-rw-r--r--src/server/Model/Init.hs30
-rw-r--r--src/server/Model/Json/Category.hs24
-rw-r--r--src/server/Model/Json/Conf.hs17
-rw-r--r--src/server/Model/Json/CreateCategory.hs17
-rw-r--r--src/server/Model/Json/CreateIncome.hs17
-rw-r--r--src/server/Model/Json/CreatePayment.hs23
-rw-r--r--src/server/Model/Json/EditCategory.hs19
-rw-r--r--src/server/Model/Json/EditIncome.hs20
-rw-r--r--src/server/Model/Json/EditPayment.hs25
-rw-r--r--src/server/Model/Json/Income.hs26
-rw-r--r--src/server/Model/Json/Init.hs36
-rw-r--r--src/server/Model/Json/MessagePart.hs18
-rw-r--r--src/server/Model/Json/Number.hs15
-rw-r--r--src/server/Model/Json/Payment.hs40
-rw-r--r--src/server/Model/Json/PaymentCategory.hs23
-rw-r--r--src/server/Model/Json/Translation.hs20
-rw-r--r--src/server/Model/Json/User.hs25
-rw-r--r--src/server/Model/Mail.hs12
-rw-r--r--src/server/Model/Message.hs35
-rw-r--r--src/server/Model/Message/Key.hs193
-rw-r--r--src/server/Model/Message/Lang.hs11
-rw-r--r--src/server/Model/Message/Parts.hs37
-rw-r--r--src/server/Model/Message/Translations.hs729
-rw-r--r--src/server/Model/Payment.hs163
-rw-r--r--src/server/Model/PaymentCategory.hs74
-rw-r--r--src/server/Model/Query.hs32
-rw-r--r--src/server/Model/SignIn.hs66
-rw-r--r--src/server/Model/UUID.hs10
-rw-r--r--src/server/Model/User.hs64
32 files changed, 0 insertions, 2055 deletions
diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs
deleted file mode 100644
index 9597bd9..0000000
--- a/src/server/Model/Category.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Category
- ( CategoryId
- , Category(..)
- , list
- , create
- , edit
- , delete
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (isJust, listToMaybe)
-import Data.Text (Text)
-import Data.Time (UTCTime)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Query (Query(Query))
-
-type CategoryId = Int64
-
-data Category = Category
- { id :: CategoryId
- , name :: Text
- , color :: Text
- , createdAt :: UTCTime
- , editedAt :: Maybe UTCTime
- , deletedAt :: Maybe UTCTime
- } deriving Show
-
-instance FromRow Category where
- fromRow = Category <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field
-
-list :: Query [Category]
-list =
- Query (\conn ->
- SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL"
- )
-
-create :: Text -> Text -> Query CategoryId
-create categoryName categoryColor =
- Query (\conn -> do
- now <- getCurrentTime
- SQLite.execute
- conn
- "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)"
- (categoryName, categoryColor, now)
- SQLite.lastInsertRowId conn
- )
-
-edit :: CategoryId -> Text -> Text -> Query Bool
-edit categoryId categoryName categoryColor =
- Query (\conn -> do
- mbCategory <- listToMaybe <$>
- (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category])
- if isJust mbCategory
- then do
- now <- getCurrentTime
- SQLite.execute
- conn
- "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?"
- (now, categoryName, categoryColor, categoryId)
- return True
- else
- return False
- )
-
-delete :: CategoryId -> Query Bool
-delete categoryId =
- Query (\conn -> do
- mbCategory <- listToMaybe <$>
- (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category])
- if isJust mbCategory
- then do
- now <- getCurrentTime
- SQLite.execute
- conn
- "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId)
- return True
- else
- return False
- )
diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs
deleted file mode 100644
index f9958e1..0000000
--- a/src/server/Model/Frequency.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Model.Frequency
- ( Frequency(..)
- ) where
-
-import Data.Aeson
-import Database.SQLite.Simple (SQLData(SQLText))
-import Database.SQLite.Simple.FromField (fieldData, FromField(fromField))
-import Database.SQLite.Simple.Ok (Ok(Ok, Errors))
-import Database.SQLite.Simple.ToField (ToField(toField))
-import GHC.Generics
-import qualified Data.Text as T
-import Web.Scotty (parseParam, Parsable, readEither)
-
-data Frequency =
- Punctual
- | Monthly
- deriving (Eq, Show, Read, Generic)
-
-instance Parsable Frequency where parseParam = readEither
-instance FromJSON Frequency
-instance ToJSON Frequency
-
-instance FromField Frequency where
- fromField field = case fieldData field of
- SQLText text -> Ok (read (T.unpack text) :: Frequency)
- _ -> Errors [error "SQLText field required for frequency"]
-
-instance ToField Frequency where
- toField frequency = SQLText . T.pack . show $ frequency
diff --git a/src/server/Model/Income.hs b/src/server/Model/Income.hs
deleted file mode 100644
index c6cdb55..0000000
--- a/src/server/Model/Income.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Income
- ( IncomeId
- , Income(..)
- , list
- , create
- , editOwn
- , deleteOwn
- , modifiedDuring
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (listToMaybe)
-import Data.Time.Calendar (Day)
-import Data.Time.Clock (UTCTime, getCurrentTime)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
-import Prelude hiding (id)
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Query (Query(Query))
-import Model.User (User, UserId)
-import qualified Model.User as User
-import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
-
-type IncomeId = Int64
-
-data Income = Income
- { id :: IncomeId
- , userId :: UserId
- , date :: Day
- , amount :: Int
- , createdAt :: UTCTime
- , editedAt :: Maybe UTCTime
- , deletedAt :: Maybe UTCTime
- } deriving Show
-
-instance Resource Income where
- resourceCreatedAt = createdAt
- resourceEditedAt = editedAt
- resourceDeletedAt = deletedAt
-
-instance FromRow Income where
- fromRow = Income <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field
-
-list :: Query [Income]
-list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL")
-
-create :: UserId -> Day -> Int -> Query IncomeId
-create incomeUserId incomeDate incomeAmount =
- Query (\conn -> do
- now <- getCurrentTime
- SQLite.execute
- conn
- "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)"
- (incomeUserId, incomeDate, incomeAmount, now)
- SQLite.lastInsertRowId conn
- )
-
-editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool
-editOwn incomeUserId incomeId incomeDate incomeAmount =
- Query (\conn -> do
- mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
- case mbIncome of
- Just income ->
- if userId income == incomeUserId
- then do
- now <- getCurrentTime
- SQLite.execute
- conn
- "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?"
- (now, incomeDate, incomeAmount, incomeId)
- return True
- else
- return False
- Nothing ->
- return False
- )
-
-deleteOwn :: User -> IncomeId -> Query Bool
-deleteOwn user incomeId =
- Query (\conn -> do
- mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
- case mbIncome of
- Just income ->
- if userId income == User.id user
- then do
- now <- getCurrentTime
- SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId)
- return True
- else
- return False
- Nothing ->
- return False
- )
-
-modifiedDuring :: UTCTime -> UTCTime -> Query [Income]
-modifiedDuring start end =
- Query (\conn ->
- SQLite.query
- conn
- "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)"
- (start, end, start, end, start, end)
- )
diff --git a/src/server/Model/Init.hs b/src/server/Model/Init.hs
deleted file mode 100644
index 7a9ccea..0000000
--- a/src/server/Model/Init.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Init
- ( getInit
- ) where
-
-import Model.Json.Init (Init)
-import Model.Query (Query)
-import Model.User (User)
-import qualified Model.Category as Category
-import qualified Model.Income as Income
-import qualified Model.Json.Category as Json
-import qualified Model.Json.Income as Json
-import qualified Model.Json.Init as Init
-import qualified Model.Json.Payment as Json
-import qualified Model.Json.PaymentCategory as Json
-import qualified Model.Json.User as Json
-import qualified Model.Payment as Payment
-import qualified Model.PaymentCategory as PaymentCategory
-import qualified Model.User as User
-
-getInit :: User -> Query Init
-getInit user =
- Init.Init <$>
- (map Json.fromUser <$> User.list) <*>
- (return . User.id $ user) <*>
- (map Json.fromPayment <$> Payment.list) <*>
- (map Json.fromIncome <$> Income.list) <*>
- (map Json.fromCategory <$> Category.list) <*>
- (map Json.fromPaymentCategory <$> PaymentCategory.list)
diff --git a/src/server/Model/Json/Category.hs b/src/server/Model/Json/Category.hs
deleted file mode 100644
index 8b5e527..0000000
--- a/src/server/Model/Json/Category.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Category
- ( Category(..)
- , fromCategory
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import GHC.Generics
-
-import Model.Category (CategoryId)
-import qualified Model.Category as M
-
-data Category = Category
- { id :: CategoryId
- , name :: Text
- , color :: Text
- } deriving (Show, Generic)
-
-instance ToJSON Category
-
-fromCategory :: M.Category -> Category
-fromCategory category = Category (M.id category) (M.name category) (M.color category)
diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs
deleted file mode 100644
index a66fb55..0000000
--- a/src/server/Model/Json/Conf.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Conf
- ( Conf(..)
- ) where
-
-import GHC.Generics
-
-import Data.Aeson
-import Data.Text
-
-data Conf = Conf
- { currency :: Text
- } deriving (Show, Generic)
-
-instance FromJSON Conf
-instance ToJSON Conf
diff --git a/src/server/Model/Json/CreateCategory.hs b/src/server/Model/Json/CreateCategory.hs
deleted file mode 100644
index fffc882..0000000
--- a/src/server/Model/Json/CreateCategory.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.CreateCategory
- ( CreateCategory(..)
- ) where
-
-import GHC.Generics
-
-import Data.Aeson
-import Data.Text (Text)
-
-data CreateCategory = CreateCategory
- { name :: Text
- , color :: Text
- } deriving (Show, Generic)
-
-instance FromJSON CreateCategory
diff --git a/src/server/Model/Json/CreateIncome.hs b/src/server/Model/Json/CreateIncome.hs
deleted file mode 100644
index cf9b1c3..0000000
--- a/src/server/Model/Json/CreateIncome.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.CreateIncome
- ( CreateIncome(..)
- ) where
-
-import GHC.Generics
-
-import Data.Aeson
-import Data.Time.Calendar (Day)
-
-data CreateIncome = CreateIncome
- { date :: Day
- , amount :: Int
- } deriving (Show, Generic)
-
-instance FromJSON CreateIncome
diff --git a/src/server/Model/Json/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs
deleted file mode 100644
index 6ab3a5b..0000000
--- a/src/server/Model/Json/CreatePayment.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.CreatePayment
- ( CreatePayment(..)
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import Data.Time.Calendar (Day)
-import GHC.Generics
-
-import Model.Category (CategoryId)
-import Model.Frequency (Frequency)
-
-data CreatePayment = CreatePayment
- { name :: Text
- , cost :: Int
- , date :: Day
- , category :: CategoryId
- , frequency :: Frequency
- } deriving (Show, Generic)
-
-instance FromJSON CreatePayment
diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs
deleted file mode 100644
index a10ce39..0000000
--- a/src/server/Model/Json/EditCategory.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.EditCategory
- ( EditCategory(..)
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import GHC.Generics
-
-import Model.Category (CategoryId)
-
-data EditCategory = EditCategory
- { id :: CategoryId
- , name :: Text
- , color :: Text
- } deriving (Show, Generic)
-
-instance FromJSON EditCategory
diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs
deleted file mode 100644
index 9b29379..0000000
--- a/src/server/Model/Json/EditIncome.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.EditIncome
- ( EditIncome(..)
- ) where
-
-import GHC.Generics
-
-import Data.Aeson
-import Data.Time.Calendar (Day)
-
-import Model.Income (IncomeId)
-
-data EditIncome = EditIncome
- { id :: IncomeId
- , date :: Day
- , amount :: Int
- } deriving (Show, Generic)
-
-instance FromJSON EditIncome
diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs
deleted file mode 100644
index b7d4d7d..0000000
--- a/src/server/Model/Json/EditPayment.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.EditPayment
- ( EditPayment(..)
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import Data.Time.Calendar (Day)
-import GHC.Generics
-
-import Model.Category (CategoryId)
-import Model.Frequency (Frequency)
-import Model.Payment (PaymentId)
-
-data EditPayment = EditPayment
- { id :: PaymentId
- , name :: Text
- , cost :: Int
- , date :: Day
- , category :: CategoryId
- , frequency :: Frequency
- } deriving (Show, Generic)
-
-instance FromJSON EditPayment
diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs
deleted file mode 100644
index 7e23a84..0000000
--- a/src/server/Model/Json/Income.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Income
- ( Income(..)
- , fromIncome
- ) where
-
-import Data.Aeson
-import Data.Time.Calendar (Day)
-import GHC.Generics
-
-import Model.Income (IncomeId)
-import Model.User (UserId)
-import qualified Model.Income as M
-
-data Income = Income
- { id :: IncomeId
- , userId :: UserId
- , date :: Day
- , amount :: Int
- } deriving (Show, Generic)
-
-instance ToJSON Income
-
-fromIncome :: M.Income -> Income
-fromIncome income = Income (M.id income) (M.userId income) (M.date income) (M.amount income)
diff --git a/src/server/Model/Json/Init.hs b/src/server/Model/Json/Init.hs
deleted file mode 100644
index 530c3b7..0000000
--- a/src/server/Model/Json/Init.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Init
- ( Init(..)
- , InitResult(..)
- ) where
-
-import Data.Aeson
-import GHC.Generics
-
-import Model.Json.Category (Category)
-import Model.Json.Income (Income)
-import Model.Json.Payment (Payment)
-import Model.Json.PaymentCategory (PaymentCategory)
-import Model.Json.User (User)
-import Model.Message.Key (Key)
-import Model.User (UserId)
-
-data Init = Init
- { users :: [User]
- , me :: UserId
- , payments :: [Payment]
- , incomes :: [Income]
- , categories :: [Category]
- , paymentCategories :: [PaymentCategory]
- } deriving (Show, Generic)
-
-instance ToJSON Init
-
-data InitResult =
- InitEmpty
- | InitSuccess Init
- | InitError Key
- deriving (Show, Generic)
-
-instance ToJSON InitResult
diff --git a/src/server/Model/Json/MessagePart.hs b/src/server/Model/Json/MessagePart.hs
deleted file mode 100644
index 0753d7c..0000000
--- a/src/server/Model/Json/MessagePart.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.MessagePart
- ( MessagePart(..)
- ) where
-
-import Data.Text (Text)
-
-import Data.Aeson
-import GHC.Generics
-
-data MessagePart =
- Order Int
- | Str Text
- deriving (Eq, Show, Generic)
-
-instance FromJSON MessagePart
-instance ToJSON MessagePart
diff --git a/src/server/Model/Json/Number.hs b/src/server/Model/Json/Number.hs
deleted file mode 100644
index 52c9da8..0000000
--- a/src/server/Model/Json/Number.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Number
- ( Number(..)
- ) where
-
-import Data.Aeson
-import GHC.Generics
-
-data Number = Number
- { number :: Int
- } deriving (Show, Generic)
-
-instance FromJSON Number
-instance ToJSON Number
diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs
deleted file mode 100644
index e406c0f..0000000
--- a/src/server/Model/Json/Payment.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Payment
- ( Payment(..)
- , fromPayment
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import Data.Time.Calendar (Day)
-import GHC.Generics
-import Prelude hiding (id)
-
-import Model.Frequency
-import Model.Payment (PaymentId)
-import Model.User (UserId)
-import qualified Model.Payment as M
-
-data Payment = Payment
- { id :: PaymentId
- , date :: Day
- , name :: Text
- , cost :: Int
- , userId :: UserId
- , frequency :: Frequency
- } deriving (Show, Generic)
-
-instance FromJSON Payment
-instance ToJSON Payment
-
-fromPayment :: M.Payment -> Payment
-fromPayment payment =
- Payment
- { id = M.id payment
- , date = M.date payment
- , name = M.name payment
- , cost = M.cost payment
- , userId = M.userId payment
- , frequency = M.frequency payment
- }
diff --git a/src/server/Model/Json/PaymentCategory.hs b/src/server/Model/Json/PaymentCategory.hs
deleted file mode 100644
index fd97674..0000000
--- a/src/server/Model/Json/PaymentCategory.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.PaymentCategory
- ( PaymentCategory(..)
- , fromPaymentCategory
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import GHC.Generics
-
-import Model.Category (CategoryId)
-import qualified Model.PaymentCategory as M
-
-data PaymentCategory = PaymentCategory
- { name :: Text
- , category :: CategoryId
- } deriving (Show, Generic)
-
-instance ToJSON PaymentCategory
-
-fromPaymentCategory :: M.PaymentCategory -> PaymentCategory
-fromPaymentCategory pc = PaymentCategory (M.name pc) (M.category pc)
diff --git a/src/server/Model/Json/Translation.hs b/src/server/Model/Json/Translation.hs
deleted file mode 100644
index 9dcfe80..0000000
--- a/src/server/Model/Json/Translation.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Translation
- ( Translation(..)
- ) where
-
-import GHC.Generics
-
-import Data.Aeson
-import Data.Text
-
-import Model.Json.MessagePart
-
-data Translation = Translation
- { key :: Text
- , message :: [MessagePart]
- } deriving (Show, Generic)
-
-instance FromJSON Translation
-instance ToJSON Translation
diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs
deleted file mode 100644
index c289fe0..0000000
--- a/src/server/Model/Json/User.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.User
- ( User(..)
- , fromUser
- ) where
-
-import Data.Aeson
-import Data.Text (Text)
-import GHC.Generics
-
-import Model.User (UserId)
-import qualified Model.User as M
-
-data User = User
- { id :: UserId
- , name :: Text
- , email :: Text
- } deriving (Show, Generic)
-
-instance FromJSON User
-instance ToJSON User
-
-fromUser :: M.User -> User
-fromUser user = User (M.id user) (M.name user) (M.email user)
diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs
deleted file mode 100644
index 9a4db73..0000000
--- a/src/server/Model/Mail.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Model.Mail
- ( Mail(..)
- ) where
-
-import Data.Text (Text)
-
-data Mail = Mail
- { from :: Text
- , to :: [Text]
- , subject :: Text
- , plainBody :: Text
- } deriving (Eq, Show)
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
deleted file mode 100644
index 026967f..0000000
--- a/src/server/Model/Message.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Model.Message
- ( getMessage
- , getParamMessage
- , getTranslations
- , plural
- ) where
-
-import Data.Text (Text)
-import qualified Data.Text as T
-
-import Model.Message.Key (Key)
-import Model.Message.Lang
-import Model.Message.Translations (getNonFormattedMessage)
-import Model.Message.Parts
-
-import Model.Json.Translation
-
-getMessage :: Key -> Text
-getMessage = getParamMessage []
-
-getParamMessage :: [Text] -> Key -> Text
-getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey)
-
-getTranslations :: [Translation]
-getTranslations = (map getTranslation [minBound..])
-
-getTranslation :: Key -> Translation
-getTranslation translationKey =
- Translation
- (T.pack . show $ translationKey)
- (getParts $ getNonFormattedMessage lang translationKey)
-
-plural :: Int -> Key -> Key -> Text
-plural count singularKey pluralKey =
- getParamMessage [T.pack . show $ count] (if count <= 1 then singularKey else pluralKey)
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
deleted file mode 100644
index 18f16f0..0000000
--- a/src/server/Model/Message/Key.hs
+++ /dev/null
@@ -1,193 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Message.Key
- ( Key(..)
- ) where
-
-import qualified Data.Aeson as Json
-import qualified Data.Text as T
-
-data Key =
-
- -- Title
-
- SharedCost
-
- -- Sign
-
- | Email
- | SignIn
- | SendEmailFail
- | InvalidEmail
- | UnauthorizedSignIn
- | Forbidden
- | EnterValidEmail
- | SignInUsed
- | SignInExpired
- | SignInInvalid
- | SignInMailTitle
- | SignInMail
- | SignInEmailSent
-
- -- Dates
-
- | January
- | February
- | March
- | April
- | May
- | June
- | July
- | August
- | September
- | October
- | November
- | December
-
- | ShortDate
- | ShortMonthAndYear
- | LongDate
-
- -- Search
-
- | SearchName
- | SearchPunctual
- | SearchMonthly
-
- -- Payments
-
- | PaymentsAreBalanced
- | Name
- | Cost
- | Payer
- | Date
- | Frequency
- | InvalidFrequency
- | AddPayment
- | ClonePayment
- | EditPayment
- | PaymentNotDeleted
- | Punctual
- | Monthly
-
- | PaymentsTitle
- | Payment
- | Payments
- | Worth
- | NoPayment
-
- | PaymentName
- | PaymentCost
- | PaymentDate
- | PaymentCategory
- | PaymentPunctual
- | PaymentMonthly
-
- | Clone
- | Edit
- | Delete
- | ConfirmPaymentDelete
-
- -- Categories
-
- | Categories
- | NoCategories
- | CategoryNotDeleted
- | AddCategory
- | CloneCategory
- | EditCategory
- | ConfirmCategoryDelete
- | CategoryName
- | CategoryColor
- | Color
- | UsedCategory
-
- -- Statistics
-
- | Statistics
- | ByMonthsAndMean
- | By
- | Total
-
- -- Income
-
- | CumulativeIncomesSince
- | NoIncome
- | Income
- | MonthlyNetIncomes
- | AddIncome
- | CloneIncome
- | EditIncome
- | IncomeNotDeleted
- | IncomeAmount
- | IncomeDate
- | ConfirmIncomeDelete
- | Add
-
- -- Form
-
- | Empty
- | InvalidString
- | InvalidDate
- | CostMustNotBeNull
- | InvalidInt
- | InvalidCategory
- | InvalidColor
- | AlreadyExists
- | SmallerIntThan
- | GreaterIntThan
-
- -- Errors
-
- | CreatePaymentError
- | EditPaymentError
- | DeletePaymentError
- | CreateIncomeError
- | EditIncomeError
- | DeleteIncomeError
- | CreateCategoryError
- | EditCategoryError
- | DeleteCategoryError
- | SignOutError
-
- -- Dialog
-
- | Confirm
- | Undo
-
- -- Page not found
-
- | PageNotFound
-
- -- Weekly report
-
- | WeeklyReport
- | WeeklyReportEmpty
- | PaymentCreated
- | PaymentsCreated
- | PaymentEdited
- | PaymentsEdited
- | PaymentDeleted
- | PaymentsDeleted
- | IncomeCreated
- | IncomesCreated
- | IncomeEdited
- | IncomesEdited
- | IncomeDeleted
- | IncomesDeleted
- | PayedFor
- | DidNotPayFor
- | IsPayedFrom
- | IsNotPayedFrom
-
- -- Http error
-
- | BadUrl
- | Timeout
- | NetworkError
- | BadPayload
-
- deriving (Enum, Bounded, Show)
-
-instance Json.ToJSON Key where
- toJSON = Json.String . T.pack . show
diff --git a/src/server/Model/Message/Lang.hs b/src/server/Model/Message/Lang.hs
deleted file mode 100644
index f515c96..0000000
--- a/src/server/Model/Message/Lang.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module Model.Message.Lang
- ( Lang(..)
- , lang
- ) where
-
-data Lang =
- English
- | French
-
-lang :: Lang
-lang = French
diff --git a/src/server/Model/Message/Parts.hs b/src/server/Model/Message/Parts.hs
deleted file mode 100644
index d065cf2..0000000
--- a/src/server/Model/Message/Parts.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Message.Parts
- ( replaceParts
- , getParts
- ) where
-
-import Data.Maybe (listToMaybe, fromMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-
-import Text.ParserCombinators.Parsec
-
-import Model.Json.MessagePart
-
-replaceParts :: [Text] -> Text -> Text
-replaceParts values message =
- T.concat . map (replacePart values) $ getParts message
-
-replacePart :: [Text] -> MessagePart -> Text
-replacePart _ (Str str) = str
-replacePart values (Order n) =
- fromMaybe (T.concat ["{", T.pack (show n), "}"]) . listToMaybe . drop (n - 1) $ values
-
-getParts :: Text -> [MessagePart]
-getParts str =
- case parse partsParser "" (T.unpack str) of
- Right parts -> parts
- Left _ -> []
-
-partsParser :: Parser [MessagePart]
-partsParser = many partParser
-
-partParser :: Parser MessagePart
-partParser =
- (do _ <- string "{"; n <- read <$> many1 digit; _ <- string "}"; return (Order n))
- <|> (do str <- T.pack <$> many1 (noneOf "{"); return (Str str))
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
deleted file mode 100644
index 7d26c3f..0000000
--- a/src/server/Model/Message/Translations.hs
+++ /dev/null
@@ -1,729 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Message.Translations
- ( getNonFormattedMessage
- ) where
-
-import Data.Text (Text)
-import qualified Data.Text as T
-
-import Model.Message.Key
-import Model.Message.Lang
-
-getNonFormattedMessage :: Lang -> Key -> Text
-getNonFormattedMessage = m
-
-m :: Lang -> Key -> Text
-
--- Title
-
-m l SharedCost =
- case l of
- English -> "Shared Cost"
- French -> "Partage des frais"
-
--- Sign in
-
-m l Email =
- case l of
- English -> "Email"
- French -> "Courriel"
-
-m l SignIn =
- case l of
- English -> "Sign in"
- French -> "Connexion"
-
-m l InvalidEmail =
- case l of
- English -> "Your email is not valid."
- French -> "Votre courriel n'est pas valide."
-
-m l UnauthorizedSignIn =
- case l of
- English -> "You are not authorized to sign in."
- French -> "Tu n'es pas autorisé à te connecter."
-
-m l Forbidden =
- case l of
- English -> "You need to be logged in to perform this action"
- French -> "Tu dois te connecter pour effectuer cette action"
-
-m l SendEmailFail =
- case l of
- English -> "You are authorized to sign in, but we failed to send you the sign up email."
- French -> "Tu es autorisé à te connecter, mais nous n'avons pas pu t'envoyer le courriel de connexion."
-
-m l EnterValidEmail =
- case l of
- English -> "Please enter a valid email address."
- French -> "Ton courriel n'est pas valide."
-
-m l SignInUsed =
- case l of
- English -> "You already used this link, please sign in again."
- French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau."
-
-m l SignInExpired =
- case l of
- English -> "The link expired, please sign in again."
- French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau."
-
-m l SignInInvalid =
- case l of
- English -> "The link is invalid, please sign in again."
- French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau."
-
-m l SignInMailTitle =
- case l of
- English -> T.concat ["Sign in to ", m l SharedCost]
- French -> T.concat ["Connexion à ", m l SharedCost]
-
-m l SignInMail =
- T.intercalate
- "\n"
- ( case l of
- English ->
- [ "Hi {1},"
- , ""
- , T.concat
- [ "Click to the following link in order to sign in to Shared Cost:"
- , m l SharedCost
- , ":"
- ]
- , "{2}"
- , ""
- , "See you soon!"
- ]
- French ->
- [ "Salut {1},"
- , ""
- , T.concat
- [ "Clique sur le lien suivant pour te connecter à "
- , m l SharedCost
- , ":"
- ]
- , "{2}"
- , ""
- , "À très vite !"
- ]
- )
-
-m l SignInEmailSent =
- case l of
- English -> "We sent you an email with a connexion link."
- French -> "Nous t'avons envoyé un courriel avec un lien pour te connecter."
-
--- Date
-
-m l January =
- case l of
- English -> "january"
- French -> "janvier"
-
-m l February =
- case l of
- English -> "february"
- French -> "février"
-
-m l March =
- case l of
- English -> "march"
- French -> "mars"
-
-m l April =
- case l of
- English -> "april"
- French -> "avril"
-
-m l May =
- case l of
- English -> "may"
- French -> "mai"
-
-m l June =
- case l of
- English -> "june"
- French -> "juin"
-
-m l July =
- case l of
- English -> "july"
- French -> "juillet"
-
-m l August =
- case l of
- English -> "august"
- French -> "août"
-
-m l September =
- case l of
- English -> "september"
- French -> "septembre"
-
-m l October =
- case l of
- English -> "october"
- French -> "octobre"
-
-m l November =
- case l of
- English -> "november"
- French -> "novembre"
-
-m l December =
- case l of
- English -> "december"
- French -> "décembre"
-
-m l ShortDate =
- case l of
- English -> "{3}-{2}-{1}"
- French -> "{1}/{2}/{3}"
-
-m l ShortMonthAndYear =
- case l of
- English -> "{2}-{1}"
- French -> "{1}/{2}"
-
-m l LongDate =
- case l of
- English -> "{2} {1}, {3}"
- French -> "{1} {2} {3}"
-
--- Search
-
-m l SearchName =
- case l of
- English -> "Search"
- French -> "Recherche"
-
-m l SearchPunctual =
- case l of
- English -> "Punctual"
- French -> "Ponctuel"
-
-m l SearchMonthly =
- case l of
- English -> "Monthly"
- French -> "Mensuel"
-
--- Payments
-
-m l PaymentsAreBalanced =
- case l of
- English -> "Payments are balanced."
- French -> "Les paiements sont équilibrés."
-
-m l Name =
- case l of
- English -> "Name"
- French -> "Nom"
-
-m l Cost =
- case l of
- English -> "Cost"
- French -> "Coût"
-
-m l Payer =
- case l of
- English -> "Payer"
- French -> "Payeur"
-
-m l Date =
- case l of
- English -> "Date"
- French -> "Date"
-
-m l Frequency =
- case l of
- English -> "Frequency"
- French -> "Fréquence"
-
-m l InvalidFrequency =
- case l of
- English -> "Invalid frequency"
- French -> "Fréquence invalide"
-
-m l AddPayment =
- case l of
- English -> "Add a payment"
- French -> "Ajouter un paiement"
-
-m l ClonePayment =
- case l of
- English -> "Clone a payment"
- French -> "Cloner un paiement"
-
-m l EditPayment =
- case l of
- English -> "Edit a payment"
- French -> "Modifier un paiement"
-
-m l PaymentNotDeleted =
- case l of
- English -> "The payment could not have been deleted."
- French -> "Le paiement n'a pas pu être supprimé."
-
-m l Punctual =
- case l of
- English -> "Punctual"
- French -> "Ponctuelle"
-
-m l Monthly =
- case l of
- English -> "Monthly"
- French -> "Mensuelle"
-
-m l PaymentsTitle =
- case l of
- English -> "Payments"
- French -> "Paiements"
-
-m l Payment =
- case l of
- English -> "payment"
- French -> "paiement"
-
-m l Payments =
- case l of
- English -> "payments"
- French -> "paiements"
-
-m l Worth =
- case l of
- English -> "{1} worth {2}"
- French -> "{1} comptabilisant {2}"
-
-m l NoPayment =
- case l of
- English -> "No payment found from your search criteria."
- French -> "Aucun paiement ne correspond à vos critères de recherches."
-
-m l PaymentName =
- case l of
- English -> "Name"
- French -> "Nom"
-
-m l PaymentCost =
- case l of
- English -> "Cost"
- French -> "Coût"
-
-m l PaymentDate =
- case l of
- English -> "Date"
- French -> "Date"
-
-m l PaymentCategory =
- case l of
- English -> "Category"
- French -> "Catégorie"
-
-m l PaymentPunctual =
- case l of
- English -> "Punctual"
- French -> "Ponctuel"
-
-m l PaymentMonthly =
- case l of
- English -> "Monthly"
- French -> "Mensuel"
-
-m l ConfirmPaymentDelete =
- case l of
- English -> "Are you sure to delete this payment ?"
- French -> "Voulez-vous vraiment supprimer ce paiement ?"
-
-m l Edit =
- case l of
- English -> "Edit"
- French -> "Modifier"
-
-m l Clone =
- case l of
- English -> "Clone"
- French -> "Cloner"
-
-m l Delete =
- case l of
- English -> "Delete"
- French -> "Supprimer"
-
--- Categories
-
-m l Categories =
- case l of
- English -> "Categories"
- French -> "Catégories"
-
-m l NoCategories =
- case l of
- English -> "No category."
- French -> "Aucune catégorie."
-
-m l CategoryNotDeleted =
- case l of
- English -> "The category could not have been deleted."
- French -> "La catégorie n'a pas pu être supprimé."
-
-m l AddCategory =
- case l of
- English -> "Add an category"
- French -> "Ajouter une catégorie"
-
-m l CloneCategory =
- case l of
- English -> "Clone an category"
- French -> "Cloner une catégorie"
-
-m l EditCategory =
- case l of
- English -> "Edit an category"
- French -> "Modifier une catégorie"
-
-m l ConfirmCategoryDelete =
- case l of
- English -> "Are you sure to delete this category ?"
- French -> "Voulez-vous vraiment supprimer cette catégorie ?"
-
-m l CategoryName =
- case l of
- English -> "Name"
- French -> "Nom"
-
-m l CategoryColor =
- case l of
- English -> "Color"
- French -> "Couleur"
-
-m l Color =
- case l of
- English -> "Color"
- French -> "Couleur"
-
-m l UsedCategory =
- case l of
- English -> "This category is currently being used"
- French -> "Cette catégorie est actuellement utilisée"
-
--- Statistics
-
-m l Statistics =
- case l of
- English -> "Statistics"
- French -> "Statistiques"
-
-m l ByMonthsAndMean =
- case l of
- English -> "Payments by category by month months ({1} on average)"
- French -> "Paiements par catégorie par mois (en moyenne {1})"
-
-m l By =
- case l of
- English -> "{1}: {2}"
- French -> "{1} : {2}"
-
-m l Total =
- case l of
- English -> "Total"
- French -> "Total"
-
--- Income
-
-m l CumulativeIncomesSince =
- case l of
- English -> "Cumulative incomes since {1}"
- French -> "Revenus nets cumulés depuis le {1}"
-
-m l NoIncome =
- case l of
- English -> "No income."
- French -> "Aucun revenu."
-
-m l Income =
- case l of
- English -> "Income"
- French -> "Revenu"
-
-m l MonthlyNetIncomes =
- case l of
- English -> "Net monthly incomes"
- French -> "Revenus mensuels nets"
-
-m l AddIncome =
- case l of
- English -> "Add an income"
- French -> "Ajouter un revenu"
-
-m l CloneIncome =
- case l of
- English -> "Clone an income"
- French -> "Cloner un revenu"
-
-m l EditIncome =
- case l of
- English -> "Edit an income"
- French -> "Modifier un revenu"
-
-m l IncomeNotDeleted =
- case l of
- English -> "The income could not have been deleted."
- French -> "Le revenu n'a pas pu être supprimé."
-
-m l IncomeAmount =
- case l of
- English -> "Amount"
- French -> "Montant"
-
-m l IncomeDate =
- case l of
- English -> "Date"
- French -> "Date"
-
-m l ConfirmIncomeDelete =
- case l of
- English -> "Are you sure to delete this income ?"
- French -> "Voulez-vous vraiment supprimer ce revenu ?"
-
-m l Add =
- case l of
- English -> "Add"
- French -> "Ajouter"
-
--- Form error
-
-m l Empty =
- case l of
- English -> "Required field"
- French -> "Champ requis"
-
-m l InvalidString =
- case l of
- English -> "String required"
- French -> "Chaîne de caractères requise"
-
-m l InvalidDate =
- case l of
- English -> "day/month/year required"
- French -> "jour/mois/année requis"
-
-m l CostMustNotBeNull =
- case l of
- English -> "Cost must not be zero"
- French -> "Le coût ne doît pas être nul"
-
-m l InvalidInt =
- case l of
- English -> "Integer required"
- French -> "Entier requis"
-
-m l InvalidCategory =
- case l of
- English -> "Invalid category"
- French -> "Catégorie invalide"
-
-m l InvalidColor =
- case l of
- English -> "Invalid color"
- French -> "Couleur invalide"
-
-m l AlreadyExists =
- case l of
- English -> "Dupplicate field"
- French -> "Doublon"
-
-m l SmallerIntThan =
- case l of
- English -> "Integer bigger than {1} or equal required"
- French -> "Entier supérieur ou égal à {1} requis"
-
-m l GreaterIntThan =
- case l of
- English -> "Integer smaller than {1} or equal required"
- French -> "Entier inférieur ou égal à {1} requis"
-
--- Errors
-
-m l CreatePaymentError =
- case l of
- English -> "Error at payment creation"
- French -> "Erreur lors de la création du paiement"
-
-m l EditPaymentError =
- case l of
- English -> "Error at payment edition"
- French -> "Erreur lors de la modification du paiement"
-
-m l DeletePaymentError =
- case l of
- English -> "Error at payment deletion"
- French -> "Erreur lors de la suppression du paiement"
-
-m l CreateIncomeError =
- case l of
- English -> "Error at income creation"
- French -> "Erreur lors de la création du revenu"
-
-m l EditIncomeError =
- case l of
- English -> "Error at income edition"
- French -> "Erreur lors de la modification du revenu"
-
-m l DeleteIncomeError =
- case l of
- English -> "Error at income deletion"
- French -> "Erreur lors de la suppression du revenu"
-
-m l CreateCategoryError =
- case l of
- English -> "Error at category creation"
- French -> "Erreur lors de la création de la catégorie"
-
-m l EditCategoryError =
- case l of
- English -> "Error at category edition"
- French -> "Erreur lors de la modification de la catégorie"
-
-m l DeleteCategoryError =
- case l of
- English -> "Error at category deletion"
- French -> "Erreur lors de la suppression de la catégorie"
-
-m l SignOutError =
- case l of
- English -> "Error at sign out"
- French -> "Erreur lors de la déconnexion"
-
--- Dialog
-
-m l Confirm =
- case l of
- English -> "Confirm"
- French -> "Confirmer"
-
-m l Undo =
- case l of
- English -> "Undo"
- French -> "Annuler"
-
--- Page not found
-
-m l PageNotFound =
- case l of
- English -> "Page not found"
- French -> "Page introuvable"
-
--- Weekly report
-
-m l WeeklyReport =
- case l of
- English -> "Weekly report"
- French -> "Rapport hebdomadaire"
-
-m l WeeklyReportEmpty =
- case l of
- English -> "No activity the previous week."
- French -> "Pas d'activité la semaine passée."
-
-m l PaymentCreated =
- case l of
- English -> "{1} payment created:"
- French -> "{1} paiement créé :"
-
-m l PaymentsCreated =
- case l of
- English -> "{1} payments created:"
- French -> "{1} paiements créés :"
-
-m l PaymentEdited =
- case l of
- English -> "{1} payment edited:"
- French -> "{1} paiement modifié :"
-
-m l PaymentsEdited =
- case l of
- English -> "{1} payments edited:"
- French -> "{1} paiements modifiés :"
-
-m l PaymentDeleted =
- case l of
- English -> "{1} payment deleted:"
- French -> "{1} paiement supprimé :"
-
-m l PaymentsDeleted =
- case l of
- English -> "{1} payments deleted:"
- French -> "{1} paiements supprimés :"
-
-m l IncomeCreated =
- case l of
- English -> "{1} income created:"
- French -> "{1} revenu créé :"
-
-m l IncomesCreated =
- case l of
- English -> "{1} incomes created:"
- French -> "{1} revenus créés :"
-
-m l IncomeEdited =
- case l of
- English -> "{1} income edited:"
- French -> "{1} revenu modifié :"
-
-m l IncomesEdited =
- case l of
- English -> "{1} incomes edited:"
- French -> "{1} revenus modifiés :"
-
-m l IncomeDeleted =
- case l of
- English -> "{1} income deleted:"
- French -> "{1} revenu supprimé :"
-
-m l IncomesDeleted =
- case l of
- English -> "{1} incomes deleted:"
- French -> "{1} revenus supprimés :"
-
-m l PayedFor =
- case l of
- English -> "{1} payed {2} for “{3}” at {4}"
- French -> "{1} a payé {2} concernant « {3} » le {4}"
-
-m l DidNotPayFor =
- case l of
- English -> "{1} didn't pay {2} for “{3}” at {4}"
- French -> "{1} n'a pas payé {2} concernant « {3} » le {4}"
-
-m l IsPayedFrom =
- case l of
- English -> "{1} is payed {2} of net monthly income from {3}"
- French -> "{1} est payé {2} net par mois à partir du {3}"
-
-m l IsNotPayedFrom =
- case l of
- English -> "{1} isn't payed {2} of net monthly income from {3}"
- French -> "{1} n'est pas payé {2} net par mois à partir du {3}"
-
--- Http error
-
-m l BadUrl =
- case l of
- English -> "URL not valid"
- French -> "l'URL n'est pas valide"
-
-m l Timeout =
- case l of
- English -> "Timeout server error"
- French -> "Le serveur met trop de temps à répondre"
-
-m l NetworkError =
- case l of
- English -> "Network can not be reached"
- French -> "Le serveur n'est pas accessible"
-
-m l BadPayload =
- case l of
- English -> "Bad payload server error"
- French -> "Contenu inattendu en provenance du serveur"
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
deleted file mode 100644
index 5414d18..0000000
--- a/src/server/Model/Payment.hs
+++ /dev/null
@@ -1,163 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.Payment
- ( PaymentId
- , Payment(..)
- , find
- , list
- , listMonthly
- , create
- , createMany
- , editOwn
- , deleteOwn
- , modifiedDuring
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-import Data.Time (UTCTime)
-import Data.Time.Calendar (Day)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow)
-import Database.SQLite.Simple.ToField (ToField(toField))
-import Prelude hiding (id)
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Frequency
-import Model.Query (Query(Query))
-import Model.User (UserId)
-import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
-
-type PaymentId = Int64
-
-data Payment = Payment
- { id :: PaymentId
- , userId :: UserId
- , name :: Text
- , cost :: Int
- , date :: Day
- , frequency :: Frequency
- , createdAt :: UTCTime
- , editedAt :: Maybe UTCTime
- , deletedAt :: Maybe UTCTime
- } deriving Show
-
-instance Resource Payment where
- resourceCreatedAt = createdAt
- resourceEditedAt = editedAt
- resourceDeletedAt = deletedAt
-
-instance FromRow Payment where
- fromRow = Payment <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field
-
-instance ToRow Payment where
- toRow p =
- [ toField (userId p)
- , toField (name p)
- , toField (cost p)
- , toField (date p)
- , toField (frequency p)
- , toField (createdAt p)
- ]
-
-find :: PaymentId -> Query (Maybe Payment)
-find paymentId =
- Query (\conn -> listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
- )
-
-list :: Query [Payment]
-list =
- Query (\conn ->
- SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
- )
-
-listMonthly :: Query [Payment]
-listMonthly =
- Query (\conn ->
- SQLite.query
- conn
- "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ? ORDER BY name DESC"
- (Only Monthly)
- )
-
-create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId
-create paymentUserId paymentName paymentCost paymentDate paymentFrequency =
- Query (\conn -> do
- now <- getCurrentTime
- SQLite.execute
- conn
- "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)"
- (paymentUserId, paymentName, paymentCost, paymentDate, paymentFrequency, now)
- SQLite.lastInsertRowId conn
- )
-
-createMany :: [Payment] -> Query ()
-createMany payments =
- Query (\conn ->
- SQLite.executeMany
- conn
- "INSERT INTO payment (user_id, name, cost, date, frequency, created_at) VALUES (?, ?, ?, ?, ?, ?)"
- payments
- )
-
-editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
-editOwn paymentUserId paymentId paymentName paymentCost paymentDate paymentFrequency =
- Query (\conn -> do
- mbPayment <- listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
- case mbPayment of
- Just payment ->
- if userId payment == paymentUserId
- then do
- now <- getCurrentTime
- SQLite.execute
- conn
- "UPDATE payment SET edited_at = ?, name = ?, cost = ?, date = ?, frequency = ? WHERE id = ?"
- (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId)
- return True
- else
- return False
- Nothing ->
- return False
- )
-
-deleteOwn :: UserId -> PaymentId -> Query Bool
-deleteOwn paymentUserId paymentId =
- Query (\conn -> do
- mbPayment <- listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
- case mbPayment of
- Just payment ->
- if userId payment == paymentUserId
- then do
- now <- getCurrentTime
- SQLite.execute
- conn
- "UPDATE payment SET deleted_at = ? WHERE id = ?"
- (now, paymentId)
- return True
- else
- return False
- Nothing ->
- return False
- )
-
-modifiedDuring :: UTCTime -> UTCTime -> Query [Payment]
-modifiedDuring start end =
- Query (\conn ->
- SQLite.query
- conn
- "SELECT * FROM payment WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)"
- (start, end, start, end, start, end)
- )
diff --git a/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs
deleted file mode 100644
index 7c504dc..0000000
--- a/src/server/Model/PaymentCategory.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.PaymentCategory
- ( PaymentCategoryId
- , PaymentCategory(..)
- , list
- , listByCategory
- , save
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (isJust, listToMaybe)
-import Data.Text (Text)
-import Data.Time (UTCTime)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
-import qualified Data.Text as T
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Category (CategoryId)
-import Model.Query (Query(Query))
-import qualified Utils.Text as T
-
-type PaymentCategoryId = Int64
-
-data PaymentCategory = PaymentCategory
- { id :: PaymentCategoryId
- , name :: Text
- , category :: CategoryId
- , createdAt :: UTCTime
- , editedAt :: Maybe UTCTime
- } deriving Show
-
-instance FromRow PaymentCategory where
- fromRow = PaymentCategory <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field
-
-list :: Query [PaymentCategory]
-list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category")
-
-listByCategory :: CategoryId -> Query [PaymentCategory]
-listByCategory cat =
- Query (\conn ->
- SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
- )
-
-save :: Text -> CategoryId -> Query ()
-save newName categoryId =
- Query (\conn -> do
- now <- getCurrentTime
- mbPaymentCategory <- listToMaybe <$>
- (SQLite.query
- conn
- "SELECT * FROM payment_category WHERE name = ?"
- (Only (formatPaymentName newName)) :: IO [PaymentCategory])
- if isJust mbPaymentCategory
- then
- SQLite.execute
- conn
- "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
- (categoryId, now, formatPaymentName newName)
- else do
- SQLite.execute
- conn
- "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
- (formatPaymentName newName, categoryId, now)
- )
- where
- formatPaymentName :: Text -> Text
- formatPaymentName = T.unaccent . T.toLower
diff --git a/src/server/Model/Query.hs b/src/server/Model/Query.hs
deleted file mode 100644
index d15fb5f..0000000
--- a/src/server/Model/Query.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Model.Query
- ( Query(..)
- , run
- ) where
-
-import Data.Functor (Functor)
-import Database.SQLite.Simple (Connection)
-import qualified Database.SQLite.Simple as SQLite
-
-data Query a = Query (Connection -> IO a)
-
-instance Functor Query where
- fmap f (Query call) = Query (fmap f . call)
-
-instance Applicative Query where
- pure x = Query (const $ return x)
- (Query callF) <*> (Query callX) = Query (\conn -> do
- x <- callX conn
- f <- callF conn
- return (f x))
-
-instance Monad Query where
- (Query callX) >>= f = Query (\conn -> do
- x <- callX conn
- case f x of Query callY -> callY conn)
-
-run :: Query a -> IO a
-run (Query call) = do
- conn <- SQLite.open "database"
- result <- call conn
- _ <- SQLite.close conn
- return result
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
deleted file mode 100644
index c5182f0..0000000
--- a/src/server/Model/SignIn.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.SignIn
- ( SignIn(..)
- , createSignInToken
- , getSignIn
- , signInTokenToUsed
- , isLastTokenValid
- ) where
-
-import Data.Int (Int64)
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Clock (UTCTime)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Query (Query(Query))
-import Model.UUID (generateUUID)
-
-type SignInId = Int64
-
-data SignIn = SignIn
- { id :: SignInId
- , token :: Text
- , creation :: UTCTime
- , email :: Text
- , isUsed :: Bool
- } deriving Show
-
-instance FromRow SignIn where
- fromRow = SignIn <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field
-
-createSignInToken :: Text -> Query Text
-createSignInToken signInEmail =
- Query (\conn -> do
- now <- getCurrentTime
- signInToken <- generateUUID
- SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False)
- return signInToken
- )
-
-getSignIn :: Text -> Query (Maybe SignIn)
-getSignIn signInToken =
- Query (\conn -> do
- listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn])
- )
-
-signInTokenToUsed :: SignInId -> Query ()
-signInTokenToUsed tokenId =
- Query (\conn ->
- SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId)
- )
-
-isLastTokenValid :: SignIn -> Query Bool
-isLastTokenValid signIn =
- Query (\conn -> do
- [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True)
- return . maybe False (== (token signIn)) $ lastToken
- )
diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs
deleted file mode 100644
index 6cb7ce0..0000000
--- a/src/server/Model/UUID.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Model.UUID
- ( generateUUID
- ) where
-
-import Data.UUID (toString)
-import Data.UUID.V4 (nextRandom)
-import Data.Text (Text, pack)
-
-generateUUID :: IO Text
-generateUUID = pack . toString <$> nextRandom
diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs
deleted file mode 100644
index c8a0d53..0000000
--- a/src/server/Model/User.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Model.User
- ( UserId
- , User(..)
- , list
- , getUser
- , findUser
- , createUser
- , deleteUser
- ) where
-
-import Data.Int (Int64)
-import Data.List (find)
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Clock (UTCTime)
-import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
-import Prelude hiding (id)
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Query (Query(Query))
-
-type UserId = Int64
-
-data User = User
- { id :: UserId
- , creation :: UTCTime
- , email :: Text
- , name :: Text
- } deriving Show
-
-instance FromRow User where
- fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field
-
-list :: Query [User]
-list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC")
-
-getUser :: Text -> Query (Maybe User)
-getUser userEmail =
- Query (\conn -> listToMaybe <$>
- SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
- )
-
-findUser :: UserId -> [User] -> Maybe User
-findUser userId = find ((==) userId . id)
-
-createUser :: Text -> Text -> Query UserId
-createUser userEmail userName =
- Query (\conn -> do
- now <- getCurrentTime
- SQLite.execute
- conn
- "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)"
- (now, userEmail, userName)
- SQLite.lastInsertRowId conn
- )
-
-deleteUser :: Text -> Query ()
-deleteUser userEmail =
- Query (\conn ->
- SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail)
- )