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
import qualified Network.HTTP.Types as HT
import Network.OAuth.OAuth2.Internal
fetchAccessToken :: OAuth2
-> BS.ByteString
-> IO (OAuth2Result AccessToken)
fetchAccessToken oa code = doJSONPostRequest oa uri body
where (uri, body) = accessTokenUrl oa code
fetchRefreshToken :: OAuth2
-> BS.ByteString
-> IO (OAuth2Result AccessToken)
fetchRefreshToken oa rtoken = doJSONPostRequest oa uri body
where (uri, body) = refreshAccessTokenUrl oa rtoken
doJSONPostRequest :: FromJSON a
=> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result a)
doJSONPostRequest oa uri body = liftM parseResponseJSON (doSimplePostRequest oa uri body)
doSimplePostRequest :: OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result BSL.ByteString)
doSimplePostRequest 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
withManager $ httpLbs (urlEncodedBody body req')
authGetJSON :: FromJSON a
=> AccessToken
-> URI
-> IO (OAuth2Result a)
authGetJSON t uri = liftM parseResponseJSON $ authGetBS t uri
authGetBS :: AccessToken
-> URI
-> IO (OAuth2Result BSL.ByteString)
authGetBS token url = liftM handleResponse go
where go = do
req <- parseUrl $ BS.unpack $ url `appendAccessToken` token
authenticatedRequest token HT.GET req
authPostJSON :: FromJSON a
=> AccessToken
-> URI
-> PostBody
-> IO (OAuth2Result a)
authPostJSON t uri pb = liftM parseResponseJSON $ authPostBS t uri pb
authPostBS :: AccessToken
-> URI
-> PostBody
-> IO (OAuth2Result BSL.ByteString)
authPostBS token url pb = liftM handleResponse go
where body = pb ++ accessTokenToParam token
go = do
req <- parseUrl $ BS.unpack url
authenticatedRequest token HT.POST $ urlEncodedBody body req
authenticatedRequest :: AccessToken
-> HT.StdMethod
-> Request
-> IO (Response BSL.ByteString)
authenticatedRequest token m r = withManager
$ httpLbs
$ updateRequestHeaders (Just token)
$ setMethod m r
setMethod :: HT.StdMethod -> Request -> Request
setMethod m req = req { method = HT.renderStdMethod m }
handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString
handleResponse rsp =
if HT.statusCode (responseStatus rsp) == 200
then Right $ responseBody rsp
else Left $ BSL.append "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 ("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 }