From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- src/server/Controller/Category.hs | 55 ------------------------- src/server/Controller/Income.hs | 48 ---------------------- src/server/Controller/Index.hs | 86 --------------------------------------- src/server/Controller/Payment.hs | 60 --------------------------- src/server/Controller/SignIn.hs | 47 --------------------- 5 files changed, 296 deletions(-) delete mode 100644 src/server/Controller/Category.hs delete mode 100644 src/server/Controller/Income.hs delete mode 100644 src/server/Controller/Index.hs delete mode 100644 src/server/Controller/Payment.hs delete mode 100644 src/server/Controller/SignIn.hs (limited to 'src/server/Controller') diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs deleted file mode 100644 index 1a44083..0000000 --- a/src/server/Controller/Category.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Category - ( create - , edit - , delete - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty hiding (delete) - -import Common.Model.Category (CategoryId) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.CreateCategory as Json -import qualified Common.Model.EditCategory as Json - -import Json (jsonId) -import qualified Model.Category as Category -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 . Query.run $ Category.create name color) >>= jsonId - ) - -edit :: Json.EditCategory -> ActionM () -edit (Json.EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color - if updated - then status ok200 - else status badRequest400 - ) - -delete :: CategoryId -> ActionM () -delete categoryId = - Secure.loggedAction (\_ -> do - deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId - if null paymentCategories - then Category.delete categoryId - else return False - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted - ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs deleted file mode 100644 index 148b713..0000000 --- a/src/server/Controller/Income.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Income - ( create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) - -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query -import qualified Secure - -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId - ) - -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted - ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs deleted file mode 100644 index 8473c5c..0000000 --- a/src/server/Controller/Index.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Controller.Index - ( get - , signOut - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) - -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) - -import Conf (Conf(..)) -import Model.Init (getInit) -import qualified LoginSession -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 () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult - -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 . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of - Nothing -> - return . Left $ Key.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Key.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Key.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized - Just user -> Right user - -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of - Nothing -> - return Nothing - Just token -> do - 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 deleted file mode 100644 index 6a9ede7..0000000 --- a/src/server/Controller/Payment.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Payment - ( list - , create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import qualified Common.Model.CreatePayment as M -import qualified Common.Model.EditPayment as M -import Common.Model (PaymentId, User(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json - ) - -create :: M.CreatePayment -> ActionM () -create (M.CreatePayment name cost date category frequency) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId - ) - -editOwn :: M.EditPayment -> ActionM () -editOwn (M.EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - 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 () - return edited - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = - Secure.loggedAction (\user -> do - 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 deleted file mode 100644 index 932ce53..0000000 --- a/src/server/Controller/SignIn.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.SignIn as M - -import Conf (Conf) -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 -> M.SignIn -> ActionM () -signIn conf (M.SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) -- cgit v1.2.3