OpenID claimed IDs

.gitignore

@@ -6,5 +6,4 @@ dist
 client_session_key.aes
 cabal-dev/
 yesod/foobar/
-yesod-platform/yesod-platform.cabal
 .virthualenv

yesod-auth/Yesod/Auth/OpenId.hs

@@ -4,6 +4,8 @@ module Yesod.Auth.OpenId
     ( authOpenId
     , authOpenIdExtended
     , forwardUrl
+    , claimedKey
+    , credsIdentClaimed
     ) where
 
 import Yesod.Auth
@@ -15,9 +17,10 @@ import Yesod.Widget (toWidget, whamlet)
 import Yesod.Request
 import Text.Cassius (cassius)
 import Text.Blaze (toHtml)
-import Data.Text (Text)
+import Data.Text (Text, isPrefixOf)
 import qualified Yesod.Auth.Message as Msg
 import Control.Exception.Lifted (SomeException, try)
+import Data.Maybe (fromMaybe)
 
 forwardUrl :: AuthRoute
 forwardUrl = PluginR "openid" ["forward"]
@@ -80,11 +83,40 @@ authOpenIdExtended extensionFields =
 completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
 completeHelper gets' = do
         master <- getYesod
-        eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
+        eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
         toMaster <- getRouteToMaster
         let onFailure err = do
             setMessage $ toHtml $ show (err :: SomeException)
             redirect $ toMaster LoginR
-        let onSuccess (OpenId.Identifier ident, _) =
-                setCreds True $ Creds "openid" ident gets'
+        let onSuccess oir = do
+                let claimed =
+                        case OpenId.oirClaimed oir of
+                            Nothing -> id
+                            Just (OpenId.Identifier i) -> ((claimedKey, i):)
+                    gets'' = claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
+                    i = OpenId.identifier $ OpenId.oirOpLocal oir
+                setCreds True $ Creds "openid" i gets''
         either onFailure onSuccess eres
+
+-- | The main identifier provided by the OpenID authentication plugin is the
+-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
+-- available.
+--
+-- In the 'credsExtra' field of the 'Creds' datatype, you can lookup this key
+-- to find the claimed identifier, if available.
+--
+-- > let finalID = fromMaybe (credsIdent creds)
+-- >             $ lookup claimedKey (credsExtra creds)
+--
+-- Since 1.0.2
+claimedKey :: Text
+claimedKey = "__CLAIMED"
+
+-- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier.
+--
+-- See 'claimedKey'.
+--
+-- Since 1.0.2
+credsIdentClaimed :: Creds m -> Text
+credsIdentClaimed c = fromMaybe (credsIdent c)
+                    $ lookup claimedKey (credsExtra c)

yesod-auth/openid.hs

@@ -44,7 +44,7 @@ instance YesodAuth BID where
     type AuthId BID = Text
     loginDest _ = AfterLoginR
     logoutDest _ = AuthR LoginR
-    getAuthId = return . Just . credsIdent
+    getAuthId = return . Just . credsIdentClaimed
     authPlugins _ = [authOpenId]
     authHttpManager = httpManager
 

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.0.1
+version:         1.0.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -16,7 +16,7 @@ flag ghc7
 
 library
     build-depends:   base                    >= 4         && < 5
-                   , authenticate            >= 1.2       && < 1.3
+                   , authenticate            >= 1.2.1     && < 1.3
                    , bytestring              >= 0.9.1.4   && < 0.10
                    , yesod-core              >= 1.0       && < 1.1
                    , wai                     >= 1.2       && < 1.3