diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -39,14 +39,13 @@ -- | Attempt to resolve an OpenID endpoint, and user identifier. discover :: ( MonadIO m - , Failure OpenIdException m + , Failure AuthenticateException m , Failure HttpException m - , Failure InvalidUrlException m ) => Identifier -> m Discovery discover ident@(Identifier i) = do - res1 <- discoverYADIS ident Nothing + res1 <- discoverYADIS ident Nothing 10 case res1 of Just (x, y) -> return $ Discovery2 x y Nothing -> do @@ -61,12 +60,13 @@ -- an OpenID endpoint, and the actual identifier for the user. discoverYADIS :: ( MonadIO m , Failure HttpException m - , Failure InvalidUrlException m ) => Identifier -> Maybe String + -> Int -- ^ remaining redirects -> m (Maybe (Provider,Identifier)) -discoverYADIS ident mb_loc = do +discoverYADIS _ _ 0 = failure TooManyRedirects +discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri res <- httpLbs req @@ -78,7 +78,7 @@ case statusCode res of 200 -> case mloc' of - Just loc -> discoverYADIS ident (Just loc) + Just loc -> discoverYADIS ident (Just loc) (redirects - 1) Nothing -> do let mdoc = parseXRDS $ BSLU.toString $ responseBody res case mdoc of @@ -112,10 +112,7 @@ -- | Attempt to discover an OpenID endpoint, from an HTML document. The result -- will be an endpoint on success, and the actual identifier of the user. -discoverHTML :: ( MonadIO m - , Failure HttpException m - , Failure InvalidUrlException m - ) +discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -24,7 +24,7 @@ import Control.Failure (Failure (..)) import Network.URI -normalize :: Failure OpenIdException m => String -> m Identifier +normalize :: Failure AuthenticateException m => String -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -13,19 +13,11 @@ module OpenId2.Types ( Provider (..) , Identifier (..) - , OpenIdException (..) + , AuthenticateException (..) ) where -- Libraries -import Control.Exception (Exception) -import Data.Typeable (Typeable) - -data OpenIdException = - NormalizationException String - | DiscoveryException String - | AuthenticationException String - deriving (Show, Typeable) -instance Exception OpenIdException +import Web.Authenticate.Internal -- | An OpenID provider. newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -1,18 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Web.Authenticate.Internal ( qsEncode , qsUrl + , AuthenticateException (..) ) where import Codec.Binary.UTF8.String (encode) import Numeric (showHex) import Data.List (intercalate) +import Data.Typeable (Typeable) +import Control.Exception (Exception) +data AuthenticateException = + RpxnowException String + | NormalizationException String + | DiscoveryException String + | AuthenticationException String + deriving (Show, Typeable) +instance Exception AuthenticateException + qsUrl :: String -> [(String, String)] -> String qsUrl s [] = s qsUrl url pairs = url ++ delim : intercalate "&" (map qsPair pairs) where - qsPair (x, y) = qsEncode x ++ '=' : qsEncode y + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y delim = if '?' `elem` url then '&' else '?' qsEncode :: String -> String diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -2,7 +2,7 @@ module Web.Authenticate.OpenId ( getForwardUrl , authenticate - , OpenIdException (..) + , AuthenticateException (..) , Identifier (..) ) where @@ -10,24 +10,22 @@ import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) -import OpenId2.Types (OpenIdException (..), Identifier (Identifier), - Provider (Provider)) +import OpenId2.Types 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 - , HttpException, InvalidUrlException + , HttpException ) import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe) getForwardUrl :: ( MonadIO m - , Failure OpenIdException m + , Failure AuthenticateException m , Failure HttpException m - , Failure InvalidUrlException m ) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. @@ -40,6 +38,7 @@ [ ("openid.mode", "checkid_setup") , ("openid.identity", fromMaybe openid' mdelegate) , ("openid.return_to", complete) + , ("openid.trust_root", complete) ] Discovery2 (Provider p) (Identifier i) -> return $ qsUrl p @@ -51,8 +50,7 @@ ] authenticate :: ( MonadIO m - , Failure OpenIdException m - , Failure InvalidUrlException m + , Failure AuthenticateException m , Failure HttpException m ) => [(String, String)] diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -19,7 +19,7 @@ module Web.Authenticate.Rpxnow ( Identifier (..) , authenticate - , RpxnowException (..) + , AuthenticateException (..) ) where import Data.Object @@ -31,8 +31,8 @@ import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Control.Exception (throwIO, Exception) -import Data.Typeable (Typeable) +import Control.Exception (throwIO) +import Web.Authenticate.Internal -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -43,8 +43,7 @@ -- | Attempt to log a user in. authenticate :: (MonadIO m, Failure HttpException m, - Failure InvalidUrlException m, - Failure RpxnowException m, + Failure AuthenticateException m, Failure ObjectExtractError m, Failure JsonDecodeError m) => String -- ^ API key given by RPXNOW. @@ -73,7 +72,7 @@ res <- httpLbsRedirect req let b = responseBody res unless (200 <= statusCode res && statusCode res < 300) $ - liftIO $ throwIO $ HttpException (statusCode res) b + liftIO $ throwIO $ StatusCodeException (statusCode res) b o <- decode $ S.concat $ L.toChunks b m <- fromMapping o stat <- lookupScalar "stat" m @@ -92,7 +91,3 @@ go ("identifier", _) = Nothing go (k, Scalar v) = Just (k, v) go _ = Nothing - -data RpxnowException = RpxnowException String - deriving (Show, Typeable) -instance Exception RpxnowException diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.6.1 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ build-depends: base >= 4 && < 5, data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, - http-enumerator >= 0.1.1 && < 0.2, + http-enumerator >= 0.2.0 && < 0.3, tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3,