module Network.OAuth.OAuth2.HttpClient (
fetchAccessToken,
fetchRefreshToken,
doJSONPostRequest,
doSimplePostRequest,
authGetJSON,
authGetBS,
authGetBS',
authPostJSON,
authPostBS,
authRequest,
handleResponse,
parseResponseJSON,
updateRequestHeaders,
setMethod
) 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
fetchAccessToken :: Manager
-> OAuth2
-> BS.ByteString
-> IO (OAuth2Result AccessToken)
fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body
where (uri, body) = accessTokenUrl oa code
fetchRefreshToken :: Manager
-> OAuth2
-> BS.ByteString
-> IO (OAuth2Result AccessToken)
fetchRefreshToken manager oa rtoken = doJSONPostRequest manager oa uri body
where (uri, body) = refreshAccessTokenUrl oa rtoken
doJSONPostRequest :: FromJSON a
=> Manager
-> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result a)
doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body)
doSimplePostRequest :: Manager
-> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result BSL.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
authGetJSON :: FromJSON a
=> Manager
-> AccessToken
-> URI
-> IO (OAuth2Result a)
authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri
authGetBS :: Manager
-> AccessToken
-> URI
-> IO (OAuth2Result BSL.ByteString)
authGetBS manager token url = do
req <- parseUrl $ BS.unpack url
authRequest req upReq manager
where upReq = updateRequestHeaders (Just token) . setMethod HT.GET
authGetBS' :: Manager
-> AccessToken
-> URI
-> IO (OAuth2Result BSL.ByteString)
authGetBS' manager token url = do
req <- parseUrl $ BS.unpack $ url `appendAccessToken` token
authRequest req upReq manager
where upReq = updateRequestHeaders Nothing . setMethod HT.GET
authPostJSON :: FromJSON a
=> Manager
-> AccessToken
-> URI
-> PostBody
-> IO (OAuth2Result a)
authPostJSON manager t uri pb = liftM parseResponseJSON $ authPostBS manager t uri pb
authPostBS :: Manager
-> AccessToken
-> URI
-> PostBody
-> IO (OAuth2Result BSL.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
authRequest :: Request
-> (Request -> Request)
-> Manager
-> IO (OAuth2Result BSL.ByteString)
authRequest req upReq manager = liftM handleResponse (httpLbs (upReq req) manager)
handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString
handleResponse rsp =
if HT.statusIsSuccessful (responseStatus rsp)
then Right $ responseBody rsp
else Left $ BSL.append "hoauth2.HttpClient.parseResponseJSON/Gaining token failed: " (responseBody rsp)
parseResponseJSON :: FromJSON a
=> OAuth2Result BSL.ByteString
-> OAuth2Result a
parseResponseJSON (Left b) = Left b
parseResponseJSON (Right b) = case decode b of
Nothing -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: " `BSL.append` b)
Just x -> Right x
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 }
setMethod :: HT.StdMethod -> Request -> Request
setMethod m req = req { method = HT.renderStdMethod m }