hoauth2 0.2.4 → 0.2.5
raw patch · 2 files changed
+56/−49 lines, 2 filesdep +resourcetdep ~http-conduit
Dependencies added: resourcet
Dependency ranges changed: http-conduit
Files
- hoauth2.cabal +5/−5
- src/Network/OAuth2/HTTP/HttpClient.hs +51/−44
hoauth2.cabal view
@@ -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: <http://open.weibo.com/wiki/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 -
src/Network/OAuth2/HTTP/HttpClient.hs view
@@ -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