diff options
Diffstat (limited to 'src/server')
36 files changed, 803 insertions, 659 deletions
diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 19109a3..3f800da 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -7,43 +7,42 @@ module Controller.Category ) where import Control.Monad.IO.Class (liftIO) - -import Data.Text (Text) import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL import Web.Scotty hiding (delete) import Json (jsonId) -import Model.Database +import Model.Category (CategoryId) import qualified Model.Category as Category import qualified Model.Json.CreateCategory as Json import qualified Model.Json.EditCategory as Json import qualified Model.Message.Key as Key import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure create :: Json.CreateCategory -> ActionM () create (Json.CreateCategory name color) = Secure.loggedAction (\_ -> - (liftIO . runDb $ Category.create name color) >>= jsonId + (liftIO . Query.run $ Category.create name color) >>= jsonId ) edit :: Json.EditCategory -> ActionM () edit (Json.EditCategory categoryId name color) = Secure.loggedAction (\_ -> do - updated <- liftIO . runDb $ Category.edit categoryId name color + updated <- liftIO . Query.run $ Category.edit categoryId name color if updated then status ok200 else status badRequest400 ) -delete :: Text -> ActionM () +delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do - deleted <- liftIO . runDb $ do - paymentCategories <- PaymentCategory.listByCategory (textToKey categoryId) + deleted <- liftIO . Query.run $ do + paymentCategories <- PaymentCategory.listByCategory categoryId if null paymentCategories - then Category.delete (textToKey categoryId) + then Category.delete categoryId else return False if deleted then diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index ff3e75d..18394d0 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -6,46 +6,40 @@ module Controller.Income , deleteOwn ) where -import Web.Scotty - -import Network.HTTP.Types.Status (ok200, badRequest400) - import Control.Monad.IO.Class (liftIO) - -import Database.Persist - -import Data.Text (Text) +import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text.Lazy as TL - -import qualified Secure +import Web.Scotty import Json (jsonId) - -import Model.Database +import Model.Income (IncomeId) import qualified Model.Income as Income -import qualified Model.Message.Key as Key import qualified Model.Json.CreateIncome as Json import qualified Model.Json.EditIncome as Json +import qualified Model.Message.Key as Key +import qualified Model.Query as Query +import qualified Model.User as User +import qualified Secure create :: Json.CreateIncome -> ActionM () create (Json.CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . runDb $ Income.create (entityKey user) date amount) >>= jsonId + (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId ) editOwn :: Json.EditIncome -> ActionM () editOwn (Json.EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . runDb $ Income.editOwn (entityKey user) incomeId date amount + updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount if updated then status ok200 else status badRequest400 ) -deleteOwn :: Text -> ActionM () +deleteOwn :: IncomeId -> ActionM () deleteOwn incomeId = Secure.loggedAction (\user -> do - deleted <- liftIO . runDb $ Income.deleteOwn user (textToKey incomeId) + deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId if deleted then status ok200 diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 96d0a49..9fb2aa0 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -4,28 +4,22 @@ module Controller.Index ) where import Control.Monad.IO.Class (liftIO) - -import Web.Scotty hiding (get) - -import Network.HTTP.Types.Status (ok200) - import Data.Text (Text) import Data.Time.Clock (getCurrentTime, diffUTCTime) - -import Database.Persist hiding (Key, get) +import Network.HTTP.Types.Status (ok200) +import Web.Scotty hiding (get) import Conf (Conf(..)) +import Model.Init (getInit) +import Model.Json.Init (InitResult(..)) +import Model.Message.Key +import Model.User (User) import qualified LoginSession -import Secure (getUserFromToken) - -import Model.Database hiding (Key) import qualified Model.Json.Conf as M -import Model.User (getUser) -import Model.Message.Key -import Model.SignIn (getSignIn, signInTokenToUsed) -import Model.Json.Init (InitResult(..)) -import Model.Init (getInit) - +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import Secure (getUserFromToken) import View.Page (page) get :: Conf -> Maybe Text -> ActionM () @@ -37,54 +31,54 @@ get conf mbToken = do Left errorKey -> return . InitError $ errorKey Right user -> - liftIO . runDb . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess . getInit $ user Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> return InitEmpty Just user -> - liftIO . runDb . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess . getInit $ user html $ page (M.Conf { M.currency = currency conf }) initResult -validateSignIn :: Conf -> Text -> ActionM (Either Key (Entity User)) +validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do mbLoggedUser <- getLoggedUser case mbLoggedUser of Just loggedUser -> return . Right $ loggedUser Nothing -> do - mbSignIn <- liftIO . runDb $ getSignIn textToken + mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken now <- liftIO getCurrentTime case mbSignIn of Nothing -> return . Left $ SignInInvalid - Just signInValue -> - if signInIsUsed . entityVal $ signInValue + Just signIn -> + if SignIn.isUsed signIn then return . Left $ SignInUsed else - let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue) + let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then return . Left $ SignInExpired else do - LoginSession.put conf (signInToken . entityVal $ signInValue) - mbUser <- liftIO . runDb $ do - signInTokenToUsed . entityKey $ signInValue - getUser . signInEmail . entityVal $ signInValue + LoginSession.put conf (SignIn.token signIn) + mbUser <- liftIO . Query.run $ do + SignIn.signInTokenToUsed . SignIn.id $ signIn + User.getUser . SignIn.email $ signIn return $ case mbUser of Nothing -> Left UnauthorizedSignIn Just user -> Right user -getLoggedUser :: ActionM (Maybe (Entity User)) +getLoggedUser :: ActionM (Maybe User) getLoggedUser = do mbToken <- LoginSession.get case mbToken of Nothing -> return Nothing Just token -> do - liftIO . runDb . getUserFromToken $ token + liftIO . Query.run . getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> status ok200 diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index 831abbf..d71b451 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -8,40 +8,40 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) - -import Data.Text (Text) -import Database.Persist import Network.HTTP.Types.Status (ok200, badRequest400) import Web.Scotty import Json (jsonId) -import Model.Database +import Model.Payment (PaymentId) import qualified Model.Json.CreatePayment as Json import qualified Model.Json.EditPayment as Json +import qualified Model.Json.Payment as Json import qualified Model.Payment as Payment import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Model.User as User import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO $ runDb Payment.list) >>= json + (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json ) create :: Json.CreatePayment -> ActionM () create (Json.CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . runDb $ do + (liftIO . Query.run $ do PaymentCategory.save name category - Payment.create (entityKey user) name cost date frequency + Payment.create (User.id user) name cost date frequency ) >>= jsonId ) editOwn :: Json.EditPayment -> ActionM () editOwn (Json.EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do - updated <- liftIO . runDb $ do - edited <- Payment.editOwn (entityKey user) paymentId name cost date frequency + updated <- liftIO . Query.run $ do + edited <- Payment.editOwn (User.id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -51,10 +51,10 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = else status badRequest400 ) -deleteOwn :: Text -> ActionM () +deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . runDb $ Payment.deleteOwn (entityKey user) (textToKey paymentId) + deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId if deleted then status ok200 else status badRequest400 diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 1b8121d..152168c 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -4,48 +4,39 @@ module Controller.SignIn ( signIn ) where -import Web.Scotty - -import Network.HTTP.Types.Status (ok200, badRequest400) - -import Database.Persist hiding (Key) - import Control.Monad.IO.Class (liftIO) - import Data.Text (Text) +import Network.HTTP.Types.Status (ok200, badRequest400) import qualified Data.Text as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Web.Scotty import Conf (Conf) -import qualified Conf - -import SendMail - -import Text.Email.Validate as Email - -import Model.Database -import Model.User -import Model.SignIn import Model.Message.Key - +import qualified Conf +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import qualified SendMail +import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn signIn :: Conf -> Text -> ActionM () signIn conf login = if Email.isValid (TE.encodeUtf8 login) then do - maybeUser <- liftIO . runDb $ getUser login + maybeUser <- liftIO . Query.run $ User.getUser login case maybeUser of Just user -> do - token <- liftIO . runDb $ createSignInToken login + token <- liftIO . Query.run $ SignIn.createSignInToken login let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, "?signInToken=", token ] - maybeSentMail <- liftIO . sendMail $ SignIn.mail conf (entityVal user) url [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [login] case maybeSentMail of Right _ -> status ok200 diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs index 8259b18..0bc6f6e 100644 --- a/src/server/Job/Daemon.hs +++ b/src/server/Job/Daemon.hs @@ -2,21 +2,17 @@ module Job.Daemon ( runDaemons ) where -import Data.Time.Clock (UTCTime) - import Control.Concurrent (threadDelay, forkIO, ThreadId) import Control.Monad (forever) +import Data.Time.Clock (UTCTime) -import Model.Database - -import Job.Kind (Kind(..)) +import Conf (Conf) import Job.Frequency (Frequency(..), microSeconds) +import Job.Kind (Kind(..)) import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) import Job.MonthlyPayment (monthlyPayment) import Job.WeeklyReport (weeklyReport) - -import Conf (Conf) - +import qualified Model.Query as Query import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) runDaemons :: Conf -> IO () @@ -28,13 +24,13 @@ runDaemons conf = do runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId runDaemon kind frequency isLastExecutionTooOld runJob = forkIO . forever $ do - mbLastExecution <- runDb $ do + mbLastExecution <- Query.run $ do actualizeLastCheck kind getLastExecution kind hasToRun <- case mbLastExecution of Just lastExecution -> isLastExecutionTooOld lastExecution Nothing -> return True if hasToRun - then runJob mbLastExecution >>= (runDb . actualizeLastExecution kind) + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) else return () threadDelay . microSeconds $ frequency diff --git a/src/server/Job/Kind.hs b/src/server/Job/Kind.hs index 473b7c4..af5d4f8 100644 --- a/src/server/Job/Kind.hs +++ b/src/server/Job/Kind.hs @@ -1,14 +1,22 @@ -{-# LANGUAGE TemplateHaskell #-} - module Job.Kind ( Kind(..) ) where -import Database.Persist.TH +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 data Kind = MonthlyPayment | WeeklyReport deriving (Eq, Show, Read) -derivePersistField "Kind" +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/src/server/Job/Model.hs b/src/server/Job/Model.hs index cd7297a..e1a3c77 100644 --- a/src/server/Job/Model.hs +++ b/src/server/Job/Model.hs @@ -1,33 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + module Job.Model - ( getLastExecution + ( Job(..) + , getLastExecution , actualizeLastExecution , actualizeLastCheck ) where -import Control.Monad.IO.Class (liftIO) - -import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Maybe (isJust) - -import Database.Persist - -import Model.Database +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) import Job.Kind - -getLastExecution :: Kind -> Persist (Maybe UTCTime) -getLastExecution kind = do - mbJob <- fmap entityVal <$> selectFirst [JobKind ==. kind] [] - return (mbJob >>= jobLastExecution) - -actualizeLastExecution :: Kind -> UTCTime -> Persist () -actualizeLastExecution kind time = do - jobKindDefined <- isJust <$> selectFirst [JobKind ==. kind] [] - if jobKindDefined - then updateWhere [JobKind ==. kind] [JobLastExecution =. Just time] - else insert (Job kind (Just time) (Just time)) >> return () - -actualizeLastCheck :: Kind -> Persist () -actualizeLastCheck kind = do - now <- liftIO getCurrentTime - updateWhere [JobKind ==. kind] [JobLastCheck =. Just now] +import Model.Query (Query(Query)) + +data Job = Job + { id :: String + , kind :: Kind + , lastExecution :: Maybe UTCTime + , lastCheck :: Maybe UTCTime + } deriving (Show) + +getLastExecution :: Kind -> Query (Maybe UTCTime) +getLastExecution jobKind = + Query (\conn -> do + [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] + return time + ) + +actualizeLastExecution :: Kind -> UTCTime -> Query () +actualizeLastExecution jobKind time = + Query (\conn -> do + [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] + if isJust result + then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) + else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) + ) + +actualizeLastCheck :: Kind -> Query () +actualizeLastCheck jobKind = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) + ) diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs index bac7062..8c11ccf 100644 --- a/src/server/Job/MonthlyPayment.hs +++ b/src/server/Job/MonthlyPayment.hs @@ -2,23 +2,18 @@ module Job.MonthlyPayment ( monthlyPayment ) where -import Control.Monad.IO.Class (liftIO) - import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.Persist (entityVal, insert) - -import Model.Database -import qualified Model.Payment as Payment import Model.Frequency - +import qualified Model.Payment as Payment import Utils.Time (timeToDay) +import qualified Model.Query as Query monthlyPayment :: Maybe UTCTime -> IO UTCTime -monthlyPayment _ = runDb $ do - monthlyPayments <- map entityVal <$> Payment.listMonthly - now <- liftIO $ getCurrentTime - actualDay <- liftIO $ timeToDay now - let punctualPayments = map (\p -> p { paymentFrequency = Punctual, paymentDate = actualDay, paymentCreatedAt = now }) monthlyPayments - _ <- sequence $ map insert punctualPayments +monthlyPayment _ = do + monthlyPayments <- Query.run Payment.listMonthly + now <- getCurrentTime + actualDay <- timeToDay now + let punctualPayments = map (\p -> p { Payment.frequency = Punctual, Payment.date = actualDay, Payment.createdAt = now }) monthlyPayments + _ <- Query.run (Payment.createMany punctualPayments) return now diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs index 5cde3e9..5737c75 100644 --- a/src/server/Job/WeeklyReport.hs +++ b/src/server/Job/WeeklyReport.hs @@ -4,16 +4,13 @@ module Job.WeeklyReport import Data.Time.Clock (UTCTime, getCurrentTime) -import Model.Database (runDb) -import qualified Model.Payment as Payment +import Conf (Conf) import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.Query as Query import qualified Model.User as User - -import SendMail - -import Conf (Conf) - -import View.Mail.WeeklyReport (mail) +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime weeklyReport conf mbLastExecution = do @@ -21,11 +18,11 @@ weeklyReport conf mbLastExecution = do case mbLastExecution of Nothing -> return () Just lastExecution -> do - (payments, incomes, users) <- runDb $ + (payments, incomes, users) <- Query.run $ (,,) <$> Payment.modifiedDuring lastExecution now <*> Income.modifiedDuring lastExecution now <*> User.list - _ <- sendMail (mail conf users payments incomes lastExecution now) + _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) return () return now diff --git a/src/server/Json.hs b/src/server/Json.hs index 408742a..cc6327a 100644 --- a/src/server/Json.hs +++ b/src/server/Json.hs @@ -6,19 +6,14 @@ module Json , jsonId ) where -import Web.Scotty - +import Data.Int (Int64) +import Data.Text (Text) import qualified Data.Aeson.Types as Json import qualified Data.HashMap.Strict as M -import Data.Text (Text) - -import Database.Persist -import Database.Persist.Sqlite - -import Model.Database +import Web.Scotty jsonObject :: [(Text, Json.Value)] -> ActionM () jsonObject = json . Json.Object . M.fromList -jsonId :: (ToBackendKey SqlBackend a) => Key a -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral . keyToInt64 $ key)] +jsonId :: Int64 -> ActionM () +jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/src/server/Main.hs b/src/server/Main.hs index 7ae8c1c..17c2594 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -5,7 +5,6 @@ import qualified Data.Text.Lazy as LT import Web.Scotty import Job.Daemon (runDaemons) -import Model.Database (runMigrations) import qualified Conf import qualified Controller.Category as Category import qualified Controller.Income as Income @@ -15,7 +14,6 @@ import qualified Controller.SignIn as SignIn main :: IO () main = do - runMigrations conf <- Conf.get "application.conf" _ <- runDaemons conf scotty (Conf.port conf) $ do 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) + ) diff --git a/src/server/Resource.hs b/src/server/Resource.hs index 8999b77..f52bbfa 100644 --- a/src/server/Resource.hs +++ b/src/server/Resource.hs @@ -1,8 +1,8 @@ module Resource ( Resource - , createdAt - , editedAt - , deletedAt + , resourceCreatedAt + , resourceEditedAt + , resourceDeletedAt , Status(..) , statuses , groupByStatus @@ -15,9 +15,9 @@ import qualified Data.Map as M import Data.Time.Clock (UTCTime) class Resource a where - createdAt :: a -> UTCTime - editedAt :: a -> Maybe UTCTime - deletedAt :: a -> Maybe UTCTime + resourceCreatedAt :: a -> UTCTime + resourceEditedAt :: a -> Maybe UTCTime + resourceDeletedAt :: a -> Maybe UTCTime data Status = Created @@ -46,9 +46,9 @@ statusDuring start end resource | not created && deleted = Just Deleted | otherwise = Nothing where - created = belongs (createdAt resource) start end - edited = fromMaybe False (fmap (\t -> belongs t start end) $ editedAt resource) - deleted = fromMaybe False (fmap (\t -> belongs t start end) $ deletedAt resource) + created = belongs (resourceCreatedAt resource) start end + edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) + deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) belongs :: UTCTime -> UTCTime -> UTCTime -> Bool belongs time start end = time >= start && time < end diff --git a/src/server/Secure.hs b/src/server/Secure.hs index 93d5a60..da48878 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -5,31 +5,27 @@ module Secure , getUserFromToken ) where -import Web.Scotty - -import Network.HTTP.Types.Status (forbidden403) - -import Database.Persist (Entity, entityVal) - +import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty -import Model.User (getUser) -import Model.SignIn (getSignIn) -import Model.Database import Model.Message (getMessage) -import qualified Model.Message.Key as Key - -import Control.Monad.IO.Class (liftIO) - +import Model.Query (Query) +import Model.User (User) import qualified LoginSession +import qualified Model.Message.Key as Key +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User -loggedAction :: (Entity User -> ActionM ()) -> ActionM () +loggedAction :: (User -> ActionM ()) -> ActionM () loggedAction action = do maybeToken <- LoginSession.get case maybeToken of Just token -> do - maybeUser <- liftIO . runDb . getUserFromToken $ token + maybeUser <- liftIO . Query.run . getUserFromToken $ token case maybeUser of Just user -> action user @@ -40,11 +36,11 @@ loggedAction action = do status forbidden403 html . fromStrict . getMessage $ Key.Forbidden -getUserFromToken :: Text -> Persist (Maybe (Entity User)) +getUserFromToken :: Text -> Query (Maybe User) getUserFromToken token = do - mbSignIn <- fmap entityVal <$> getSignIn token + mbSignIn <- SignIn.getSignIn token case mbSignIn of - Just signIn -> do - getUser (signInEmail signIn) + Just signIn -> + User.getUser (SignIn.email signIn) Nothing -> return Nothing diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs index 8eaa077..c7d40d8 100644 --- a/src/server/View/Mail/SignIn.hs +++ b/src/server/View/Mail/SignIn.hs @@ -6,13 +6,12 @@ module View.Mail.SignIn import Data.Text (Text) -import Model.Database (User(..)) -import qualified Model.Mail as M -import Model.Message.Key -import Model.Message - import Conf (Conf) +import Model.Message +import Model.Message.Key +import Model.User (User(..)) import qualified Conf as Conf +import qualified Model.Mail as M mail :: Conf -> User -> Text -> [Text] -> M.Mail mail conf user url to = @@ -20,5 +19,5 @@ mail conf user url to = { M.from = Conf.noReplyMail conf , M.to = to , M.subject = (getMessage SignInMailTitle) - , M.plainBody = getParamMessage [userName user, url] SignInMail + , M.plainBody = getParamMessage [name user, url] SignInMail } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs index e33459c..1a80b95 100644 --- a/src/server/View/Mail/WeeklyReport.hs +++ b/src/server/View/Mail/WeeklyReport.hs @@ -4,27 +4,29 @@ module View.Mail.WeeklyReport ( mail ) where -import Data.Monoid ((<>)) -import Data.Maybe (catMaybes, fromMaybe) +import Data.List (sortOn) import Data.Map (Map) -import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (UTCTime) import Data.Time.Calendar (Day, toGregorian) -import Data.List (sortOn) +import Data.Time.Clock (UTCTime) +import qualified Data.Map as M +import qualified Data.Text as T import Resource (Status(..), groupByStatus, statuses) -import Database.Persist (Entity, entityVal) - -import Model.Database (Payment, Income, User, UserId) -import qualified Model.Database as D +import Model.Income (Income) import Model.Mail (Mail(Mail)) -import qualified Model.Mail as M import Model.Message (getMessage, getParamMessage, plural) -import qualified Model.Message.Key as K +import Model.Payment (Payment) import Model.User (findUser) +import Model.User (User, UserId) +import qualified Model.Income as Income +import qualified Model.Mail as M +import qualified Model.Message.Key as K +import qualified Model.Payment as Payment +import qualified Model.User as User import Conf (Conf) import qualified Conf as Conf @@ -33,16 +35,16 @@ import qualified View.Format as Format import Utils.Time (monthToKey) -mail :: Conf -> [Entity User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail +mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail mail conf users payments incomes start end = Mail { M.from = Conf.noReplyMail conf - , M.to = map (D.userEmail . entityVal) users + , M.to = map User.email users , M.subject = T.concat [getMessage K.SharedCost, " − ", getMessage K.WeeklyReport] , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) } -body :: Conf -> [Entity User] -> Map Status [Payment] -> Map Status [Income] -> Text +body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text body conf users paymentsByStatus incomesByStatus = if M.null paymentsByStatus && M.null incomesByStatus then @@ -53,24 +55,24 @@ body conf users paymentsByStatus incomesByStatus = , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses ] -paymentSection :: Status -> Conf -> [Entity User] -> [Payment] -> Text +paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text paymentSection status conf users payments = section (plural (length payments) singleKey pluralKey) - (map (payedFor status conf users) . sortOn D.paymentDate $ payments) + (map (payedFor status conf users) . sortOn Payment.date $ payments) where (singleKey, pluralKey) = case status of Created -> (K.PaymentCreated, K.PaymentsCreated) Edited -> (K.PaymentEdited, K.PaymentsEdited) Deleted -> (K.PaymentDeleted, K.PaymentsDeleted) -payedFor :: Status -> Conf -> [Entity User] -> Payment -> Text +payedFor :: Status -> Conf -> [User] -> Payment -> Text payedFor status conf users payment = getParamMessage - [ formatUserName (D.paymentUserId payment) users - , Format.price conf . D.paymentCost $ payment - , D.paymentName payment - , formatDay $ D.paymentDate payment + [ formatUserName (Payment.userId payment) users + , Format.price conf . Payment.cost $ payment + , Payment.name payment + , formatDay $ Payment.date payment ] ( case status of Created -> K.PayedFor @@ -78,23 +80,23 @@ payedFor status conf users payment = Deleted -> K.DidNotPayFor ) -incomeSection :: Status -> Conf -> [Entity User] -> [Income] -> Text +incomeSection :: Status -> Conf -> [User] -> [Income] -> Text incomeSection status conf users incomes = section (plural (length incomes) singleKey pluralKey) - (map (isPayedFrom status conf users) . sortOn D.incomeDate $ incomes) + (map (isPayedFrom status conf users) . sortOn Income.date $ incomes) where (singleKey, pluralKey) = case status of Created -> (K.IncomeCreated, K.IncomesCreated) Edited -> (K.IncomeEdited, K.IncomesEdited) Deleted -> (K.IncomeDeleted, K.IncomesDeleted) -isPayedFrom :: Status -> Conf -> [Entity User] -> Income -> Text +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text isPayedFrom status conf users income = getParamMessage - [ formatUserName (D.incomeUserId income) users - , Format.price conf . D.incomeAmount $ income - , formatDay $ D.incomeDate income + [ formatUserName (Income.userId income) users + , Format.price conf . Income.amount $ income + , formatDay $ Income.date income ] ( case status of Created -> K.IsPayedFrom @@ -102,8 +104,8 @@ isPayedFrom status conf users income = Deleted -> K.IsNotPayedFrom ) -formatUserName :: UserId -> [Entity User] -> Text -formatUserName userId = fromMaybe "−" . fmap D.userName . findUser userId +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap User.name . findUser userId formatDay :: Day -> Text formatDay d = |