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

yesod-auth: send json responses

Browse Source
This commit is contained in:
Greg Weber 2014-01-08 10:43:00 -08:00
parent 12480b2d2a
commit 153654adb9
9 changed files with 190 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
yesod-auth/Yesod/Auth.hs
View File

@ -22,6 +22,7 @@ module Yesod.Auth
-- * Plugin interface -- * Plugin interface
, Creds (..) , Creds (..)
, setCreds , setCreds
, setCredsRedirect
, clearCreds , clearCreds
, loginErrorMessage , loginErrorMessage
, loginErrorMessageI , loginErrorMessageI
@ -36,6 +37,9 @@ module Yesod.Auth
, AuthHandler , AuthHandler
-- * Internal -- * Internal
, credsKey , credsKey
, provideJsonMessage
, messageJson401
, asHtml
) where ) where
import Control.Monad (when) import Control.Monad (when)
@ -64,6 +68,7 @@ import Control.Exception (Exception)
import Network.HTTP.Types (unauthorized401) import Network.HTTP.Types (unauthorized401)
import Control.Monad.Trans.Resource (MonadResourceBase) import Control.Monad.Trans.Resource (MonadResourceBase)
import qualified Control.Monad.Trans.Writer as Writer import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void)
type AuthRoute = Route Auth type AuthRoute = Route Auth
@ -74,7 +79,7 @@ type Piece = Text
data AuthPlugin master = AuthPlugin data AuthPlugin master = AuthPlugin
{ apName :: Text { apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master () , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO () , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
} }
@ -106,7 +111,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
authPlugins :: master -> [AuthPlugin master] authPlugins :: master -> [AuthPlugin master]
-- | What to show on the login page. -- | What to show on the login page.
loginHandler :: AuthHandler master RepHtml loginHandler :: AuthHandler master Html
loginHandler = do loginHandler = do
tp <- getRouteToParent tp <- getRouteToParent
lift $ defaultLayout $ do lift $ defaultLayout $ do
@ -171,9 +176,6 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
onErrorHtml dest msg = do onErrorHtml dest msg = do
setMessage $ toHtml msg setMessage $ toHtml msg
fmap asHtml $ redirect dest fmap asHtml $ redirect dest
where
asHtml :: Html -> Html
asHtml = id
-- | Internal session key used to hold the authentication information. -- | Internal session key used to hold the authentication information.
-- --
@ -227,7 +229,7 @@ cachedAuth aid = runMaybeT $ do
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
=> Route child => Route child
-> AuthMessage -> AuthMessage
-> HandlerT child (HandlerT master m) a -> HandlerT child (HandlerT master m) TypedContent
loginErrorMessageI dest msg = do loginErrorMessageI dest msg = do
toParent <- getRouteToParent toParent <- getRouteToParent
lift $ loginErrorMessageMasterI (toParent dest) msg lift $ loginErrorMessageMasterI (toParent dest) msg
@ -236,7 +238,7 @@ loginErrorMessageI dest msg = do
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
=> Route master => Route master
-> AuthMessage -> AuthMessage
-> HandlerT master m a -> HandlerT master m TypedContent
loginErrorMessageMasterI dest msg = do loginErrorMessageMasterI dest msg = do
mr <- getMessageRender mr <- getMessageRender
loginErrorMessage dest (mr msg) loginErrorMessage dest (mr msg)
@ -246,47 +248,55 @@ loginErrorMessageMasterI dest msg = do
loginErrorMessage :: (YesodAuth master, MonadResourceBase m) loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
=> Route master => Route master
-> Text -> Text
-> HandlerT master m a -> HandlerT master m TypedContent
loginErrorMessage dest msg = loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
sendResponseStatus unauthorized401 =<< (
selectRep $ do messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
provideRep $ do messageJson401 msg html = selectRep $ do
onErrorHtml dest msg provideRep html
provideJsonMessage msg provideRep $ do
) let obj = object ["message" .= msg]
void $ sendResponseStatus unauthorized401 obj
return obj
provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect :: YesodAuth master
=> Creds master -- ^ new credentials
-> HandlerT master IO TypedContent
setCredsRedirect creds = do
y <- getYesod
maid <- getAuthId creds
case maid of
Nothing ->
case authRoute y of
Nothing -> do
messageJson401 "Invalid Login" $ defaultLayout $
toWidget [shamlet|<h1>Invalid login|]
Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
Just aid -> do
setSession credsKey $ toPathPiece aid
onLogin
res <- selectRep $ do
provideRepType typeHtml $
fmap asHtml $ redirectUltDest $ loginDest y
provideJsonMessage "Login Successful"
sendResponse res
-- | Sets user credentials for the session after checking them with authentication backends. -- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: YesodAuth master setCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirects should be done => Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials -> Creds master -- ^ new credentials
-> HandlerT master IO () -> HandlerT master IO ()
setCreds doRedirects creds = do setCreds doRedirects creds =
y <- getYesod if doRedirects
maid <- getAuthId creds then void $ setCredsRedirect creds
case maid of else do maid <- getAuthId creds
Nothing -> when doRedirects $ do case maid of
case authRoute y of Nothing -> return ()
Nothing -> do Just aid -> setSession credsKey $ toPathPiece aid
sendResponseStatus unauthorized401 =<< (
selectRep $ do
provideRep $ defaultLayout $ toWidget [shamlet|<h1>Invalid login|]
provideJsonMessage "Invalid Login"
)
Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
Just aid -> do
setSession credsKey $ toPathPiece aid
when doRedirects $ do
onLogin
res <- selectRep $ do
provideRepType typeHtml $ do
_ <- redirectUltDest $ loginDest y
return ()
provideJsonMessage "Login Successful"
sendResponse res
-- | Clears current user credentials for the session. -- | Clears current user credentials for the session.
-- --
@ -327,7 +337,7 @@ setUltDestReferer' = lift $ do
master <- getYesod master <- getYesod
when (redirectToReferer master) setUltDestReferer when (redirectToReferer master) setUltDestReferer
getLoginR :: AuthHandler master RepHtml getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master () getLogoutR :: AuthHandler master ()
@ -336,7 +346,7 @@ getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
postLogoutR :: AuthHandler master () postLogoutR :: AuthHandler master ()
postLogoutR = lift $ clearCreds True postLogoutR = lift $ clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master () handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do handlePluginR plugin pieces = do
master <- lift getYesod master <- lift getYesod
env <- waiRequest env <- waiRequest
@ -423,3 +433,6 @@ instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html
asHtml = id

2
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -77,7 +77,7 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
$logErrorS "yesod-auth" "BrowserID assertion failure" $logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "BrowserID login error." lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> lift $ setCreds True Creds Just email -> lift $ setCredsRedirect Creds
{ credsPlugin = pid { credsPlugin = pid
, credsIdent = email , credsIdent = email
, credsExtra = [] , credsExtra = []

2
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -18,7 +18,7 @@ authDummy =
where where
dispatch "POST" [] = do dispatch "POST" [] = do
ident <- lift $ runInputPost $ ireq textField "ident" ident <- lift $ runInputPost $ ireq textField "ident"
lift $ setCreds True $ Creds "dummy" ident [] lift $ setCredsRedirect $ Creds "dummy" ident []
dispatch _ _ = notFound dispatch _ _ = notFound
url = PluginR "dummy" [] url = PluginR "dummy" []
login authToMaster = login authToMaster =

209
yesod-auth/Yesod/Auth/Email.hs
View File

@ -41,8 +41,8 @@ import qualified Crypto.PasswordStore as PS
import qualified Text.Email.Validate import qualified Text.Email.Validate
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Control.Monad (void)
import Yesod.Form import Yesod.Form
import Control.Monad (when)
import Data.Time (getCurrentTime, addUTCTime) import Data.Time (getCurrentTime, addUTCTime)
import Safe (readMay) import Safe (readMay)
@ -78,7 +78,11 @@ data EmailCreds site = EmailCreds
, emailCredsEmail :: Email , emailCredsEmail :: Email
} }
class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where class ( YesodAuth site
, PathPiece (AuthEmailId site)
, (RenderMessage site Msg.AuthMessage)
)
=> YesodAuthEmail site where
type AuthEmailId site type AuthEmailId site
-- | Add a new email address to the database, but indicate that the address -- | Add a new email address to the database, but indicate that the address
@ -167,10 +171,14 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
-- | Response after sending a confirmation email. -- | Response after sending a confirmation email.
-- --
-- Since 1.2.2 -- Since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO Html confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
confirmationEmailSentResponse identifier = defaultLayout $ do confirmationEmailSentResponse identifier = do
setTitleI Msg.ConfirmationEmailSentTitle mr <- getMessageRender
[whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|] messageJson401 (mr msg) $ defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet|<p>_{msg}|]
where
msg = Msg.ConfirmationEmailSent identifier
-- | Additional normalization of email addresses, besides standard canonicalization. -- | Additional normalization of email addresses, besides standard canonicalization.
-- --
@ -183,6 +191,7 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress :: site -> Text -> Text
normalizeEmailAddress _ = TS.toLower normalizeEmailAddress _ = TS.toLower
authEmail :: YesodAuthEmail m => AuthPlugin m authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail = authEmail =
AuthPlugin "email" dispatch $ \tm -> AuthPlugin "email" dispatch $ \tm ->
@ -235,40 +244,46 @@ getRegisterR = do
registerHelper :: YesodAuthEmail master registerHelper :: YesodAuthEmail master
=> Bool -- ^ allow usernames? => Bool -- ^ allow usernames?
-> Route Auth -> Route Auth
-> HandlerT Auth (HandlerT master IO) Html -> HandlerT Auth (HandlerT master IO) TypedContent
registerHelper allowUsername dest = do registerHelper allowUsername dest = do
y <- lift getYesod y <- lift getYesod
midentifier <- lookupPostParam "email" midentifier <- lookupPostParam "email"
identifier <- let eidentifier = case midentifier of
case midentifier of Nothing -> Left Msg.NoIdentifierProvided
Nothing -> loginErrorMessageI dest Msg.NoIdentifierProvided
Just x Just x
| Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) -> | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
return $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x' Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
| allowUsername -> return $ TS.strip x | allowUsername -> Right $ TS.strip x
| otherwise -> loginErrorMessageI dest Msg.InvalidEmailAddress | otherwise -> Left Msg.InvalidEmailAddress
mecreds <- lift $ getEmailCreds identifier case eidentifier of
(lid, verKey, email) <- Left route -> loginErrorMessageI dest route
case mecreds of Right identifier -> do
Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return (lid, key, email)
Nothing
| allowUsername ->
loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return (lid, key, identifier)
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html mecreds <- lift $ getEmailCreds identifier
registerCreds <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return $ Just (lid, key, email)
Nothing
| allowUsername -> return Nothing
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return $ Just (lid, key, identifier)
case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postRegisterR = registerHelper False registerR postRegisterR = registerHelper False registerR
getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
@ -286,35 +301,43 @@ getForgotPasswordR = do
<button .btn>_{Msg.SendPasswordResetEmail} <button .btn>_{Msg.SendPasswordResetEmail}
|] |]
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postForgotPasswordR = registerHelper True forgotPasswordR postForgotPasswordR = registerHelper True forgotPasswordR
getVerifyR :: YesodAuthEmail site getVerifyR :: YesodAuthEmail site
=> AuthEmailId site => AuthEmailId site
-> Text -> Text
-> HandlerT Auth (HandlerT site IO) Html -> HandlerT Auth (HandlerT site IO) TypedContent
getVerifyR lid key = do getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid realKey <- lift $ getVerifyKey lid
memail <- lift $ getEmail lid memail <- lift $ getEmail lid
mr <- lift getMessageRender
case (realKey == Just key, memail) of case (realKey == Just key, memail) of
(True, Just email) -> do (True, Just email) -> do
muid <- lift $ verifyAccount lid muid <- lift $ verifyAccount lid
case muid of case muid of
Nothing -> return () Nothing -> invalidKey mr
Just uid -> do Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid? lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setMessageI Msg.AddressVerified
lift $ setLoginLinkKey uid lift $ setLoginLinkKey uid
redirect setpassR let msgAv = Msg.AddressVerified
_ -> return () selectRep $ do
lift $ defaultLayout $ do provideRep $ do
setTitleI Msg.InvalidKey lift $ setMessageI msgAv
fmap asHtml $ redirect setpassR
provideJsonMessage $ mr msgAv
_ -> invalidKey mr
where
msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ defaultLayout $ do
setTitleI msgIk
[whamlet| [whamlet|
$newline never $newline never
<p>_{Msg.InvalidKey} <p>_{msgIk}
|] |]
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postLoginR = do postLoginR = do
(identifier, pass) <- lift $ runInputPost $ (,) (identifier, pass) <- lift $ runInputPost $ (,)
<$> ireq textField "email" <$> ireq textField "email"
@ -337,30 +360,33 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of case maid of
Just email -> Just email ->
lift $ setCreds True $ Creds lift $ setCredsRedirect $ Creds
(if isEmail then "email" else "username") (if isEmail then "email" else "username")
email email
[("verifiedEmail", email)] [("verifiedEmail", email)]
Nothing -> do Nothing ->
loginErrorMessageI LoginR $ loginErrorMessageI LoginR $
if isEmail if isEmail
then Msg.InvalidEmailPass then Msg.InvalidEmailPass
else Msg.InvalidUsernamePass else Msg.InvalidUsernamePass
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
getPasswordR = do getPasswordR = do
maid <- lift maybeAuthId maid <- lift maybeAuthId
pass0 <- newIdent
pass1 <- newIdent
pass2 <- newIdent
case maid of case maid of
Just _ -> return ()
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
tp <- getRouteToParent Just _ -> do
needOld <- maybe (return True) (lift . needOldPassword) maid pass0 <- newIdent
lift $ defaultLayout $ do pass1 <- newIdent
setTitleI Msg.SetPassTitle pass2 <- newIdent
[whamlet| tp <- getRouteToParent
needOld <- maybe (return True) (lift . needOldPassword) maid
mr <- lift getMessageRender
selectRep $ do
provideJsonMessage $ mr Msg.SetPass
provideRep $ lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
[whamlet|
$newline never $newline never
<h3>_{Msg.SetPass} <h3>_{Msg.SetPass}
<form method="post" action="@{tp setpassR}"> <form method="post" action="@{tp setpassR}">
@ -386,45 +412,52 @@ $newline never
<input type="submit" value=_{Msg.SetPassTitle}> <input type="submit" value=_{Msg.SetPassTitle}>
|] |]
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) () postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postPasswordR = do postPasswordR = do
maid <- lift maybeAuthId maid <- lift maybeAuthId
aid <- case maid of case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> return aid Just aid -> do
tm <- getRouteToParent
tm <- getRouteToParent needOld <- lift $ needOldPassword aid
if not needOld then confirmPassword aid tm else do
needOld <- lift $ needOldPassword aid current <- lift $ runInputPost $ ireq textField "current"
when needOld $ do mrealpass <- lift $ getPassword aid
current <- lift $ runInputPost $ ireq textField "current" case mrealpass of
mrealpass <- lift $ getPassword aid Nothing ->
case mrealpass of lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
Nothing -> Just realpass
lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" | isValidPass current realpass -> confirmPassword aid tm
Just realpass | otherwise ->
| isValidPass current realpass -> return () lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
| otherwise ->
lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
(new, confirm) <- lift $ runInputPost $ (,) where
<$> ireq textField "new" msgOk = Msg.PassUpdated
<*> ireq textField "confirm" confirmPassword aid tm = do
when (new /= confirm) $ (new, confirm) <- lift $ runInputPost $ (,)
loginErrorMessageI setpassR Msg.PassMismatch <$> ireq textField "new"
<*> ireq textField "confirm"
isSecure <- lift $ checkPasswordSecurity aid new if new /= confirm
case isSecure of then loginErrorMessageI setpassR Msg.PassMismatch
Left e -> lift $ loginErrorMessage (tm setpassR) e else do
Right () -> return () isSecure <- lift $ checkPasswordSecurity aid new
case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e
Right () -> do
salted <- liftIO $ saltPass new
y <- lift $ do
setPassword aid salted
deleteSession loginLinkKey
setMessageI msgOk
getYesod
salted <- liftIO $ saltPass new mr <- lift getMessageRender
lift $ do selectRep $ do
y <- getYesod provideRep $
setPassword aid salted fmap asHtml $ lift $ redirect $ afterPasswordRoute y
setMessageI Msg.PassUpdated provideJsonMessage (mr msgOk)
deleteSession loginLinkKey
redirect $ afterPasswordRoute y
saltLength :: Int saltLength :: Int
saltLength = 5 saltLength = 5

6
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -69,19 +69,19 @@ authGoogleEmail =
completeHelper posts completeHelper posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master () completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent
completeHelper gets' = do completeHelper gets' = do
master <- lift getYesod master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
tm <- getRouteToParent tm <- getRouteToParent
either (onFailure tm) (onSuccess tm) eres either (onFailure tm) (onSuccess tm) eres
where where
onFailure tm err = do onFailure tm err =
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException) lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
onSuccess tm oir = do onSuccess tm oir = do
let OpenId.Identifier ident = OpenId.oirOpLocal oir let OpenId.Identifier ident = OpenId.oirOpLocal oir
memail <- lookupGetParam "openid.ext1.value.email" memail <- lookupGetParam "openid.ext1.value.email"
case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
(Just email, True) -> lift $ setCreds True $ Creds pid email [] (Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported" (_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided" (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

11
yesod-auth/Yesod/Auth/HashDB.hs
View File

@ -82,7 +82,7 @@ import Yesod.Core
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM) import Control.Monad (replicateM, liftM, void)
import Data.Typeable import Data.Typeable
import qualified Data.ByteString.Lazy.Char8 as BS (pack) import qualified Data.ByteString.Lazy.Char8 as BS (pack)
@ -90,6 +90,7 @@ import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.Text (Text, pack, unpack, append) import Data.Text (Text, pack, unpack, append)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import System.Random (randomRIO) import System.Random (randomRIO)
-- | Interface for data type which holds user info. It's just a -- | Interface for data type which holds user info. It's just a
-- collection of getters and setters -- collection of getters and setters
class HashDBUser user where class HashDBUser user where
@ -167,7 +168,7 @@ postLoginR :: ( YesodAuth y, YesodPersist y
, PersistUnique (b (HandlerT y IO)) , PersistUnique (b (HandlerT y IO))
) )
=> (Text -> Maybe (Unique user)) => (Text -> Maybe (Unique user))
-> HandlerT Auth (HandlerT y IO) () -> HandlerT Auth (HandlerT y IO) TypedContent
postLoginR uniq = do postLoginR uniq = do
(mu,mp) <- lift $ runInputPost $ (,) (mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username" <$> iopt textField "username"
@ -176,7 +177,7 @@ postLoginR uniq = do
isValid <- lift $ fromMaybe (return False) isValid <- lift $ fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp) (validateUser <$> (uniq =<< mu) <*> mp)
if isValid if isValid
then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] then lift $ setCredsRedirect $ Creds "hashdb" (fromMaybe "" mu) []
else do else do
tm <- getRouteToParent tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "Invalid username/password" lift $ loginErrorMessage (tm LoginR) "Invalid username/password"
@ -207,7 +208,9 @@ getAuthIdHashDB authR uniq creds = do
case x of case x of
-- user exists -- user exists
Just (Entity uid _) -> return $ Just uid Just (Entity uid _) -> return $ Just uid
Nothing -> loginErrorMessage (authR LoginR) "User not found" Nothing -> do
void $ loginErrorMessage (authR LoginR) "User not found"
return Nothing
-- | Prompt for username and password, validate that against a database -- | Prompt for username and password, validate that against a database
-- which holds the username and a hash of the password -- which holds the username and a hash of the password

4
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -85,7 +85,7 @@ $newline never
completeHelper idType posts completeHelper idType posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master () completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do completeHelper idType gets' = do
master <- lift getYesod master <- lift getYesod
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
@ -108,7 +108,7 @@ completeHelper idType gets' = do
case idType of case idType of
OPLocal -> OpenId.oirOpLocal oir OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
lift $ setCreds True $ Creds "openid" i gets'' lift $ setCredsRedirect $ Creds "openid" i gets''
-- | The main identifier provided by the OpenID authentication plugin is the -- | The main identifier provided by the OpenID authentication plugin is the
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier

2
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -48,7 +48,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x)) $ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[] []
lift $ setCreds True creds lift $ setCredsRedirect creds
dispatch _ _ = notFound dispatch _ _ = notFound
-- | Get some form of a display name. -- | Get some form of a display name.

2
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth name: yesod-auth
version: 1.2.5.2 version: 1.3.0.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin