diff --git a/example/Google/test.hs b/example/Google/test.hs --- a/example/Google/test.hs +++ b/example/Google/test.hs @@ -17,8 +17,8 @@ import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) import System.Environment -import Network.OAuth2.HTTP.HttpClient -import Network.OAuth2.OAuth2 +import Network.OAuth.OAuth2.HttpClient +import Network.OAuth.OAuth2 import Google.Key @@ -59,6 +59,8 @@ print accessToken res <- validateToken accessToken print res + res2 <- userinfo accessToken + print res2 where extraParams = renderSimpleQuery False googleScopeEmail @@ -74,3 +76,10 @@ -- Token Validation validateToken accessToken = doSimplePostRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo", (accessTokenToParam accessToken)) + +-- | fetch user email. +-- for more information, please check the playround site. +-- +userinfo accessToken = doSimpleGetRequest (appendQueryParam + "https://www.googleapis.com/oauth2/v2/userinfo" + (accessTokenToParam accessToken)) diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs --- a/example/Weibo/test.hs +++ b/example/Weibo/test.hs @@ -30,23 +30,17 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Data.Conduit (MonadResource) -import Network.OAuth2.HTTP.HttpClient -import Network.OAuth2.OAuth2 +import Network.OAuth.OAuth2.HttpClient +import Network.OAuth.OAuth2 import Weibo.Key - -weibooauth :: OAuth2 -weibooauth = weiboKey { oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize" - , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token" - , oauthAccessToken = Nothing - } main :: IO () main = do - print $ authorizationUrl weibooauth + print $ authorizationUrl weiboKeys putStrLn "visit the url and paste code here: " code <- getLine - token <- requestAccessToken weibooauth (sToBS code) + token <- requestAccessToken weiboKeys (sToBS code) print token sToBS :: String -> BS.ByteString diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,9 +1,9 @@ Name: hoauth2 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) -Version: 0.2.5.1 +Version: 0.2.6 Synopsis: hoauth2 -Description: +Description: Haskell OAuth2 authentication. . Tested following services @@ -21,12 +21,12 @@ Category: Network Build-type: Simple stability: alpha -tested-with: GHC <= 7.4.1 +tested-with: GHC <= 7.6.1 -- Extra files to be distributed with the package, such as examples or -- a README. -Extra-source-files: +Extra-source-files: README.md example/Google/test.hs example/Weibo/test.hs @@ -40,28 +40,28 @@ Library hs-source-dirs: src - Exposed-modules: - Network.OAuth2.HTTP.HttpClient - Network.OAuth2.OAuth2 + Exposed-modules: + Network.OAuth.OAuth2.HttpClient + Network.OAuth.OAuth2 Build-Depends: aeson >= 0.6 && < 0.7, base >= 4 && < 5, text >= 0.11 && < 0.12, - bytestring >= 0.9 && < 0.10, + bytestring >= 0.9 && < 0.11, bytestring-show >= 0.3.5 && < 0.4, conduit >= 0.5 && < 0.6, - http-conduit >= 1.8.3 && < 1.8.4, + http-conduit >= 1.8.4 && < 1.8.5, 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) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-orphans + -fno-warn-orphans diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/OAuth2.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A simple OAuth2 Haskell binding. +-- (This is supposed to be independent with http client.) + +module Network.OAuth.OAuth2 where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception +import Control.Monad (mzero) +import Data.Aeson +import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) +import Network.HTTP.Types (renderSimpleQuery) + +-------------------------------------------------- +-- Data Types +-------------------------------------------------- + +-- | Query Parameter Representation +-- +data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString + , oauthClientSecret :: BS.ByteString + , oauthOAuthorizeEndpoint :: BS.ByteString + , oauthAccessTokenEndpoint :: BS.ByteString + , oauthCallback :: Maybe BS.ByteString + , oauthAccessToken :: Maybe BS.ByteString + -- ^ TODO: why not Maybe AccessToken??? + } deriving (Show, Eq) + +-- | Simple Exception representation. +data OAuthException = OAuthException String + deriving (Show, Eq, Typeable) + +-- | OAuthException is kind of Exception. +-- +instance Exception OAuthException + +-- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@. +-- The @refresheToken@ is special at some case. +-- e.g. https://developers.google.com/accounts/docs/OAuth2 +-- +data AccessToken = AccessToken { accessToken :: BS.ByteString + , refreshToken :: Maybe BS.ByteString } + deriving (Show) + +-- | Parse JSON data into {AccessToken} +-- +instance FromJSON AccessToken where + parseJSON (Object o) = AccessToken + <$> o .: "access_token" + <*> o .:? "refresh_token" + parseJSON _ = mzero + +-------------------------------------------------- +-- Types Synonym +-------------------------------------------------- + +-- | type synonym of query parameters +type QueryParams = [(BS.ByteString, BS.ByteString)] + +-- | type synonym of post body content +type PostBody = [(BS.ByteString, BS.ByteString)] + +-- | type synonym of a URI +type URI = BS.ByteString + +-- | Access Code that is required for fetching Access Token +type AccessCode = BS.ByteString + + +-------------------------------------------------- +-- URLs +-------------------------------------------------- + +-- | Prepare the authorization URL. +-- Redirect to this URL asking for user interactive authentication. +-- +authorizationUrl :: OAuth2 -> URI +authorizationUrl oa = oauthOAuthorizeEndpoint oa `appendQueryParam` queryStr + where queryStr = transform' [ ("client_id", Just $ oauthClientId oa) + , ("response_type", Just "code") + , ("redirect_uri", oauthCallback oa)] + + +-- | Prepare URL and the request body query for fetching access token. +-- +accessTokenUrl :: OAuth2 + -> AccessCode -- ^ access code gained via authorization URL + -> (URI, PostBody) -- ^ access token request URL plus the request body. +accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") + + +accessTokenUrl' :: OAuth2 + -> AccessCode -- ^ access code gained via authorization URL + -> Maybe BS.ByteString -- ^ Grant Type + -> (URI, PostBody) -- ^ access token request URL plus the request body. +accessTokenUrl' oa code gt = (uri, body) + where uri = oauthAccessTokenEndpoint oa + body = transform' [ ("client_id", Just $ oauthClientId oa) + , ("client_secret", Just $ oauthClientSecret oa) + , ("code", Just code) + , ("redirect_uri", oauthCallback oa) + , ("grant_type", gt) ] + +-- | Using a Refresh Token. +-- obtain a new access token by sending a refresh token to the Authorization server. +-- +refreshAccessTokenUrl :: OAuth2 + -> BS.ByteString -- ^ refresh token gained via authorization URL + -> (URI, PostBody) -- ^ refresh token request URL plus the request body. +refreshAccessTokenUrl oa rtoken = (uri, body) + where uri = oauthAccessTokenEndpoint oa + body = transform' [ ("client_id", Just $ oauthClientId oa) + , ("client_secret", Just $ oauthClientSecret oa) + , ("grant_type", Just "refresh_token") + , ("refresh_token", Just rtoken) ] + +-------------------------------------------------- +-- UTILs +-------------------------------------------------- + +-- | Append query parameters with '?' +appendQueryParam :: URI -> QueryParams -> URI +appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q + +-- | Append query parameters with '&'. +appendQueryParam' :: URI -> QueryParams -> URI +appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q + +-- | For GET method API. +appendAccessToken :: URI -- ^ Base URI + -> OAuth2 -- ^ OAuth has Authorized Access Token + -> URI -- ^ Combined Result +appendAccessToken uri oauth = appendQueryParam uri + (token $ oauthAccessToken oauth) + where token :: Maybe BS.ByteString -> QueryParams + token = accessTokenToParam . fromMaybe "" + +-- | Create QueryParams with given access token value. +-- +accessTokenToParam :: BS.ByteString -> QueryParams +accessTokenToParam token = [("access_token", token)] + + +-- | lift value in the Maybe and abonda Nothing +transform' :: [(a, Maybe b)] -> [(a, b)] +transform' = foldr step' [] + where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)] + step' (a, Just b) xs = (a, b):xs + step' _ xs = xs + + + -- Expect Access Token exists + -- FIXME: append empty when Nothing + --uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth) + diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A simple http client for request OAuth2 tokens and several utils. + +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 + +-------------------------------------------------- +-- Fetch AccessToken; RefreshAccessToken +-------------------------------------------------- + +-- | Request (via POST method) "Access Token". +-- +-- FIXME: what if @requestAccessToken'@ return error? +-- +requestAccessToken :: OAuth2 -- ^ OAuth Data + -> BS.ByteString -- ^ Authentication code gained after authorization + -> IO (Maybe AccessToken) -- ^ Access Token +requestAccessToken oa code = doJSONPostRequest (accessTokenUrl oa code) + + +-- | Request the "Refresh Token". +-- +refreshAccessToken :: OAuth2 + -> BS.ByteString -- ^ refresh token gained after authorization + -> IO (Maybe AccessToken) +refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken) + + +-------------------------------------------------- +-- conduit http request +-------------------------------------------------- + +-- | Conduct post request. +-- +doSimplePostRequest :: (URI, PostBody) -- ^ The URI and request body for fetching token. + -> IO BSL.ByteString -- ^ Response as ByteString +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 :: URI -- ^ URL + -> IO BSL.ByteString -- ^ Response as ByteString +doSimpleGetRequest url = doGetRequest (bsToS url) [] >>= handleResponse + +-- | Conduct GET request and return response as JSON. +-- +doJSONGetRequest :: FromJSON a + => URI -- ^ Full URL + -> IO (Maybe a) -- ^ Response as ByteString +doJSONGetRequest url = doGetRequest (bsToS url) [] + >>= liftM decode . handleResponse + + +-- | 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 = 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 = 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 + 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 diff --git a/src/Network/OAuth2/HTTP/HttpClient.hs b/src/Network/OAuth2/HTTP/HttpClient.hs deleted file mode 100644 --- a/src/Network/OAuth2/HTTP/HttpClient.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - --- | A simple http client for request OAuth2 tokens and several utils. - -module Network.OAuth2.HTTP.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.OAuth2.OAuth2 - --------------------------------------------------- --- Fetch AccessToken; RefreshAccessToken --------------------------------------------------- - --- | Request (via POST method) "Access Token". --- --- FIXME: what if @requestAccessToken'@ return error? --- -requestAccessToken :: OAuth2 -- ^ OAuth Data - -> BS.ByteString -- ^ Authentication code gained after authorization - -> IO (Maybe AccessToken) -- ^ Access Token -requestAccessToken oa code = doJSONPostRequest (accessTokenUrl oa code) - - --- | Request the "Refresh Token". --- -refreshAccessToken :: OAuth2 - -> BS.ByteString -- ^ refresh token gained after authorization - -> IO (Maybe AccessToken) -refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken) - - --------------------------------------------------- --- conduit http request --------------------------------------------------- - --- | Conduct post request. --- -doSimplePostRequest :: (URI, PostBody) -- ^ The URI and request body for fetching token. - -> IO BSL.ByteString -- ^ Response as ByteString -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 :: URI -- ^ URL - -> IO BSL.ByteString -- ^ Response as ByteString -doSimpleGetRequest url = doGetRequest (bsToS url) [] >>= handleResponse - --- | Conduct GET request and return response as JSON. --- -doJSONGetRequest :: FromJSON a - => URI -- ^ Full URL - -> IO (Maybe a) -- ^ Response as ByteString -doJSONGetRequest url = doGetRequest (bsToS url) [] - >>= liftM decode . handleResponse - - --- | 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 = 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 = 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 - 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 diff --git a/src/Network/OAuth2/OAuth2.hs b/src/Network/OAuth2/OAuth2.hs deleted file mode 100644 --- a/src/Network/OAuth2/OAuth2.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - --- | A simple OAuth2 Haskell binding. --- (This is supposed to be independent with http client.) - -module Network.OAuth2.OAuth2 where - -import Control.Applicative ((<$>), (<*>)) -import Control.Exception -import Control.Monad (mzero) -import Data.Aeson -import qualified Data.ByteString as BS -import Data.Maybe (fromMaybe) -import Data.Typeable (Typeable) -import Network.HTTP.Types (renderSimpleQuery) - --------------------------------------------------- --- Data Types --------------------------------------------------- - --- | Query Parameter Representation --- -data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString - , oauthClientSecret :: BS.ByteString - , oauthOAuthorizeEndpoint :: BS.ByteString - , oauthAccessTokenEndpoint :: BS.ByteString - , oauthCallback :: Maybe BS.ByteString - , oauthAccessToken :: Maybe BS.ByteString - -- ^ TODO: why not Maybe AccessToken??? - } deriving (Show, Eq) - --- | Simple Exception representation. -data OAuthException = OAuthException String - deriving (Show, Eq, Typeable) - --- | OAuthException is kind of Exception. --- -instance Exception OAuthException - --- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@. --- The @refresheToken@ is special at some case. --- e.g. https://developers.google.com/accounts/docs/OAuth2 --- -data AccessToken = AccessToken { accessToken :: BS.ByteString - , refreshToken :: Maybe BS.ByteString } - deriving (Show) - --- | Parse JSON data into {AccessToken} --- -instance FromJSON AccessToken where - parseJSON (Object o) = AccessToken - <$> o .: "access_token" - <*> o .:? "refresh_token" - parseJSON _ = mzero - --------------------------------------------------- --- Types Synonym --------------------------------------------------- - --- | type synonym of query parameters -type QueryParams = [(BS.ByteString, BS.ByteString)] - --- | type synonym of post body content -type PostBody = [(BS.ByteString, BS.ByteString)] - --- | type synonym of a URI -type URI = BS.ByteString - --- | Access Code that is required for fetching Access Token -type AccessCode = BS.ByteString - - --------------------------------------------------- --- URLs --------------------------------------------------- - --- | Prepare the authorization URL. --- Redirect to this URL asking for user interactive authentication. --- -authorizationUrl :: OAuth2 -> URI -authorizationUrl oa = oauthOAuthorizeEndpoint oa `appendQueryParam` queryStr - where queryStr = transform' [ ("client_id", Just $ oauthClientId oa) - , ("response_type", Just "code") - , ("redirect_uri", oauthCallback oa)] - - --- | Prepare URL and the request body query for fetching access token. --- -accessTokenUrl :: OAuth2 - -> AccessCode -- ^ access code gained via authorization URL - -> (URI, PostBody) -- ^ access token request URL plus the request body. -accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") - - -accessTokenUrl' :: OAuth2 - -> AccessCode -- ^ access code gained via authorization URL - -> Maybe BS.ByteString -- ^ Grant Type - -> (URI, PostBody) -- ^ access token request URL plus the request body. -accessTokenUrl' oa code gt = (uri, body) - where uri = oauthAccessTokenEndpoint oa - body = transform' [ ("client_id", Just $ oauthClientId oa) - , ("client_secret", Just $ oauthClientSecret oa) - , ("code", Just code) - , ("redirect_uri", oauthCallback oa) - , ("grant_type", gt) ] - --- | Using a Refresh Token. --- obtain a new access token by sending a refresh token to the Authorization server. --- -refreshAccessTokenUrl :: OAuth2 - -> BS.ByteString -- ^ refresh token gained via authorization URL - -> (URI, PostBody) -- ^ refresh token request URL plus the request body. -refreshAccessTokenUrl oa rtoken = (uri, body) - where uri = oauthAccessTokenEndpoint oa - body = transform' [ ("client_id", Just $ oauthClientId oa) - , ("client_secret", Just $ oauthClientSecret oa) - , ("grant_type", Just "refresh_token") - , ("refresh_token", Just rtoken) ] - --------------------------------------------------- --- UTILs --------------------------------------------------- - --- | Append query parameters with '?' -appendQueryParam :: URI -> QueryParams -> URI -appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q - --- | Append query parameters with '&'. -appendQueryParam' :: URI -> QueryParams -> URI -appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q - - --- | For GET method API. -appendAccessToken :: URI -- ^ Base URI - -> OAuth2 -- ^ OAuth has Authorized Access Token - -> URI -- ^ Combined Result -appendAccessToken uri oauth = appendQueryParam uri - (token $ oauthAccessToken oauth) - where token :: Maybe BS.ByteString -> QueryParams - token = accessTokenToParam . fromMaybe "" - --- | Create QueryParams with given access token value. --- -accessTokenToParam :: BS.ByteString -> QueryParams -accessTokenToParam token = [("access_token", token)] - - --- | lift value in the Maybe and abonda Nothing -transform' :: [(a, Maybe b)] -> [(a, b)] -transform' = foldr step' [] - where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)] - step' (a, Just b) xs = (a, b):xs - step' _ xs = xs - - - -- Expect Access Token exists - -- FIXME: append empty when Nothing - --uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth) -