From a7db22556b91bc7c499e010b4c051f4442ad8ce2 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 29 Dec 2015 22:38:42 +0100 Subject: Using persona to validate emails --- src/server/Config.hs | 2 - src/server/Controller/SignIn.hs | 84 ++++++-------------------------- src/server/Design/Header.hs | 2 +- src/server/Design/SignIn.hs | 20 -------- src/server/Main.hs | 12 ++--- src/server/Model/Database.hs | 1 - src/server/Model/Message/Key.hs | 6 +-- src/server/Model/Message/Translations.hs | 26 ++-------- src/server/Model/SignIn.hs | 17 +------ src/server/Persona.hs | 42 ++++++++++++++++ src/server/Secure.hs | 7 +-- src/server/View/Page.hs | 4 +- 12 files changed, 71 insertions(+), 152 deletions(-) create mode 100644 src/server/Persona.hs (limited to 'src/server') diff --git a/src/server/Config.hs b/src/server/Config.hs index bd7f325..37f57ec 100644 --- a/src/server/Config.hs +++ b/src/server/Config.hs @@ -18,7 +18,6 @@ import Control.Arrow (left) data Config = Config { hostname :: Text , port :: Int - , signInExpirationMn :: Int , currency :: Text } deriving (Read, Eq, Show) @@ -29,6 +28,5 @@ getConfig filePath = Config <$> (T.pack <$> get cp "DEFAULT" "hostname") <*> (get cp "DEFAULT" "port") <*> - (get cp "DEFAULT" "sign-in-expiration-mn") <*> (T.pack <$> get cp "DEFAULT" "currency") ) diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs index 31cd510..8eceb56 100644 --- a/src/server/Controller/SignIn.hs +++ b/src/server/Controller/SignIn.hs @@ -2,32 +2,21 @@ module Controller.SignIn ( signIn - , validateSignIn ) where import Web.Scotty import Network.HTTP.Types.Status (ok200) -import Database.Persist - import Control.Monad.IO.Class (liftIO) import Data.Text (Text) -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 Data.Maybe (isJust) import qualified LoginSession import Config -import SendMail - -import Text.Email.Validate as Email - import Model.Database import Model.User import Model.SignIn @@ -36,65 +25,20 @@ import Model.Message (getMessage) import Json (jsonError) -import Secure (getUserFromToken) - -import qualified View.Mail.SignIn as SignIn +import Persona (verifyEmail) signIn :: Config -> Text -> ActionM () -signIn config login = - if Email.isValid (TE.encodeUtf8 login) - then do - maybeUser <- liftIO . runDb $ getUser login - case maybeUser of - Just user -> do - token <- liftIO . runDb $ createSignInToken login - let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token] - maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login] - case maybeSentMail of - Right _ -> - status ok200 - Left _ -> - jsonError (getMessage SendEmailFail) - Nothing -> - jsonError (getMessage Unauthorized) - else - jsonError (getMessage EnterValidEmail) - -validateSignIn :: Config -> Text -> ActionM () -validateSignIn config textToken = do - alreadySigned <- isAlreadySigned - if alreadySigned - then - redirect "/" - else do - mbSignIn <- liftIO . runDb $ getSignInToken textToken - now <- liftIO getCurrentTime - case mbSignIn of - Just signIn -> - if signInIsUsed . entityVal $ signIn - then - redirectError (getMessage SignInUsed) - else - let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn) - in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60) - then - redirectError (getMessage SignInExpired) - else do - LoginSession.put (signInToken . entityVal $ signIn) - liftIO . runDb . signInTokenToUsed . entityKey $ signIn - redirect "/" - Nothing -> - redirectError (getMessage SignInInvalid) - -isAlreadySigned :: ActionM Bool -isAlreadySigned = do - mbToken <- LoginSession.get - case mbToken of +signIn config assertion = do + mbEmail <- liftIO $ verifyEmail config assertion + case mbEmail of Nothing -> - return False - Just token -> do - liftIO . runDb . fmap isJust $ getUserFromToken token - -redirectError :: Text -> ActionM () -redirectError msg = - redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg] + jsonError (getMessage InvalidEmail) + Just email -> do + isAuthorized <- liftIO . fmap isJust . runDb $ getUser email + if isAuthorized + then do + token <- liftIO . runDb $ createSignInToken email + LoginSession.put token + status ok200 + else + jsonError (getMessage Unauthorized) diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs index 7b82577..9f83778 100644 --- a/src/server/Design/Header.hs +++ b/src/server/Design/Header.hs @@ -25,7 +25,7 @@ headerDesign = marginBottom blockMarginBottom paddingLeft sidePercent - button # ".signOut" ? do + button # ".icon" ? do let iconHeight = 50 let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2) position absolute diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs index 6bacc3a..7aff720 100644 --- a/src/server/Design/SignIn.hs +++ b/src/server/Design/SignIn.hs @@ -15,26 +15,6 @@ signInDesign = ".signIn" ? do - opacityAnimation - - form ? do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - defaultInput inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - defaultButton C.red C.white (px inputHeight) - display block - width (pct 100) - ".result" ? do marginTop (px 40) textAlign (alignSide sideCenter) diff --git a/src/server/Main.hs b/src/server/Main.hs index 3d61481..3539120 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -8,7 +8,7 @@ import Control.Concurrent (forkIO) import MonthlyPaymentJob (monthlyPaymentJobListener) import Data.Text (Text) -import qualified Data.Text.IO as TIO +import qualified Data.Text.IO as T import Controller.Index import Controller.SignIn @@ -28,7 +28,7 @@ main = do eitherConfig <- Config.getConfig "config.txt" case eitherConfig of Left errorMessage -> - TIO.putStrLn errorMessage + T.putStrLn errorMessage Right config -> do scotty (Config.port config) $ do middleware $ @@ -40,12 +40,8 @@ main = do -- SignIn post "/signIn" $ do - login <- param "login" :: ActionM Text - signIn config login - - get "/validateSignIn" $ do - token <- param "token" :: ActionM Text - validateSignIn config token + assertion <- param "assertion" :: ActionM Text + signIn config assertion -- Users diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs index 8d1da25..67cc8b3 100644 --- a/src/server/Model/Database.hs +++ b/src/server/Model/Database.hs @@ -44,7 +44,6 @@ SignIn token Text creation UTCTime email Text - isUsed Bool UniqSignInToken token deriving Show Job diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs index e9f8ef6..7f49ae7 100644 --- a/src/server/Model/Message/Key.hs +++ b/src/server/Model/Message/Key.hs @@ -12,12 +12,8 @@ data Key = | SharedCost | SignIn - | SendEmailFail + | InvalidEmail | Unauthorized - | EnterValidEmail - | SignInUsed - | SignInExpired - | SignInInvalid | SignInMailTitle | SignInMail | SignInEmailSent diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs index a2e9a30..29b21ea 100644 --- a/src/server/Model/Message/Translations.hs +++ b/src/server/Model/Message/Translations.hs @@ -34,36 +34,16 @@ m l SignIn = English -> "Sign in" French -> "Connexion" -m l SendEmailFail = +m l InvalidEmail = case l of - English -> "Sorry, we failed to send you the sign up email." - French -> "Désolé, nous n'avons pas pu t'envoyer le courriel de connexion." + English -> "Your email is not valid." + French -> "Votre courriel n'est pas valide." m l Unauthorized = case l of English -> "You are not authorized to sign in." French -> "Tu n'es pas autorisé à te connecter." -m l EnterValidEmail = - case l of - English -> "Please enter a valid email address." - French -> "Ton courriel n'est pas valide." - -m l SignInUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignInExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignInInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - m l SignInMailTitle = case l of English -> T.concat ["Sign in to ", m l SharedCost] diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs index 117b8b5..b475fdb 100644 --- a/src/server/Model/SignIn.hs +++ b/src/server/Model/SignIn.hs @@ -1,8 +1,6 @@ module Model.SignIn ( createSignInToken , getSignInToken - , signInTokenToUsed - , isLastValidToken ) where import Data.Text (Text) @@ -19,22 +17,9 @@ createSignInToken :: Text -> Persist Text createSignInToken email = do now <- liftIO getCurrentTime token <- liftIO generateUUID - _ <- insert $ SignIn token now email False + _ <- insert $ SignIn token now email return token getSignInToken :: Text -> Persist (Maybe (Entity SignIn)) getSignInToken token = selectFirst [SignInToken ==. 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/Persona.hs b/src/server/Persona.hs new file mode 100644 index 0000000..8055e8b --- /dev/null +++ b/src/server/Persona.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Persona + ( verifyEmail + ) where + +import Control.Monad (guard) + +import Network.HTTP.Conduit + +import Data.Text (Text) +import qualified Data.Text as T +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Aeson +import Data.Aeson.Types (parseMaybe) + +import Config + +verifyEmail :: Config -> Text -> IO (Maybe Text) +verifyEmail config assertion = do + + initReq <- parseUrl "https://verifier.login.persona.org/verify" + + let request = + (flip urlEncodedBody) initReq $ + [ ("assertion", encodeUtf8 $ assertion) + , ("audience", encodeUtf8 $ hostname config) + ] + + manager <- newManager tlsManagerSettings + response <- httpLbs request manager + + return . parseEmail . decodeUtf8 . toStrict . responseBody $ response + +parseEmail :: Text -> Maybe Text +parseEmail payload = do + result <- decode . fromStrict . encodeUtf8 $ payload + flip parseMaybe result $ \obj -> do + status <- T.pack <$> obj .: "status" + guard (status == "okay") + obj .: "email" diff --git a/src/server/Secure.hs b/src/server/Secure.hs index 192fa10..7b6e6de 100644 --- a/src/server/Secure.hs +++ b/src/server/Secure.hs @@ -12,7 +12,7 @@ import Network.HTTP.Types.Status (forbidden403) import Database.Persist (Entity, entityVal) import Model.User (getUser) -import Model.SignIn (getSignInToken, isLastValidToken) +import Model.SignIn (getSignInToken) import Model.Database import Control.Monad.IO.Class (liftIO) @@ -44,9 +44,6 @@ 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 + getUser (signInEmail signIn) Nothing -> return Nothing diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index 2865337..7310fbb 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -26,7 +26,9 @@ page config = renderHtml . docTypeHtml $ do H.head $ do meta ! charset "UTF-8" + meta ! httpEquiv "X-UA-Compatible" ! content "IE=Edge" -- IE8+ only is valid to use with persona H.title (toHtml $ getMessage SharedCost) + script ! src "https://login.persona.org/include.js" $ "" script ! src "javascripts/client.js" $ "" script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations script ! A.id "config" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ config @@ -35,4 +37,4 @@ page config = link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign body $ do - script ! src "javascripts/elmLauncher.js" $ "" + script ! src "javascripts/main.js" $ "" -- cgit v1.2.3