From 51d1ff2273315ad1270794499d0c49e8fb99aba5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 1 Nov 2015 19:47:24 +0100 Subject: Store the sign in token instead of the login in the session cookie --- src/server/Controller/Payment.hs | 11 ++++------- src/server/Controller/SignIn.hs | 22 ++++++++-------------- src/server/Json.hs | 14 ++++++++++++-- src/server/Model/SignIn.hs | 10 ++++++++++ src/server/Secure.hs | 29 +++++++++++++++++++++-------- 5 files changed, 55 insertions(+), 31 deletions(-) (limited to 'src') diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs index ffb575c..d233aa2 100644 --- a/src/server/Controller/Payment.hs +++ b/src/server/Controller/Payment.hs @@ -10,22 +10,20 @@ module Controller.Payment import Web.Scotty -import Network.HTTP.Types.Status (ok200, badRequest400) +import Network.HTTP.Types.Status (ok200) import Database.Persist import Control.Monad.IO.Class (liftIO) import Data.Text (Text) -import qualified Data.Aeson.Types as Json import qualified Secure -import Json (jsonObject) +import Json (jsonError) import Model.Database import qualified Model.Payment as P -import qualified Model.Payer as Payer import Model.Frequency import Model.Json.Number import qualified Model.Json.PaymentId as JP @@ -58,9 +56,8 @@ deletePayment paymentId = if deleted then status ok200 - else do - status badRequest400 - jsonObject [("error", Json.String $ getMessage PaymentNotDeleted)] + else + jsonError (getMessage PaymentNotDeleted) ) getPaymentsCount :: ActionM () diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 3bbb9ff..5306ee1 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -7,7 +7,7 @@ module Controller.SignIn import Web.Scotty -import Network.HTTP.Types.Status (ok200, badRequest400) +import Network.HTTP.Types.Status (ok200) import Database.Persist @@ -18,7 +18,6 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Data.Time.Clock (getCurrentTime, diffUTCTime) -import qualified Data.Aeson.Types as Json import qualified LoginSession @@ -26,7 +25,7 @@ import Config import SendMail -import Text.Email.Validate (isValid) +import Text.Email.Validate as Email import Model.Database import Model.User @@ -34,13 +33,13 @@ import Model.SignIn import Model.Message.Key import Model.Message (getMessage) -import Json (jsonObject) +import Json (jsonError) import qualified View.Mail.SignIn as SignIn signIn :: Config -> Text -> ActionM () signIn config login = - if isValid (TE.encodeUtf8 login) + if Email.isValid (TE.encodeUtf8 login) then do maybeUser <- liftIO . runDb $ getUser login case maybeUser of @@ -52,16 +51,11 @@ signIn config login = Right _ -> status ok200 Left _ -> - errorResponse (getMessage SendEmailFail) + jsonError (getMessage SendEmailFail) Nothing -> - errorResponse (getMessage Unauthorized) + jsonError (getMessage Unauthorized) else - errorResponse (getMessage EnterValidEmail) - -errorResponse :: Text -> ActionM () -errorResponse msg = do - status badRequest400 - jsonObject [("error", Json.String msg)] + jsonError (getMessage EnterValidEmail) validateSignIn :: Config -> Text -> ActionM () validateSignIn config textToken = do @@ -78,7 +72,7 @@ validateSignIn config textToken = do then redirectError (getMessage SignInExpired) else do - LoginSession.put (signInEmail . entityVal $ token) + LoginSession.put (signInToken . entityVal $ token) liftIO . runDb . signInTokenToUsed . entityKey $ token redirect "/" Nothing -> diff --git a/src/server/Json.hs b/src/server/Json.hs index 51287ed..bd5ac3e 100644 --- a/src/server/Json.hs +++ b/src/server/Json.hs @@ -1,12 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + module Json - ( jsonObject + ( jsonError + , jsonObject ) where -import Web.Scotty (json, ActionM) +import Web.Scotty + +import Network.HTTP.Types.Status (badRequest400) import qualified Data.Aeson.Types as Json import qualified Data.HashMap.Strict as M import Data.Text (Text) +jsonError :: Text -> ActionM () +jsonError msg = do + status badRequest400 + jsonObject [("error", Json.String msg)] + jsonObject :: [(Text, Json.Value)] -> ActionM () jsonObject = json . Json.Object . M.fromList diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs index 0f9c6ce..117b8b5 100644 --- a/src/server/Model/SignIn.hs +++ b/src/server/Model/SignIn.hs @@ -2,6 +2,7 @@ module Model.SignIn ( createSignInToken , getSignInToken , signInTokenToUsed + , isLastValidToken ) where import Data.Text (Text) @@ -28,3 +29,12 @@ getSignInToken token = signInTokenToUsed :: SignInId -> Persist () signInTokenToUsed tokenId = update tokenId [SignInIsUsed =. True] + +isLastValidToken :: SignIn -> Persist Bool +isLastValidToken signIn = do + maybe False ((== (signInToken signIn)) . signInToken . entityVal) <$> + selectFirst + [ SignInEmail ==. (signInEmail signIn) + , SignInIsUsed ==. True + ] + [ Desc SignInCreation ] diff --git a/src/server/Secure.hs b/src/server/Secure.hs index 1fef713..8565098 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -8,13 +8,15 @@ import Web.Scotty import Network.HTTP.Types.Status (forbidden403) -import Database.Persist (Entity) +import Database.Persist (Entity, entityVal) -import Model.Database (User, runDb) import Model.User (getUser) +import Model.SignIn (getSignInToken, isLastValidToken) +import Model.Database import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -22,17 +24,28 @@ import qualified LoginSession loggedAction :: (Entity User -> ActionM ()) -> ActionM () loggedAction action = do - maybeLogin <- LoginSession.get - case maybeLogin of - Just login -> do - maybeUser <- liftIO . runDb $ getUser login + maybeToken <- LoginSession.get + case maybeToken of + Just token -> do + maybeUser <- liftIO . runDb . getUserFromToken $ token case maybeUser of Just user -> action user Nothing -> do status forbidden403 - liftIO . TIO.putStrLn . T.concat $ ["Could not find the user which login is ", login] - html "Could not find a user from your login" + html "You are not authorized to logged in" Nothing -> do status forbidden403 html "You need to be logged in to perform this action" + +getUserFromToken :: Text -> Persist (Maybe (Entity User)) +getUserFromToken token = do + mbSignIn <- fmap entityVal <$> getSignInToken token + case mbSignIn of + Just signIn -> do + isValid <- isLastValidToken signIn + if isValid + then getUser (signInEmail signIn) + else return Nothing + Nothing -> + return Nothing -- cgit v1.2.3