module Network.OAuth.OAuth2.HttpClient where
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (ResourceT)
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 uri body
where (uri, body) = accessTokenUrl oa code
fetchRefreshToken :: OAuth2
-> BS.ByteString
-> IO (OAuth2Result AccessToken)
fetchRefreshToken oa rtoken = doJSONPostRequest uri body
where (uri, body) = refreshAccessTokenUrl oa rtoken
doJSONPostRequest :: FromJSON a
=> URI
-> PostBody
-> IO (OAuth2Result a)
doJSONPostRequest uri body = liftM parseResponseJSON (doSimplePostRequest uri body)
doSimplePostRequest :: URI
-> PostBody
-> IO (OAuth2Result BSL.ByteString)
doSimplePostRequest url body = liftM handleResponse go
where go = do
req <- parseUrl $ BS.unpack url
let req' = 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 (ResourceT IO)
-> IO (Response BSL.ByteString)
authenticatedRequest token m r = withManager
$ httpLbs
$ updateRequestHeaders (Just token)
$ setMethod m r
setMethod :: HT.StdMethod -> Request m -> Request m
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 m -> Request m
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 }