haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cap YADIS redirects to 10

Browse Source
This commit is contained in:
Michael Snoyman 2010-10-06 19:59:47 +02:00
parent e0011ad2b5
commit a2eb422a2a
3 changed files with 8 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
OpenId2/Discovery.hs
View File

@ -46,7 +46,7 @@ discover :: ( MonadIO m
=> Identifier => Identifier
-> m Discovery -> m Discovery
discover ident@(Identifier i) = do discover ident@(Identifier i) = do
res1 <- discoverYADIS ident Nothing res1 <- discoverYADIS ident Nothing 10
case res1 of case res1 of
Just (x, y) -> return $ Discovery2 x y Just (x, y) -> return $ Discovery2 x y
Nothing -> do Nothing -> do
@ -65,8 +65,11 @@ discoverYADIS :: ( MonadIO m
) )
=> Identifier => Identifier
-> Maybe String -> Maybe String
-> Int -- ^ remaining redirects
-> m (Maybe (Provider,Identifier)) -> 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 let uri = fromMaybe (identifier ident) mb_loc
req <- parseUrl uri req <- parseUrl uri
res <- httpLbs req res <- httpLbs req
@ -78,7 +81,7 @@ discoverYADIS ident mb_loc = do
case statusCode res of case statusCode res of
200 -> 200 ->
case mloc' of case mloc' of
Just loc -> discoverYADIS ident (Just loc) Just loc -> discoverYADIS ident (Just loc) (redirects - 1)
Nothing -> do Nothing -> do
let mdoc = parseXRDS $ BSLU.toString $ responseBody res let mdoc = parseXRDS $ BSLU.toString $ responseBody res
case mdoc of case mdoc of

1
Web/Authenticate/OpenId.hs
View File

@ -40,6 +40,7 @@ getForwardUrl openid' complete = do
[ ("openid.mode", "checkid_setup") [ ("openid.mode", "checkid_setup")
, ("openid.identity", fromMaybe openid' mdelegate) , ("openid.identity", fromMaybe openid' mdelegate)
, ("openid.return_to", complete) , ("openid.return_to", complete)
, ("openid.trust_root", complete)
] ]
Discovery2 (Provider p) (Identifier i) -> Discovery2 (Provider p) (Identifier i) ->
return $ qsUrl p return $ qsUrl p

2
authenticate.cabal
View File

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