From 0b191f5c48edffc9da3e38c284e9640fd82e7cb1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Jun 2017 18:02:13 +0200 Subject: Replace persistent by sqlite-simple --- src/server/Controller/Category.hs | 17 ++++++------- src/server/Controller/Income.hs | 28 +++++++++------------ src/server/Controller/Index.hs | 52 +++++++++++++++++---------------------- src/server/Controller/Payment.hs | 22 ++++++++--------- src/server/Controller/SignIn.hs | 33 +++++++++---------------- 5 files changed, 65 insertions(+), 87 deletions(-) (limited to 'src/server/Controller') 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 -- cgit v1.2.3