From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Sep 2017 22:14:48 +0200 Subject: Bootstrap with GHCJS and reflex: - setup login and logout, - first draft of payment view. --- src/server/Controller/Category.hs | 12 +++++++----- src/server/Controller/Income.hs | 23 +++++++++++------------ src/server/Controller/Index.hs | 30 ++++++++++++++++-------------- src/server/Controller/Payment.hs | 25 ++++++++++++------------- src/server/Controller/SignIn.hs | 34 +++++++++++++++------------------- src/server/Controller/User.hs | 20 -------------------- 6 files changed, 61 insertions(+), 83 deletions(-) delete mode 100644 src/server/Controller/User.hs (limited to 'src/server/Controller') diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs index 3f800da..1a44083 100644 --- a/src/server/Controller/Category.hs +++ b/src/server/Controller/Category.hs @@ -11,12 +11,14 @@ 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 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 @@ -49,5 +51,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.CategoryNotDeleted + text . TL.fromStrict $ Message.get Key.Category_NotDeleted ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs index 18394d0..148b713 100644 --- a/src/server/Controller/Income.hs +++ b/src/server/Controller/Income.hs @@ -11,26 +11,25 @@ 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 Model.Income (IncomeId) import qualified Model.Income as Income -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) = +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (User.id 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) = +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount if updated then status ok200 else status badRequest400 @@ -45,5 +44,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.pack . show $ Key.IncomeNotDeleted + text . TL.fromStrict $ Message.get Key.Income_NotDeleted ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs index 9fb2aa0..8473c5c 100644 --- a/src/server/Controller/Index.hs +++ b/src/server/Controller/Index.hs @@ -7,15 +7,17 @@ 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 Model.Json.Init (InitResult(..)) -import Model.Message.Key -import Model.User (User) import qualified LoginSession -import qualified Model.Json.Conf as M import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User @@ -29,17 +31,17 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitError $ errorKey + return . InitEmpty . Left . Message.get $ errorKey Right user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user + liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return InitEmpty + return . InitEmpty . Right $ Nothing Just user -> - liftIO . Query.run . fmap InitSuccess . getInit $ user - html $ page (M.Conf { M.currency = currency conf }) initResult + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -52,23 +54,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ SignInInvalid + return . Left $ Key.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ SignInUsed + return . Left $ Key.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ SignInExpired + return . Left $ Key.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.getUser . SignIn.email $ signIn + User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left UnauthorizedSignIn + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index d71b451..6a9ede7 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -11,37 +11,36 @@ 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 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 . Query.run $ map Json.fromPayment <$> Payment.list) >>= json + (liftIO . Query.run $ Payment.list) >>= json ) -create :: Json.CreatePayment -> ActionM () -create (Json.CreatePayment name cost date category frequency) = +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 + Payment.create (_user_id user) name cost date frequency ) >>= jsonId ) -editOwn :: Json.EditPayment -> ActionM () -editOwn (Json.EditPayment paymentId name cost date category frequency) = +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 + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategory.save name category >> return () else return () @@ -54,7 +53,7 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) = deleteOwn :: PaymentId -> ActionM () deleteOwn paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) 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 152168c..932ce53 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -5,15 +5,17 @@ module Controller.SignIn ) where 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.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 Model.Message.Key import qualified Conf import qualified Model.Query as Query import qualified Model.SignIn as SignIn @@ -22,30 +24,24 @@ 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) +signIn :: Conf -> M.SignIn -> ActionM () +signIn conf (M.SignIn email) = + if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.getUser login + maybeUser <- liftIO . Query.run $ User.get email case maybeUser of Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken login + 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 [login] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> - status ok200 - Left _ -> do - status badRequest400 - text . TL.pack . show $ SendEmailFail - Nothing -> do - status badRequest400 - text . TL.pack . show $ UnauthorizedSignIn - else do - status badRequest400 - text . TL.pack . show $ EnterValidEmail + 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) diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs deleted file mode 100644 index d8604ac..0000000 --- a/src/server/Controller/User.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.User - ( getUsers - ) where - -import Web.Scotty - -import Control.Monad.IO.Class (liftIO) - -import qualified Secure - -import Model.Database -import qualified Model.User as User - -getUsers :: ActionM () -getUsers = - Secure.loggedAction (\_ -> - (liftIO $ map User.getJsonUser <$> runDb User.list) >>= json - ) -- cgit v1.2.3