diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index a9ed6e88..dde4d019 100644 --- a/OpenId2/Discovery.hs +++ b/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 - [ ("http://specs.openid.net/auth/2.0/server", ident) + (lid, itype) <- listToMaybe $ mapMaybe f + [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent)) -- claimed identifiers - , ("http://specs.openid.net/auth/2.0/signon", localId) - , ("http://openid.net/signon/1.0" , localId) - , ("http://openid.net/signon/1.1" , localId) + , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent)) + , ("http://openid.net/signon/1.0" , (localId, ClaimedIdent)) + , ("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 diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index 66afab4b..ac157344 100644 --- a/OpenId2/Types.hs +++ b/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) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 22663091..73df129c 100644 --- a/Web/Authenticate/OpenId.hs +++ b/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.identity", i) + : ("openid.claimed_id", 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 diff --git a/authenticate.cabal b/authenticate.cabal index 66a09147..111779b9 100644 --- a/authenticate.cabal +++ b/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