diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,7 +1,7 @@ Cabal-version: 2.4 Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -Version: 2.2.0 +Version: 2.3.0 Synopsis: Haskell OAuth2 authentication client @@ -52,20 +52,19 @@ Network.OAuth.OAuth2.AuthorizationRequest Build-Depends: base >= 4 && < 5, + data-default >= 0.7 && < 0.8, binary >= 0.8.3 && < 0.8.9, + containers >= 0.6 && < 0.7, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.1 && < 2.4, http-types >= 0.11 && < 0.13, aeson >= 2.0 && < 2.1, transformers >= 0.5 && < 0.6, - unordered-containers >= 0.2.5 && < 0.3, uri-bytestring >= 0.2.3 && < 0.4, uri-bytestring-aeson >= 0.1 && < 0.2, microlens >= 0.4.0 && < 0.5, - hashable >= 1.2.6 && < 1.5.0, exceptions >= 0.8.3 && < 0.11 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind - + -fno-warn-unused-do-bind -Wunused-packages diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs --- a/src/Network/OAuth/OAuth2.hs +++ b/src/Network/OAuth/OAuth2.hs @@ -1,21 +1,30 @@ ------------------------------------------------------------ + +------------------------------------------------------------ + -- | -- Module : Network.OAuth.OAuth2 -- Description : OAuth2 client -- Copyright : (c) 2012 Haisheng Wu -- License : BSD-style (see the file LICENSE) -- Maintainer : Haisheng Wu --- Stability : alpha +-- Stability : Beta -- Portability : portable -- -- A lightweight oauth2 haskell binding. ------------------------------------------------------------- - module Network.OAuth.OAuth2 - (module Network.OAuth.OAuth2.HttpClient, - module Network.OAuth.OAuth2.Internal - ) - where + ( module Network.OAuth.OAuth2.HttpClient, + module Network.OAuth.OAuth2.AuthorizationRequest, + module Network.OAuth.OAuth2.TokenRequest, + module Network.OAuth.OAuth2.Internal, + ) +where -import Network.OAuth.OAuth2.HttpClient -import Network.OAuth.OAuth2.Internal +{- + Hiding Errors data type from default. + Shall qualified import given the naming conflicts. +-} +import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..)) +import Network.OAuth.OAuth2.HttpClient +import Network.OAuth.OAuth2.Internal +import Network.OAuth.OAuth2.TokenRequest hiding (Errors(..)) diff --git a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs --- a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs +++ b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs @@ -1,19 +1,31 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Network.OAuth.OAuth2.AuthorizationRequest where -import Data.Aeson -import GHC.Generics +import Data.Aeson +import qualified Data.Text.Encoding as T +import GHC.Generics +import Lens.Micro +import Network.OAuth.OAuth2.Internal +import URI.ByteString +-------------------------------------------------- + +-- * Errors + +-------------------------------------------------- + instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } + parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + instance ToJSON Errors where - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } + toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} -- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 -- Implicit Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.2.2.1 -data Errors = - InvalidRequest +data Errors + = InvalidRequest | UnauthorizedClient | AccessDenied | UnsupportedResponseType @@ -21,3 +33,20 @@ | ServerError | TemporarilyUnavailable deriving (Show, Eq, Generic) + +-------------------------------------------------- + +-- * URLs + +-------------------------------------------------- + +-- | Prepare the authorization URL. Redirect to this URL +-- asking for user interactive authentication. +authorizationUrl :: OAuth2 -> URI +authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) + where + queryParts = + [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), + ("response_type", "code"), + ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa) + ] 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,281 +1,243 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. - -module Network.OAuth.OAuth2.HttpClient ( --- * Token management - fetchAccessToken, - fetchAccessToken2, - refreshAccessToken, - refreshAccessToken2, - doSimplePostRequest, --- * AUTH requests - authGetJSON, - authGetBS, - authGetBS2, - authPostJSON, - authPostBS, - authPostBS2, - authPostBS3, - authRequest -) where +module Network.OAuth.OAuth2.HttpClient + ( -- * AUTH requests + authGetJSON, + authGetBS, + authGetBS2, + authGetJSONInternal, + authGetBSInternal, + authPostJSON, + authPostBS, + authPostBS1, + authPostBS2, + authPostBS3, + authPostJSONInternal, + authPostBSInternal, + ) +where +import qualified Data.Set as Set import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except -import qualified Data.Aeson.KeyMap as KeyMap -import qualified Data.Aeson.Key as Key -import Data.Aeson -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Maybe -import qualified Data.Text.Encoding as T -import Network.HTTP.Conduit -import qualified Network.HTTP.Types as HT -import Network.HTTP.Types.URI (parseQuery) -import Network.OAuth.OAuth2.Internal -import qualified Network.OAuth.OAuth2.TokenRequest as TR -import URI.ByteString +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Maybe +import qualified Data.Text.Encoding as T +import Lens.Micro +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT +import Network.OAuth.OAuth2.Internal +import URI.ByteString -------------------------------------------------- --- * Token management --------------------------------------------------- --- | Fetch OAuth2 Token with authenticate in request header. --- --- OAuth2 spec allows `client_id` and `client_secret` to --- either be sent in the header (as basic authentication) --- OR as form/url params. --- The OAuth server can choose to implement only one, or both. --- Unfortunately, there is no way for the OAuth client (i.e. this library) to --- know which method to use. Please take a look at the documentation of the --- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2` -fetchAccessToken :: Manager -- ^ HTTP connection manager - -> OAuth2 -- ^ OAuth Data - -> ExchangeToken -- ^ OAuth2 Code - -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token -fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body - where (uri, body) = accessTokenUrl oa code - --- | Please read the docs of `fetchAccessToken`. --- -fetchAccessToken2 :: Manager -- ^ HTTP connection manager - -> OAuth2 -- ^ OAuth Data - -> ExchangeToken -- ^ OAuth 2 Tokens - -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token -fetchAccessToken2 mgr oa code = do - let (url, body1) = accessTokenUrl oa code - let extraBody = [ - ("client_id", T.encodeUtf8 $ oauth2ClientId oa), - ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) - ] - doJSONPostRequest mgr oa url (extraBody ++ body1) - --- | Fetch a new AccessToken with the Refresh Token with authentication in request header. --- OAuth2 spec allows `client_id` and `client_secret` to --- either be sent in the header (as basic authentication) --- OR as form/url params. --- The OAuth server can choose to implement only one, or both. --- Unfortunately, there is no way for the OAuth client (i.e. this library) to --- know which method to use. Please take a look at the documentation of the --- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2` -refreshAccessToken :: Manager -- ^ HTTP connection manager. - -> OAuth2 -- ^ OAuth context - -> RefreshToken -- ^ refresh token gained after authorization - -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -refreshAccessToken manager oa token = doJSONPostRequest manager oa uri body - where (uri, body) = refreshAccessTokenUrl oa token - --- | Please read the docs of `refreshAccessToken`. --- -refreshAccessToken2 :: Manager -- ^ HTTP connection manager. - -> OAuth2 -- ^ OAuth context - -> RefreshToken -- ^ refresh token gained after authorization - -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -refreshAccessToken2 manager oa token = do - let (uri, body) = refreshAccessTokenUrl oa token - let extraBody = [ - ("client_id", T.encodeUtf8 $ oauth2ClientId oa), - ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) - ] - doJSONPostRequest manager oa uri (extraBody ++ body) - --- | Conduct post request and return response as JSON. -doJSONPostRequest :: (FromJSON err, FromJSON a) - => Manager -- ^ HTTP connection manager. - -> OAuth2 -- ^ OAuth options - -> URI -- ^ The URL - -> PostBody -- ^ request body - -> ExceptT (OAuth2Error err) IO a -- ^ Response as JSON -doJSONPostRequest manager oa uri body = do - resp <- doSimplePostRequest manager oa uri body - case parseResponseFlexible resp of - Right obj -> return obj - Left e -> throwE e - --- | Conduct post request. -doSimplePostRequest :: FromJSON err => Manager -- ^ HTTP connection manager. - -> OAuth2 -- ^ OAuth options - -> URI -- ^ URL - -> PostBody -- ^ Request body. - -> ExceptT (OAuth2Error err) IO BSL.ByteString -- ^ Response as ByteString -doSimplePostRequest manager oa url body = - ExceptT $ fmap handleOAuth2TokenResponse go - where - addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) - go = do - req <- uriToRequest url - let req' = (addBasicAuth . updateRequestHeaders Nothing) req - httpLbs (urlEncodedBody body req') manager - --- | Parses a @Response@ to to @OAuth2Result@ -handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString -handleOAuth2TokenResponse rsp = - if HT.statusIsSuccessful (responseStatus rsp) - then Right $ responseBody rsp - else Left $ parseOAuth2Error (responseBody rsp) - --- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String. -parseResponseFlexible :: (FromJSON err, FromJSON a) - => BSL.ByteString - -> Either (OAuth2Error err) a -parseResponseFlexible r = case eitherDecode r of - Left _ -> parseResponseString r - Right x -> Right x - --- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String -parseResponseString :: (FromJSON err, FromJSON a) - => BSL.ByteString - -> Either (OAuth2Error err) a -parseResponseString b = case parseQuery $ BSL.toStrict b of - [] -> Left errorMessage - a -> case fromJSON $ queryToValue a of - Error _ -> Left errorMessage - Success x -> Right x - where - queryToValue = Object . KeyMap.fromList . map paramToPair - paramToPair (k, mv) = (Key.fromText $T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) - errorMessage = parseOAuth2Error b - --------------------------------------------------- -- * AUTH requests --- Making request with Access Token injected into header or request body. + +-- Making request with Access Token appended to Header, Request body or query string. -- -------------------------------------------------- -- | Conduct an authorized GET request and return response as JSON. -- Inject Access Token to Authorization Header. --- -authGetJSON :: (FromJSON b) - => Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> ExceptT BSL.ByteString IO b -- ^ Response as JSON -authGetJSON manager t uri = do - resp <- authGetBS manager t uri - case eitherDecode resp of - Right obj -> return obj - Left e -> throwE $ BSL.pack e +authGetJSON :: + (FromJSON b) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString IO b +authGetJSON = authGetJSONInternal (Set.fromList [AuthInRequestHeader]) +{-# DEPRECATED authGetJSON "use authGetJSONInternal" #-} +-- | Conduct an authorized GET request and return response as JSON. +-- Allow to specify how to append AccessToken. +authGetJSONInternal :: + (FromJSON b) => + Set.Set APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString IO b +authGetJSONInternal authTypes manager t uri = do + resp <- authGetBSInternal authTypes manager t uri + either (throwE . BSL.pack) return (eitherDecode resp) + -- | Conduct an authorized GET request. -- Inject Access Token to Authorization Header. --- -authGetBS :: Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString -authGetBS manager token url = do - req <- uriToRequest url - authRequest req upReq manager - where upReq = updateRequestHeaders (Just token) . setMethod HT.GET +authGetBS :: + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authGetBS = authGetBSInternal $ Set.fromList [AuthInRequestHeader] -- | Same to 'authGetBS' but set access token to query parameter rather than header --- -authGetBS2 :: Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString -authGetBS2 manager token url = do - req <- liftIO $ uriToRequest (url `appendAccessToken` token) +authGetBS2 :: + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authGetBS2 = authGetBSInternal $ Set.fromList [AuthInRequestQuery] +{-# DEPRECATED authGetBS2 "use authGetBSInternal" #-} + +-- | Conduct an authorized GET request and return response as ByteString. +-- Allow to specify how to append AccessToken. +authGetBSInternal :: + -- | + Set.Set APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authGetBSInternal authTypes manager token url = do + let appendToUrl = AuthInRequestQuery `Set.member` authTypes + let appendToHeader = AuthInRequestHeader `Set.member` authTypes + let uri = if appendToUrl then url `appendAccessToken` token else url + let upReq = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.GET + req <- liftIO $ uriToRequest uri authRequest req upReq manager - where upReq = updateRequestHeaders Nothing . setMethod HT.GET -- | Conduct POST request and return response as JSON. --- Inject Access Token to Authorization Header and request body. --- -authPostJSON :: (FromJSON b) - => Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> PostBody - -> ExceptT BSL.ByteString IO b -- ^ Response as JSON -authPostJSON manager t uri pb = do - resp <- authPostBS manager t uri pb - case eitherDecode resp of - Right obj -> return obj - Left e -> throwE $ BSL.pack e +-- Inject Access Token to Authorization Header. +authPostJSON :: + (FromJSON b) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as JSON + ExceptT BSL.ByteString IO b +authPostJSON = authPostJSONInternal $ Set.fromList [AuthInRequestHeader] +{-# DEPRECATED authPostJSON "use authPostJSONInternal" #-} +-- | Conduct POST request and return response as JSON. +-- Allow to specify how to append AccessToken. +authPostJSONInternal :: + FromJSON a => + Set.Set APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString IO a +authPostJSONInternal authTypes manager token url body = do + resp <- authPostBSInternal authTypes manager token url body + either (throwE . BSL.pack) return (eitherDecode resp) + -- | Conduct POST request. --- Inject Access Token to http header (Authorization) and request body. --- -authPostBS :: Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> PostBody - -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString -authPostBS manager token url pb = do - req <- uriToRequest url - authRequest req upReq manager - where upBody = urlEncodedBody (pb ++ accessTokenToParam token) - upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST - upReq = upHeaders . upBody +-- Inject Access Token to http header (Authorization) +authPostBS :: + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authPostBS = authPostBSInternal $ Set.fromList [AuthInRequestHeader] +-- | Conduct POST request. +-- Inject Access Token to both http header (Authorization) and request body. +authPostBS1 :: + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authPostBS1 = authPostBSInternal $ Set.fromList [AuthInRequestBody, AuthInRequestHeader] +{-# DEPRECATED authPostBS1 "use authPostBSInternal" #-} + -- | Conduct POST request with access token only in the request body but header. --- -authPostBS2 :: Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> PostBody - -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString -authPostBS2 manager token url pb = do - req <- uriToRequest url - authRequest req upReq manager - where upBody = urlEncodedBody (pb ++ accessTokenToParam token) - upHeaders = updateRequestHeaders Nothing . setMethod HT.POST - upReq = upHeaders . upBody +authPostBS2 :: + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authPostBS2 = authPostBSInternal $ Set.fromList [AuthInRequestBody] +{-# DEPRECATED authPostBS2 "use authPostBSInternal" #-} -- | Conduct POST request with access token only in the header and not in body -authPostBS3 :: Manager -- ^ HTTP connection manager. - -> AccessToken - -> URI - -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString -authPostBS3 manager token url = do +authPostBS3 :: + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authPostBS3 = authPostBSInternal $ Set.fromList [AuthInRequestHeader] +{-# DEPRECATED authPostBS3 "use authPostBSInternal" #-} + +-- | Conduct POST request and return response as ByteString. +-- Allow to specify how to append AccessToken. +authPostBSInternal :: + Set.Set APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString IO BSL.ByteString +authPostBSInternal authTypes manager token url body = do + let appendToBody = AuthInRequestBody `Set.member` authTypes + let appendToHeader = AuthInRequestHeader `Set.member` authTypes + let reqBody = if appendToBody then body ++ accessTokenToParam token else body + -- TODO: urlEncodedBody send request as 'application/x-www-form-urlencoded' + -- seems shall go with application/json which is more common? + let upBody = if null reqBody then id else urlEncodedBody reqBody + let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST + let upReq = upHeaders . upBody + req <- uriToRequest url authRequest req upReq manager - where upBody req = req { requestBody = "null" } - upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST - upReq = upHeaders . upBody --- |Send an HTTP request including the Authorization header with the specified --- access token. --- -authRequest :: Request -- ^ Request to perform - -> (Request -> Request) -- ^ Modify request before sending - -> Manager -- ^ HTTP connection manager. - -> ExceptT BSL.ByteString IO BSL.ByteString -authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage - -------------------------------------------------- + -- * Utilities + -------------------------------------------------- +-- | Send an HTTP request. +authRequest :: + -- | Request to perform + Request -> + -- | Modify request before sending + (Request -> Request) -> + -- | HTTP connection manager. + Manager -> + ExceptT BSL.ByteString IO BSL.ByteString +authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage + -- | Parses a @Response@ to to @OAuth2Result@ handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp = - if HT.statusIsSuccessful (responseStatus rsp) - then Right $ responseBody rsp - else Left $ responseBody rsp + if HT.statusIsSuccessful (responseStatus rsp) + then Right $ responseBody rsp + else -- TODO: better to surface up entire resp so that client can decide what to do when error happens. + Left $ responseBody rsp -- | Set several header values: -- + userAgennt : `hoauth2` @@ -283,13 +245,24 @@ -- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = - let extras = [ (HT.hUserAgent, "hoauth2") - , (HT.hAccept, "application/json") ] - bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t] - headers = bearer ++ extras ++ requestHeaders req - in - req { requestHeaders = headers } + let bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t] + headers = bearer ++ defaultRequestHeaders ++ requestHeaders req + in req {requestHeaders = headers} -- | Set the HTTP method to use. setMethod :: HT.StdMethod -> Request -> Request -setMethod m req = req { method = HT.renderStdMethod m } +setMethod m req = req {method = HT.renderStdMethod m} + +-- | For `GET` method API. +appendAccessToken :: + -- | Base URI + URIRef a -> + -- | Authorized Access Token + AccessToken -> + -- | Combined Result + URIRef a +appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri + +-- | Create 'QueryParams' with given access token value. +accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] +accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)] 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,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK -ignore-exports #-} @@ -17,17 +17,19 @@ import Data.Binary (Binary) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Default import Data.Maybe import Data.Text (Text, pack, unpack) import Data.Text.Encoding +import GHC.Generics import Lens.Micro import Lens.Micro.Extras import Network.HTTP.Conduit as C import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types as HT import URI.ByteString import URI.ByteString.Aeson () -import Data.Hashable -import GHC.Generics +import URI.ByteString.QQ -------------------------------------------------- @@ -41,17 +43,19 @@ oauth2ClientSecret :: Text, oauth2AuthorizeEndpoint :: URIRef Absolute, oauth2TokenEndpoint :: URIRef Absolute, - oauth2RedirectUri :: Maybe ( URIRef Absolute ) + oauth2RedirectUri :: URIRef Absolute } deriving (Show, Eq) -instance Hashable OAuth2 where - hashWithSalt salt OAuth2{..} = salt - `hashWithSalt` hash oauth2ClientId - `hashWithSalt` hash oauth2ClientSecret - `hashWithSalt` hash (show oauth2AuthorizeEndpoint) - `hashWithSalt` hash (show oauth2TokenEndpoint) - `hashWithSalt` hash (show oauth2RedirectUri) +instance Default OAuth2 where + def = + OAuth2 + { oauth2ClientId = "", + oauth2ClientSecret = "", + oauth2AuthorizeEndpoint = [uri|https://www.example.com/|], + oauth2TokenEndpoint = [uri|https://www.example.com/|], + oauth2RedirectUri = [uri|https://www.example.com/|] + } newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) @@ -106,8 +110,8 @@ do err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str) desc <- a .:? "error_description" - uri <- a .:? "error_uri" - return $ OAuth2Error err desc uri + errorUri <- a .:? "error_uri" + return $ OAuth2Error err desc errorUri parseJSON _ = fail "Expected an object" instance ToJSON err => ToJSON (OAuth2Error err) where @@ -125,6 +129,20 @@ (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response)) Nothing +data APIAuthenticationMethod + = -- | Provides in Authorization header + AuthInRequestHeader + | -- | Provides in request body + AuthInRequestBody + | -- | Provides in request query parameter + AuthInRequestQuery + deriving (Eq, Ord) + +data ClientAuthenticationMethod + = ClientSecretBasic + | ClientSecretPost + deriving (Eq, Ord) + -------------------------------------------------- -- * Types Synonym @@ -138,92 +156,27 @@ -------------------------------------------------- --- * URLs +-- * Utilies -------------------------------------------------- --- | Prepare the authorization URL. Redirect to this URL --- asking for user interactive authentication. -authorizationUrl :: OAuth2 -> URI -authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) - where - queryParts = - catMaybes - [ Just ("client_id", encodeUtf8 $ oauth2ClientId oa), - Just ("response_type", "code"), - fmap (("redirect_uri",) . serializeURIRef') (oauth2RedirectUri oa) - ] - --- | Prepare the URL and the request body query for fetching an access token. -accessTokenUrl :: - OAuth2 -> - -- | access code gained via authorization URL - ExchangeToken -> - -- | access token request URL plus the request body. - (URI, PostBody) -accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") - --- | Prepare the URL and the request body query for fetching an access token, with --- optional grant type. -accessTokenUrl' :: - OAuth2 -> - -- | access code gained via authorization URL - ExchangeToken -> - -- | Grant Type - Maybe Text -> - -- | access token request URL plus the request body. - (URI, PostBody) -accessTokenUrl' oa code gt = (uri, body) - where - uri = oauth2TokenEndpoint oa - body = - catMaybes - [ Just ("code", encodeUtf8 $ extoken code), - ("redirect_uri",) . serializeURIRef' <$> oauth2RedirectUri oa, - fmap (("grant_type",) . encodeUtf8) gt - ] - --- | Using a Refresh Token. Obtain a new access token by --- sending a refresh token to the Authorization server. -refreshAccessTokenUrl :: - OAuth2 -> - -- | refresh token gained via authorization URL - RefreshToken -> - -- | refresh token request URL plus the request body. - (URI, PostBody) -refreshAccessTokenUrl oa token = (uri, body) - where - uri = oauth2TokenEndpoint oa - body = - [ ("grant_type", "refresh_token"), - ("refresh_token", encodeUtf8 $ rtoken token) - ] - --- | For `GET` method API. -appendAccessToken :: - -- | Base URI - URIRef a -> - -- | Authorized Access Token - AccessToken -> - -- | Combined Result - URIRef a -appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri - --- | Create 'QueryParams' with given access token value. -accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] -accessTokenToParam t = [("access_token", encodeUtf8 $ atoken t)] +defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] +defaultRequestHeaders = + [ (HT.hUserAgent, "hoauth2"), + (HT.hAccept, "application/json") + ] appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a appendQueryParams params = over (queryL . queryPairsL) (params ++) uriToRequest :: MonadThrow m => URI -> m Request -uriToRequest uri = do - ssl <- case view (uriSchemeL . schemeBSL) uri of +uriToRequest auri = do + ssl <- case view (uriSchemeL . schemeBSL) auri of "http" -> return False "https" -> return True - s -> throwM $ InvalidUrlException (show uri) ("Invalid scheme: " ++ show s) - let query = fmap (second Just) (view (queryL . queryPairsL) uri) + s -> throwM $ InvalidUrlException (show auri) ("Invalid scheme: " ++ show s) + let query = fmap (second Just) (view (queryL . queryPairsL) auri) hostL = authorityL . _Just . authorityHostL . hostBSL portL = authorityL . _Just . authorityPortL . _Just . portNumberL defaultPort = (if ssl then 443 else 80) :: Int @@ -232,10 +185,10 @@ setQueryString query $ defaultRequest { secure = ssl, - path = view pathL uri + path = view pathL auri } - req2 = (over hostLens . maybe id const . preview hostL) uri req - req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) uri req2 + req2 = (over hostLens . maybe id const . preview hostL) auri req + req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) auri req2 return req3 requestToUri :: Request -> URI diff --git a/src/Network/OAuth/OAuth2/TokenRequest.hs b/src/Network/OAuth/OAuth2/TokenRequest.hs --- a/src/Network/OAuth/OAuth2/TokenRequest.hs +++ b/src/Network/OAuth/OAuth2/TokenRequest.hs @@ -1,21 +1,270 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Network.OAuth.OAuth2.TokenRequest where -import Data.Aeson -import GHC.Generics +import Control.Monad.Trans.Except +import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text.Encoding as T +import GHC.Generics +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.URI (parseQuery) +import Network.OAuth.OAuth2.Internal +import URI.ByteString +-------------------------------------------------- + +-- * Token Request Errors + +-------------------------------------------------- + instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } + parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} + instance ToJSON Errors where - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } + toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 -data Errors = - InvalidRequest +data Errors + = InvalidRequest | InvalidClient | InvalidGrant | UnauthorizedClient | UnsupportedGrantType | InvalidScope deriving (Show, Eq, Generic) + +-------------------------------------------------- + +-- * URL + +-------------------------------------------------- + +-- | Prepare the URL and the request body query for fetching an access token. +accessTokenUrl :: + OAuth2 -> + -- | access code gained via authorization URL + ExchangeToken -> + -- | access token request URL plus the request body. + (URI, PostBody) +accessTokenUrl oa code = + let uri = oauth2TokenEndpoint oa + body = + [ ("code", T.encodeUtf8 $ extoken code), + ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa), + ("grant_type", "authorization_code") + ] + in (uri, body) + +-- | Using a Refresh Token. Obtain a new access token by +-- sending a refresh token to the Authorization server. +refreshAccessTokenUrl :: + OAuth2 -> + -- | refresh token gained via authorization URL + RefreshToken -> + -- | refresh token request URL plus the request body. + (URI, PostBody) +refreshAccessTokenUrl oa token = (uri, body) + where + uri = oauth2TokenEndpoint oa + body = + [ ("grant_type", "refresh_token"), + ("refresh_token", T.encodeUtf8 $ rtoken token) + ] + +clientSecretPost :: OAuth2 -> PostBody +clientSecretPost oa = + [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa), + ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) + ] + +-------------------------------------------------- + +-- * Token management + +-------------------------------------------------- + +-- | Fetch OAuth2 Token with authenticate in request header. +-- +-- OAuth2 spec allows `client_id` and `client_secret` to +-- either be sent in the header (as basic authentication) +-- OR as form/url params. +-- The OAuth server can choose to implement only one, or both. +-- Unfortunately, there is no way for the OAuth client (i.e. this library) to +-- know which method to use. +-- Please take a look at the documentation of the +-- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2` +fetchAccessToken :: + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | OAuth2 Code + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) IO OAuth2Token +fetchAccessToken = fetchAccessTokenInternal ClientSecretBasic + +fetchAccessToken2 :: + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | OAuth 2 Tokens + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) IO OAuth2Token +fetchAccessToken2 = fetchAccessTokenInternal ClientSecretPost +{-# DEPRECATED fetchAccessToken2 "renamed to fetchAccessTokenInternal" #-} + +fetchAccessTokenInternal :: + ClientAuthenticationMethod -> + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | OAuth 2 Tokens + ExchangeToken -> + -- | Access Token + ExceptT (OAuth2Error Errors) IO OAuth2Token +fetchAccessTokenInternal authMethod manager oa code = do + let (uri, body) = accessTokenUrl oa code + let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else [] + doJSONPostRequest manager oa uri (body ++ extraBody) + +-- doJSONPostRequest append client secret to header which is needed for both +-- client_secret_post and client_secret_basic + +-- | Fetch a new AccessToken with the Refresh Token with authentication in request header. +-- +-- OAuth2 spec allows `client_id` and `client_secret` to +-- either be sent in the header (as basic authentication) +-- OR as form/url params. +-- The OAuth server can choose to implement only one, or both. +-- Unfortunately, there is no way for the OAuth client (i.e. this library) to +-- know which method to use. Please take a look at the documentation of the +-- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2` +refreshAccessToken :: + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | refresh token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) IO OAuth2Token +refreshAccessToken = refreshAccessTokenInternal ClientSecretBasic + +refreshAccessToken2 :: + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | refresh token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) IO OAuth2Token +refreshAccessToken2 = refreshAccessTokenInternal ClientSecretPost +{-# DEPRECATED refreshAccessToken2 "renamed to fetchAccessTokenInternal" #-} + +refreshAccessTokenInternal :: + ClientAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | refresh token gained after authorization + RefreshToken -> + ExceptT (OAuth2Error Errors) IO OAuth2Token +refreshAccessTokenInternal authMethod manager oa token = do + let (uri, body) = refreshAccessTokenUrl oa token + let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else [] + doJSONPostRequest manager oa uri (body ++ extraBody) + +-------------------------------------------------- + +-- * Utilies + +-------------------------------------------------- + +-- | Conduct post request and return response as JSON. +doJSONPostRequest :: + (FromJSON err, FromJSON a) => + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | The URL + URI -> + -- | request body + PostBody -> + -- | Response as JSON + ExceptT (OAuth2Error err) IO a +doJSONPostRequest manager oa uri body = do + resp <- doSimplePostRequest manager oa uri body + case parseResponseFlexible resp of + Right obj -> return obj + Left e -> throwE e + +-- | Conduct post request. +doSimplePostRequest :: + FromJSON err => + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | URL + URI -> + -- | Request body. + PostBody -> + -- | Response as ByteString + ExceptT (OAuth2Error err) IO BSL.ByteString +doSimplePostRequest manager oa url body = + ExceptT $ fmap handleOAuth2TokenResponse go + where + addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) + go = do + req <- uriToRequest url + let req' = (addBasicAuth . addDefaultRequestHeaders) req + httpLbs (urlEncodedBody body req') manager + +-- | Parses a @Response@ to to @OAuth2Result@ +handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString +handleOAuth2TokenResponse rsp = + if HT.statusIsSuccessful (responseStatus rsp) + then Right $ responseBody rsp + else Left $ parseOAuth2Error (responseBody rsp) + +-- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String. +parseResponseFlexible :: + (FromJSON err, FromJSON a) => + BSL.ByteString -> + Either (OAuth2Error err) a +parseResponseFlexible r = case eitherDecode r of + Left _ -> parseResponseString r + Right x -> Right x + +-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String +parseResponseString :: + (FromJSON err, FromJSON a) => + BSL.ByteString -> + Either (OAuth2Error err) a +parseResponseString b = case parseQuery $ BSL.toStrict b of + [] -> Left errorMessage + a -> case fromJSON $ queryToValue a of + Error _ -> Left errorMessage + Success x -> Right x + where + queryToValue = Object . KeyMap.fromList . map paramToPair + paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) + errorMessage = parseOAuth2Error b + +-- | Set several header values: +-- + userAgennt : `hoauth2` +-- + accept : `application/json` +addDefaultRequestHeaders :: Request -> Request +addDefaultRequestHeaders req = + let headers = defaultRequestHeaders ++ requestHeaders req + in req {requestHeaders = headers}