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

Fixed some warnings

Browse Source
This commit is contained in:
Michael Snoyman 2012-04-23 14:01:25 +03:00
parent 4789a1d073
commit aa459bc8d8
2 changed files with 9 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -72,12 +72,13 @@ authGoogleEmail =
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do completeHelper gets' = do
master <- getYesod master <- getYesod
eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master) eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
let onFailure err = do let onFailure err = do
setMessage $ toHtml $ show (err :: SomeException) setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR redirect $ toMaster LoginR
let onSuccess (OpenId.Identifier ident, _) = do let onSuccess oir = do
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) -> setCreds True $ Creds "openid" email [] (Just email, True) -> setCreds True $ Creds "openid" email []

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

@ -92,7 +92,7 @@ completeHelper gets' = do
let claimed = let claimed =
case OpenId.oirClaimed oir of case OpenId.oirClaimed oir of
Nothing -> id Nothing -> id
Just (OpenId.Identifier i) -> ((claimedKey, i):) Just (OpenId.Identifier i') -> ((claimedKey, i'):)
gets'' = claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets' gets'' = claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
i = OpenId.identifier $ OpenId.oirOpLocal oir i = OpenId.identifier $ OpenId.oirOpLocal oir
setCreds True $ Creds "openid" i gets'' setCreds True $ Creds "openid" i gets''
@ -118,5 +118,10 @@ claimedKey = "__CLAIMED"
-- --
-- Since 1.0.2 -- Since 1.0.2
credsIdentClaimed :: Creds m -> Text credsIdentClaimed :: Creds m -> Text
-- Prevent other backends from overloading the __CLAIMED value, which could
-- possibly open us to security holes.
credsIdentClaimed c | credsPlugin c /= "openid" = credsIdent c
credsIdentClaimed c = fromMaybe (credsIdent c) credsIdentClaimed c = fromMaybe (credsIdent c)
$ lookup claimedKey (credsExtra c) $ lookup claimedKey (credsExtra c)