From 0b191f5c48edffc9da3e38c284e9640fd82e7cb1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Jun 2017 18:02:13 +0200 Subject: Replace persistent by sqlite-simple --- src/server/Model/Category.hs | 128 +++++++++++------- src/server/Model/Database.hs | 108 --------------- src/server/Model/Frequency.hs | 23 ++-- src/server/Model/Income.hs | 148 +++++++++++++-------- src/server/Model/Init.hs | 38 +++--- src/server/Model/Json/Category.hs | 10 +- src/server/Model/Json/CreatePayment.hs | 7 +- src/server/Model/Json/EditCategory.hs | 5 +- src/server/Model/Json/EditIncome.hs | 2 +- src/server/Model/Json/EditPayment.hs | 8 +- src/server/Model/Json/Income.hs | 11 +- src/server/Model/Json/Init.hs | 11 +- src/server/Model/Json/Payment.hs | 22 +++- src/server/Model/Json/PaymentCategory.hs | 10 +- src/server/Model/Json/User.hs | 10 +- src/server/Model/Payment.hs | 220 ++++++++++++++++++++----------- src/server/Model/PaymentCategory.hs | 93 ++++++++----- src/server/Model/Query.hs | 32 +++++ src/server/Model/SignIn.hs | 78 +++++++---- src/server/Model/User.hs | 70 ++++++---- 20 files changed, 600 insertions(+), 434 deletions(-) delete mode 100644 src/server/Model/Database.hs create mode 100644 src/server/Model/Query.hs (limited to 'src/server/Model') diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs index 50c3622..9597bd9 100644 --- a/src/server/Model/Category.hs +++ b/src/server/Model/Category.hs @@ -1,56 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + module Model.Category - ( list + ( CategoryId + , Category(..) + , list , create , edit , delete ) where +import Data.Int (Int64) +import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) -import Data.Maybe (isJust) +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 + ) -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 +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/Database.hs b/src/server/Model/Database.hs deleted file mode 100644 index ba302de..0000000 --- a/src/server/Model/Database.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Model.Database where - -import Control.Monad.Logger (NoLoggingT, runNoLoggingT) -import Control.Monad.Trans.Resource (runResourceT, ResourceT) - -import Data.Text -import Data.Time.Clock (UTCTime) -import Data.Time.Calendar (Day) -import Data.Int (Int64) - -import Database.Persist.Sqlite -import Database.Persist.TH - -import Resource (Resource, createdAt, editedAt, deletedAt) - -import Model.Frequency - -import Job.Kind - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -User - creation UTCTime - email Text - name Text - UniqUserEmail email - UniqUserName name - deriving Show -Payment - userId UserId - name Text - cost Int - date Day - frequency Frequency - createdAt UTCTime - 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 - email Text - isUsed Bool - UniqSignInToken token - deriving Show -Job - kind Kind - lastExecution UTCTime Maybe - lastCheck UTCTime Maybe - UniqJobName kind - deriving Show -Income - userId UserId - date Day - amount Int - createdAt UTCTime - editedAt UTCTime Maybe - deletedAt UTCTime Maybe - deriving Show -|] - -instance Resource Payment where - createdAt = paymentCreatedAt - editedAt = paymentEditedAt - deletedAt = paymentDeletedAt - -instance Resource Income where - createdAt = incomeCreatedAt - editedAt = incomeEditedAt - deletedAt = incomeDeletedAt - -type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a - -runDb :: Persist a -> IO a -runDb = runNoLoggingT . runResourceT . withSqliteConn "database" . runSqlConn - -runMigrations :: IO () -runMigrations = runDb $ runMigration migrateAll - -textToKey :: (ToBackendKey SqlBackend a) => Text -> Key a -textToKey text = toSqlKey (read (unpack text) :: Int64) - -keyToInt64 :: (ToBackendKey SqlBackend a) => Key a -> Int64 -keyToInt64 = fromSqlKey diff --git a/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs index a6ba55c..f9958e1 100644 --- a/src/server/Model/Frequency.hs +++ b/src/server/Model/Frequency.hs @@ -6,21 +6,28 @@ module Model.Frequency ( Frequency(..) ) where -import GHC.Generics - -import Web.Scotty - -import Database.Persist.TH - 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) -derivePersistField "Frequency" - 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 index ff6accd..c6cdb55 100644 --- a/src/server/Model/Income.hs +++ b/src/server/Model/Income.hs @@ -1,73 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + module Model.Income - ( list + ( IncomeId + , Income(..) + , list , create , editOwn , deleteOwn , modifiedDuring ) where -import Data.Time.Clock (UTCTime, getCurrentTime) +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) -import Control.Monad.IO.Class (liftIO) +type IncomeId = Int64 -import Database.Persist +data Income = Income + { id :: IncomeId + , userId :: UserId + , date :: Day + , amount :: Int + , createdAt :: UTCTime + , editedAt :: Maybe UTCTime + , deletedAt :: Maybe UTCTime + } deriving Show -import Model.Database -import qualified Model.Json.Income as Json +instance Resource Income where + resourceCreatedAt = createdAt + resourceEditedAt = editedAt + resourceDeletedAt = deletedAt -list :: Persist [Json.Income] -list = map getJsonIncome <$> selectList [IncomeDeletedAt ==. Nothing] [] +instance FromRow Income where + fromRow = Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field -getJsonIncome :: Entity Income -> Json.Income -getJsonIncome incomeEntity = - Json.Income (entityKey incomeEntity) (incomeUserId income) (incomeDate income) (incomeAmount income) - where income = entityVal incomeEntity +list :: Query [Income] +list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") -create :: UserId -> Day -> Int -> Persist IncomeId -create userId date amount = do - now <- liftIO getCurrentTime - insert (Income userId date amount now Nothing Nothing) +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 -> Persist Bool -editOwn userId incomeId date amount = do - mbIncome <- get incomeId - case mbIncome of - Just income -> - if incomeUserId income == userId - then do - now <- liftIO getCurrentTime - update incomeId - [ IncomeEditedAt =. Just now - , IncomeDate =. date - , IncomeAmount =. amount - ] - return True - else - return False - Nothing -> - return False +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 :: Entity User -> IncomeId -> Persist Bool -deleteOwn user incomeId = do - mbIncome <- get incomeId - case mbIncome of - Just income -> - if incomeUserId income == entityKey user - then do - now <- liftIO getCurrentTime - update incomeId [IncomeDeletedAt =. Just now] - 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 -> Persist [Income] +modifiedDuring :: UTCTime -> UTCTime -> Query [Income] modifiedDuring start end = - map entityVal <$> selectList - ( [IncomeCreatedAt >=. start, IncomeCreatedAt <. end] - ||. [IncomeEditedAt >=. Just start, IncomeEditedAt <. Just end] - ||. [IncomeDeletedAt >=. Just start, IncomeDeletedAt <. Just 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 index 7610b25..7a9ccea 100644 --- a/src/server/Model/Init.hs +++ b/src/server/Model/Init.hs @@ -4,27 +4,27 @@ module Model.Init ( getInit ) where -import Control.Monad.IO.Class (liftIO) - -import Database.Persist - -import Model.Database - import Model.Json.Init (Init) -import qualified Model.Payment as Payment -import qualified Model.User as User -import qualified Model.Income as Income +import Model.Query (Query) +import Model.User (User) import qualified Model.Category as Category -import qualified Model.PaymentCategory as PaymentCategory - +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 :: Entity User -> Persist Init +getInit :: User -> Query Init getInit user = - liftIO . runDb $ Init.Init <$> - (map User.getJson <$> User.list) <*> - (return . entityKey $ user) <*> - Payment.list <*> - Income.list <*> - Category.list <*> - PaymentCategory.list + 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 index daad4c2..8b5e527 100644 --- a/src/server/Model/Json/Category.hs +++ b/src/server/Model/Json/Category.hs @@ -2,14 +2,15 @@ module Model.Json.Category ( Category(..) + , fromCategory ) where -import GHC.Generics - import Data.Aeson import Data.Text (Text) +import GHC.Generics -import Model.Database (CategoryId) +import Model.Category (CategoryId) +import qualified Model.Category as M data Category = Category { id :: CategoryId @@ -18,3 +19,6 @@ data Category = Category } 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/CreatePayment.hs b/src/server/Model/Json/CreatePayment.hs index 5bc6b47..6ab3a5b 100644 --- a/src/server/Model/Json/CreatePayment.hs +++ b/src/server/Model/Json/CreatePayment.hs @@ -4,13 +4,12 @@ module Model.Json.CreatePayment ( CreatePayment(..) ) where -import GHC.Generics - import Data.Aeson -import Data.Time.Calendar (Day) import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics -import Model.Database (CategoryId) +import Model.Category (CategoryId) import Model.Frequency (Frequency) data CreatePayment = CreatePayment diff --git a/src/server/Model/Json/EditCategory.hs b/src/server/Model/Json/EditCategory.hs index bda3418..a10ce39 100644 --- a/src/server/Model/Json/EditCategory.hs +++ b/src/server/Model/Json/EditCategory.hs @@ -4,12 +4,11 @@ module Model.Json.EditCategory ( EditCategory(..) ) where -import GHC.Generics - import Data.Aeson import Data.Text (Text) +import GHC.Generics -import Model.Database (CategoryId) +import Model.Category (CategoryId) data EditCategory = EditCategory { id :: CategoryId diff --git a/src/server/Model/Json/EditIncome.hs b/src/server/Model/Json/EditIncome.hs index be3c7dc..9b29379 100644 --- a/src/server/Model/Json/EditIncome.hs +++ b/src/server/Model/Json/EditIncome.hs @@ -9,7 +9,7 @@ import GHC.Generics import Data.Aeson import Data.Time.Calendar (Day) -import Model.Database (IncomeId) +import Model.Income (IncomeId) data EditIncome = EditIncome { id :: IncomeId diff --git a/src/server/Model/Json/EditPayment.hs b/src/server/Model/Json/EditPayment.hs index 35f44e5..b7d4d7d 100644 --- a/src/server/Model/Json/EditPayment.hs +++ b/src/server/Model/Json/EditPayment.hs @@ -4,14 +4,14 @@ module Model.Json.EditPayment ( EditPayment(..) ) where -import GHC.Generics - import Data.Aeson -import Data.Time.Calendar (Day) import Data.Text (Text) +import Data.Time.Calendar (Day) +import GHC.Generics +import Model.Category (CategoryId) import Model.Frequency (Frequency) -import Model.Database (PaymentId, CategoryId) +import Model.Payment (PaymentId) data EditPayment = EditPayment { id :: PaymentId diff --git a/src/server/Model/Json/Income.hs b/src/server/Model/Json/Income.hs index bb1ac97..7e23a84 100644 --- a/src/server/Model/Json/Income.hs +++ b/src/server/Model/Json/Income.hs @@ -2,14 +2,16 @@ module Model.Json.Income ( Income(..) + , fromIncome ) where -import GHC.Generics - import Data.Aeson import Data.Time.Calendar (Day) +import GHC.Generics -import Model.Database (IncomeId, UserId) +import Model.Income (IncomeId) +import Model.User (UserId) +import qualified Model.Income as M data Income = Income { id :: IncomeId @@ -19,3 +21,6 @@ data Income = Income } 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 index b9f7f40..530c3b7 100644 --- a/src/server/Model/Json/Init.hs +++ b/src/server/Model/Json/Init.hs @@ -5,17 +5,16 @@ module Model.Json.Init , InitResult(..) ) where -import GHC.Generics - import Data.Aeson +import GHC.Generics -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.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] diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs index 04c6de8..e406c0f 100644 --- a/src/server/Model/Json/Payment.hs +++ b/src/server/Model/Json/Payment.hs @@ -2,16 +2,19 @@ module Model.Json.Payment ( Payment(..) + , fromPayment ) where -import GHC.Generics - -import Data.Text (Text) import Data.Aeson +import Data.Text (Text) import Data.Time.Calendar (Day) +import GHC.Generics +import Prelude hiding (id) -import Model.Database (PaymentId, UserId) import Model.Frequency +import Model.Payment (PaymentId) +import Model.User (UserId) +import qualified Model.Payment as M data Payment = Payment { id :: PaymentId @@ -24,3 +27,14 @@ data Payment = Payment 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 index edd4388..fd97674 100644 --- a/src/server/Model/Json/PaymentCategory.hs +++ b/src/server/Model/Json/PaymentCategory.hs @@ -2,14 +2,15 @@ module Model.Json.PaymentCategory ( PaymentCategory(..) + , fromPaymentCategory ) where -import GHC.Generics - import Data.Aeson import Data.Text (Text) +import GHC.Generics -import Model.Database (CategoryId) +import Model.Category (CategoryId) +import qualified Model.PaymentCategory as M data PaymentCategory = PaymentCategory { name :: Text @@ -17,3 +18,6 @@ data PaymentCategory = PaymentCategory } 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/User.hs b/src/server/Model/Json/User.hs index ebc347b..c289fe0 100644 --- a/src/server/Model/Json/User.hs +++ b/src/server/Model/Json/User.hs @@ -2,14 +2,15 @@ module Model.Json.User ( User(..) + , fromUser ) where -import GHC.Generics - import Data.Aeson import Data.Text (Text) +import GHC.Generics -import Model.Database (UserId) +import Model.User (UserId) +import qualified Model.User as M data User = User { id :: UserId @@ -19,3 +20,6 @@ data User = User 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/Payment.hs b/src/server/Model/Payment.hs index d8caaa8..88df477 100644 --- a/src/server/Model/Payment.hs +++ b/src/server/Model/Payment.hs @@ -1,100 +1,164 @@ {-# LANGUAGE OverloadedStrings #-} module Model.Payment - ( find + ( 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.Clock (getCurrentTime) 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 Control.Monad.IO.Class (liftIO) +import Model.Frequency +import Model.Query (Query(Query)) +import Model.User (UserId) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) -import Database.Persist +type PaymentId = Int64 -import Model.Database -import Model.Frequency -import qualified Model.Json.Payment as P +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 -find :: PaymentId -> Persist (Maybe (Entity Payment)) -find paymentId = selectFirst [ PaymentId ==. paymentId ] [] +instance Resource Payment where + resourceCreatedAt = createdAt + resourceEditedAt = editedAt + resourceDeletedAt = deletedAt -list :: Persist [P.Payment] -list = map getJsonPayment <$> selectList [ PaymentDeletedAt ==. Nothing ] [] +instance FromRow Payment where + fromRow = Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field -listMonthly :: Persist [Entity Payment] -listMonthly = - selectList - [ PaymentDeletedAt ==. Nothing - , PaymentFrequency ==. Monthly +instance ToRow Payment where + toRow p = + [ toField (userId p) + , toField (name p) + , toField (cost p) + , toField (date p) + , toField (frequency p) + , toField (createdAt p) + , toField (createdAt p) ] - [ Desc PaymentName ] - -getJsonPayment :: Entity Payment -> P.Payment -getJsonPayment paymentEntity = - let payment = entityVal paymentEntity - in P.Payment - { P.id = entityKey paymentEntity - , P.date = paymentDate payment - , P.name = paymentName payment - , P.cost = paymentCost payment - , P.userId = paymentUserId payment - , P.frequency = paymentFrequency payment - } - -create :: UserId -> Text -> Int -> Day -> Frequency -> Persist PaymentId -create userId name cost date frequency = do - now <- liftIO getCurrentTime - insert (Payment userId name cost date frequency now Nothing Nothing) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Persist Bool -editOwn userId paymentId name cost date frequency = do - mbPayment <- get paymentId - case mbPayment of - Just payment -> - if paymentUserId payment == userId - then do - now <- liftIO getCurrentTime - update paymentId - [ PaymentEditedAt =. Just now - , PaymentName =. name - , PaymentCost =. cost - , PaymentDate =. date - , PaymentFrequency =. frequency - ] - return True - else - return False - Nothing -> - return False - -deleteOwn :: UserId -> PaymentId -> Persist Bool -deleteOwn userId paymentId = do - mbPayment <- get paymentId - case mbPayment of - Just payment -> - if paymentUserId payment == userId - then do - now <- liftIO getCurrentTime - update paymentId [PaymentDeletedAt =. Just now] - return True - else - return False - Nothing -> - return False - -modifiedDuring :: UTCTime -> UTCTime -> Persist [Payment] + +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 = - map entityVal <$> selectList - ( [PaymentFrequency ==. Punctual, PaymentCreatedAt >=. start, PaymentCreatedAt <. end] - ||. [PaymentFrequency ==. Punctual, PaymentEditedAt >=. Just start, PaymentEditedAt <. Just end] - ||. [PaymentFrequency ==. Punctual, PaymentDeletedAt >=. Just start, PaymentDeletedAt <. Just 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 index 3b0b858..668fb01 100644 --- a/src/server/Model/PaymentCategory.hs +++ b/src/server/Model/PaymentCategory.hs @@ -1,48 +1,71 @@ {-# LANGUAGE OverloadedStrings #-} module Model.PaymentCategory - ( list + ( PaymentCategoryId + , PaymentCategory(..) + , list , listByCategory , save ) where -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (isJust) - +import Data.Int (Int64) +import Data.Maybe (isJust, listToMaybe) import Data.Text (Text) +import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) -import Database.Persist +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) import qualified Data.Text as T +import qualified Database.SQLite.Simple as SQLite -import Model.Database -import qualified Model.Json.PaymentCategory as Json +import Model.Category (CategoryId) +import Model.Query (Query(Query)) 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 - -save :: Text -> CategoryId -> Persist () -save newName category = do - now <- liftIO getCurrentTime - mbPaymentCategory <- selectFirst [PaymentCategoryName ==. (formatPaymentName newName)] [] - if isJust mbPaymentCategory - then - updateWhere - [ 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 +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 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 new file mode 100644 index 0000000..d15fb5f --- /dev/null +++ b/src/server/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/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs index 06aba5a..c5182f0 100644 --- a/src/server/Model/SignIn.hs +++ b/src/server/Model/SignIn.hs @@ -1,40 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + module Model.SignIn - ( createSignInToken + ( SignIn(..) + , createSignInToken , getSignIn , signInTokenToUsed - , isLastValidToken + , 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 Control.Monad.IO.Class (liftIO) +import Model.Query (Query(Query)) +import Model.UUID (generateUUID) -import Database.Persist +type SignInId = Int64 -import Model.Database -import Model.UUID (generateUUID) +data SignIn = SignIn + { id :: SignInId + , token :: Text + , creation :: UTCTime + , email :: Text + , isUsed :: Bool + } deriving Show -createSignInToken :: Text -> Persist Text -createSignInToken email = do - now <- liftIO getCurrentTime - token <- liftIO generateUUID - _ <- insert $ SignIn token now email False - return token +instance FromRow SignIn where + fromRow = SignIn <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field -getSignIn :: Text -> Persist (Maybe (Entity SignIn)) -getSignIn token = - selectFirst [SignInToken ==. token] [] +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 + ) -signInTokenToUsed :: SignInId -> Persist () +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 = - update tokenId [SignInIsUsed =. True] - -isLastValidToken :: SignIn -> Persist Bool -isLastValidToken signIn = do - maybe False ((== (signInToken signIn)) . signInToken . entityVal) <$> - selectFirst - [ SignInEmail ==. (signInEmail signIn) - , SignInIsUsed ==. True - ] - [ Desc SignInCreation ] + 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/User.hs b/src/server/Model/User.hs index ab39822..c8a0d53 100644 --- a/src/server/Model/User.hs +++ b/src/server/Model/User.hs @@ -1,42 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + module Model.User - ( list + ( UserId + , User(..) + , list , getUser - , getJson , 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.List (find) +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 Control.Monad.IO.Class (liftIO) +import Model.Query (Query(Query)) -import Database.Persist +type UserId = Int64 -import Model.Database -import qualified Model.Json.User as Json +data User = User + { id :: UserId + , creation :: UTCTime + , email :: Text + , name :: Text + } deriving Show -list :: Persist [Entity User] -list = selectList [] [Desc UserCreation] +instance FromRow User where + fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field -getUser :: Text -> Persist (Maybe (Entity User)) -getUser email = selectFirst [UserEmail ==. email] [] +list :: Query [User] +list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") -findUser :: UserId -> [Entity User] -> Maybe User -findUser i = fmap entityVal . find ((==) i . entityKey) +getUser :: Text -> Query (Maybe User) +getUser userEmail = + Query (\conn -> listToMaybe <$> + SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + ) -getJson :: Entity User -> Json.User -getJson userEntity = - let user = entityVal userEntity - in Json.User (entityKey userEntity) (userName user) (userEmail user) +findUser :: UserId -> [User] -> Maybe User +findUser userId = find ((==) userId . id) -createUser :: Text -> Text -> Persist UserId -createUser email name = do - now <- liftIO getCurrentTime - insert $ User now email name +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 -> Persist () -deleteUser email = - deleteWhere [UserEmail ==. email] +deleteUser :: Text -> Query () +deleteUser userEmail = + Query (\conn -> + SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) + ) -- cgit v1.2.3