OpenId uses Text
This commit is contained in:
Michael Snoyman
parent
72281c7fa0
commit
705528277c
@ -33,6 +33,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Failure (Failure (failure))
|
||||
import Control.Monad (mplus, liftM)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Text (Text, pack, unpack)
|
||||
|
||||
data Discovery = Discovery1 String (Maybe String)
|
||||
| Discovery2 Provider Identifier IdentType
|
||||
@ -53,7 +54,7 @@ discover ident@(Identifier i) = do
|
||||
res2 <- discoverHTML ident
|
||||
case res2 of
|
||||
Just x -> return x
|
||||
Nothing -> failure $ DiscoveryException i
|
||||
Nothing -> failure $ DiscoveryException $ unpack i
|
||||
|
||||
-- YADIS-Based Discovery -------------------------------------------------------
|
||||
|
||||
@ -68,7 +69,7 @@ discoverYADIS :: ( MonadIO m
|
||||
-> m (Maybe (Provider, Identifier, IdentType))
|
||||
discoverYADIS _ _ 0 = failure TooManyRedirects
|
||||
discoverYADIS ident mb_loc redirects = do
|
||||
let uri = fromMaybe (identifier ident) mb_loc
|
||||
let uri = fromMaybe (unpack $ identifier ident) mb_loc
|
||||
req <- parseUrl uri
|
||||
res <- liftIO $ withManager $ httpLbs req
|
||||
let mloc = fmap S8.unpack
|
||||
@ -95,7 +96,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
|
||||
where
|
||||
isOpenId svc = do
|
||||
let tys = serviceTypes svc
|
||||
localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc
|
||||
localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc
|
||||
f (x,y) | x `elem` tys = Just y
|
||||
| otherwise = Nothing
|
||||
(lid, itype) <- listToMaybe $ mapMaybe f
|
||||
@ -117,7 +118,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m)
|
||||
=> Identifier
|
||||
-> m (Maybe Discovery)
|
||||
discoverHTML ident'@(Identifier ident) =
|
||||
(parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident
|
||||
(parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident)
|
||||
|
||||
-- | Parse out an OpenID endpoint and an actual identifier from an HTML
|
||||
-- document.
|
||||
@ -135,7 +136,7 @@ parseHTML ident = resolve
|
||||
return $ Discovery1 server delegate
|
||||
resolve2 ls = do
|
||||
prov <- lookup "openid2.provider" ls
|
||||
let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
|
||||
let lid = maybe ident (Identifier . pack) $ lookup "openid2.local_id" ls
|
||||
-- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only
|
||||
-- result in a claimed identifier.
|
||||
return $ Discovery2 (Provider prov) lid ClaimedIdent
|
||||
|
||||
@ -26,12 +26,13 @@ import Network.URI
|
||||
( uriToString, normalizeCase, normalizeEscape
|
||||
, normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment
|
||||
)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
|
||||
normalize :: Failure AuthenticateException m => String -> m Identifier
|
||||
normalize :: Failure AuthenticateException m => Text -> m Identifier
|
||||
normalize ident =
|
||||
case normalizeIdentifier $ Identifier ident of
|
||||
Just i -> return i
|
||||
Nothing -> failure $ NormalizationException ident
|
||||
Nothing -> failure $ NormalizationException $ unpack ident
|
||||
|
||||
-- | Normalize an identifier, discarding XRIs.
|
||||
normalizeIdentifier :: Identifier -> Maybe Identifier
|
||||
@ -42,12 +43,13 @@ normalizeIdentifier = normalizeIdentifier' (const Nothing)
|
||||
-- normalize an XRI.
|
||||
normalizeIdentifier' :: (String -> Maybe String) -> Identifier
|
||||
-> Maybe Identifier
|
||||
normalizeIdentifier' xri (Identifier str)
|
||||
normalizeIdentifier' xri (Identifier str')
|
||||
| null str = Nothing
|
||||
| "xri://" `isPrefixOf` str = Identifier `fmap` xri str
|
||||
| head str `elem` "=@+$!" = Identifier `fmap` xri str
|
||||
| "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str
|
||||
| head str `elem` "=@+$!" = (Identifier . pack) `fmap` xri str
|
||||
| otherwise = fmt `fmap` (url >>= norm)
|
||||
where
|
||||
str = unpack str'
|
||||
url = parseURI str <|> parseURI ("http://" ++ str)
|
||||
|
||||
norm uri = validScheme >> return u
|
||||
@ -59,6 +61,7 @@ normalizeIdentifier' xri (Identifier str)
|
||||
| otherwise = uriPath uri
|
||||
|
||||
fmt u = Identifier
|
||||
$ pack
|
||||
$ normalizePathSegments
|
||||
$ normalizeEscape
|
||||
$ normalizeCase
|
||||
|
||||
@ -21,12 +21,13 @@ module OpenId2.Types (
|
||||
import Data.Data (Data)
|
||||
import Data.Typeable (Typeable)
|
||||
import Web.Authenticate.Internal
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | An OpenID provider.
|
||||
newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
|
||||
|
||||
-- | A valid OpenID identifier.
|
||||
newtype Identifier = Identifier { identifier :: String }
|
||||
newtype Identifier = Identifier { identifier :: Text }
|
||||
deriving (Eq, Ord, Show, Read, Data, Typeable)
|
||||
|
||||
data IdentType = OPIdent | ClaimedIdent
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Web.Authenticate.OpenId
|
||||
( getForwardUrl
|
||||
, authenticate
|
||||
@ -22,25 +23,28 @@ import Network.HTTP.Enumerator
|
||||
import Control.Arrow ((***))
|
||||
import Data.List (unfoldr)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
|
||||
getForwardUrl
|
||||
:: ( 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.
|
||||
=> Text -- ^ The openid the user provided.
|
||||
-> Text -- ^ The URL for this application\'s complete page.
|
||||
-> Maybe Text -- ^ Optional realm
|
||||
-> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
|
||||
-> m Text -- ^ URL to send the user to.
|
||||
getForwardUrl openid' complete mrealm params = do
|
||||
let realm = fromMaybe complete mrealm
|
||||
disc <- normalize openid' >>= discover
|
||||
case disc of
|
||||
Discovery1 server mdelegate ->
|
||||
return $ qsUrl server
|
||||
return $ pack $ qsUrl server
|
||||
$ map (unpack *** unpack) -- FIXME
|
||||
$ ("openid.mode", "checkid_setup")
|
||||
: ("openid.identity", fromMaybe openid' mdelegate)
|
||||
: ("openid.identity", maybe openid' pack mdelegate)
|
||||
: ("openid.return_to", complete)
|
||||
: ("openid.realm", realm)
|
||||
: ("openid.trust_root", complete)
|
||||
@ -50,22 +54,22 @@ getForwardUrl openid' complete mrealm params = do
|
||||
case itype of
|
||||
ClaimedIdent -> i
|
||||
OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"
|
||||
return $ qsUrl p
|
||||
return $ pack $ 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)
|
||||
: ("openid.realm", realm)
|
||||
: params
|
||||
: ("openid.claimed_id", unpack i')
|
||||
: ("openid.identity", unpack i')
|
||||
: ("openid.return_to", unpack complete)
|
||||
: ("openid.realm", unpack realm)
|
||||
: map (unpack *** unpack) params
|
||||
|
||||
authenticate
|
||||
:: ( MonadIO m
|
||||
, Failure AuthenticateException m
|
||||
, Failure HttpException m
|
||||
)
|
||||
=> [(String, String)]
|
||||
-> m (Identifier, [(String, String)])
|
||||
=> [(Text, Text)]
|
||||
-> m (Identifier, [(Text, Text)])
|
||||
authenticate params = do
|
||||
unless (lookup "openid.mode" params == Just "id_res")
|
||||
$ failure $ case lookup "openid.mode" params of
|
||||
@ -74,8 +78,8 @@ authenticate params = do
|
||||
| m == "error" ->
|
||||
case lookup "openid.error" params of
|
||||
Nothing -> AuthenticationException "An error occurred, but no error message was provided."
|
||||
(Just e) -> AuthenticationException e
|
||||
| otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res."
|
||||
(Just e) -> AuthenticationException $ unpack e
|
||||
| otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res."
|
||||
ident <- case lookup "openid.identity" params of
|
||||
Just i -> return i
|
||||
Nothing ->
|
||||
@ -84,20 +88,21 @@ authenticate params = do
|
||||
let endpoint = case disc of
|
||||
Discovery1 p _ -> p
|
||||
Discovery2 (Provider p) _ _ -> p
|
||||
let params' = map (BSU.fromString *** BSU.fromString)
|
||||
let params' = map (encodeUtf8 *** encodeUtf8)
|
||||
$ ("openid.mode", "check_authentication")
|
||||
: filter (\(k, _) -> k /= "openid.mode") params
|
||||
req' <- parseUrl endpoint
|
||||
let req = urlEncodedBody params' req'
|
||||
rsp <- liftIO $ withManager $ httpLbsRedirect req
|
||||
let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
|
||||
let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME
|
||||
case lookup "is_valid" rps of
|
||||
Just "true" -> return (Identifier ident, rps)
|
||||
_ -> failure $ AuthenticationException "OpenID provider did not validate"
|
||||
|
||||
-- | Turn a response body into a list of parameters.
|
||||
parseDirectResponse :: String -> [(String, String)]
|
||||
parseDirectResponse = unfoldr step
|
||||
parseDirectResponse :: Text -> [(Text, Text)]
|
||||
parseDirectResponse =
|
||||
map (pack *** pack) . unfoldr step . unpack
|
||||
where
|
||||
step [] = Nothing
|
||||
step str = case split (== '\n') str of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user