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 --- server/src/Controller/Category.hs | 53 ++++++++++++++++++++++++ server/src/Controller/Income.hs | 48 ++++++++++++++++++++++ server/src/Controller/Index.hs | 86 +++++++++++++++++++++++++++++++++++++++ server/src/Controller/Payment.hs | 58 ++++++++++++++++++++++++++ server/src/Controller/SignIn.hs | 47 +++++++++++++++++++++ 5 files changed, 292 insertions(+) create mode 100644 server/src/Controller/Category.hs create mode 100644 server/src/Controller/Income.hs create mode 100644 server/src/Controller/Index.hs create mode 100644 server/src/Controller/Payment.hs create mode 100644 server/src/Controller/SignIn.hs (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..d6ed2f2 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,53 @@ +{-# 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 qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) + +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 :: CreateCategory -> ActionM () +create (CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Category.create name color) >>= jsonId + ) + +edit :: EditCategory -> ActionM () +edit (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/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..148b713 --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,48 @@ +{-# 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/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..8473c5c --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,86 @@ +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/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..dc10311 --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,58 @@ +{-# 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 Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) + +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 :: CreatePayment -> ActionM () +create (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 :: EditPayment -> ActionM () +editOwn (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/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs new file mode 100644 index 0000000..0086fa5 --- /dev/null +++ b/server/src/Controller/SignIn.hs @@ -0,0 +1,47 @@ +{-# 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 Common.Model (SignIn(..)) + +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 -> SignIn -> ActionM () +signIn conf (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