From 6e575cf0276e5a447987b9add1eb442a8965b6d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 11:02:49 +0200 Subject: [PATCH] OpenID 1 support built into OpenID 2 code --- OpenId2/Discovery.hs | 36 ++++++++++++++++++++++++++------- Web/Authenticate/Internal.hs | 3 ++- Web/Authenticate/OpenId2.hs | 39 ++++++++++++++++++++---------------- 3 files changed, 53 insertions(+), 25 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index f4898bb0..935429f4 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -14,8 +14,10 @@ module OpenId2.Discovery ( -- * Discovery discover + , Discovery (..) ) where +import Debug.Trace -- FIXME -- Friends import OpenId2.Types import OpenId2.XRDS @@ -27,19 +29,24 @@ import Data.Maybe import Network.HTTP.Enumerator import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 -import Control.Arrow (first) +import Control.Arrow (first, (***)) import Control.Applicative ((<$>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) +import Control.Monad (mplus) + +data Discovery = Discovery1 String (Maybe String) + | Discovery2 Provider Identifier + deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier. discover :: (MonadIO m, Failure OpenIdException m) => Identifier - -> m (Provider, Identifier) + -> m Discovery discover ident@(Identifier i) = do res1 <- liftIO $ discoverYADIS ident Nothing case res1 of - Just x -> return x + Just (x, y) -> return $ Discovery2 x y Nothing -> do res2 <- liftIO $ discoverHTML ident case res2 of @@ -97,23 +104,29 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat -- | Attempt to discover an OpenID endpoint, from an HTML document. The result -- will be an endpoint on success, and the actual identifier of the user. -discoverHTML :: Identifier -> IO (Maybe (Provider,Identifier)) +discoverHTML :: Identifier -> IO (Maybe Discovery) discoverHTML ident'@(Identifier ident) = parseHTML ident' . BSLU.toString <$> simpleHttp ident -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. -parseHTML :: Identifier -> String -> Maybe (Provider,Identifier) +parseHTML :: Identifier -> String -> Maybe Discovery parseHTML ident = resolve . filter isOpenId + . map (dropQuotes *** dropQuotes) . linkTags . htmlTags where isOpenId (rel,_) = "openid" `isPrefixOf` rel - resolve ls = do + resolve1 ls = do + server <- lookup "openid.server" ls + let delegate = lookup "openid.delegate" ls + return $ Discovery1 server delegate + resolve2 ls = do prov <- lookup "openid2.provider" ls let lid = maybe ident Identifier $ lookup "openid2.local_id" ls - return (Provider prov,lid) + return $ Discovery2 (Provider prov) lid + resolve ls = traceShow ls $ resolve2 ls `mplus` resolve1 ls -- | Filter out link tags from a list of html tags. @@ -150,3 +163,12 @@ splitAttr xs = case break (== '=') xs of f key p cs = case break p cs of (_,[]) -> Nothing (value,_:rest) -> Just ((key,value), dropWhile isSpace rest) + +dropQuotes :: String -> String +dropQuotes s@('\'':x:y) + | last y == '\'' = x : init y + | otherwise = s +dropQuotes s@('"':x:y) + | last y == '"' = x : init y + | otherwise = s +dropQuotes s = s diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs index 93e8594a..9e410ce7 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -10,9 +10,10 @@ import Data.List (intercalate) qsUrl :: String -> [(String, String)] -> String qsUrl s [] = s qsUrl url pairs = - url ++ "?" ++ intercalate "&" (map qsPair pairs) + url ++ delim : intercalate "&" (map qsPair pairs) where qsPair (x, y) = qsEncode x ++ '=' : qsEncode y + delim = if '?' `elem` url then '&' else '?' qsEncode :: String -> String qsEncode = diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs index 59498f92..9b408625 100644 --- a/Web/Authenticate/OpenId2.hs +++ b/Web/Authenticate/OpenId2.hs @@ -7,7 +7,7 @@ module Web.Authenticate.OpenId2 import Control.Monad.IO.Class import OpenId2.Normalization (normalize) -import OpenId2.Discovery (discover) +import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) import OpenId2.Types (OpenIdException (..), Identifier (Identifier), Provider (Provider)) @@ -19,20 +19,29 @@ import Network.HTTP.Enumerator (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect) import Control.Arrow ((***)) import Data.List (unfoldr) +import Data.Maybe (fromMaybe) getForwardUrl :: (MonadIO m, Failure OpenIdException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid' complete = do - (Provider p, Identifier i) <- normalize openid' >>= discover - return $ qsUrl p - [ ("openid.ns", "http://specs.openid.net/auth/2.0") - , ("openid.mode", "checkid_setup") - , ("openid.claimed_id", i) - , ("openid.identity", i) - , ("openid.return_to", complete) - ] + disc <- normalize openid' >>= discover + case disc of + Discovery1 server mdelegate -> + return $ qsUrl server + [ ("openid.mode", "checkid_setup") + , ("openid.identity", fromMaybe openid' mdelegate) + , ("openid.return_to", complete) + ] + Discovery2 (Provider p) (Identifier i) -> + return $ qsUrl p + [ ("openid.ns", "http://specs.openid.net/auth/2.0") + , ("openid.mode", "checkid_setup") + , ("openid.claimed_id", i) + , ("openid.identity", i) + , ("openid.return_to", complete) + ] authenticate :: (MonadIO m, Failure OpenIdException m) => [(String, String)] @@ -44,14 +53,10 @@ authenticate params = do Just i -> return i Nothing -> failure $ AuthenticationException "Missing identity" - endpoint <- - case lookup "openid.op_endpoint" params of - Just e -> return e - Nothing -> - failure $ AuthenticationException "Missing op_endpoint" - (Provider p, Identifier i) <- normalize ident >>= discover - unless (endpoint == p) $ - failure $ AuthenticationException "endpoint does not match discovery" + disc <- normalize ident >>= discover + let endpoint = case disc of + Discovery1 p _ -> p + Discovery2 (Provider p) _ -> p let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params