diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,9 @@ [![Build Status](https://secure.travis-ci.org/freizl/hoauth2.png?branch=master)](http://travis-ci.org/freizl/hoauth2) -## Introduction +# Introduction A lightweight oauth2 haskell binding. See examples in `example/` folder. -In additions, [snaplet-oauth] use this lib as well. - -[snaplet-oauth]: https://github.com/HaskellCNOrg/snaplet-oauth - -## Contribute +# Contribute Feel free send pull request or submit issue ticket. diff --git a/example/Douban/test.hs b/example/Douban/test.hs new file mode 100644 --- /dev/null +++ b/example/Douban/test.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{- + +douban oauth2: http://developers.douban.com/wiki/?title=oauth2 + +-} + +module Main where + +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.OAuth.OAuth2 + +import Keys + +main :: IO () +main = do + print $ authorizationUrl doubanKey + putStrLn "visit the url and paste code here: " + code <- getLine + mgr <- newManager conduitManagerSettings + token <- fetchAccessToken mgr doubanKey (sToBS code) + print token + case token of + Right r -> do + uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me" + print uid + Left l -> BSL.putStrLn l + closeManager mgr + +sToBS :: String -> BS.ByteString +sToBS = T.encodeUtf8 . T.pack diff --git a/example/Facebook/test.hs b/example/Facebook/test.hs --- a/example/Facebook/test.hs +++ b/example/Facebook/test.hs @@ -6,21 +6,17 @@ module Main where -import Keys (facebookKey) +import Keys (facebookKey) import Network.OAuth.OAuth2 -import Network.OAuth.OAuth2.HttpClient -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mzero) -import Data.Aeson (FromJSON, Value (Object), - parseJSON, (.:), (.:?)) -import Data.Aeson.TH (deriveJSON, defaultOptions) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Text (Text) -import Prelude hiding (id) -import qualified Prelude as P (id) -import System.Environment (getArgs) +import Data.Aeson (FromJSON) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Text (Text) +import Network.HTTP.Conduit +import Prelude hiding (id) +import qualified Prelude as P (id) -------------------------------------------------- @@ -38,10 +34,12 @@ print $ authorizationUrl facebookKey `appendQueryParam` facebookScope putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine + mgr <- newManager conduitManagerSettings let (url, body) = accessTokenUrl facebookKey code - (Right token) <- doJSONPostRequest facebookKey url (body ++ [("state", "test")]) - userinfo token >>= print - userinfo' token >>= print + (Right token) <- doJSONPostRequest mgr facebookKey url (body ++ [("state", "test")]) + userinfo mgr token >>= print + userinfo' mgr token >>= print + closeManager mgr -------------------------------------------------- -- FaceBook API @@ -51,9 +49,8 @@ facebookScope = [("scope", "user_about_me,email")] -- | Fetch user id and email. -userinfo :: AccessToken -> IO (OAuth2Result BL.ByteString) -userinfo token = authGetBS token "https://graph.facebook.com/me?fields=id,name,email&" - -userinfo' :: FromJSON User => AccessToken -> IO (OAuth2Result User) -userinfo' token = authGetJSON token "https://graph.facebook.com/me?fields=id,name,email" +userinfo :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString) +userinfo mgr token = authGetBS mgr token "https://graph.facebook.com/me?fields=id,name,email&" +userinfo' :: FromJSON User => Manager -> AccessToken -> IO (OAuth2Result User) +userinfo' mgr token = authGetJSON mgr token "https://graph.facebook.com/me?fields=id,name,email" diff --git a/example/Github/test.hs b/example/Github/test.hs --- a/example/Github/test.hs +++ b/example/Github/test.hs @@ -6,21 +6,15 @@ module Main where import Control.Applicative -import Control.Monad (mzero) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad (mzero) import Data.Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Conduit (MonadResource) -import Data.Maybe (fromJust) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Network.HTTP.Conduit -import qualified Network.HTTP.Types as HT import Network.OAuth.OAuth2 -import Network.OAuth.OAuth2.HttpClient import Keys @@ -31,18 +25,20 @@ print $ authorizationUrl githubKey `appendQueryParam` [("state", state)] putStrLn "visit the url and paste code here: " code <- getLine + mgr <- newManager conduitManagerSettings let (url, body) = accessTokenUrl githubKey (sToBS code) - token <- doJSONPostRequest githubKey url (body ++ [("state", state)]) + token <- doJSONPostRequest mgr githubKey url (body ++ [("state", state)]) print (token :: OAuth2Result AccessToken) case token of - Right at -> userInfo at >>= print - Left l -> print "no access token found yet" + Right at -> userInfo mgr at >>= print + Left _ -> putStrLn "no access token found yet" + closeManager mgr -- | Test API: user -- -userInfo :: AccessToken -> IO (OAuth2Result GithubUser) -userInfo token = authGetJSON token "https://api.github.com/user" +userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser) +userInfo mgr token = authGetJSON mgr token "https://api.github.com/user" data GithubUser = GithubUser { gid :: Integer , gname :: Text diff --git a/example/Google/test.hs b/example/Google/test.hs --- a/example/Google/test.hs +++ b/example/Google/test.hs @@ -13,33 +13,29 @@ module Main where -import Keys (googleKey) +import Keys (googleKey) import Network.OAuth.OAuth2 -import Network.OAuth.OAuth2.HttpClient -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (mzero) -import Data.Aeson (FromJSON, Value (Object), - parseJSON, (.:), (.:?)) -import Data.Aeson.TH (deriveJSON, defaultOptions) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Internal as BL -import Data.Text (Text) -import Network.HTTP.Types (renderSimpleQuery) -import Prelude hiding (id) -import qualified Prelude as P (id) -import System.Environment (getArgs) +import Data.Aeson (FromJSON) +import Data.Aeson.TH (defaultOptions, deriveJSON) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Internal as BL +import Data.Text (Text) +import Network.HTTP.Conduit +import Prelude hiding (id) +import qualified Prelude as P (id) +import System.Environment (getArgs) -------------------------------------------------- -data Token = Token { issued_to :: Text - , audience :: Text - , user_id :: Maybe Text - , scope :: Text - , expires_in :: Integer +data Token = Token { issued_to :: Text + , audience :: Text + , user_id :: Maybe Text + , scope :: Text + , expires_in :: Integer -- , email :: Maybe Text -- , verified_email :: Maybe Bool - , access_type :: Text + , access_type :: Text } deriving (Show) @@ -63,16 +59,18 @@ main :: IO () main = do xs <- getArgs + mgr <- newManager conduitManagerSettings case xs of - ["offline"] -> offlineCase - _ -> normalCase + ["offline"] -> offlineCase mgr + _ -> normalCase mgr + closeManager mgr -offlineCase :: IO () -offlineCase = do +offlineCase :: Manager -> IO () +offlineCase mgr = do BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` (googleScopeEmail ++ googleAccessOffline) putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine - (Right token) <- fetchAccessToken googleKey code + (Right token) <- fetchAccessToken mgr googleKey code f token -- -- obtain a new access token with refresh token, which turns out only in response at first time. @@ -81,30 +79,30 @@ case refreshToken token of Nothing -> putStrLn "Failed to fetch refresh token" Just tk -> do - (Right token) <- fetchRefreshToken googleKey tk - f token + (Right token') <- fetchRefreshToken mgr googleKey tk + f token' --validateToken accessToken >>= print --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print where f token = do print token - validateToken token >>= print - (validateToken' token :: IO (OAuth2Result Token)) >>= print + validateToken mgr token >>= print + (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print -normalCase :: IO () -normalCase = do +normalCase :: Manager -> IO () +normalCase mgr = do BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` googleScopeUserInfo putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine - (Right token) <- fetchAccessToken googleKey code + (Right token) <- fetchAccessToken mgr googleKey code putStr "AccessToken: " >> print token -- get response in ByteString - validateToken token >>= print + validateToken mgr token >>= print -- get response in JSON - (validateToken' token :: IO (OAuth2Result Token)) >>= print + (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print -- get response in ByteString - userinfo token >>= print + userinfo mgr token >>= print -- get response in JSON - (userinfo' token :: IO (OAuth2Result User)) >>= print + (userinfo' mgr token :: IO (OAuth2Result User)) >>= print -------------------------------------------------- -- Google API @@ -123,18 +121,27 @@ ,("approval_prompt", "force")] -- | Token Validation -validateToken :: AccessToken -> IO (OAuth2Result BL.ByteString) -validateToken token = authGetBS token "https://www.googleapis.com/oauth2/v1/tokeninfo" +validateToken :: Manager + -> AccessToken + -> IO (OAuth2Result BL.ByteString) +validateToken mgr token = authGetBS mgr token "https://www.googleapis.com/oauth2/v1/tokeninfo" -validateToken' :: FromJSON a => AccessToken -> IO (OAuth2Result a) -validateToken' token = authGetJSON token "https://www.googleapis.com/oauth2/v1/tokeninfo" +validateToken' :: FromJSON a + => Manager + -> AccessToken + -> IO (OAuth2Result a) +validateToken' mgr token = authGetJSON mgr token "https://www.googleapis.com/oauth2/v1/tokeninfo" -- | fetch user email. -- for more information, please check the playround site. -- -userinfo :: AccessToken -> IO (OAuth2Result BL.ByteString) -userinfo token = authGetBS token "https://www.googleapis.com/oauth2/v2/userinfo" - -userinfo' :: FromJSON a => AccessToken -> IO (OAuth2Result a) -userinfo' token = authGetJSON token "https://www.googleapis.com/oauth2/v2/userinfo" +userinfo :: Manager + -> AccessToken + -> IO (OAuth2Result BL.ByteString) +userinfo mgr token = authGetBS mgr token "https://www.googleapis.com/oauth2/v2/userinfo" +userinfo' :: FromJSON a + => Manager + -> AccessToken + -> IO (OAuth2Result a) +userinfo' mgr token = authGetJSON mgr token "https://www.googleapis.com/oauth2/v2/userinfo" diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample --- a/example/Keys.hs.sample +++ b/example/Keys.hs.sample @@ -38,3 +38,11 @@ , oauthAccessTokenEndpoint = "https://graph.facebook.com/oauth/access_token" } +doubanKey :: OAuth2 +doubanKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx" + , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx" + , oauthCallback = Just "http://localhost:9999/oauthCallback" + , oauthOAuthorizeEndpoint = "https://www.douban.com/service/auth2/auth" + , oauthAccessTokenEndpoint = "https://www.douban.com/service/auth2/token" + } + diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs --- a/example/Weibo/test.hs +++ b/example/Weibo/test.hs @@ -20,33 +20,29 @@ module Main where -import Control.Monad.Trans.Control (MonadBaseControl) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Conduit (MonadResource) -import Data.Maybe (fromJust) -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 qualified Network.HTTP.Types as HT - import Network.OAuth.OAuth2 -import Network.OAuth.OAuth2.HttpClient import Keys main :: IO () main = do - print $ authorizationUrl weiboKey - putStrLn "visit the url and paste code here: " - code <- getLine - token <- fetchAccessToken weiboKey (sToBS code) - print token - case token of - Right r -> do - uid <- authGetBS r "https://api.weibo.com/2/account/get_uid.json" - print uid - Left l -> BSL.putStrLn l + print $ authorizationUrl weiboKey + putStrLn "visit the url and paste code here: " + code <- getLine + mgr <- newManager conduitManagerSettings + token <- fetchAccessToken mgr weiboKey (sToBS code) + print token + case token of + Right r -> do + uid <- authGetBS mgr r "https://api.weibo.com/2/account/get_uid.json" + print uid + Left l -> BSL.putStrLn l + closeManager mgr sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack 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.3.7 +Version: 0.4.0 Synopsis: hoauth2 Description: @@ -38,7 +38,7 @@ example/run-7.6.sh example/run.sh -Cabal-version: >=1.8 +Cabal-version: >=1.10 Source-Repository head Type: git @@ -47,6 +47,7 @@ Library hs-source-dirs: src + default-language: Haskell2010 Exposed-modules: Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.Internal @@ -58,18 +59,111 @@ text >= 0.11 && < 1.2, bytestring >= 0.9 && < 0.11, bytestring-show >= 0.3.5 && < 0.4, - conduit >= 1.0 && < 1.1, - http-conduit >= 2.0 && < 2.1, + http-conduit >= 2.0 && < 2.2, http-types >= 0.8 && < 0.9, monad-control >= 0.3 && < 0.4, - mtl >= 1 && < 2.2, - transformers >= 0.2 && < 0.4, - resourcet >= 0.4 && < 0.5, + mtl >= 1 && < 2.3, + transformers >= 0.2 && < 0.5, random if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-orphans -fno-warn-unused-do-bind + -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-orphans + +Executable test-weibo + main-is: Weibo/test.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >=4.5 && <5, + http-types >= 0.8 && < 0.9, + http-conduit >= 2.0 && < 2.2, + text >= 0.11 && < 1.2, + text >= 0.11 && < 1.2, + bytestring >= 0.9 && < 0.11, + hoauth2 + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + + +Executable test-google + main-is: Google/test.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >=4.5 && <5, + http-types >= 0.8 && < 0.9, + http-conduit >= 2.0 && < 2.2, + text >= 0.11 && < 1.2, + text >= 0.11 && < 1.2, + bytestring >= 0.9 && < 0.11, + aeson >= 0.7 && < 0.8, + hoauth2 + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + + +Executable test-github + main-is: Github/test.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >=4.5 && <5, + http-types >= 0.8 && < 0.9, + http-conduit >= 2.0 && < 2.2, + text >= 0.11 && < 1.2, + text >= 0.11 && < 1.2, + bytestring >= 0.9 && < 0.11, + aeson >= 0.7 && < 0.8, + hoauth2 + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + +Executable test-douban + main-is: Douban/test.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >=4.5 && <5, + http-types >= 0.8 && < 0.9, + http-conduit >= 2.0 && < 2.2, + text >= 0.11 && < 1.2, + text >= 0.11 && < 1.2, + bytestring >= 0.9 && < 0.11, + aeson >= 0.7 && < 0.8, + hoauth2 + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + +Executable test-fb + main-is: Facebook/test.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >=4.5 && <5, + http-types >= 0.8 && < 0.9, + http-conduit >= 2.0 && < 2.2, + text >= 0.11 && < 1.2, + text >= 0.11 && < 1.2, + bytestring >= 0.9 && < 0.11, + aeson >= 0.7 && < 0.8, + hoauth2 + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. @@ -10,7 +10,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe -import Network.HTTP.Conduit +import Network.HTTP.Conduit hiding (withManager) import qualified Network.HTTP.Types as HT import Network.OAuth.OAuth2.Internal @@ -22,40 +22,44 @@ -- | Request (via POST method) "Access Token". -- -- -fetchAccessToken :: OAuth2 -- ^ OAuth Data +fetchAccessToken :: Manager -- ^ HTTP connection manager + -> OAuth2 -- ^ OAuth Data -> BS.ByteString -- ^ Authentication code gained after authorization -> IO (OAuth2Result AccessToken) -- ^ Access Token -fetchAccessToken oa code = doJSONPostRequest oa uri body +fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code -- | Request the "Refresh Token". -fetchRefreshToken :: OAuth2 -- ^ OAuth context +fetchRefreshToken :: Manager -- ^ HTTP connection manager. + -> OAuth2 -- ^ OAuth context -> BS.ByteString -- ^ refresh token gained after authorization -> IO (OAuth2Result AccessToken) -fetchRefreshToken oa rtoken = doJSONPostRequest oa uri body +fetchRefreshToken manager oa rtoken = doJSONPostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa rtoken -- | Conduct post request and return response as JSON. doJSONPostRequest :: FromJSON a - => OAuth2 + => Manager -- ^ HTTP connection manager. + -> OAuth2 -- ^ OAuth options -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result a) -- ^ Response as ByteString -doJSONPostRequest oa uri body = liftM parseResponseJSON (doSimplePostRequest oa uri body) +doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body) -- | Conduct post request. -doSimplePostRequest :: OAuth2 - -> URI -- ^ URL +doSimplePostRequest :: Manager -- ^ HTTP connection manager. + -> OAuth2 -- ^ OAuth options + -> URI -- ^ URL -> PostBody -- ^ Request body. -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString -doSimplePostRequest oa url body = liftM handleResponse go +doSimplePostRequest manager 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') + httpLbs (urlEncodedBody body req') manager -------------------------------------------------- -- * AUTH requests @@ -63,52 +67,54 @@ -- | Conduct GET request and return response as JSON. authGetJSON :: FromJSON a - => AccessToken + => Manager -- ^ HTTP connection manager. + -> AccessToken -> URI -- ^ Full URL -> IO (OAuth2Result a) -- ^ Response as JSON -authGetJSON t uri = liftM parseResponseJSON $ authGetBS t uri +authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri -- | Conduct GET request. -authGetBS :: AccessToken +authGetBS :: Manager -- ^ HTTP connection manager. + -> AccessToken -> URI -- ^ URL -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString -authGetBS token url = liftM handleResponse go +authGetBS manager token url = liftM handleResponse go where go = do req <- parseUrl $ BS.unpack $ url `appendAccessToken` token - authenticatedRequest token HT.GET req + authenticatedRequest manager token HT.GET req -- | Conduct POST request and return response as JSON. authPostJSON :: FromJSON a - => AccessToken + => Manager -- ^ HTTP connection manager. + -> AccessToken -> URI -- ^ Full URL -> PostBody -> IO (OAuth2Result a) -- ^ Response as JSON -authPostJSON t uri pb = liftM parseResponseJSON $ authPostBS t uri pb +authPostJSON manager t uri pb = liftM parseResponseJSON $ authPostBS manager t uri pb -- | Conduct POST request. -authPostBS :: AccessToken +authPostBS :: Manager -- ^ HTTP connection manager. + -> AccessToken -> URI -- ^ URL -> PostBody -> IO (OAuth2Result BSL.ByteString) -- ^ Response as ByteString -authPostBS token url pb = liftM handleResponse go +authPostBS manager 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 manager token HT.POST $ urlEncodedBody body req -- |Sends a HTTP request including the Authorization header with the specified -- access token. -- -authenticatedRequest :: AccessToken -- ^ Authentication token to use +authenticatedRequest :: Manager -- ^ HTTP connection manager. + -> AccessToken -- ^ Authentication token to use -> HT.StdMethod -- ^ Method to use -> Request -- ^ Request to perform -> IO (Response BSL.ByteString) -authenticatedRequest token m r = withManager - $ httpLbs - $ updateRequestHeaders (Just token) - $ setMethod m r --- { checkStatus = \_ _ _ -> Nothing } +authenticatedRequest manager token m r = + httpLbs (updateRequestHeaders (Just token) $ setMethod m r) manager -- | Sets the HTTP method to use -- @@ -128,7 +134,7 @@ else Left $ BSL.append "Gaining token failed: " (responseBody rsp) -- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@ --- +-- parseResponseJSON :: FromJSON a => OAuth2Result BSL.ByteString -> OAuth2Result a @@ -141,7 +147,7 @@ -- + userAgennt : hoauth2 -- + accept : application/json -- + authorization : Bearer xxxxx if AccessToken provided. --- +-- updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2") diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK -ignore-exports #-} @@ -144,4 +144,3 @@ -- | lift value in the Maybe and abonda Nothing transform' :: [(a, Maybe b)] -> [(a, b)] transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd) -