module Network.OAuth.OAuth2.HttpClient where
import Control.Exception
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Conduit
import Network.HTTP.Types (renderSimpleQuery)
import qualified Network.HTTP.Types as HT
import Network.OAuth.OAuth2
requestAccessToken :: OAuth2
-> BS.ByteString
-> IO (Maybe AccessToken)
requestAccessToken oa code = doJSONPostRequest (accessTokenUrl oa code)
refreshAccessToken :: OAuth2
-> BS.ByteString
-> IO (Maybe AccessToken)
refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken)
doSimplePostRequest :: (URI, PostBody)
-> IO BSL.ByteString
doSimplePostRequest (uri, body) = doPostRequst (bsToS uri) body >>= handleResponse
doJSONPostRequest :: FromJSON a
=> (URI, PostBody)
-> IO (Maybe a)
doJSONPostRequest (uri, body) = doPostRequst (bsToS uri) body
>>= liftM decode . handleResponse
doSimpleGetRequest :: URI
-> IO BSL.ByteString
doSimpleGetRequest url = doGetRequest (bsToS url) [] >>= handleResponse
doJSONGetRequest :: FromJSON a
=> URI
-> IO (Maybe a)
doJSONGetRequest url = doGetRequest (bsToS url) []
>>= liftM decode . handleResponse
doGetRequest :: String
-> [(BS.ByteString, BS.ByteString)]
-> IO (Response BSL.ByteString)
doGetRequest url pm = doGetRequestWithReq url pm id
doGetRequestWithReq :: String
-> [(BS.ByteString, BS.ByteString)]
-> (Request (ResourceT IO) -> Request (ResourceT IO))
-> IO (Response BSL.ByteString)
doGetRequestWithReq url pm f = do
req <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm)
let req' = (updateRequestHeaders .f) req
withManager $ httpLbs req'
doPostRequst :: String
-> [(BS.ByteString, BS.ByteString)]
-> IO (Response BSL.ByteString)
doPostRequst url body = doPostRequstWithReq url body id
doPostRequstWithReq :: String
-> [(BS.ByteString, BS.ByteString)]
-> (Request (ResourceT IO) -> Request (ResourceT IO))
-> IO (Response BSL.ByteString)
doPostRequstWithReq url body f = do
req <- parseUrl url
let req' = (updateRequestHeaders . f) req
withManager $ httpLbs (urlEncodedBody body req')
handleResponse :: Response BSL.ByteString -> IO BSL.ByteString
handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200
then return (responseBody rsp)
else throwIO . OAuthException $
"Gaining token failed: " ++ BSL.unpack (responseBody rsp)
updateRequestHeaders :: Request m -> Request m
updateRequestHeaders req = req { requestHeaders = [ (HT.hAccept, "application/json") ] }
bsToS :: BS.ByteString -> String
bsToS = T.unpack . T.decodeUtf8