diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,6 +1,6 @@ Name: hoauth2 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) -Version: 0.2.4 +Version: 0.2.5 Synopsis: hoauth2 Description: @@ -12,7 +12,7 @@ . * weibo oauth2: -Homepage: freizl.github.com +Homepage: https://github.com/freizl/hoauth2 License: BSD3 License-file: LICENSE Author: Haisheng Wu @@ -35,7 +35,7 @@ Source-Repository head Type: git - Location: https://github.com/freizl/hoauth2 + Location: git://github.com/freizl/hoauth2.git Library @@ -51,11 +51,12 @@ bytestring >= 0.9 && < 0.10, bytestring-show >= 0.3.5 && < 0.4, conduit >= 0.5 && < 0.6, - http-conduit >= 1.6 && < 1.7, + http-conduit >= 1.8.3 && < 1.8.4, http-types >= 0.7 && < 0.8, monad-control >= 0.3 && < 0.4, mtl >= 1 && < 2.2, transformers >= 0.2 && < 0.4, + resourcet >= 0.4.0.2 && < 0.4.1, random if impl(ghc >= 6.12.0) @@ -64,4 +65,3 @@ else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans - diff --git a/src/Network/OAuth2/HTTP/HttpClient.hs b/src/Network/OAuth2/HTTP/HttpClient.hs --- a/src/Network/OAuth2/HTTP/HttpClient.hs +++ b/src/Network/OAuth2/HTTP/HttpClient.hs @@ -6,22 +6,23 @@ module Network.OAuth2.HTTP.HttpClient where -import Control.Applicative ((<$>)) import Control.Exception -import Control.Monad.Trans (liftIO) -import Control.Monad (liftM) +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 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.HTTP.Types (renderSimpleQuery) +import qualified Network.HTTP.Types as HT import Network.OAuth2.OAuth2 -------------------------------------------------- +-- Fetch AccessToken; RefreshAccessToken +-------------------------------------------------- -- | Request (via POST method) "Access Token". -- @@ -30,7 +31,7 @@ requestAccessToken :: OAuth2 -- ^ OAuth Data -> BS.ByteString -- ^ Authentication code gained after authorization -> IO (Maybe AccessToken) -- ^ Access Token -requestAccessToken oa code = decode <$> doSimplePostRequest (accessTokenUrl oa code) +requestAccessToken oa code = doJSONPostRequest (accessTokenUrl oa code) -- | Request the "Refresh Token". @@ -38,10 +39,12 @@ refreshAccessToken :: OAuth2 -> BS.ByteString -- ^ refresh token gained after authorization -> IO (Maybe AccessToken) -refreshAccessToken oa rtoken = decode <$> doSimplePostRequest (refreshAccessTokenUrl oa rtoken) +refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken) -------------------------------------------------- +-- conduit http request +-------------------------------------------------- -- | Conduct post request. -- @@ -50,72 +53,76 @@ doSimplePostRequest (uri, body) = doPostRequst (bsToS uri) body >>= handleResponse -- | Conduct post request and return response as JSON. --- +-- doJSONPostRequest :: FromJSON a => (URI, PostBody) -- ^ The URI and request body for fetching token. -> IO (Maybe a) -- ^ Response as ByteString doJSONPostRequest (uri, body) = doPostRequst (bsToS uri) body >>= liftM decode . handleResponse - -- | Conduct GET request. -- -doSimpleGetRequest :: String -- ^ URL +doSimpleGetRequest :: URI -- ^ URL -> IO (Response BSL.ByteString) -- ^ Response as ByteString -doSimpleGetRequest url = liftIO $ withManager $ \man -> do - req' <- liftIO $ parseUrl url - httpLbs req' man +doSimpleGetRequest url = doGetRequest (bsToS url) [] -- | Conduct GET request and return response as JSON. -- doJSONGetRequest :: FromJSON a - => String -- ^ Full URL - -> IO (Maybe a) -- ^ Response as ByteString -doJSONGetRequest url = doGetRequest url [] - >>= liftM decode . handleResponse - - --liftIO $ withManager $ \man -> do - -- req' <- liftIO $ parseUrl url - -- httpLbs req' man + => URI -- ^ Full URL + -> IO (Maybe a) -- ^ Response as ByteString +doJSONGetRequest url = doGetRequest (bsToS url) [] + >>= liftM decode . handleResponse --------------------------------------------------- --- conduit http request --------------------------------------------------- - -- | Conduct GET request with given URL by append extra parameters provided. -- doGetRequest :: String -- ^ URL -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters -> IO (Response BSL.ByteString) -- ^ Response -doGetRequest url pm = liftIO $ withManager $ \man -> do - req' <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm) - httpLbs req' man +doGetRequest url pm = doGetRequestWithReq url pm id +-- | TODO: can not be `Request m -> Request m`, why?? +-- +doGetRequestWithReq :: String -- ^ URL + -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters + -> (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ update Request + -> IO (Response BSL.ByteString) -- ^ Response +doGetRequestWithReq url pm f = do + req <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm) + let req' = (updateRequestHeaders .f) req + withManager $ httpLbs req' + -- | Conduct POST request with given URL with post body data. -- -doPostRequst :: String -- ^ URL - -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body - -> IO (Response BSL.ByteString) -- ^ Response -doPostRequst url body = liftIO $ withManager $ \man -> do - req' <- parseUrl url - httpLbs (urlEncodedBody body req') man +doPostRequst :: String -- ^ URL + -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body + -> IO (Response BSL.ByteString) -- ^ Response +doPostRequst url body = doPostRequstWithReq url body id +doPostRequstWithReq :: String -- ^ URL + -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body + -> (Request (ResourceT IO) -> Request (ResourceT IO)) + -> IO (Response BSL.ByteString) -- ^ Response +doPostRequstWithReq url body f = do + req <- parseUrl url + let req' = (updateRequestHeaders . f) req + withManager $ httpLbs (urlEncodedBody body req') + -------------------------------------------------- +-- Utils +-------------------------------------------------- handleResponse :: Response BSL.ByteString -> IO BSL.ByteString -handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200 +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 - - --else BSL.putStrLn "Error rsp" >> return "ERROR" - --- TODO: Control.Exception.try --- result <- liftIO $ Control.Exception.try $ runResourceT $ httpLbs request man