From 63853a78dfffbf6edf70b20bcf32d0a73bf6e15d Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 5 Oct 2010 11:16:42 +0200
Subject: [PATCH] Proper exception propogation

---
 OpenId2/Discovery.hs       | 32 ++++++++++++++++++++++----------
 Web/Authenticate/OpenId.hs | 20 +++++++++++++++-----
 2 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs
index 7922638a..9ba7385a 100644
--- a/OpenId2/Discovery.hs
+++ b/OpenId2/Discovery.hs
@@ -29,25 +29,28 @@ import Network.HTTP.Enumerator
 import qualified Data.ByteString.Lazy.UTF8 as BSLU
 import qualified Data.ByteString.Char8 as S8
 import Control.Arrow (first, (***))
-import Control.Applicative ((<$>))
-import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.IO.Class (MonadIO)
 import Control.Failure (Failure (failure))
-import Control.Monad (mplus)
+import Control.Monad (mplus, liftM)
 
 data Discovery = Discovery1 String (Maybe String)
                | Discovery2 Provider Identifier
     deriving Show
 
 -- | Attempt to resolve an OpenID endpoint, and user identifier.
-discover :: (MonadIO m, Failure OpenIdException m)
+discover :: ( MonadIO m
+            , Failure OpenIdException m
+            , Failure HttpException m
+            , Failure InvalidUrlException m
+            )
          => Identifier
          -> m Discovery
 discover ident@(Identifier i) = do
-    res1 <- liftIO $ discoverYADIS ident Nothing
+    res1 <- discoverYADIS ident Nothing
     case res1 of
         Just (x, y) -> return $ Discovery2 x y
         Nothing -> do
-            res2 <- liftIO $ discoverHTML ident
+            res2 <- discoverHTML ident
             case res2 of
                 Just x -> return x
                 Nothing -> failure $ DiscoveryException i
@@ -56,9 +59,13 @@ discover ident@(Identifier i) = do
 
 -- | Attempt a YADIS based discovery, given a valid identifier.  The result is
 --   an OpenID endpoint, and the actual identifier for the user.
-discoverYADIS :: Identifier
+discoverYADIS :: ( MonadIO m
+                 , Failure HttpException m
+                 , Failure InvalidUrlException m
+                 )
+              => Identifier
               -> Maybe String
-              -> IO (Maybe (Provider,Identifier))
+              -> m (Maybe (Provider,Identifier))
 discoverYADIS ident mb_loc = do
     let uri = fromMaybe (identifier ident) mb_loc
     req <- parseUrl uri
@@ -103,9 +110,14 @@ 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 :: Identifier -> IO (Maybe Discovery)
+discoverHTML :: ( MonadIO m
+                , Failure HttpException m
+                , Failure InvalidUrlException m
+                )
+             => Identifier
+             -> m (Maybe Discovery)
 discoverHTML ident'@(Identifier ident) =
-    parseHTML ident' . BSLU.toString <$> simpleHttp ident
+    (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident
 
 -- | Parse out an OpenID endpoint and an actual identifier from an HTML
 -- document.
diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs
index 0652a052..8c510320 100644
--- a/Web/Authenticate/OpenId.hs
+++ b/Web/Authenticate/OpenId.hs
@@ -17,12 +17,18 @@ 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)
+    ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
+    , HttpException, InvalidUrlException
+    )
 import Control.Arrow ((***))
 import Data.List (unfoldr)
 import Data.Maybe (fromMaybe)
 
-getForwardUrl :: (MonadIO m, Failure OpenIdException m)
+getForwardUrl :: ( MonadIO m
+                 , Failure OpenIdException m
+                 , Failure HttpException m
+                 , Failure InvalidUrlException m
+                 )
               => String -- ^ The openid the user provided.
               -> String -- ^ The URL for this application\'s complete page.
               -> m String -- ^ URL to send the user to.
@@ -44,7 +50,11 @@ getForwardUrl openid' complete = do
                 , ("openid.return_to", complete)
                 ]
 
-authenticate :: (MonadIO m, Failure OpenIdException m)
+authenticate :: ( MonadIO m
+                , Failure OpenIdException m
+                , Failure InvalidUrlException m
+                , Failure HttpException m
+                )
              => [(String, String)]
              -> m Identifier
 authenticate params = do
@@ -61,9 +71,9 @@ authenticate params = do
     let params' = map (BSU.fromString *** BSU.fromString)
                 $ ("openid.mode", "check_authentication")
                 : filter (\(k, _) -> k /= "openid.mode") params
-    req' <- liftIO $ parseUrl endpoint
+    req' <- parseUrl endpoint
     let req = urlEncodedBody params' req'
-    rsp <- liftIO $ httpLbsRedirect req
+    rsp <- httpLbsRedirect req
     let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
     case lookup "is_valid" rps of
         Just "true" -> return $ Identifier ident