Consolidated exception types

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 =
+discoverYADIS _ _ 0 = failure TooManyRedirects
-    failure $ InvalidUrlException "" "discoverYADIS redirected too many times" -- FIXME better failure
 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
+discoverHTML :: ( MonadIO m, Failure HttpException m)
-                , Failure HttpException m
-                , Failure InvalidUrlException m
-                )
              => Identifier
              -> m (Maybe Discovery)
 discoverHTML ident'@(Identifier ident) =

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

OpenId2/Types.hs

@@ -13,19 +13,13 @@
 module OpenId2.Types (
     Provider (..)
   , Identifier (..)
-  , OpenIdException (..)
+  , AuthenticateException (..)
   ) where
 
 -- Libraries
 import Control.Exception (Exception)
 import Data.Typeable (Typeable)
-
+import Web.Authenticate.Internal
-data OpenIdException =
-      NormalizationException String
-    | DiscoveryException String
-    | AuthenticationException String
-  deriving (Show, Typeable)
-instance Exception OpenIdException
 
 -- | An OpenID provider.
 newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)

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

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),
+import OpenId2.Types
-                      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
-    , 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 AuthenticateException m
-                , Failure InvalidUrlException m
                 , Failure HttpException m
                 )
              => [(String, String)]

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 Control.Exception (throwIO)
-import Data.Typeable (Typeable)
+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 AuthenticateException m,
-                 Failure RpxnowException 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

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 <michael@snoyman.com>
@@ -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,