Merged OpenId and OpenId2
This commit is contained in:
Michael Snoyman
parent
6e575cf027
commit
48f31ed6de
@ -17,7 +17,6 @@ module OpenId2.Discovery (
|
||||
, Discovery (..)
|
||||
) where
|
||||
|
||||
import Debug.Trace -- FIXME
|
||||
-- Friends
|
||||
import OpenId2.Types
|
||||
import OpenId2.XRDS
|
||||
@ -61,7 +60,7 @@ discoverYADIS :: Identifier
|
||||
-> Maybe String
|
||||
-> IO (Maybe (Provider,Identifier))
|
||||
discoverYADIS ident mb_loc = do
|
||||
let uri = fromMaybe (getIdentifier ident) mb_loc
|
||||
let uri = fromMaybe (identifier ident) mb_loc
|
||||
req <- parseUrl uri
|
||||
res <- httpLbs req
|
||||
let mloc = lookup "x-xrds-location"
|
||||
@ -126,9 +125,10 @@ parseHTML ident = resolve
|
||||
prov <- lookup "openid2.provider" ls
|
||||
let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
|
||||
return $ Discovery2 (Provider prov) lid
|
||||
resolve ls = traceShow ls $ resolve2 ls `mplus` resolve1 ls
|
||||
resolve ls = resolve2 ls `mplus` resolve1 ls
|
||||
|
||||
|
||||
-- FIXME this would all be a lot better if it used tagsoup
|
||||
-- | Filter out link tags from a list of html tags.
|
||||
linkTags :: [String] -> [(String,String)]
|
||||
linkTags = mapMaybe f . filter p
|
||||
|
||||
@ -31,5 +31,5 @@ instance Exception OpenIdException
|
||||
newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
|
||||
|
||||
-- | A valid OpenID identifier.
|
||||
newtype Identifier = Identifier { getIdentifier :: String }
|
||||
deriving (Eq,Show,Read)
|
||||
newtype Identifier = Identifier { identifier :: String }
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
@ -1,152 +1,83 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
---------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Web.Authenticate.OpenId
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Unstable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Provides functionality for being an OpenId consumer.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Web.Authenticate.OpenId
|
||||
( Identifier (..)
|
||||
, getForwardUrl
|
||||
( getForwardUrl
|
||||
, authenticate
|
||||
, AuthenticateException (..)
|
||||
, OpenIdException (..)
|
||||
, Identifier (..)
|
||||
) where
|
||||
|
||||
import Network.HTTP.Enumerator
|
||||
import Text.HTML.TagSoup
|
||||
import "transformers" Control.Monad.IO.Class
|
||||
import Data.Data
|
||||
import Control.Failure hiding (Error)
|
||||
import Control.Exception
|
||||
import Control.Monad (liftM, unless)
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import Control.Monad.IO.Class
|
||||
import OpenId2.Normalization (normalize)
|
||||
import OpenId2.Discovery (discover, Discovery (..))
|
||||
import Control.Failure (Failure (failure))
|
||||
import OpenId2.Types (OpenIdException (..), Identifier (Identifier),
|
||||
Provider (Provider))
|
||||
import Web.Authenticate.Internal (qsUrl)
|
||||
import Data.List (intercalate)
|
||||
import Control.Monad (unless)
|
||||
import qualified Data.ByteString.UTF8 as BSU
|
||||
import qualified Data.ByteString.Lazy.UTF8 as BSLU
|
||||
import Network.HTTP.Enumerator
|
||||
(parseUrl, urlEncodedBody, responseBody, httpLbsRedirect)
|
||||
import Control.Arrow ((***))
|
||||
import Data.List (unfoldr)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
-- | An openid identifier (ie, a URL).
|
||||
newtype Identifier = Identifier { identifier :: String }
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Error v = Error String | Ok v
|
||||
instance Monad Error where
|
||||
return = Ok
|
||||
Error s >>= _ = Error s
|
||||
Ok v >>= f = f v
|
||||
fail s = Error s
|
||||
|
||||
-- | Returns a URL to forward the user to in order to login.
|
||||
getForwardUrl :: (MonadIO m,
|
||||
Failure InvalidUrlException m,
|
||||
Failure HttpException m,
|
||||
Failure MissingVar m
|
||||
)
|
||||
getForwardUrl :: (MonadIO m, Failure OpenIdException m)
|
||||
=> String -- ^ The openid the user provided.
|
||||
-> String -- ^ The URL for this application\'s complete page.
|
||||
-> m String -- ^ URL to send the user to.
|
||||
getForwardUrl openid complete = do
|
||||
bodyIdent' <- simpleHttp openid
|
||||
let bodyIdent = L8.unpack bodyIdent'
|
||||
server <- getOpenIdVar "server" bodyIdent
|
||||
let delegate = maybe openid id
|
||||
$ getOpenIdVar "delegate" bodyIdent
|
||||
return $ qsUrl server
|
||||
[ ("openid.mode", "checkid_setup")
|
||||
, ("openid.identity", delegate)
|
||||
, ("openid.return_to", complete)
|
||||
]
|
||||
getForwardUrl openid' complete = do
|
||||
disc <- normalize openid' >>= discover
|
||||
case disc of
|
||||
Discovery1 server mdelegate ->
|
||||
return $ qsUrl server
|
||||
[ ("openid.mode", "checkid_setup")
|
||||
, ("openid.identity", fromMaybe openid' mdelegate)
|
||||
, ("openid.return_to", complete)
|
||||
]
|
||||
Discovery2 (Provider p) (Identifier i) ->
|
||||
return $ 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)
|
||||
]
|
||||
|
||||
data MissingVar = MissingVar String
|
||||
deriving (Typeable, Show)
|
||||
instance Exception MissingVar
|
||||
|
||||
getOpenIdVar :: Failure MissingVar m => String -> String -> m String
|
||||
getOpenIdVar var content = do
|
||||
let tags = parseTags content
|
||||
let secs = sections (~== ("<link rel=openid." ++ var ++ ">")) tags
|
||||
secs' <- mhead secs
|
||||
secs'' <- mhead secs'
|
||||
return $ fromAttrib "href" secs''
|
||||
where
|
||||
mhead [] = failure $ MissingVar $ "openid." ++ var
|
||||
mhead (x:_) = return x
|
||||
|
||||
-- | Handle a redirect from an OpenID provider and check that the user
|
||||
-- logged in properly. If it was successfully, 'return's the openid.
|
||||
-- Otherwise, 'failure's an explanation.
|
||||
authenticate :: (MonadIO m,
|
||||
Failure AuthenticateException m,
|
||||
Failure InvalidUrlException m,
|
||||
Failure HttpException m,
|
||||
Failure MissingVar m)
|
||||
authenticate :: (MonadIO m, Failure OpenIdException m)
|
||||
=> [(String, String)]
|
||||
-> m Identifier
|
||||
authenticate req = do
|
||||
unless (lookup "openid.mode" req == Just "id_res") $
|
||||
failure $ AuthenticateException "authenticate without openid.mode=id_res"
|
||||
authUrl <- getAuthUrl req
|
||||
content <- L8.unpack `liftM` simpleHttp authUrl
|
||||
if contains "is_valid:true" content
|
||||
then Identifier `liftM` alookup "openid.identity" req
|
||||
else failure $ AuthenticateException content
|
||||
authenticate params = do
|
||||
unless (lookup "openid.mode" params == Just "id_res")
|
||||
$ failure $ AuthenticationException "mode is not id_res"
|
||||
ident <- case lookup "openid.identity" params of
|
||||
Just i -> return i
|
||||
Nothing ->
|
||||
failure $ AuthenticationException "Missing identity"
|
||||
disc <- normalize ident >>= discover
|
||||
let endpoint = case disc of
|
||||
Discovery1 p _ -> p
|
||||
Discovery2 (Provider p) _ -> p
|
||||
let params' = map (BSU.fromString *** BSU.fromString)
|
||||
$ ("openid.mode", "check_authentication")
|
||||
: filter (\(k, _) -> k /= "openid.mode") params
|
||||
req' <- liftIO $ parseUrl endpoint
|
||||
let req = urlEncodedBody params' req'
|
||||
rsp <- liftIO $ httpLbsRedirect req
|
||||
let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
|
||||
case lookup "is_valid" rps of
|
||||
Just "true" -> return $ Identifier ident
|
||||
_ -> failure $ AuthenticationException "OpenID provider did not validate"
|
||||
|
||||
alookup :: (Failure AuthenticateException m, Monad m)
|
||||
=> String
|
||||
-> [(String, String)]
|
||||
-> m String
|
||||
alookup k x = case lookup k x of
|
||||
Just k' -> return k'
|
||||
Nothing -> failure $ MissingOpenIdParameter k
|
||||
-- | Turn a response body into a list of parameters.
|
||||
parseDirectResponse :: String -> [(String, String)]
|
||||
parseDirectResponse = unfoldr step
|
||||
where
|
||||
step [] = Nothing
|
||||
step str = case split (== '\n') str of
|
||||
(ps,rest) -> Just (split (== ':') ps,rest)
|
||||
|
||||
data AuthenticateException = AuthenticateException String
|
||||
| MissingOpenIdParameter String
|
||||
deriving (Show, Typeable)
|
||||
instance Exception AuthenticateException
|
||||
|
||||
getAuthUrl :: (MonadIO m, Failure AuthenticateException m,
|
||||
Failure InvalidUrlException m,
|
||||
Failure HttpException m,
|
||||
Failure MissingVar m)
|
||||
=> [(String, String)] -> m String
|
||||
getAuthUrl req = do
|
||||
identity <- alookup "openid.identity" req
|
||||
idContent <- simpleHttp identity
|
||||
helper $ L8.unpack idContent
|
||||
where
|
||||
helper idContent = do
|
||||
server <- getOpenIdVar "server" idContent
|
||||
dargs <- mapM makeArg [
|
||||
"assoc_handle",
|
||||
"sig",
|
||||
"signed",
|
||||
"identity",
|
||||
"return_to"
|
||||
]
|
||||
let sargs = [("openid.mode", "check_authentication")]
|
||||
return $ qsUrl server $ dargs ++ sargs
|
||||
makeArg s = do
|
||||
let k = "openid." ++ s
|
||||
v <- alookup k req
|
||||
return (k, v)
|
||||
|
||||
contains :: String -> String -> Bool
|
||||
contains [] _ = True
|
||||
contains _ [] = False
|
||||
contains needle haystack =
|
||||
begins needle haystack ||
|
||||
(contains needle $ tail haystack)
|
||||
|
||||
begins :: String -> String -> Bool
|
||||
begins [] _ = True
|
||||
begins _ [] = False
|
||||
begins (x:xs) (y:ys) = x == y && begins xs ys
|
||||
split :: (a -> Bool) -> [a] -> ([a],[a])
|
||||
split p as = case break p as of
|
||||
(xs,_:ys) -> (xs,ys)
|
||||
pair -> pair
|
||||
|
||||
@ -1,82 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Web.Authenticate.OpenId2
|
||||
( getForwardUrl
|
||||
, authenticate
|
||||
, OpenIdException (..)
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import OpenId2.Normalization (normalize)
|
||||
import OpenId2.Discovery (discover, Discovery (..))
|
||||
import Control.Failure (Failure (failure))
|
||||
import OpenId2.Types (OpenIdException (..), Identifier (Identifier),
|
||||
Provider (Provider))
|
||||
import Web.Authenticate.Internal (qsUrl)
|
||||
import Control.Monad (unless)
|
||||
import qualified Data.ByteString.UTF8 as BSU
|
||||
import qualified Data.ByteString.Lazy.UTF8 as BSLU
|
||||
import Network.HTTP.Enumerator
|
||||
(parseUrl, urlEncodedBody, responseBody, httpLbsRedirect)
|
||||
import Control.Arrow ((***))
|
||||
import Data.List (unfoldr)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
getForwardUrl :: (MonadIO m, Failure OpenIdException m)
|
||||
=> String -- ^ The openid the user provided.
|
||||
-> String -- ^ The URL for this application\'s complete page.
|
||||
-> m String -- ^ URL to send the user to.
|
||||
getForwardUrl openid' complete = do
|
||||
disc <- normalize openid' >>= discover
|
||||
case disc of
|
||||
Discovery1 server mdelegate ->
|
||||
return $ qsUrl server
|
||||
[ ("openid.mode", "checkid_setup")
|
||||
, ("openid.identity", fromMaybe openid' mdelegate)
|
||||
, ("openid.return_to", complete)
|
||||
]
|
||||
Discovery2 (Provider p) (Identifier i) ->
|
||||
return $ 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)
|
||||
]
|
||||
|
||||
authenticate :: (MonadIO m, Failure OpenIdException m)
|
||||
=> [(String, String)]
|
||||
-> m String
|
||||
authenticate params = do
|
||||
unless (lookup "openid.mode" params == Just "id_res")
|
||||
$ failure $ AuthenticationException "mode is not id_res"
|
||||
ident <- case lookup "openid.identity" params of
|
||||
Just i -> return i
|
||||
Nothing ->
|
||||
failure $ AuthenticationException "Missing identity"
|
||||
disc <- normalize ident >>= discover
|
||||
let endpoint = case disc of
|
||||
Discovery1 p _ -> p
|
||||
Discovery2 (Provider p) _ -> p
|
||||
let params' = map (BSU.fromString *** BSU.fromString)
|
||||
$ ("openid.mode", "check_authentication")
|
||||
: filter (\(k, _) -> k /= "openid.mode") params
|
||||
req' <- liftIO $ parseUrl endpoint
|
||||
let req = urlEncodedBody params' req'
|
||||
rsp <- liftIO $ httpLbsRedirect req
|
||||
let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
|
||||
case lookup "is_valid" rps of
|
||||
Just "true" -> return ident
|
||||
_ -> failure $ AuthenticationException "OpenID provider did not validate"
|
||||
|
||||
-- | Turn a response body into a list of parameters.
|
||||
parseDirectResponse :: String -> [(String, String)]
|
||||
parseDirectResponse = unfoldr step
|
||||
where
|
||||
step [] = Nothing
|
||||
step str = case split (== '\n') str of
|
||||
(ps,rest) -> Just (split (== ':') ps,rest)
|
||||
|
||||
split :: (a -> Bool) -> [a] -> ([a],[a])
|
||||
split p as = case break p as of
|
||||
(xs,_:ys) -> (xs,ys)
|
||||
pair -> pair
|
||||
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Authenticate.Rpxnow
|
||||
@ -18,6 +19,7 @@
|
||||
module Web.Authenticate.Rpxnow
|
||||
( Identifier (..)
|
||||
, authenticate
|
||||
, RpxnowException (..)
|
||||
) where
|
||||
|
||||
import Data.Object
|
||||
@ -26,11 +28,11 @@ import Network.HTTP.Enumerator
|
||||
import "transformers" Control.Monad.IO.Class
|
||||
import Control.Failure
|
||||
import Data.Maybe
|
||||
import Web.Authenticate.OpenId (AuthenticateException (..))
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as S
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Exception (throwIO, Exception)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
-- | Information received from Rpxnow after a valid login.
|
||||
data Identifier = Identifier
|
||||
@ -42,7 +44,7 @@ data Identifier = Identifier
|
||||
authenticate :: (MonadIO m,
|
||||
Failure HttpException m,
|
||||
Failure InvalidUrlException m,
|
||||
Failure AuthenticateException m,
|
||||
Failure RpxnowException m,
|
||||
Failure ObjectExtractError m,
|
||||
Failure JsonDecodeError m)
|
||||
=> String -- ^ API key given by RPXNOW.
|
||||
@ -75,7 +77,7 @@ authenticate apiKey token = do
|
||||
o <- decode $ S.concat $ L.toChunks b
|
||||
m <- fromMapping o
|
||||
stat <- lookupScalar "stat" m
|
||||
unless (stat == "ok") $ failure $ AuthenticateException $
|
||||
unless (stat == "ok") $ failure $ RpxnowException $
|
||||
"Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b
|
||||
parseProfile m
|
||||
|
||||
@ -90,3 +92,7 @@ parseProfile m = do
|
||||
go ("identifier", _) = Nothing
|
||||
go (k, Scalar v) = Just (k, v)
|
||||
go _ = Nothing
|
||||
|
||||
data RpxnowException = RpxnowException String
|
||||
deriving (Show, Typeable)
|
||||
instance Exception RpxnowException
|
||||
|
||||
@ -27,7 +27,6 @@ library
|
||||
xml >= 1.3.7 && < 1.4
|
||||
exposed-modules: Web.Authenticate.Rpxnow,
|
||||
Web.Authenticate.OpenId,
|
||||
Web.Authenticate.OpenId2,
|
||||
Web.Authenticate.Facebook
|
||||
other-modules: Web.Authenticate.Internal,
|
||||
OpenId2.Discovery,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user