aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Category.hs17
-rw-r--r--src/server/Controller/Income.hs28
-rw-r--r--src/server/Controller/Index.hs52
-rw-r--r--src/server/Controller/Payment.hs22
-rw-r--r--src/server/Controller/SignIn.hs33
-rw-r--r--src/server/Job/Daemon.hs16
-rw-r--r--src/server/Job/Kind.hs16
-rw-r--r--src/server/Job/Model.hs64
-rw-r--r--src/server/Job/MonthlyPayment.hs21
-rw-r--r--src/server/Job/WeeklyReport.hs17
-rw-r--r--src/server/Json.hs15
-rw-r--r--src/server/Main.hs2
-rw-r--r--src/server/Model/Category.hs128
-rw-r--r--src/server/Model/Database.hs108
-rw-r--r--src/server/Model/Frequency.hs23
-rw-r--r--src/server/Model/Income.hs148
-rw-r--r--src/server/Model/Init.hs38
-rw-r--r--src/server/Model/Json/Category.hs10
-rw-r--r--src/server/Model/Json/CreatePayment.hs7
-rw-r--r--src/server/Model/Json/EditCategory.hs5
-rw-r--r--src/server/Model/Json/EditIncome.hs2
-rw-r--r--src/server/Model/Json/EditPayment.hs8
-rw-r--r--src/server/Model/Json/Income.hs11
-rw-r--r--src/server/Model/Json/Init.hs11
-rw-r--r--src/server/Model/Json/Payment.hs22
-rw-r--r--src/server/Model/Json/PaymentCategory.hs10
-rw-r--r--src/server/Model/Json/User.hs10
-rw-r--r--src/server/Model/Payment.hs220
-rw-r--r--src/server/Model/PaymentCategory.hs93
-rw-r--r--src/server/Model/Query.hs32
-rw-r--r--src/server/Model/SignIn.hs78
-rw-r--r--src/server/Model/User.hs70
-rw-r--r--src/server/Resource.hs18
-rw-r--r--src/server/Secure.hs34
-rw-r--r--src/server/View/Mail/SignIn.hs11
-rw-r--r--src/server/View/Mail/WeeklyReport.hs62
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 =