diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index ba60a3a1..6381441e 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -39,9 +39,8 @@ data Discovery = Discovery1 String (Maybe String) -- | 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 @@ -61,14 +60,12 @@ discover ident@(Identifier i) = do -- 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 _ _ 0 = - failure $ InvalidUrlException "" "discoverYADIS redirected too many times" -- FIXME better failure +discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri @@ -115,10 +112,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat -- | 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 index 203c697c..9b71b300 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -24,7 +24,7 @@ import Data.List 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 index 2660ca57..8230d634 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -13,19 +13,13 @@ 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 index 9e410ce7..91393ab1 100644 --- 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 index 8d773653..ab1244d0 100644 --- 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 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 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. @@ -52,8 +50,7 @@ getForwardUrl openid' complete = do ] 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 index 299a9b30..740521dc 100644 --- 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 Data.Maybe 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 @@ data Identifier = Identifier -- | 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 @@ authenticate apiKey token = do 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 @@ 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 diff --git a/authenticate.cabal b/authenticate.cabal index 296a7f42..068a533b 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.6.2 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library 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,