diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 03b6a561..ba60a3a1 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -46,7 +46,7 @@ discover :: ( MonadIO m => Identifier -> m Discovery discover ident@(Identifier i) = do - res1 <- discoverYADIS ident Nothing + res1 <- discoverYADIS ident Nothing 10 case res1 of Just (x, y) -> return $ Discovery2 x y Nothing -> do @@ -65,8 +65,11 @@ discoverYADIS :: ( MonadIO m ) => Identifier -> Maybe String + -> Int -- ^ remaining redirects -> m (Maybe (Provider,Identifier)) -discoverYADIS ident mb_loc = do +discoverYADIS _ _ 0 = + failure $ InvalidUrlException "" "discoverYADIS redirected too many times" -- FIXME better failure +discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri res <- httpLbs req @@ -78,7 +81,7 @@ discoverYADIS ident mb_loc = do case statusCode res of 200 -> case mloc' of - Just loc -> discoverYADIS ident (Just loc) + Just loc -> discoverYADIS ident (Just loc) (redirects - 1) Nothing -> do let mdoc = parseXRDS $ BSLU.toString $ responseBody res case mdoc of diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 8c510320..8d773653 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -40,6 +40,7 @@ getForwardUrl openid' complete = do [ ("openid.mode", "checkid_setup") , ("openid.identity", fromMaybe openid' mdelegate) , ("openid.return_to", complete) + , ("openid.trust_root", complete) ] Discovery2 (Provider p) (Identifier i) -> return $ qsUrl p diff --git a/authenticate.cabal b/authenticate.cabal index 604d5fab..296a7f42 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.6.1 +version: 0.6.6.2 license: BSD3 license-file: LICENSE author: Michael Snoyman