aboutsummaryrefslogtreecommitdiff
path: root/server/src/Model
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Model')
-rw-r--r--server/src/Model/Category.hs79
-rw-r--r--server/src/Model/Frequency.hs22
-rw-r--r--server/src/Model/Income.hs97
-rw-r--r--server/src/Model/Init.hs27
-rw-r--r--server/src/Model/Mail.hs12
-rw-r--r--server/src/Model/Payer.hs216
-rw-r--r--server/src/Model/Payment.hs175
-rw-r--r--server/src/Model/PaymentCategory.hs62
-rw-r--r--server/src/Model/Query.hs32
-rw-r--r--server/src/Model/SignIn.hs66
-rw-r--r--server/src/Model/UUID.hs10
-rw-r--r--server/src/Model/User.hs49
12 files changed, 847 insertions, 0 deletions
diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs
new file mode 100644
index 0000000..6b7a488
--- /dev/null
+++ b/server/src/Model/Category.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Category
+ ( list
+ , create
+ , edit
+ , delete
+ ) where
+
+import Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
+
+import Common.Model (Category(..), CategoryId)
+
+import Model.Query (Query(Query))
+
+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/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs
new file mode 100644
index 0000000..b334a40
--- /dev/null
+++ b/server/src/Model/Frequency.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Frequency () where
+
+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 qualified Data.Text as T
+
+import Common.Model (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/server/src/Model/Income.hs b/server/src/Model/Income.hs
new file mode 100644
index 0000000..bbe7657
--- /dev/null
+++ b/server/src/Model/Income.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Income
+ ( list
+ , create
+ , editOwn
+ , deleteOwn
+ , modifiedDuring
+ ) where
+
+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 Common.Model (Income(..), IncomeId, User(..), UserId)
+
+import Model.Query (Query(Query))
+import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
+
+instance Resource Income where
+ resourceCreatedAt = _income_createdAt
+ resourceEditedAt = _income_editedAt
+ resourceDeletedAt = _income_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 _income_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 _income_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/server/src/Model/Init.hs b/server/src/Model/Init.hs
new file mode 100644
index 0000000..8c6a961
--- /dev/null
+++ b/server/src/Model/Init.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Init
+ ( getInit
+ ) where
+
+import Common.Model (Init(Init), User(..))
+
+import Conf (Conf)
+import qualified Conf
+import Model.Query (Query)
+import qualified Model.Category as Category
+import qualified Model.Income as Income
+import qualified Model.Payment as Payment
+import qualified Model.PaymentCategory as PaymentCategory
+import qualified Model.User as User
+
+getInit :: User -> Conf -> Query Init
+getInit user conf =
+ Init <$>
+ User.list <*>
+ (return . _user_id $ user) <*>
+ Payment.list <*>
+ Income.list <*>
+ Category.list <*>
+ PaymentCategory.list <*>
+ (return . Conf.currency $ conf)
diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs
new file mode 100644
index 0000000..9a4db73
--- /dev/null
+++ b/server/src/Model/Mail.hs
@@ -0,0 +1,12 @@
+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/server/src/Model/Payer.hs b/server/src/Model/Payer.hs
new file mode 100644
index 0000000..de4abd1
--- /dev/null
+++ b/server/src/Model/Payer.hs
@@ -0,0 +1,216 @@
+module Model.Payer
+ ( getOrderedExceedingPayers
+ ) where
+
+import Data.Map (Map)
+import Data.Time (UTCTime(..), NominalDiffTime)
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
+import qualified Data.Time as Time
+
+import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..))
+
+type Users = Map UserId User
+
+type Payers = Map UserId Payer
+
+type Incomes = Map IncomeId Income
+
+type Payments = [Payment]
+
+data Payer = Payer
+ { preIncomePaymentSum :: Int
+ , postIncomePaymentSum :: Int
+ , _incomes :: [Income]
+ }
+
+data PostPaymentPayer = PostPaymentPayer
+ { _preIncomePaymentSum :: Int
+ , _cumulativeIncome :: Int
+ , ratio :: Float
+ }
+
+data ExceedingPayer = ExceedingPayer
+ { _userId :: UserId
+ , amount :: Int
+ } deriving (Show)
+
+getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer]
+getOrderedExceedingPayers currentTime users incomes payments =
+ let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users
+ incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes
+ payers = getPayers currentTime usersMap incomesMap payments
+ exceedingPayersOnPreIncome =
+ exceedingPayersFromAmounts
+ . Map.toList
+ . Map.map preIncomePaymentSum
+ $ payers
+ mbSince = useIncomesFrom usersMap incomesMap payments
+ in case mbSince of
+ Just since ->
+ let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers
+ mbMaxRatio =
+ safeMaximum
+ . map (ratio . snd)
+ . Map.toList
+ $ postPaymentPayers
+ in case mbMaxRatio of
+ Just maxRatio ->
+ exceedingPayersFromAmounts
+ . Map.toList
+ . Map.map (getFinalDiff maxRatio)
+ $ postPaymentPayers
+ Nothing ->
+ exceedingPayersOnPreIncome
+ _ ->
+ exceedingPayersOnPreIncome
+
+useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime
+useIncomesFrom users incomes payments =
+ let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments
+ mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes
+ in case (firstPaymentTime, mbIncomeTime) of
+ (Just t1, Just t2) -> Just (max t1 t2)
+ _ -> Nothing
+
+paymentTime :: Payment -> UTCTime
+paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date
+
+getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers
+getPayers currentTime users incomes payments =
+ let userIds = Map.keys users
+ incomesDefined = incomeDefinedForAll userIds incomes
+ in Map.fromList
+ . map (\userId ->
+ ( userId
+ , Payer
+ { preIncomePaymentSum =
+ totalPayments
+ (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined))
+ userId
+ payments
+ , postIncomePaymentSum =
+ totalPayments
+ (\p ->
+ case incomesDefined of
+ Nothing -> False
+ Just t -> paymentTime p >= t
+ )
+ userId
+ payments
+ , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes)
+ }
+ )
+ )
+ $ userIds
+
+exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer]
+exceedingPayersFromAmounts userAmounts =
+ case mbMinAmount of
+ Nothing ->
+ []
+ Just minAmount ->
+ filter (\payer -> amount payer > 0)
+ . map (\userAmount ->
+ ExceedingPayer
+ { _userId = fst userAmount
+ , amount = snd userAmount - minAmount
+ }
+ )
+ $ userAmounts
+ where mbMinAmount = safeMinimum . map snd $ userAmounts
+
+getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer
+getPostPaymentPayer currentTime since payer =
+ PostPaymentPayer
+ { _preIncomePaymentSum = preIncomePaymentSum payer
+ , _cumulativeIncome = cumulativeIncome
+ , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome)
+ }
+ where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer)
+
+getFinalDiff :: Float -> PostPaymentPayer -> Int
+getFinalDiff maxRatio payer =
+ let postIncomeDiff =
+ truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer)
+ in postIncomeDiff + _preIncomePaymentSum payer
+
+incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime
+incomeDefinedForAll userIds incomes =
+ let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds
+ firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes
+ in if all Maybe.isJust firstIncomes
+ then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes
+ else Nothing
+
+cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int
+cumulativeIncomesSince currentTime since incomes =
+ getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
+
+getOrderedIncomesSince :: UTCTime -> [Income] -> [Income]
+getOrderedIncomesSince time incomes =
+ let mbStarterIncome = getIncomeAt time incomes
+ orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes
+ in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
+
+getIncomeAt :: UTCTime -> [Income] -> Maybe Income
+getIncomeAt time incomes =
+ case incomes of
+ [x] ->
+ if incomeTime x < time
+ then Just $ x { _income_date = utctDay time }
+ else Nothing
+ x1 : x2 : xs ->
+ if incomeTime x1 < time && incomeTime x2 >= time
+ then Just $ x1 { _income_date = utctDay time }
+ else getIncomeAt time (x2 : xs)
+ [] ->
+ Nothing
+
+getCumulativeIncome :: UTCTime -> [Income] -> Int
+getCumulativeIncome currentTime incomes =
+ sum
+ . map durationIncome
+ . getIncomesWithDuration currentTime
+ . List.sortOn incomeTime
+ $ incomes
+
+getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)]
+getIncomesWithDuration currentTime incomes =
+ case incomes of
+ [] ->
+ []
+ [income] ->
+ [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)]
+ (income1 : income2 : xs) ->
+ (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs))
+
+incomeTime :: Income -> UTCTime
+incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date
+
+durationIncome :: (NominalDiffTime, Int) -> Int
+durationIncome (duration, income) =
+ truncate $ duration * fromIntegral income / (nominalDay * 365 / 12)
+
+nominalDay :: NominalDiffTime
+nominalDay = 86400
+
+safeHead :: [a] -> Maybe a
+safeHead [] = Nothing
+safeHead (x : _) = Just x
+
+safeMinimum :: (Ord a) => [a] -> Maybe a
+safeMinimum [] = Nothing
+safeMinimum xs = Just . minimum $ xs
+
+safeMaximum :: (Ord a) => [a] -> Maybe a
+safeMaximum [] = Nothing
+safeMaximum xs = Just . maximum $ xs
+
+totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int
+totalPayments paymentFilter userId payments =
+ sum
+ . map _payment_cost
+ . filter (\payment -> paymentFilter payment && _payment_user payment == userId)
+ $ payments
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
new file mode 100644
index 0000000..14efe77
--- /dev/null
+++ b/server/src/Model/Payment.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Payment
+ ( Payment(..)
+ , find
+ , list
+ , listMonthly
+ , create
+ , createMany
+ , editOwn
+ , deleteOwn
+ , modifiedDuring
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+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 Common.Model (Frequency(..), Payment(..), PaymentId, UserId)
+
+import Model.Frequency ()
+import Model.Query (Query(Query))
+import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
+
+instance Resource Payment where
+ resourceCreatedAt = _payment_createdAt
+ resourceEditedAt = _payment_editedAt
+ resourceDeletedAt = _payment_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 (_payment_user p)
+ , toField (_payment_name p)
+ , toField (_payment_cost p)
+ , toField (_payment_date p)
+ , toField (_payment_frequency p)
+ , toField (_payment_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
+ (SQLite.Query $ T.intercalate " "
+ [ "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 userId paymentName paymentCost paymentDate paymentFrequency =
+ Query (\conn -> do
+ now <- getCurrentTime
+ SQLite.execute
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
+ , "VALUES (?, ?, ?, ?, ?, ?)"
+ ])
+ (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now)
+ SQLite.lastInsertRowId conn
+ )
+
+createMany :: [Payment] -> Query ()
+createMany payments =
+ Query (\conn ->
+ SQLite.executeMany
+ conn
+ (SQLite.Query $ T.intercalate ""
+ [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
+ , "VALUES (?, ?, ?, ?, ?, ?)"
+ ])
+ payments
+ )
+
+editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
+editOwn userId 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 _payment_user payment == userId
+ then do
+ now <- getCurrentTime
+ SQLite.execute
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "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 userId paymentId =
+ Query (\conn -> do
+ mbPayment <- listToMaybe <$>
+ SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+ case mbPayment of
+ Just payment ->
+ if _payment_user payment == userId
+ 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
+ (SQLite.Query $ T.intercalate " "
+ [ "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/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs
new file mode 100644
index 0000000..6e1d304
--- /dev/null
+++ b/server/src/Model/PaymentCategory.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.PaymentCategory
+ ( list
+ , listByCategory
+ , save
+ ) where
+
+import Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+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 Common.Model (CategoryId, PaymentCategory(..))
+import qualified Common.Util.Text as T
+
+import Model.Query (Query(Query))
+
+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/server/src/Model/Query.hs b/server/src/Model/Query.hs
new file mode 100644
index 0000000..d15fb5f
--- /dev/null
+++ b/server/src/Model/Query.hs
@@ -0,0 +1,32 @@
+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/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
new file mode 100644
index 0000000..c5182f0
--- /dev/null
+++ b/server/src/Model/SignIn.hs
@@ -0,0 +1,66 @@
+{-# 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/server/src/Model/UUID.hs b/server/src/Model/UUID.hs
new file mode 100644
index 0000000..6cb7ce0
--- /dev/null
+++ b/server/src/Model/UUID.hs
@@ -0,0 +1,10 @@
+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/server/src/Model/User.hs b/server/src/Model/User.hs
new file mode 100644
index 0000000..e14fcef
--- /dev/null
+++ b/server/src/Model/User.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.User
+ ( list
+ , get
+ , create
+ , delete
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import Prelude hiding (id)
+import qualified Database.SQLite.Simple as SQLite
+
+import Common.Model (UserId, User(..))
+
+import Model.Query (Query(Query))
+
+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")
+
+get :: Text -> Query (Maybe User)
+get userEmail =
+ Query (\conn -> listToMaybe <$>
+ SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
+ )
+
+create :: Text -> Text -> Query UserId
+create userEmail userName =
+ Query (\conn -> do
+ now <- getCurrentTime
+ SQLite.execute
+ conn
+ "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)"
+ (now, userEmail, userName)
+ SQLite.lastInsertRowId conn
+ )
+
+delete :: Text -> Query ()
+delete userEmail =
+ Query (\conn ->
+ SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail)
+ )