haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Unified Auth login page

Browse Source
This commit is contained in:
Michael Snoyman 2010-08-27 13:09:43 +03:00
parent a03cc7cff8
commit 465366766b
1 changed files with 100 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

190
Yesod/Helpers/Auth.hs
View File

@ -31,10 +31,12 @@ module Yesod.Helpers.Auth
, Creds (..) , Creds (..)
, EmailCreds (..) , EmailCreds (..)
, AuthType (..) , AuthType (..)
, AuthEmailSettings (..) , RpxnowSettings (..)
, EmailSettings (..)
, FacebookSettings (..)
-- * Functions -- * Functions
, maybeCreds , maybeAuthId
, requireCreds , requireAuthId
) where ) where
import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.Rpxnow as Rpxnow
@ -86,15 +88,15 @@ class (Integral (AuthEmailId master), Yesod master,
openIdEnabled :: master -> Bool openIdEnabled :: master -> Bool
openIdEnabled _ = False openIdEnabled _ = False
rpxnowApiKey :: master -> Maybe String rpxnowSettings :: master -> Maybe RpxnowSettings
rpxnowApiKey _ = Nothing rpxnowSettings _ = Nothing
emailSettings :: master -> Maybe (AuthEmailSettings master) emailSettings :: master -> Maybe (EmailSettings master)
emailSettings _ = Nothing emailSettings _ = Nothing
-- | client id, secret and requested permissions -- | client id, secret and requested permissions
facebookKeys :: master -> Maybe (String, String, [String]) facebookSettings :: master -> Maybe FacebookSettings
facebookKeys _ = Nothing facebookSettings _ = Nothing
data Auth = Auth data Auth = Auth
@ -119,7 +121,12 @@ data EmailCreds m = EmailCreds
, emailCredsVerkey :: Maybe VerKey , emailCredsVerkey :: Maybe VerKey
} }
data AuthEmailSettings m = AuthEmailSettings data RpxnowSettings = RpxnowSettings
{ rpxnowApp :: String
, rpxnowKey :: String
}
data EmailSettings m = EmailSettings
{ addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) { addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
, getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) , getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)
@ -131,6 +138,12 @@ data AuthEmailSettings m = AuthEmailSettings
, getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) , getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
} }
data FacebookSettings = FacebookSettings
{ fbAppId :: String
, fbSecret :: String
, fbPerms :: [String]
}
-- | User credentials -- | User credentials
data Creds m = Creds data Creds m = Creds
{ credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.
@ -153,8 +166,8 @@ setCreds creds extra = do
Just aid -> showAuthId aid >>= setSession credsKey Just aid -> showAuthId aid >>= setSession credsKey
-- | Retrieves user credentials, if user is authenticated. -- | Retrieves user credentials, if user is authenticated.
maybeCreds :: YesodAuth m => GHandler s m (Maybe (AuthId m)) maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
maybeCreds = do maybeAuthId = do
ms <- lookupSession credsKey ms <- lookupSession credsKey
case ms of case ms of
Nothing -> return Nothing Nothing -> return Nothing
@ -166,18 +179,18 @@ mkYesodSub "Auth"
[$parseRoutes| [$parseRoutes|
/check CheckR GET /check CheckR GET
/logout LogoutR GET /logout LogoutR GET
/openid OpenIdR GET
/openid/forward OpenIdForwardR GET /openid/forward OpenIdForwardR GET
/openid/complete OpenIdCompleteR GET /openid/complete OpenIdCompleteR GET
/login/rpxnow RpxnowR /login/rpxnow RpxnowR
/facebook FacebookR GET /facebook FacebookR GET
/facebook/start StartFacebookR GET
/register EmailRegisterR GET POST /register EmailRegisterR GET POST
/verify/#Integer/#String EmailVerifyR GET /verify/#Integer/#String EmailVerifyR GET
/login EmailLoginR GET POST /email-login EmailLoginR POST
/set-password EmailPasswordR GET POST /set-password EmailPasswordR GET POST
/login LoginR GET
|] |]
testOpenId :: YesodAuth master => GHandler Auth master () testOpenId :: YesodAuth master => GHandler Auth master ()
@ -185,23 +198,6 @@ testOpenId = do
a <- getYesod a <- getYesod
unless (openIdEnabled a) notFound unless (openIdEnabled a) notFound
getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml
getOpenIdR = do
testOpenId
lookupGetParam "dest" >>= maybe (return ()) setUltDestString
rtom <- getRouteToMaster
message <- getMessage
defaultLayout $ do
setTitle "Log in via OpenID"
addBody [$hamlet|
$maybe message msg
%p.message $msg$
%form!method=get!action=@rtom.OpenIdForwardR@
%label!for=openid OpenID: $
%input#openid!type=text!name=openid
%input!type=submit!value=Login
|]
getOpenIdForwardR :: YesodAuth master => GHandler Auth master () getOpenIdForwardR :: YesodAuth master => GHandler Auth master ()
getOpenIdForwardR = do getOpenIdForwardR = do
testOpenId testOpenId
@ -213,7 +209,7 @@ getOpenIdForwardR = do
attempt attempt
(\err -> do (\err -> do
setMessage $ string $ show err setMessage $ string $ show err
redirect RedirectTemporary $ toMaster OpenIdR) redirect RedirectTemporary $ toMaster LoginR)
(redirectString RedirectTemporary) (redirectString RedirectTemporary)
res res
@ -226,7 +222,7 @@ getOpenIdCompleteR = do
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
let onFailure err = do let onFailure err = do
setMessage $ string $ show err setMessage $ string $ show err
redirect RedirectTemporary $ toMaster OpenIdR redirect RedirectTemporary $ toMaster LoginR
let onSuccess (OpenId.Identifier ident) = do let onSuccess (OpenId.Identifier ident) = do
y <- getYesod y <- getYesod
setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) [] setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) []
@ -237,7 +233,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master ()
handleRpxnowR = do handleRpxnowR = do
ay <- getYesod ay <- getYesod
auth <- getYesod auth <- getYesod
apiKey <- case rpxnowApiKey auth of apiKey <- case rpxnowApp <$> rpxnowSettings auth of
Just x -> return x Just x -> return x
Nothing -> notFound Nothing -> notFound
token1 <- lookupGetParam "token" token1 <- lookupGetParam "token"
@ -272,7 +268,7 @@ getDisplayName extra =
getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson
getCheckR = do getCheckR = do
creds <- maybeCreds creds <- maybeAuthId
defaultLayoutJson (do defaultLayoutJson (do
setTitle "Authentication Status" setTitle "Authentication Status"
addBody $ html creds) (json creds) addBody $ html creds) (json creds)
@ -298,9 +294,9 @@ getLogoutR = do
-- | Retrieve user credentials. If user is not logged in, redirects to the -- | Retrieve user credentials. If user is not logged in, redirects to the
-- 'authRoute'. Sets ultimate destination to current route, so user -- 'authRoute'. Sets ultimate destination to current route, so user
-- should be sent back here after authenticating. -- should be sent back here after authenticating.
requireCreds :: YesodAuth m => GHandler sub m (AuthId m) requireAuthId :: YesodAuth m => GHandler sub m (AuthId m)
requireCreds = requireAuthId =
maybeCreds >>= maybe redirectLogin return maybeAuthId >>= maybe redirectLogin return
where where
redirectLogin = do redirectLogin = do
y <- getYesod y <- getYesod
@ -309,13 +305,13 @@ requireCreds =
Just z -> redirect RedirectTemporary z Just z -> redirect RedirectTemporary z
Nothing -> permissionDenied "Please configure authRoute" Nothing -> permissionDenied "Please configure authRoute"
getAuthEmailSettings :: YesodAuth master getEmailSettings :: YesodAuth master
=> GHandler Auth master (AuthEmailSettings master) => GHandler Auth master (EmailSettings master)
getAuthEmailSettings = getYesod >>= maybe notFound return . emailSettings getEmailSettings = getYesod >>= maybe notFound return . emailSettings
getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
getEmailRegisterR = do getEmailRegisterR = do
_ae <- getAuthEmailSettings _ae <- getEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet| defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet|
%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
@ -327,7 +323,7 @@ getEmailRegisterR = do
postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
postEmailRegisterR = do postEmailRegisterR = do
ae <- getAuthEmailSettings ae <- getEmailSettings
email <- runFormPost' $ emailInput "email" email <- runFormPost' $ emailInput "email"
mecreds <- getEmailCreds ae email mecreds <- getEmailCreds ae email
(lid, verKey) <- (lid, verKey) <-
@ -355,7 +351,7 @@ getEmailVerifyR :: YesodAuth master
=> Integer -> String -> GHandler Auth master RepHtml => Integer -> String -> GHandler Auth master RepHtml
getEmailVerifyR lid' key = do getEmailVerifyR lid' key = do
let lid = fromInteger lid' let lid = fromInteger lid'
ae <- getAuthEmailSettings ae <- getEmailSettings
realKey <- getVerifyKey ae lid realKey <- getVerifyKey ae lid
memail <- getEmail ae lid memail <- getEmail ae lid
case (realKey == Just key, memail) of case (realKey == Just key, memail) of
@ -375,37 +371,9 @@ getEmailVerifyR lid' key = do
%p I'm sorry, but that was an invalid verification key. %p I'm sorry, but that was an invalid verification key.
|] |]
getEmailLoginR :: YesodAuth master => GHandler Auth master RepHtml
getEmailLoginR = do
_ae <- getAuthEmailSettings
toMaster <- getRouteToMaster
msg <- getMessage
defaultLayout $ do
setTitle "Login"
addBody [$hamlet|
$maybe msg ms
%p.message $ms$
%p Please log in to your account.
%p
%a!href=@toMaster.EmailRegisterR@ I don't have an account
%form!method=post!action=@toMaster.EmailLoginR@
%table
%tr
%th E-mail
%td
%input!type=email!name=email
%tr
%th Password
%td
%input!type=password!name=password
%tr
%td!colspan=2
%input!type=submit!value=Login
|]
postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR :: YesodAuth master => GHandler Auth master ()
postEmailLoginR = do postEmailLoginR = do
ae <- getAuthEmailSettings ae <- getEmailSettings
(email, pass) <- runFormPost' $ (,) (email, pass) <- runFormPost' $ (,)
<$> emailInput "email" <$> emailInput "email"
<*> stringInput "password" <*> stringInput "password"
@ -430,13 +398,13 @@ postEmailLoginR = do
Nothing -> do Nothing -> do
setMessage $ string "Invalid email/password combination" setMessage $ string "Invalid email/password combination"
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster EmailLoginR redirect RedirectTemporary $ toMaster LoginR
getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml
getEmailPasswordR = do getEmailPasswordR = do
_ae <- getAuthEmailSettings _ae <- getEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
maid <- maybeCreds maid <- maybeAuthId
case maid of case maid of
Just _ -> return () Just _ -> return ()
Nothing -> do Nothing -> do
@ -463,7 +431,7 @@ getEmailPasswordR = do
postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
postEmailPasswordR = do postEmailPasswordR = do
ae <- getAuthEmailSettings ae <- getEmailSettings
(new, confirm) <- runFormPost' $ (,) (new, confirm) <- runFormPost' $ (,)
<$> stringInput "new" <$> stringInput "new"
<*> stringInput "confirm" <*> stringInput "confirm"
@ -471,7 +439,7 @@ postEmailPasswordR = do
when (new /= confirm) $ do when (new /= confirm) $ do
setMessage $ string "Passwords did not match, please try again" setMessage $ string "Passwords did not match, please try again"
redirect RedirectTemporary $ toMaster EmailPasswordR redirect RedirectTemporary $ toMaster EmailPasswordR
maid <- maybeCreds maid <- maybeAuthId
aid <- case maid of aid <- case maid of
Nothing -> do Nothing -> do
setMessage $ string "You must be logged in to set a password" setMessage $ string "You must be logged in to set a password"
@ -505,10 +473,10 @@ saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass)
getFacebookR :: YesodAuth master => GHandler Auth master () getFacebookR :: YesodAuth master => GHandler Auth master ()
getFacebookR = do getFacebookR = do
y <- getYesod y <- getYesod
a <- facebookKeys <$> getYesod a <- facebookSettings <$> getYesod
case a of case a of
Nothing -> notFound Nothing -> notFound
Just (cid, secret, _) -> do Just (FacebookSettings cid secret _) -> do
render <- getUrlRender render <- getUrlRender
tm <- getRouteToMaster tm <- getRouteToMaster
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
@ -525,14 +493,56 @@ getFacebookR = do
setCreds c [] setCreds c []
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
getStartFacebookR :: YesodAuth master => GHandler Auth master () getLoginR :: YesodAuth master => GHandler Auth master RepHtml
getStartFacebookR = do getLoginR = do
lookupGetParam "dest" >>= maybe (return ()) setUltDestString
tm <- getRouteToMaster
y <- getYesod y <- getYesod
case facebookKeys y of render <- getUrlRender
Nothing -> notFound let facebookUrl f =
Just (cid, secret, perms) -> do let fb =
render <- getUrlRender Facebook.Facebook
tm <- getRouteToMaster (fbAppId f)
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR (fbSecret f)
let fburl = Facebook.getForwardUrl fb perms (render $ tm FacebookR)
redirectString RedirectTemporary fburl in Facebook.getForwardUrl fb $ fbPerms f
defaultLayout $ do
setTitle "Login"
addStyle [$cassius|
#openid
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
padding-left: 18px;
|]
addBody [$hamlet|
$maybe emailSettings.y _
%h3 Email
%form!method=post!action=@tm.EmailLoginR@
%table
%tr
%th E-mail
%td
%input!type=email!name=email
%tr
%th Password
%td
%input!type=password!name=password
%tr
%td!colspan=2
%input!type=submit!value="Login via email"
%a!href=@tm.EmailRegisterR@ I don't have an account
$if openIdEnabled.y
%h3 OpenID
%form!action=@tm.OpenIdForwardR@
%label!for=openid OpenID: $
%input#openid!type=text!name=openid
%input!type=submit!value="Login via OpenID"
$maybe facebookSettings.y f
%h3 Facebook
%p
%a!href=$facebookUrl.f$ Login via Facebook
$maybe rpxnowSettings.y r
%h3 OpenID
%p
%a!onclick="return false;"!href="https://$rpxnowApp.r$.rpxnow.com/openid/v2/signin?token_url=@tm.RpxnowR@"
Login via Rpxnow
|]