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

getForwardUrlRealm and authenticateParams

Browse Source
This commit is contained in:
Michael Snoyman 2010-12-23 11:26:54 +02:00
parent a38000b2f3
commit 6615274cc8
2 changed files with 49 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
Web/Authenticate/OpenId.hs
View File

@ -1,7 +1,9 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Web.Authenticate.OpenId module Web.Authenticate.OpenId
( getForwardUrl ( getForwardUrl
, getForwardUrlRealm
, authenticate , authenticate
, authenticateParams
, AuthenticateException (..) , AuthenticateException (..)
, Identifier (..) , Identifier (..)
) where ) where
@ -12,7 +14,7 @@ import OpenId2.Discovery (discover, Discovery (..))
import Control.Failure (Failure (failure)) import Control.Failure (Failure (failure))
import OpenId2.Types import OpenId2.Types
import Web.Authenticate.Internal (qsUrl) import Web.Authenticate.Internal (qsUrl)
import Control.Monad (unless) import Control.Monad (unless, liftM)
import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.UTF8 as BSU
import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Lazy.UTF8 as BSLU
import Network.HTTP.Enumerator import Network.HTTP.Enumerator
@ -30,32 +32,57 @@ getForwardUrl :: ( MonadIO m
=> String -- ^ The openid the user provided. => String -- ^ The openid the user provided.
-> String -- ^ The URL for this application\'s complete page. -> String -- ^ The URL for this application\'s complete page.
-> m String -- ^ URL to send the user to. -> m String -- ^ URL to send the user to.
getForwardUrl openid' complete = do getForwardUrl a b = getForwardUrlRealm a b Nothing []
getForwardUrlRealm
:: ( MonadIO m
, Failure AuthenticateException m
, Failure HttpException m
)
=> String -- ^ The openid the user provided.
-> String -- ^ The URL for this application\'s complete page.
-> Maybe String -- ^ Optional realm
-> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
-> m String -- ^ URL to send the user to.
getForwardUrlRealm openid' complete mrealm params = do
let realm = fromMaybe complete mrealm
disc <- normalize openid' >>= discover disc <- normalize openid' >>= discover
case disc of case disc of
Discovery1 server mdelegate -> Discovery1 server mdelegate ->
return $ qsUrl server return $ qsUrl server
[ ("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) : ("openid.realm", realm)
] : ("openid.trust_root", complete)
: params
Discovery2 (Provider p) (Identifier i) -> Discovery2 (Provider p) (Identifier i) ->
return $ qsUrl p return $ qsUrl 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", i)
, ("openid.identity", i) : ("openid.identity", i)
, ("openid.return_to", complete) : ("openid.return_to", complete)
] : ("openid.realm", realm)
: params
authenticate :: ( MonadIO m authenticate
, Failure AuthenticateException m :: ( MonadIO m
, Failure HttpException m , Failure AuthenticateException m
) , Failure HttpException m
=> [(String, String)] )
-> m Identifier => [(String, String)]
authenticate params = do -> m Identifier
authenticate = liftM fst . authenticateParams
authenticateParams
:: ( MonadIO m
, Failure AuthenticateException m
, Failure HttpException m
)
=> [(String, String)]
-> m (Identifier, [(String, String)])
authenticateParams params = do
unless (lookup "openid.mode" params == Just "id_res") unless (lookup "openid.mode" params == Just "id_res")
$ failure $ AuthenticationException "mode is not id_res" $ failure $ AuthenticationException "mode is not id_res"
ident <- case lookup "openid.identity" params of ident <- case lookup "openid.identity" params of
@ -74,7 +101,7 @@ authenticate params = do
rsp <- httpLbsRedirect req rsp <- httpLbsRedirect req
let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
case lookup "is_valid" rps of case lookup "is_valid" rps of
Just "true" -> return $ Identifier ident Just "true" -> return (Identifier ident, rps)
_ -> failure $ AuthenticationException "OpenID provider did not validate" _ -> failure $ AuthenticationException "OpenID provider did not validate"
-- | Turn a response body into a list of parameters. -- | Turn a response body into a list of parameters.

2
authenticate.cabal
View File

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