hoauth2-0.4.6: src/Network/OAuth/OAuth2/HttpClient.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
-- | A simple http client to request OAuth2 tokens and several utils.
module Network.OAuth.OAuth2.HttpClient where
import Control.Monad (liftM)
import Data.Aeson
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Maybe
import Network.HTTP.Conduit hiding (withManager)
import qualified Network.HTTP.Types as HT
import Network.OAuth.OAuth2.Internal
--------------------------------------------------
-- * Retrieve access token
--------------------------------------------------
-- | Request (via POST method) "Access Token".
--
--
fetchAccessToken :: Manager -- ^ HTTP connection manager
-> OAuth2 -- ^ OAuth Data
-> BS.ByteString -- ^ Authentication code gained after authorization
-> IO (OAuth2Result AccessToken) -- ^ Access Token
fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body
where (uri, body) = accessTokenUrl oa code
-- | Request the "Refresh Token".
fetchRefreshToken :: Manager -- ^ HTTP connection manager.
-> OAuth2 -- ^ OAuth context
-> BS.ByteString -- ^ refresh token gained after authorization
-> IO (OAuth2Result AccessToken)
fetchRefreshToken manager oa rtoken = doJSONPostRequest manager oa uri body
where (uri, body) = refreshAccessTokenUrl oa rtoken
-- | Conduct post request and return response as JSON.
doJSONPostRequest :: FromJSON a
=> Manager -- ^ HTTP connection manager.
-> OAuth2 -- ^ OAuth options
-> URI -- ^ The URL
-> PostBody -- ^ request body
-> IO (OAuth2Result a) -- ^ Response as ByteString
doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body)
-- | Conduct post request.
doSimplePostRequest :: Manager -- ^ HTTP connection manager.
-> OAuth2 -- ^ OAuth options
-> URI -- ^ URL
-> PostBody -- ^ Request body.
-> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString
doSimplePostRequest manager oa url body = liftM handleResponse go
where go = do
req <- parseUrl $ BS.unpack url
let addBasicAuth = applyBasicAuth (oauthClientId oa) (oauthClientSecret oa)
req' = (addBasicAuth . updateRequestHeaders Nothing) req
httpLbs (urlEncodedBody body req') manager
--------------------------------------------------
-- * AUTH requests
--------------------------------------------------
-- | Conduct GET request and return response as JSON.
--
authGetJSON :: FromJSON a
=> Manager -- ^ HTTP connection manager.
-> AccessToken
-> URI -- ^ Full URL
-> IO (OAuth2Result a) -- ^ Response as JSON
authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri
-- | Conduct GET request.
--
authGetBS :: Manager -- ^ HTTP connection manager.
-> AccessToken
-> URI -- ^ URL
-> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString
authGetBS manager token url = do
req <- parseUrl $ BS.unpack url
authRequest req upReq manager
where upReq = updateRequestHeaders (Just token) . setMethod HT.GET
-- | same to 'authGetBS' but set access token to query parameter rather than header
--
authGetBS' :: Manager -- ^ HTTP connection manager.
-> AccessToken
-> URI -- ^ URL
-> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString
authGetBS' manager token url = do
req <- parseUrl $ BS.unpack $ url `appendAccessToken` token
authRequest req upReq manager
where upReq = updateRequestHeaders Nothing . setMethod HT.GET
-- | Conduct POST request and return response as JSON.
authPostJSON :: FromJSON a
=> Manager -- ^ HTTP connection manager.
-> AccessToken
-> URI -- ^ Full URL
-> PostBody
-> IO (OAuth2Result a) -- ^ Response as JSON
authPostJSON manager t uri pb = liftM parseResponseJSON $ authPostBS manager t uri pb
-- | Conduct POST request.
authPostBS :: Manager -- ^ HTTP connection manager.
-> AccessToken
-> URI -- ^ URL
-> PostBody
-> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString
authPostBS manager token url pb = do
req <- parseUrl $ BS.unpack url
authRequest req upReq manager
where upBody = urlEncodedBody (pb ++ accessTokenToParam token)
upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST
upReq = upHeaders . upBody
-- |Sends a HTTP request including the Authorization header with the specified
-- access token.
--
authRequest :: Request -- ^ Request to perform
-> (Request -> Request) -- ^ Modify request before sending
-> Manager -- ^ HTTP connection manager.
-> IO (OAuth2Result BSL.ByteString)
authRequest req upReq manager = liftM handleResponse (authRequest' req upReq manager)
authRequest' :: Request -- ^ Request to perform
-> (Request -> Request) -- ^ Modify request before sending
-> Manager -- ^ HTTP connection manager.
-> IO (Response BSL.ByteString)
authRequest' req upReq = httpLbs (upReq req)
--------------------------------------------------
-- * Utilities
--------------------------------------------------
-- | Parses a @Response@ to to @OAuth2Result@
--
handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString
handleResponse rsp =
if HT.statusIsSuccessful (responseStatus rsp)
then Right $ responseBody rsp
else Left $ BSL.append "Gaining token failed: " (responseBody rsp)
-- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@
--
parseResponseJSON :: FromJSON a
=> OAuth2Result BSL.ByteString
-> OAuth2Result a
parseResponseJSON (Left b) = Left b
parseResponseJSON (Right b) = case decode b of
Nothing -> Left ("Could not decode JSON" `BSL.append` b)
Just x -> Right x
-- | set several header values.
-- + userAgennt : hoauth2
-- + accept : application/json
-- + authorization : Bearer xxxxx if AccessToken provided.
--
updateRequestHeaders :: Maybe AccessToken -> Request -> Request
updateRequestHeaders t req =
let extras = [ (HT.hUserAgent, "hoauth2")
, (HT.hAccept, "application/json") ]
bearer = [(HT.hAuthorization, "Bearer " `BS.append` accessToken (fromJust t)) | isJust t]
headers = bearer ++ extras ++ requestHeaders req
in
req { requestHeaders = headers }
-- | Sets the HTTP method to use
--
setMethod :: HT.StdMethod -> Request -> Request
setMethod m req = req { method = HT.renderStdMethod m }