yesod-auth: add a runHttpRequest typeclass method
This commit is contained in:
Greg Weber
parent
bb7f0afe34
commit
3f96cae289
@ -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)
|
||||
|
||||
@ -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" #-}
|
||||
|
||||
@ -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
|
||||
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 @@ 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
|
||||
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.
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user