yesod-auth: add a runHttpRequest typeclass method

yesod-auth/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.7
+
+* add a runHttpRequest function for handling HTTP errors
+
 ## 1.4.6
 
 * Use nonce package to generate verification keys and CSRF tokens [#1011](https://github.com/yesodweb/yesod/pull/1011)

yesod-auth/Yesod/Auth.hs

@@ -46,6 +46,7 @@ module Yesod.Auth
     , asHtml
     ) where
 
+import           Control.Applicative ((<$>))
 import Control.Monad                 (when)
 import Control.Monad.Trans.Maybe
 
@@ -57,11 +58,12 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.HashMap.Lazy as Map
 import Data.Monoid (Endo)
-import Network.HTTP.Conduit (Manager)
+import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
 
 import qualified Network.Wai as W
 
 import Yesod.Core
+import Yesod.Core.Types (HandlerT(..), unHandlerT)
 import Yesod.Persist
 import Yesod.Auth.Message (AuthMessage, defaultMessage)
 import qualified Yesod.Auth.Message as Msg
@@ -146,7 +148,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     authPlugins :: master -> [AuthPlugin master]
 
     -- | What to show on the login page.
-    -- 
+    --
     -- Default handler concatenates plugin widgets and wraps the result
     -- in 'authLayout'. Override if you need fancy widget containers
     -- or entirely custom page.
@@ -208,6 +210,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
         setMessage $ toHtml msg
         fmap asHtml $ redirect dest
 
+    -- | runHttpRequest gives you a chance to handle an HttpException and retry
+    --  The default behavior is to simply execute the request which will throw an exception on failure
+    --
+    --  The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
+    --  This is an experimental API that is not broadly used throughout the yesod-auth code base
+    runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a
+    runHttpRequest req inner = do
+      man <- authHttpManager <$> getYesod
+      HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t
+
     {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
 
 {-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -50,11 +50,11 @@ module Yesod.Auth.GoogleEmail2
 import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
                                            AuthRoute, Creds (Creds),
                                            Route (PluginR), YesodAuth,
-                                           authHttpManager, setCredsRedirect)
+                                           runHttpRequest, setCredsRedirect)
 import qualified Yesod.Auth.Message       as Msg
 import           Yesod.Core               (HandlerSite, HandlerT, MonadHandler,
                                            TypedContent, getRouteToParent,
-                                           getUrlRender, getYesod, invalidArgs,
+                                           getUrlRender, invalidArgs,
                                            lift, liftIO, lookupGetParam,
                                            lookupSession, notFound, redirect,
                                            setSession, whamlet, (.:))
@@ -63,7 +63,8 @@ import           Yesod.Core               (HandlerSite, HandlerT, MonadHandler,
 import           Blaze.ByteString.Builder (fromByteString, toByteString)
 import           Control.Applicative      ((<$>), (<*>))
 import           Control.Arrow            (second)
-import           Control.Monad            (liftM, unless, when)
+import           Control.Monad            (unless, when)
+import           Control.Monad.IO.Class   (MonadIO)
 import qualified Crypto.Nonce             as Nonce
 import           Data.Aeson               ((.:?))
 import qualified Data.Aeson               as A
@@ -71,7 +72,7 @@ import qualified Data.Aeson.Encode        as A
 import           Data.Aeson.Parser        (json')
 import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
                                            parseMaybe, withObject, withText)
-import           Data.Conduit             (($$+-))
+import           Data.Conduit             (($$+-), ($$))
 import           Data.Conduit.Attoparsec  (sinkParser)
 import qualified Data.HashMap.Strict      as M
 import           Data.Maybe               (fromMaybe)
@@ -83,7 +84,8 @@ import qualified Data.Text.Lazy           as TL
 import qualified Data.Text.Lazy.Builder   as TL
 import           Network.HTTP.Client      (Manager, parseUrl, requestHeaders,
                                            responseBody, urlEncodedBody)
-import           Network.HTTP.Conduit     (http)
+import           Network.HTTP.Client.Conduit (Request, bodyReaderSource)
+import           Network.HTTP.Conduit (http)
 import           Network.HTTP.Types       (renderQueryText)
 import           System.IO.Unsafe         (unsafePerformIO)
 
@@ -202,9 +204,7 @@ authPlugin storeToken clientID clientSecret =
                     req'
                         { requestHeaders = []
                         }
-        manager <- liftM authHttpManager $ lift getYesod
+        value <- makeHttpRequest req
-        res <- http req manager
-        value <- responseBody res $$+- sinkParser json'
         token@(Token accessToken' tokenType') <-
             case parseEither parseJSON value of
                 Left e -> error e
@@ -215,7 +215,7 @@ authPlugin storeToken clientID clientSecret =
         -- User's access token is saved for further access to API
         when storeToken $ setSession accessTokenKey accessToken'
 
-        personValue <- lift $ getPersonValue manager token
+        personValue <- makeHttpRequest =<< personValueRequest token
         person <- case parseEither parseJSON personValue of
                 Left e -> error e
                 Right x -> return x
@@ -229,25 +229,33 @@ authPlugin storeToken clientID clientSecret =
 
     dispatch _ _ = notFound
 
+makeHttpRequest
+  :: (YesodAuth site)
+  => Request
+  -> HandlerT Auth (HandlerT site IO) A.Value
+makeHttpRequest req = lift $
+    runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'
+
 -- | Allows to fetch information about a user from Google's API.
 --   In case of parsing error returns 'Nothing'.
 --   Will throw 'HttpException' in case of network problems or error response code.
 --
 -- Since 1.4.3
 getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)
-getPerson manager token = parseMaybe parseJSON <$> getPersonValue manager token
+getPerson manager token = parseMaybe parseJSON <$> (do
+    req <- personValueRequest token
+    res <- http req manager
+    responseBody res $$+- sinkParser json'
+  )
 
-getPersonValue :: Manager -> Token -> HandlerT site IO A.Value
+personValueRequest :: MonadIO m => Token -> m Request
-getPersonValue manager token = do
+personValueRequest token = do
     req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
-    let req2 = req2'
+    return req2'
             { requestHeaders =
                 [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)
                 ]
             }
-    res2 <- http req2 manager
-    val <- responseBody res2 $$+- sinkParser json'
-    return val
 
 --------------------------------------------------------------------------------
 -- | An authentication token which was acquired from OAuth callback.

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.4.6.1
+version:         1.4.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -39,7 +39,8 @@ library
                    , transformers            >= 0.2.2
                    , persistent              >= 2.1       && < 2.3
                    , persistent-template     >= 2.1       && < 2.2
-                   , http-conduit            >= 1.5
+                   , http-client
+                   , http-conduit            >= 2.1
                    , aeson                   >= 0.7
                    , lifted-base             >= 0.1
                    , blaze-html              >= 0.5