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

Set claimed_id correctly in forwarded URL

Browse Source
This commit is contained in:
Michael Snoyman 2012-04-20 09:53:30 +03:00
parent cda399131b
commit 7dd118adb1
1 changed files with 10 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
authenticate/Web/Authenticate/OpenId.hs
View File

@ -41,7 +41,8 @@ getForwardUrl
-> m Text -- ^ URL to send the user to. -> m Text -- ^ URL to send the user to.
getForwardUrl openid' complete mrealm params manager = do getForwardUrl openid' complete mrealm params manager = do
let realm = fromMaybe complete mrealm let realm = fromMaybe complete mrealm
disc <- normalize openid' >>= flip discover manager claimed <- normalize openid'
disc <- discover claimed manager
let helper s q = return $ T.concat let helper s q = return $ T.concat
[ s [ s
, if "?" `T.isInfixOf` s then "&" else "?" , if "?" `T.isInfixOf` s then "&" else "?"
@ -50,21 +51,23 @@ getForwardUrl openid' complete mrealm params manager = do
case disc of case disc of
Discovery1 server mdelegate -> helper server Discovery1 server mdelegate -> helper server
$ ("openid.mode", "checkid_setup") $ ("openid.mode", "checkid_setup")
: ("openid.identity", maybe openid' id mdelegate) : ("openid.identity", maybe (identifier claimed) id mdelegate)
: ("openid.return_to", complete) : ("openid.return_to", complete)
: ("openid.realm", realm) : ("openid.realm", realm)
: ("openid.trust_root", complete) : ("openid.trust_root", complete)
: params : params
Discovery2 (Provider p) (Identifier i) itype -> do Discovery2 (Provider p) (Identifier i) itype -> do
let i' = let (claimed', identity') =
case itype of case itype of
ClaimedIdent -> i ClaimedIdent -> (identifier claimed, i)
OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select" OPIdent ->
let x = "http://specs.openid.net/auth/2.0/identifier_select"
in (x, x)
helper p helper p
$ ("openid.ns", "http://specs.openid.net/auth/2.0") $ ("openid.ns", "http://specs.openid.net/auth/2.0")
: ("openid.mode", "checkid_setup") : ("openid.mode", "checkid_setup")
: ("openid.claimed_id", i') : ("openid.claimed_id", claimed')
: ("openid.identity", i') : ("openid.identity", identity')
: ("openid.return_to", complete) : ("openid.return_to", complete)
: ("openid.realm", realm) : ("openid.realm", realm)
: params : params