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

Allow openid to use claimed IDs (#338)

Browse Source
This commit is contained in:
Michael Snoyman 2012-07-02 09:57:20 +03:00
parent a5b4dd5d29
commit 21a4360f74
1 changed files with 23 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,10 +3,11 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Yesod.Auth.OpenId module Yesod.Auth.OpenId
( authOpenId ( authOpenId
, authOpenIdExtended
, forwardUrl , forwardUrl
, claimedKey , claimedKey
, opLocalKey
, credsIdentClaimed , credsIdentClaimed
, IdentifierType (..)
) where ) where
import Yesod.Auth import Yesod.Auth
@ -30,11 +31,13 @@ import Data.Maybe (fromMaybe)
forwardUrl :: AuthRoute forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"] forwardUrl = PluginR "openid" ["forward"]
authOpenId :: YesodAuth m => AuthPlugin m data IdentifierType = Claimed | OPLocal
authOpenId = authOpenIdExtended []
authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m authOpenId :: YesodAuth m
authOpenIdExtended extensionFields = => IdentifierType
-> [(Text, Text)] -- ^ extension fields
-> AuthPlugin m
authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login AuthPlugin "openid" dispatch login
where where
complete = PluginR "openid" ["complete"] complete = PluginR "openid" ["complete"]
@ -79,15 +82,15 @@ $newline never
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
dispatch "GET" ["complete"] = do dispatch "GET" ["complete"] = do
rr <- getRequest rr <- getRequest
completeHelper $ reqGetParams rr completeHelper idType $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
dispatch "POST" ["complete"] = do dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody (posts, _) <- runRequestBody
completeHelper posts completeHelper idType posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do completeHelper idType gets' = do
master <- getYesod master <- getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -99,8 +102,14 @@ completeHelper gets' = do
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' oplocal =
i = OpenId.identifier $ OpenId.oirOpLocal oir case OpenId.oirOpLocal oir of
OpenId.Identifier i' -> ((opLocalKey, i'):)
gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
i = OpenId.identifier $
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
setCreds True $ Creds "openid" i gets'' setCreds True $ Creds "openid" i gets''
either onFailure onSuccess eres either onFailure onSuccess eres
@ -118,6 +127,9 @@ completeHelper gets' = do
claimedKey :: Text claimedKey :: Text
claimedKey = "__CLAIMED" claimedKey = "__CLAIMED"
opLocalKey :: Text
opLocalKey = "__OPLOCAL"
-- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier. -- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier.
-- --
-- See 'claimedKey'. -- See 'claimedKey'.