OpenID 1 support built into OpenID 2 code

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

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 =

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
+    disc <- normalize openid' >>= discover
-    return $ qsUrl p
+    case disc of
-        [ ("openid.ns", "http://specs.openid.net/auth/2.0")
+        Discovery1 server mdelegate ->
-        , ("openid.mode", "checkid_setup")
+            return $ qsUrl server
-        , ("openid.claimed_id", i)
+                [ ("openid.mode", "checkid_setup")
-        , ("openid.identity", i)
+                , ("openid.identity", fromMaybe openid' mdelegate)
-        , ("openid.return_to", complete)
+                , ("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 <-
+    disc <- normalize ident >>= discover
-        case lookup "openid.op_endpoint" params of
+    let endpoint = case disc of
-            Just e -> return e
+                    Discovery1 p _ -> p
-            Nothing ->
+                    Discovery2 (Provider p) _ -> p
-                failure $ AuthenticationException "Missing op_endpoint"
-    (Provider p, Identifier i) <- normalize ident >>= discover
-    unless (endpoint == p) $
-        failure $ AuthenticationException "endpoint does not match discovery"
     let params' = map (BSU.fromString *** BSU.fromString)
                 $ ("openid.mode", "check_authentication")
                 : filter (\(k, _) -> k /= "openid.mode") params