diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/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) diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -46,6 +46,7 @@ , asHtml ) where +import Control.Applicative ((<$>)) import Control.Monad (when) import Control.Monad.Trans.Maybe @@ -57,11 +58,12 @@ 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 @@ 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. @@ -207,6 +209,16 @@ onErrorHtml dest msg = do 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 #-} diff --git a/Yesod/Auth/GoogleEmail2.hs b/Yesod/Auth/GoogleEmail2.hs --- a/Yesod/Auth/GoogleEmail2.hs +++ b/Yesod/Auth/GoogleEmail2.hs @@ -50,11 +50,11 @@ 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 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 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.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 @@ req' { requestHeaders = [] } - manager <- liftM authHttpManager $ lift getYesod - res <- http req manager - value <- responseBody res $$+- sinkParser json' + value <- makeHttpRequest req token@(Token accessToken' tokenType') <- case parseEither parseJSON value of Left e -> error e @@ -215,7 +215,7 @@ -- 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 @@ 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 -getPersonValue manager token = do +personValueRequest :: MonadIO m => Token -> m Request +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. diff --git a/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/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 @@ , 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