Proper support for OP identifiers in Yadis

OpenId2/Discovery.hs

@@ -35,7 +35,7 @@ import Control.Monad (mplus, liftM)
 import Network.Wai (ciOriginal)
 
 data Discovery = Discovery1 String (Maybe String)
-               | Discovery2 Provider Identifier
+               | Discovery2 Provider Identifier IdentType
     deriving Show
 
 -- | Attempt to resolve an OpenID endpoint, and user identifier.
@@ -48,7 +48,7 @@ discover :: ( MonadIO m
 discover ident@(Identifier i) = do
     res1 <- discoverYADIS ident Nothing 10
     case res1 of
-        Just (x, y) -> return $ Discovery2 x y
+        Just (x, y, z) -> return $ Discovery2 x y z
         Nothing -> do
             res2 <- discoverHTML ident
             case res2 of
@@ -65,7 +65,7 @@ discoverYADIS :: ( MonadIO m
               => Identifier
               -> Maybe String
               -> Int -- ^ remaining redirects
-              -> m (Maybe (Provider,Identifier))
+              -> m (Maybe (Provider, Identifier, IdentType))
 discoverYADIS _ _ 0 = failure TooManyRedirects
 discoverYADIS ident mb_loc redirects = do
     let uri = fromMaybe (identifier ident) mb_loc
@@ -90,7 +90,7 @@ discoverYADIS ident mb_loc redirects = do
 
 -- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml
 -- document.
-parseYADIS :: Identifier -> XRDS -> Maybe (Provider,Identifier)
+parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)
 parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
   where
   isOpenId svc = do
@@ -98,15 +98,15 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
         localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc
         f (x,y) | x `elem` tys = Just y
                 | otherwise    = Nothing
-    lid <- listToMaybe $ mapMaybe f
+    (lid, itype) <- listToMaybe $ mapMaybe f
-      [ ("http://specs.openid.net/auth/2.0/server", ident)
+      [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent))
       -- claimed identifiers
-      , ("http://specs.openid.net/auth/2.0/signon", localId)
+      , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent))
-      , ("http://openid.net/signon/1.0"           , localId)
+      , ("http://openid.net/signon/1.0"           , (localId, ClaimedIdent))
-      , ("http://openid.net/signon/1.1"           , localId)
+      , ("http://openid.net/signon/1.1"           , (localId, ClaimedIdent))
       ]
     uri <- listToMaybe $ serviceURIs svc
-    return (Provider uri, lid)
+    return (Provider uri, lid, itype)
 
 
 -- HTML-Based Discovery --------------------------------------------------------
@@ -136,7 +136,9 @@ parseHTML ident = resolve
     resolve2 ls = do
       prov <- lookup "openid2.provider" ls
       let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
-      return $ Discovery2 (Provider prov) lid
+      -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only
+      -- result in a claimed identifier.
+      return $ Discovery2 (Provider prov) lid ClaimedIdent
     resolve ls = resolve2 ls `mplus` resolve1 ls
 
 

OpenId2/Types.hs

@@ -13,6 +13,7 @@
 module OpenId2.Types (
     Provider (..)
   , Identifier (..)
+  , IdentType (..)
   , AuthenticateException (..)
   ) where
 
@@ -27,3 +28,6 @@ newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
 -- | A valid OpenID identifier.
 newtype Identifier = Identifier { identifier :: String }
     deriving (Eq, Ord, Show, Read, Data, Typeable)
+
+data IdentType = OPIdent | ClaimedIdent
+    deriving (Eq, Ord, Show, Read, Data, Typeable)

Web/Authenticate/OpenId.hs

@@ -45,12 +45,16 @@ getForwardUrl openid' complete mrealm params = do
                 : ("openid.realm", realm)
                 : ("openid.trust_root", complete)
                 : params
-        Discovery2 (Provider p) (Identifier i) ->
+        Discovery2 (Provider p) (Identifier i) itype -> do
+            let i' =
+                    case itype of
+                        ClaimedIdent -> i
+                        OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"
             return $ qsUrl p
                 $ ("openid.ns", "http://specs.openid.net/auth/2.0")
                 : ("openid.mode", "checkid_setup")
-                : ("openid.claimed_id", i)
+                : ("openid.claimed_id", i')
-                : ("openid.identity", i)
+                : ("openid.identity", i')
                 : ("openid.return_to", complete)
                 : ("openid.realm", realm)
                 : params
@@ -79,7 +83,7 @@ authenticate params = do
     disc <- normalize ident >>= discover
     let endpoint = case disc of
                     Discovery1 p _ -> p
-                    Discovery2 (Provider p) _ -> p
+                    Discovery2 (Provider p) _ _ -> p
     let params' = map (BSU.fromString *** BSU.fromString)
                 $ ("openid.mode", "check_authentication")
                 : filter (\(k, _) -> k /= "openid.mode") params

authenticate.cabal

@@ -1,5 +1,5 @@
 name:            authenticate
-version:         0.8.0
+version:         0.8.0.1
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>