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/Index.hs | 86 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 86 insertions(+) create mode 100644 server/src/Controller/Index.hs (limited to 'server/src/Controller/Index.hs') 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 -- cgit v1.2.3 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- server/src/Controller/Index.hs | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 8473c5c..bf4859d 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -3,26 +3,26 @@ module Controller.Index , 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 Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +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 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 Conf (Conf (..)) 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) +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 () get conf mbToken = do @@ -70,7 +70,7 @@ validateSignIn conf textToken = do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) -- cgit v1.2.3 From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- server/src/Controller/Index.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index bf4859d..f05ce6f 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -10,10 +10,9 @@ 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 Common.Msg (Key) +import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession @@ -31,7 +30,7 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey + return . InitEmpty . Left . Msg.get $ errorKey Right user -> liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do @@ -54,23 +53,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ Key.SignIn_LinkInvalid + return . Left $ Msg.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ Key.SignIn_LinkUsed + return . Left $ Msg.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ Key.SignIn_LinkExpired + return . Left $ Msg.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 + Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- server/src/Controller/Index.hs | 77 ++++++++++++++++++++++++++++++------------ 1 file changed, 55 insertions(+), 22 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f05ce6f..9a3e2b7 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,16 +1,23 @@ module Controller.Index ( get + , askSignIn + , trySignIn , signOut ) where import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Status (badRequest400, ok200) import Prelude hiding (error) -import Web.Scotty hiding (get) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (InitResult (..), User (..)) +import Common.Model (InitResult (..), SignIn (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg @@ -21,26 +28,52 @@ import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User import Secure (getUserFromToken) +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn 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 . Msg.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 +get :: Conf -> ActionM () +get conf = do + initResult <- do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + S.html $ page initResult + +askSignIn :: Conf -> SignIn -> ActionM () +askSignIn 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, + "/signIn/", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + +trySignIn :: Conf -> Text -> ActionM () +trySignIn conf token = do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + Right _ -> + S.redirect "/" validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -82,4 +115,4 @@ getLoggedUser = do liftIO . Query.run . getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 +signOut conf = LoginSession.delete conf >> S.status ok200 -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- server/src/Controller/Index.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 9a3e2b7..f942540 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -23,11 +23,11 @@ import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession -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 qualified Persistence.Init as InitPersistence +import qualified Persistence.User as UserPersistence +import qualified Secure import qualified SendMail import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn @@ -39,16 +39,16 @@ get conf = do mbLoggedUser <- getLoggedUser case mbLoggedUser of Nothing -> - return . InitEmpty . Right $ Nothing + return InitEmpty Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf + liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf S.html $ page initResult askSignIn :: Conf -> SignIn -> ActionM () askSignIn conf (SignIn email) = if Email.isValid (TE.encodeUtf8 email) then do - maybeUser <- liftIO . Query.run $ User.get email + maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do token <- liftIO . Query.run $ SignIn.createSignInToken email @@ -71,7 +71,7 @@ trySignIn conf token = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + S.html $ page (InitError $ Msg.get errorKey) Right _ -> S.redirect "/" @@ -100,7 +100,7 @@ validateSignIn conf textToken = do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn + UserPersistence.get . SignIn.email $ signIn return $ case mbUser of Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user @@ -112,7 +112,7 @@ getLoggedUser = do Nothing -> return Nothing Just token -> do - liftIO . Query.run . getUserFromToken $ token + liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status ok200 -- cgit v1.2.3 From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 31 Oct 2018 19:03:19 +0100 Subject: Various fixes --- server/src/Controller/Index.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f942540..0b276d3 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -6,6 +6,7 @@ module Controller.Index ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -60,7 +61,7 @@ askSignIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent + Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail Nothing -> textKey badRequest400 Msg.Secure_Unauthorized else textKey badRequest400 Msg.SignIn_EmailInvalid -- cgit v1.2.3 From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- server/src/Controller/Index.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 0b276d3..fbda527 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -9,18 +9,18 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (badRequest400, ok200) +import qualified Network.HTTP.Types.Status as Status import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (InitResult (..), SignIn (..), - User (..)) +import Common.Model (Email (..), InitResult (..), + SignInForm (..), User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession @@ -30,7 +30,6 @@ import qualified Persistence.Init as InitPersistence import qualified Persistence.User as UserPersistence import qualified Secure import qualified SendMail -import qualified Text.Email.Validate as Email import qualified View.Mail.SignIn as SignIn import View.Page (page) @@ -45,10 +44,12 @@ get conf = do liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf S.html $ page initResult -askSignIn :: Conf -> SignIn -> ActionM () -askSignIn conf (SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do +askSignIn :: Conf -> SignInForm -> ActionM () +askSignIn conf form = + case SignInValidation.signIn form of + Nothing -> + textKey Status.badRequest400 Msg.SignIn_EmailInvalid + Just (Email email) -> do maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do @@ -62,9 +63,8 @@ askSignIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid + Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) trySignIn :: Conf -> Text -> ActionM () @@ -116,4 +116,4 @@ getLoggedUser = do liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> S.status ok200 +signOut conf = LoginSession.delete conf >> S.status Status.ok200 -- cgit v1.2.3 From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- server/src/Controller/Index.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index fbda527..5ebe921 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -57,7 +57,7 @@ askSignIn conf form = let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, - "/signIn/", + "/api/signIn/", token ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] -- cgit v1.2.3 From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 21:31:57 +0200 Subject: Load init data per page with AJAX --- server/src/Controller/Index.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 5ebe921..3788685 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -16,8 +16,9 @@ import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), InitResult (..), - SignInForm (..), User (..)) +import Common.Model (Email (..), Init (..), + InitResult (..), SignInForm (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -26,7 +27,6 @@ import Conf (Conf (..)) import qualified LoginSession import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Persistence.Init as InitPersistence import qualified Persistence.User as UserPersistence import qualified Secure import qualified SendMail @@ -40,8 +40,9 @@ get conf = do case mbLoggedUser of Nothing -> return InitEmpty - Just user -> - liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf + Just user -> do + users <- liftIO . Query.run $ UserPersistence.list + return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) S.html $ page initResult askSignIn :: Conf -> SignInForm -> ActionM () -- cgit v1.2.3 From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- server/src/Controller/Index.hs | 128 ++++++++++++++--------------------------- 1 file changed, 42 insertions(+), 86 deletions(-) (limited to 'server/src/Controller/Index.hs') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 3788685..4f4ae77 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,120 +1,76 @@ module Controller.Index ( get - , askSignIn - , trySignIn + , signIn , signOut ) where import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as Json import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status -import Prelude hiding (error) +import Prelude hiding (error, init) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), Init (..), - InitResult (..), SignInForm (..), +import Common.Model (Init (..), SignInForm (..), User (..)) -import Common.Msg (Key) import qualified Common.Msg as Msg -import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession +import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn +import Model.SignIn (SignIn (..)) import qualified Persistence.User as UserPersistence -import qualified Secure -import qualified SendMail -import qualified View.Mail.SignIn as SignIn +import qualified Validation.SignIn as SignInValidation import View.Page (page) get :: Conf -> ActionM () get conf = do - initResult <- do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of + init <- do + mbToken <- LoginSession.get + case mbToken of Nothing -> - return InitEmpty - Just user -> do - users <- liftIO . Query.run $ UserPersistence.list - return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) - S.html $ page initResult + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init -askSignIn :: Conf -> SignInForm -> ActionM () -askSignIn conf form = +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = case SignInValidation.signIn form of - Nothing -> - textKey Status.badRequest400 Msg.SignIn_EmailInvalid - Just (Email email) -> do - maybeUser <- liftIO . Query.run $ UserPersistence.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, - "/api/signIn/", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized - where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init -trySignIn :: Conf -> Text -> ActionM () -trySignIn conf token = do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - S.html $ page (InitError $ Msg.get errorKey) - Right _ -> - S.redirect "/" - -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 $ Msg.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Msg.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Msg.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - UserPersistence.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Msg.Secure_Unauthorized - Just user -> Right user + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) Nothing -> return Nothing - Just token -> do - liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status Status.ok200 -- cgit v1.2.3