diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,156 @@ +# hoauth2 Changelog + +## 2.15.0 (2025-10-05) +- Breaking changes + - Type and class renames + - `OAuth2Token` renamed to `TokenResponse`. + - `TokenRequestAuthenicationMethod` renamed to `ClientAuthenticationMethod`. + - `HasTokenRequestClientAuthenticationMethod` renamed to `HasClientAuthenticationMethod`. + - Removed several `Has*` type classes (e.g., `HasOAuth2Key`, `HasOAuthKey` from `HasTokenRequest`). + - Removed deprecated API in `Network.OAuth2.HttpClient` + - Deprecated functions have been removed. Use `authGetJSON`/`authGetBS`/`authPostJSON`/`authPostBS` and the `WithAuthMethod` variants with `APIAuthenticationMethod`. + - Request body encoding behavior + - `authPostJSON` now sends JSON with `Content-Type: application/json`. If an endpoint requires form-encoded data, use `authPostBS` or construct a custom request body. + - Import/module path cleanup + - Consumers should import `Network.OAuth2` (not `Network.OAuth.OAuth2`). +- Behavioral changes and bug fixes + - Client authentication handling + - Append `client_id` and `client_secret` for `ClientSecretPost` in client credentials flow. + - Refresh token flow honors the configured client authentication method. + - Authorization Code flow supports client authentication methods. + - Device Authorization flow + - Updated handling of device authorization requests and polling behavior. +- Refactors and internal cleanup + - Refactored header handling, simplified URI-to-Request conversion, removed deprecated or unused internals, and general cleanups. +- Dependency changes + - Allow `microlens` 0.5 (`microlens` >= 0.4 && < 0.6). + - Raise lower bound to `uri-bytestring` >= 0.4 (< 0.5). + +## 2.14.3 (2025-03-14) + +- Fixes and improvements: + - Append client_id and client_secret for ClientSecretPost in client credentials flow + - Add raw response to token response and derive Show instances + - Skip empty scope; assorted refactors and cleanups + +## 2.14.2 (2025-01-30) + +* Updated uri-bytestring to version 0.4 + +## 2.14.1 (2024-11-19) + +* Updated data-default to version 0.8 + +## 2.14.0 (2024-11-19) + +* Updated crypton to version 1.0 + +## 2.13.0 (2024-03-07) + +* Replaced cryptonite with crypton + +## 2.12.0 (2024-01-19) + +* Updated base64 to version 1.0 + +## 2.11.0 (2023-12-30) + +* Updated aeson to version 2.2 +* Updated binary to version 0.10 +* Updated bytestring to version 0.12 +* Updated container to version 0.7 + +## 2.10.0 (2023-11-17) + +* Added support for text 2.2 + +## 2.9.0 (2023-10-26) + +* Refactored oauth2 Experiment module implementation +* Removed generics +* Added Device Authorization grant +* Moved IdpName to hoauth2 and enabled DataKinds +* Changed the type parameter in HttpClient methods +* Removed data family `RefreshTokenRequest` + +## 2.8.1 (2023-06-17) + +* Added support for GHC-9.6 +* Updated CI configuration for GHC 9.6.1 +* Added hiedb integration + +## 2.8.0 (2023-03-15) + +* Added support for GHC-9.4.4 +* Added support for text-2.0 + +## 2.7 (2022-11-17) + +* Added GrantType jwt-bearer +* Added JWT authentication method for ClientCredential flow +* Replaced `OAuth2Error` with `TokenRequestError` +* Moved `HasIdpName` class to hoauth2-demo +* Improved error handling when response body is empty in `HttpClient.handleResponse` +* Removed the following modules from exposure list: + - Network.OAuth2.Experiment.Pkce + - Network.OAuth2.Experiment.Types + - Network.OAuth2.Experiment.Utils + - Network.OAuth.OAuth2.Internal + +## 2.6 (2022-10-04) + +* Changed type parameter order in http client JSON method +* Modified http client to only accept one Authentication Method instead of a Set +* Removed `authPostBS1` (non-standard approach to sending credentials) +* Removed Douban IdP (discontinued OAuth2 support) +* Deprecated all *Internal methods, added *WithAuthMethod alternatives +* Changed license to MIT +* Added support for PKCE flow in `Network.OAuth2.Experiment` module +* Added support for Resource Owner Password and Client Credentials flows +* Added `hoauth2-providers` and `hoauth2-providers-tutorial` modules +* Added `hoauth2-tutorial` module + +## 2.5 (2022-08-17) + +* Updated aeson to version 2.1 + +## 2.4 (2022-08-17) + +* Relaxed binary and bytestring version constraints + +## 2.1 (2022-02-19) + +* Added documentation for OAuth2 specification +* Updated aeson to version 2 + +## 2.0 (2022-02-15) + +* Breaking change: Refactored naming convention of `OAuth2` data type + ```diff + - { oauthClientId = "xxxxxxxxxxxxxxx" + - , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx" + - , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|] + - , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|] + - , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|] + + { oauth2ClientId = "xxxxxxxxxxxxxxx" + + , oauth2ClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx" + + , oauth2RedirectUri = Just [uri|http://127.0.0.1:9988/oauthCallback|] + + , oauth2AuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|] + + , oauth2TokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|] + + } + ``` + +## 1.7.0 (2018-03-03) + +* Added sample server and removed individual sample tests +* Added `fetchAccessToken2` function +* Added `refreshAccessToken` function and deprecated `fetchRefreshToken` +* Renamed `authGetBS'` to `authGetBS2` +* Renamed `authPostBS'` to `authPostBS2` +* Added `authPostBS3` function + +## 1.0.0 (2017-04-07) + +* Added umbrella type `OAuth2Token` to accommodate `AccessToken` and `RefreshToken` +* Typed the intermediate authentication code as `ExchangeToken` +* Fixed missing client_id error in tests by appending client_id and client_secret to header diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +Haskell binding for + +- [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749) + - If the Identity Provider also implements [OIDC + spec](https://openid.net/specs/openid-connect-core-1_0.html), ID + Token will also be present in token response (see + `OAuth2Token`). +- [JWT Profile for OAuth2 Client Authentication and Authorization + Grants](https://www.rfc-editor.org/rfc/rfc7523.html) +- [The OAuth 2.0 Authorization Framework: Bearer Token + Usage](https://www.rfc-editor.org/rfc/rfc6750) diff --git a/README.org b/README.org deleted file mode 100644 --- a/README.org +++ /dev/null @@ -1,8 +0,0 @@ -* Introduction - -Haskell binding for - -- [[https://datatracker.ietf.org/doc/html/rfc6749][The OAuth 2.0 Authorization Framework]] - - If the Identity Provider also implements [[https://openid.net/specs/openid-connect-core-1_0.html][OIDC spec]], ID Token will also be present in token response (see ~OAuth2Token~). -- [[https://www.rfc-editor.org/rfc/rfc7523.html][JWT Profile for OAuth2 Client Authentication and Authorization Grants]] -- [[https://www.rfc-editor.org/rfc/rfc6750][The OAuth 2.0 Authorization Framework: Bearer Token Usage]] diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -2,7 +2,7 @@ name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -version: 2.14.3 +version: 2.15.0 synopsis: Haskell OAuth2 authentication client description: This is Haskell binding of OAuth2 Authorization framework and Bearer Token Usage framework. @@ -16,9 +16,13 @@ category: Network build-type: Simple stability: Beta -tested-with: GHC <=9.6.1 -extra-source-files: README.org +tested-with: + GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 || ==9.8.2 +extra-source-files: + CHANGELOG.md + README.md + source-repository head type: git location: git://github.com/freizl/hoauth2.git @@ -29,17 +33,18 @@ autogen-modules: Paths_hoauth2 other-modules: Network.HTTP.Client.Contrib - Network.OAuth.OAuth2.Internal + Network.OAuth2.Internal Network.OAuth2.Experiment.Grants Network.OAuth2.Experiment.Utils Paths_hoauth2 exposed-modules: - Network.OAuth.OAuth2 - Network.OAuth.OAuth2.AuthorizationRequest - Network.OAuth.OAuth2.HttpClient - Network.OAuth.OAuth2.TokenRequest + Network.OAuth2 + Network.OAuth2.AuthorizationRequest + Network.OAuth2.HttpClient + Network.OAuth2.TokenRequest Network.OAuth2.Experiment + Network.OAuth2.Experiment.Flows Network.OAuth2.Experiment.Flows.AuthorizationRequest Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest Network.OAuth2.Experiment.Flows.RefreshTokenRequest @@ -77,10 +82,10 @@ , http-conduit >=2.1 && <2.4 , http-types >=0.11 && <0.13 , memory ^>=0.18 - , microlens ^>=0.4.0 + , microlens >=0.4 && <0.6 , text >=2.0 && <2.3 , transformers >=0.4 && <0.7 - , uri-bytestring >=0.3 && <0.5 + , uri-bytestring >=0.4 && <0.5 , uri-bytestring-aeson ^>=0.1 ghc-options: @@ -98,11 +103,13 @@ , binary >=0.8 && <0.11 , hoauth2 , hspec >=2 && <3 - , uri-bytestring >=0.3 && <0.5 + , uri-bytestring >=0.4 && <0.5 + , http-conduit >=2.1 && <2.4 other-modules: - Network.OAuth.OAuth2.TokenRequestSpec - Network.OAuth.OAuth2.TokenResponseSpec + Network.OAuth2.InternalSpec + Network.OAuth2.TokenRequestSpec + Network.OAuth2.TokenResponseSpec default-language: Haskell2010 default-extensions: diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | A lightweight oauth2 Haskell binding. --- See Readme for more details -module Network.OAuth.OAuth2 ( - module Network.OAuth.OAuth2.Internal, - - -- * Authorization Requset - module Network.OAuth.OAuth2.AuthorizationRequest, - - -- * Token Request - module Network.OAuth.OAuth2.TokenRequest, - - -- * OAuth'ed http client utilities - module Network.OAuth.OAuth2.HttpClient, -) where - -{- - Hiding Errors data type from default. - Shall qualified import given the naming collision. --} -import Network.OAuth.OAuth2.AuthorizationRequest hiding ( - AuthorizationResponseError (..), - AuthorizationResponseErrorCode (..), - ) -import Network.OAuth.OAuth2.HttpClient -import Network.OAuth.OAuth2.Internal -import Network.OAuth.OAuth2.TokenRequest diff --git a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | Bindings Authorization part of The OAuth 2.0 Authorization Framework --- RFC6749 -module Network.OAuth.OAuth2.AuthorizationRequest where - -import Data.Aeson -import Data.Function (on) -import Data.List qualified as List -import Data.Text (Text) -import Data.Text.Encoding qualified as T -import Lens.Micro (over) -import Network.OAuth.OAuth2.Internal -import URI.ByteString -import Prelude hiding (error) - --------------------------------------------------- - --- * Authorization Request Errors - --------------------------------------------------- - --- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 --- --- I found hard time to figure a way to test the authorization error flow --- When anything wrong in @/authorize@ request, it will stuck at the Provider page --- hence no way for this library to parse error response. --- In other words, @/authorize@ ends up with 4xx or 5xx. --- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors. -data AuthorizationResponseError = AuthorizationResponseError - { authorizationResponseError :: AuthorizationResponseErrorCode - , authorizationResponseErrorDescription :: Maybe Text - , authorizationResponseErrorUri :: Maybe (URIRef Absolute) - } - deriving (Show, Eq) - -data AuthorizationResponseErrorCode - = InvalidRequest - | UnauthorizedClient - | AccessDenied - | UnsupportedResponseType - | InvalidScope - | ServerError - | TemporarilyUnavailable - | UnknownErrorCode Text - deriving (Show, Eq) - -instance FromJSON AuthorizationResponseErrorCode where - parseJSON = withText "parseJSON AuthorizationResponseErrorCode" $ \t -> - pure $ case t of - "invalid_request" -> InvalidRequest - "unauthorized_client" -> UnauthorizedClient - "access_denied" -> AccessDenied - "unsupported_response_type" -> UnsupportedResponseType - "invalid_scope" -> InvalidScope - "server_error" -> ServerError - "temporarily_unavailable" -> TemporarilyUnavailable - _ -> UnknownErrorCode t - -instance FromJSON AuthorizationResponseError where - parseJSON = withObject "parseJSON AuthorizationResponseError" $ \t -> do - authorizationResponseError <- t .: "error" - authorizationResponseErrorDescription <- t .:? "error_description" - authorizationResponseErrorUri <- t .:? "error_uri" - pure AuthorizationResponseError {..} - --------------------------------------------------- - --- * URLs - --------------------------------------------------- - --- | See 'authorizationUrlWithParams' -authorizationUrl :: OAuth2 -> URI -authorizationUrl = authorizationUrlWithParams [] - --- | Prepare the authorization URL. Redirect to this URL --- asking for user interactive authentication. --- --- @since 2.6.0 -authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI -authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) - where - queryParts = - List.nubBy ((==) `on` fst) $ - qs - ++ [ ("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 deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ /dev/null @@ -1,333 +0,0 @@ --- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage --- RFC6750 -module Network.OAuth.OAuth2.HttpClient ( - -- * AUTH requests - authGetJSON, - authGetBS, - authGetBS2, - authGetJSONWithAuthMethod, - authGetJSONInternal, - authGetBSWithAuthMethod, - authGetBSInternal, - authPostJSON, - authPostBS, - authPostBS2, - authPostBS3, - authPostJSONWithAuthMethod, - authPostJSONInternal, - authPostBSWithAuthMethod, - authPostBSInternal, - - -- * Types - APIAuthenticationMethod (..), -) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..), throwE) -import Data.Aeson (FromJSON, eitherDecode) -import Data.ByteString.Char8 qualified as BS -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Maybe (fromJust, isJust) -import Data.Text.Encoding qualified as T -import Lens.Micro (over) -import Network.HTTP.Client.Contrib (handleResponse) -import Network.HTTP.Conduit -import Network.HTTP.Types qualified as HT -import Network.OAuth.OAuth2.Internal -import URI.ByteString (URI, URIRef, queryL, queryPairsL) - --------------------------------------------------- - --- * AUTH requests - --- 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 :: - (MonadIO m, FromJSON a) => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as JSON - ExceptT BSL.ByteString m a -authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader - --- | Deprecated. Use `authGetJSONWithAuthMethod` instead. -authGetJSONInternal :: - (MonadIO m, FromJSON a) => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as JSON - ExceptT BSL.ByteString m a -authGetJSONInternal = authGetJSONWithAuthMethod -{-# DEPRECATED authGetJSONInternal "use authGetJSONWithAuthMethod" #-} - --- | Conduct an authorized GET request and return response as JSON. --- Allow to specify how to append AccessToken. --- --- @since 2.6.0 -authGetJSONWithAuthMethod :: - (MonadIO m, FromJSON a) => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as JSON - ExceptT BSL.ByteString m a -authGetJSONWithAuthMethod authTypes manager t uri = do - resp <- authGetBSWithAuthMethod authTypes manager t uri - either (throwE . BSL.pack) return (eitherDecode resp) - --- | Conduct an authorized GET request. --- Inject Access Token to Authorization Header. -authGetBS :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authGetBS = authGetBSWithAuthMethod AuthInRequestHeader - --- | Same to 'authGetBS' but set access token to query parameter rather than header -authGetBS2 :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authGetBS2 = authGetBSWithAuthMethod AuthInRequestQuery -{-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-} - -authGetBSInternal :: - MonadIO m => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authGetBSInternal = authGetBSWithAuthMethod -{-# DEPRECATED authGetBSInternal "use authGetBSWithAuthMethod" #-} - --- | Conduct an authorized GET request and return response as ByteString. --- Allow to specify how to append AccessToken. --- --- @since 2.6.0 -authGetBSWithAuthMethod :: - MonadIO m => - -- | Specify the way that how to append the 'AccessToken' in the request - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authGetBSWithAuthMethod authTypes manager token url = do - let appendToUrl = AuthInRequestQuery == authTypes - let appendToHeader = AuthInRequestHeader == 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 - --- | Conduct POST request and return response as JSON. --- Inject Access Token to Authorization Header. -authPostJSON :: - (MonadIO m, FromJSON a) => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as JSON - ExceptT BSL.ByteString m a -authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader - -authPostJSONInternal :: - (MonadIO m, FromJSON a) => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m a -authPostJSONInternal = authPostJSONWithAuthMethod -{-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-} - --- | Conduct POST request and return response as JSON. --- Allow to specify how to append AccessToken. --- --- @since 2.6.0 -authPostJSONWithAuthMethod :: - (MonadIO m, FromJSON a) => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m a -authPostJSONWithAuthMethod authTypes manager token url body = do - resp <- authPostBSWithAuthMethod authTypes manager token url body - either (throwE . BSL.pack) return (eitherDecode resp) - --- | Conduct POST request. --- Inject Access Token to http header (Authorization) -authPostBS :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authPostBS = authPostBSWithAuthMethod AuthInRequestHeader - --- | Conduct POST request with access token only in the request body but header. -authPostBS2 :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authPostBS2 = authPostBSWithAuthMethod AuthInRequestBody -{-# DEPRECATED authPostBS2 "use 'authPostBSWithAuthMethod'" #-} - --- | Conduct POST request with access token only in the header and not in body -authPostBS3 :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authPostBS3 = authPostBSWithAuthMethod AuthInRequestHeader -{-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-} - -authPostBSInternal :: - MonadIO m => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authPostBSInternal = authPostBSWithAuthMethod -{-# DEPRECATED authPostBSInternal "use 'authPostBSWithAuthMethod'" #-} - --- | Conduct POST request and return response as ByteString. --- Allow to specify how to append AccessToken. --- --- @since 2.6.0 -authPostBSWithAuthMethod :: - MonadIO m => - APIAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as ByteString - ExceptT BSL.ByteString m BSL.ByteString -authPostBSWithAuthMethod authTypes manager token url body = do - let appendToBody = AuthInRequestBody == authTypes - let appendToHeader = AuthInRequestHeader == 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 <- liftIO $ uriToRequest url - authRequest req upReq manager - --------------------------------------------------- - --- * Types - --------------------------------------------------- - --- | https://www.rfc-editor.org/rfc/rfc6750#section-2 -data APIAuthenticationMethod - = -- | Provides in Authorization header - AuthInRequestHeader - | -- | Provides in request body - AuthInRequestBody - | -- | Provides in request query parameter - AuthInRequestQuery - deriving (Eq, Ord) - --------------------------------------------------- - --- * Utilities - --------------------------------------------------- - --- | Send an HTTP request. -authRequest :: - MonadIO m => - -- | Request to perform - Request -> - -- | Modify request before sending - (Request -> Request) -> - -- | HTTP connection manager. - Manager -> - ExceptT BSL.ByteString m BSL.ByteString -authRequest req upReq manage = ExceptT $ do - resp <- httpLbs (upReq req) manage - pure (handleResponse resp) - --- | Set several header values: --- + userAgennt : "hoauth2" --- + accept : "application/json" --- + authorization : "Bearer xxxxx" if 'Network.OAuth.OAuth2.AccessToken' provided. -updateRequestHeaders :: Maybe AccessToken -> Request -> Request -updateRequestHeaders t req = - -- FIXME: use `applyBearerAuth` - 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} - --- | 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 deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/Internal.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Network.OAuth.OAuth2.Internal where - -import Control.Arrow (second) -import Control.Monad.Catch -import Data.Aeson -import Data.Aeson qualified as Aeson -import Data.Aeson.Types (Parser, explicitParseFieldMaybe) -import Data.Binary (Binary (..)) -import Data.Binary.Instances.Aeson () -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BS8 -import Data.Default -import Data.Maybe -import Data.Text (Text, unpack) -import Data.Version (showVersion) -import Lens.Micro -import Lens.Micro.Extras -import Network.HTTP.Conduit as C -import Network.HTTP.Types qualified as H -import Network.HTTP.Types qualified as HT -import Paths_hoauth2 (version) -import URI.ByteString -import URI.ByteString.Aeson () -import URI.ByteString.QQ - -------------------------------------------------------------------------------- - --- * OAuth2 Configuration - -------------------------------------------------------------------------------- - --- | Query Parameter Representation -data OAuth2 = OAuth2 - { oauth2ClientId :: Text - , oauth2ClientSecret :: Text - , oauth2AuthorizeEndpoint :: URIRef Absolute - , oauth2TokenEndpoint :: URIRef Absolute - , oauth2RedirectUri :: URIRef Absolute - } - deriving (Show, Eq) - -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/|] - } - -------------------------------------------------------------------------------- - --- * Tokens - -------------------------------------------------------------------------------- - -newtype AccessToken = AccessToken {atoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) - -newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) - -newtype IdToken = IdToken {idtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) - --- | Authorization Code -newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) - --- FIXME: rename to TokenResponse and move to that module - --- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 -data OAuth2Token = OAuth2Token - { accessToken :: AccessToken - , refreshToken :: Maybe RefreshToken - -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token. - , expiresIn :: Maybe Int - , tokenType :: Maybe Text - -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release. - , idToken :: Maybe IdToken - -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol. - , scope :: Maybe Text - , rawResponse :: Object - } - deriving (Eq, Show) - -instance Binary OAuth2Token where - put OAuth2Token {..} = put rawResponse - get = do - rawt <- get - case fromJSON (Aeson.Object rawt) of - Success a -> pure a - Error err -> fail err - --- | Parse JSON data into 'OAuth2Token' -instance FromJSON OAuth2Token where - parseJSON :: Value -> Parser OAuth2Token - parseJSON = withObject "OAuth2Token" $ \v -> - OAuth2Token - <$> v .: "access_token" - <*> v .:? "refresh_token" - <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" - <*> v .:? "token_type" - <*> v .:? "id_token" - <*> v .:? "scope" - <*> pure v - where - parseIntFlexible :: Value -> Parser Int - parseIntFlexible (String s) = pure . read $ unpack s - parseIntFlexible v = parseJSON v - -instance ToJSON OAuth2Token where - toJSON :: OAuth2Token -> Value - toJSON = toJSON . Object . rawResponse - toEncoding :: OAuth2Token -> Encoding - toEncoding = toEncoding . Object . rawResponse - -------------------------------------------------------------------------------- - --- * Client Authentication methods - -------------------------------------------------------------------------------- - --- | How would the Client (RP) authenticate itself? --- --- The client MUST NOT use more than one authentication method in each request. --- Means use Authorization header or Post body. --- --- See more details --- --- https://www.rfc-editor.org/rfc/rfc6749#section-2.3 --- https://oauth.net/private-key-jwt/ --- https://www.rfc-editor.org/rfc/rfc7523.html --- -data ClientAuthenticationMethod - = ClientSecretBasic - | ClientSecretPost - | ClientAssertionJwt - deriving (Eq, Show) - -------------------------------------------------------------------------------- - --- * Utilies for Request and URI - -------------------------------------------------------------------------------- - --- | Type synonym of post body content -type PostBody = [(BS.ByteString, BS.ByteString)] - --- | Type sysnonym of request query params -type QueryParams = [(BS.ByteString, BS.ByteString)] - -defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] -defaultRequestHeaders = - [ (HT.hUserAgent, "hoauth2-" <> BS8.pack (showVersion version)) - , (HT.hAccept, "application/json") - ] - -appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a -appendQueryParams params = - over (queryL . queryPairsL) (params ++) - --- TODO: why we need this method instead of `parseRequest` --- https://hackage.haskell.org/package/http-client-0.7.18/docs/Network-HTTP-Client.html#v:parseRequest --- -uriToRequest :: MonadThrow m => URI -> m Request -uriToRequest auri = do - ssl <- case view (uriSchemeL . schemeBSL) auri of - "http" -> return False - "https" -> return True - 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 - - req = - setQueryString query $ - defaultRequest - { secure = ssl - , path = view pathL auri - } - 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 -requestToUri req = - URI - ( Scheme - ( if secure req - then "https" - else "http" - ) - ) - (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req))) - (path req) - (Query $ H.parseSimpleQuery $ queryString req) - Nothing - -hostLens :: Lens' Request BS.ByteString -hostLens f req = f (C.host req) <&> \h' -> req {C.host = h'} -{-# INLINE hostLens #-} - -portLens :: Lens' Request Int -portLens f req = f (C.port req) <&> \p' -> req {C.port = p'} -{-# INLINE portLens #-} diff --git a/src/Network/OAuth/OAuth2/TokenRequest.hs b/src/Network/OAuth/OAuth2/TokenRequest.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/TokenRequest.hs +++ /dev/null @@ -1,346 +0,0 @@ --- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework --- RFC6749 -module Network.OAuth.OAuth2.TokenRequest where - -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..), throwE) -import Data.Aeson -import Data.Aeson.Key qualified as Key -import Data.Aeson.KeyMap qualified as KeyMap -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Network.HTTP.Conduit -import Network.HTTP.Types qualified as HT -import Network.HTTP.Types.URI (parseQuery) -import Network.OAuth.OAuth2.Internal -import URI.ByteString -import Prelude hiding (error) - --------------------------------------------------- - --- * Token Request Errors - --------------------------------------------------- - -data TokenResponseError = TokenResponseError - { tokenResponseError :: TokenResponseErrorCode - , tokenResponseErrorDescription :: Maybe Text - , tokenResponseErrorUri :: Maybe (URIRef Absolute) - } - deriving (Show, Eq) - --- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 -data TokenResponseErrorCode - = InvalidRequest - | InvalidClient - | InvalidGrant - | UnauthorizedClient - | UnsupportedGrantType - | InvalidScope - | UnknownErrorCode Text - deriving (Show, Eq) - -instance FromJSON TokenResponseErrorCode where - parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t -> - pure $ case t of - "invalid_request" -> InvalidRequest - "invalid_client" -> InvalidClient - "invalid_grant" -> InvalidGrant - "unauthorized_client" -> UnauthorizedClient - "unsupported_grant_type" -> UnsupportedGrantType - "invalid_scope" -> InvalidScope - _ -> UnknownErrorCode t - -instance FromJSON TokenResponseError where - parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do - tokenResponseError <- t .: "error" - tokenResponseErrorDescription <- t .:? "error_description" - tokenResponseErrorUri <- t .:? "error_uri" - pure TokenResponseError {..} - -parseTokeResponseError :: BSL.ByteString -> TokenResponseError -parseTokeResponseError string = - either (mkDecodeOAuth2Error string) id (eitherDecode string) - where - mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError - mkDecodeOAuth2Error response err = - TokenResponseError - (UnknownErrorCode "") - (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response)) - Nothing - --------------------------------------------------- - --- * 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) - --- | 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) - ] - --------------------------------------------------- - --- * Token management - --------------------------------------------------- - --- | Exchange @code@ for an Access Token with authenticate in request header. -fetchAccessToken :: - MonadIO m => - -- | HTTP connection manager - Manager -> - -- | OAuth Data - OAuth2 -> - -- | OAuth2 Code - ExchangeToken -> - -- | Access Token - ExceptT TokenResponseError m OAuth2Token -fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic - -fetchAccessToken2 :: - MonadIO m => - -- | HTTP connection manager - Manager -> - -- | OAuth Data - OAuth2 -> - -- | Authorization Code - ExchangeToken -> - -- | Access Token - ExceptT TokenResponseError m OAuth2Token -fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost -{-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-} - -fetchAccessTokenInternal :: - MonadIO m => - ClientAuthenticationMethod -> - -- | HTTP connection manager - Manager -> - -- | OAuth Data - OAuth2 -> - -- | Authorization Code - ExchangeToken -> - -- | Access Token - ExceptT TokenResponseError m OAuth2Token -fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod -{-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-} - --- | Exchange @code@ for an Access Token --- --- OAuth2 spec allows credential (@client_id@, @client_secret@) to be sent --- either in the header (a.k.a `ClientSecretBasic`). --- or as form/url params (a.k.a `ClientSecretPost`). --- --- The OAuth provider can choose to implement only one, or both. --- Look for API document from the OAuth provider you're dealing with. --- If you`re uncertain, try `fetchAccessToken` which sends credential --- in authorization http header, which is common case. --- --- @since 2.6.0 -fetchAccessTokenWithAuthMethod :: - MonadIO m => - ClientAuthenticationMethod -> - -- | HTTP connection manager - Manager -> - -- | OAuth Data - OAuth2 -> - -- | Authorization Code - ExchangeToken -> - -- | Access Token - ExceptT TokenResponseError m OAuth2Token -fetchAccessTokenWithAuthMethod 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) - --- | Fetch a new AccessToken using the Refresh Token with authentication in request header. -refreshAccessToken :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - -- | OAuth context - OAuth2 -> - -- | Refresh Token gained after authorization - RefreshToken -> - ExceptT TokenResponseError m OAuth2Token -refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic - -refreshAccessToken2 :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - -- | OAuth context - OAuth2 -> - -- | Refresh Token gained after authorization - RefreshToken -> - ExceptT TokenResponseError m OAuth2Token -refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost -{-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-} - -refreshAccessTokenInternal :: - MonadIO m => - ClientAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - -- | OAuth context - OAuth2 -> - -- | Refresh Token gained after authorization - RefreshToken -> - ExceptT TokenResponseError m OAuth2Token -refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod -{-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-} - --- | Fetch a new AccessToken using the Refresh Token. --- --- OAuth2 spec allows credential ("client_id", "client_secret") to be sent --- either in the header (a.k.a 'ClientSecretBasic'). --- or as form/url params (a.k.a 'ClientSecretPost'). --- --- The OAuth provider can choose to implement only one, or both. --- Look for API document from the OAuth provider you're dealing with. --- If you're uncertain, try 'refreshAccessToken' which sends credential --- in authorization http header, which is common case. --- --- @since 2.6.0 -refreshAccessTokenWithAuthMethod :: - MonadIO m => - ClientAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - -- | OAuth context - OAuth2 -> - -- | Refresh Token gained after authorization - RefreshToken -> - ExceptT TokenResponseError m OAuth2Token -refreshAccessTokenWithAuthMethod 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 :: - (MonadIO m, FromJSON a) => - -- | HTTP connection manager. - Manager -> - -- | OAuth options - OAuth2 -> - -- | The URL - URI -> - -- | request body - PostBody -> - -- | Response as JSON - ExceptT TokenResponseError m 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 :: - MonadIO m => - -- | HTTP connection manager. - Manager -> - -- | OAuth options - OAuth2 -> - -- | URL - URI -> - -- | Request body. - PostBody -> - -- | Response as ByteString - ExceptT TokenResponseError m BSL.ByteString -doSimplePostRequest manager oa url body = - ExceptT . liftIO $ fmap handleOAuth2TokenResponse go - where - go = do - req <- uriToRequest url - let req' = (addBasicAuth oa . addDefaultRequestHeaders) req - httpLbs (urlEncodedBody body req') manager - --- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth.OAuth2.TokenRequest.TokenResponseError' -handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString -handleOAuth2TokenResponse rsp = - if HT.statusIsSuccessful (responseStatus rsp) - then Right $ responseBody rsp - else Left $ parseTokeResponseError (responseBody rsp) - --- | Try to parses response as JSON, if failed, try to parse as like query string. -parseResponseFlexible :: - FromJSON a => - BSL.ByteString -> - Either TokenResponseError a -parseResponseFlexible r = case eitherDecode r of - Left _ -> parseResponseString r - Right x -> Right x - --- | Parses the response that contains not JSON but a Query String -parseResponseString :: - FromJSON a => - BSL.ByteString -> - Either TokenResponseError 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 = parseTokeResponseError b - --- | Add Basic Authentication header using client_id and client_secret. -addBasicAuth :: OAuth2 -> Request -> Request -addBasicAuth oa = - applyBasicAuth - (T.encodeUtf8 $ oauth2ClientId oa) - (T.encodeUtf8 $ oauth2ClientSecret oa) - --- | Set several header values: --- + userAgennt : "hoauth2" --- + accept : "application/json" -addDefaultRequestHeaders :: Request -> Request -addDefaultRequestHeaders req = - let headers = defaultRequestHeaders ++ requestHeaders req - in req {requestHeaders = headers} - --- | Add Credential (client_id, client_secret) to the request post body. -clientSecretPost :: OAuth2 -> PostBody -clientSecretPost oa = - [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa) - , ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) - ] diff --git a/src/Network/OAuth2.hs b/src/Network/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2.hs @@ -0,0 +1,26 @@ +-- | A lightweight oauth2 Haskell binding. +-- See Readme for more details +module Network.OAuth2 ( + module Network.OAuth2.Internal, + + -- * Authorization Requset + module Network.OAuth2.AuthorizationRequest, + + -- * Token Request + module Network.OAuth2.TokenRequest, + + -- * OAuth'ed http client utilities + module Network.OAuth2.HttpClient, +) where + +{- + Hiding Errors data type from default. + Shall qualified import given the naming collision. +-} +import Network.OAuth2.AuthorizationRequest hiding ( + AuthorizationResponseError (..), + AuthorizationResponseErrorCode (..), + ) +import Network.OAuth2.HttpClient +import Network.OAuth2.Internal +import Network.OAuth2.TokenRequest diff --git a/src/Network/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth2/AuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/AuthorizationRequest.hs @@ -0,0 +1,88 @@ +-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework +-- RFC6749 +module Network.OAuth2.AuthorizationRequest where + +import Data.Aeson +import Data.Function (on) +import Data.List qualified as List +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Lens.Micro (over) +import Network.OAuth2.Internal +import URI.ByteString +import Prelude hiding (error) + +-------------------------------------------------- + +-- * Authorization Request Errors + +-------------------------------------------------- + +-- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 +-- +-- I found hard time to figure a way to test the authorization error flow +-- When anything wrong in @/authorize@ request, it will stuck at the Provider page +-- hence no way for this library to parse error response. +-- In other words, @/authorize@ ends up with 4xx or 5xx. +-- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors. +data AuthorizationResponseError = AuthorizationResponseError + { authorizationResponseError :: AuthorizationResponseErrorCode + , authorizationResponseErrorDescription :: Maybe Text + , authorizationResponseErrorUri :: Maybe (URIRef Absolute) + } + deriving (Show, Eq) + +data AuthorizationResponseErrorCode + = InvalidRequest + | UnauthorizedClient + | AccessDenied + | UnsupportedResponseType + | InvalidScope + | ServerError + | TemporarilyUnavailable + | UnknownErrorCode Text + deriving (Show, Eq) + +instance FromJSON AuthorizationResponseErrorCode where + parseJSON = withText "parseJSON AuthorizationResponseErrorCode" $ \t -> + pure $ case t of + "invalid_request" -> InvalidRequest + "unauthorized_client" -> UnauthorizedClient + "access_denied" -> AccessDenied + "unsupported_response_type" -> UnsupportedResponseType + "invalid_scope" -> InvalidScope + "server_error" -> ServerError + "temporarily_unavailable" -> TemporarilyUnavailable + _ -> UnknownErrorCode t + +instance FromJSON AuthorizationResponseError where + parseJSON = withObject "parseJSON AuthorizationResponseError" $ \t -> do + authorizationResponseError <- t .: "error" + authorizationResponseErrorDescription <- t .:? "error_description" + authorizationResponseErrorUri <- t .:? "error_uri" + pure AuthorizationResponseError {..} + +-------------------------------------------------- + +-- * URLs + +-------------------------------------------------- + +-- | See 'authorizationUrlWithParams' +authorizationUrl :: OAuth2 -> URI +authorizationUrl = authorizationUrlWithParams [] + +-- | Prepare the authorization URL. Redirect to this URL +-- asking for user interactive authentication. +-- +-- @since 2.6.0 +authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI +authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa) + where + queryParts = + List.nubBy ((==) `on` fst) $ + qs + ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa) + , ("response_type", "code") + , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa) + ] diff --git a/src/Network/OAuth2/Experiment.hs b/src/Network/OAuth2/Experiment.hs --- a/src/Network/OAuth2/Experiment.hs +++ b/src/Network/OAuth2/Experiment.hs @@ -58,7 +58,7 @@ -- acAuthorizeRequestExtraParams = Map.empty, -- acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], -- acName = "sample-google-authorization-code-app", --- acTokenRequestAuthenticationMethod = ClientSecretBasic, +-- acClientAuthenticationMethod = ClientSecretBasic, -- } -- -- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google @@ -91,56 +91,53 @@ module Network.OAuth2.Experiment.Grants, -- * Authorization Code - module Network.OAuth2.Experiment.Flows.AuthorizationRequest, + mkAuthorizationRequest, + mkPkceAuthorizeRequest, -- * Device Authorization module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest, + conduitDeviceAuthorizationRequest, + pollDeviceTokenRequest, -- * Token Request module Network.OAuth2.Experiment.Flows.TokenRequest, + conduitPkceTokenRequest, + conduitTokenRequest, -- * Refresh Token Request module Network.OAuth2.Experiment.Flows.RefreshTokenRequest, + conduitRefreshTokenRequest, -- * UserInfo Request module Network.OAuth2.Experiment.Flows.UserInfoRequest, + conduitUserInfoRequest, + conduitUserInfoRequestWithCustomMethod, -- * Types module Network.OAuth2.Experiment.Types, module Network.OAuth2.Experiment.Pkce, - module Network.OAuth.OAuth2, + module Network.OAuth2, -- * Utils module Network.OAuth2.Experiment.Utils, ) where -import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..)) -import Network.OAuth2.Experiment.Flows.AuthorizationRequest ( - HasAuthorizeRequest, - mkAuthorizationRequest, - mkPkceAuthorizeRequest, - ) +import Network.OAuth2 (ClientAuthenticationMethod (..)) +import Network.OAuth2.Experiment.Flows import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest ( DeviceAuthorizationResponse (..), - HasDeviceAuthorizationRequest, - conduitDeviceAuthorizationRequest, ) import Network.OAuth2.Experiment.Flows.RefreshTokenRequest ( HasRefreshTokenRequest, - conduitRefreshTokenRequest, ) import Network.OAuth2.Experiment.Flows.TokenRequest ( ExchangeTokenInfo, HasTokenRequest, NoNeedExchangeToken (..), TokenRequest, - conduitPkceTokenRequest, - conduitTokenRequest, ) import Network.OAuth2.Experiment.Flows.UserInfoRequest ( HasUserInfoRequest, - conduitUserInfoRequest, - conduitUserInfoRequestWithCustomMethod, ) import Network.OAuth2.Experiment.Grants import Network.OAuth2.Experiment.Pkce ( @@ -150,7 +147,6 @@ AuthorizeState (..), ClientId (..), ClientSecret (..), - HasOAuth2Key, Idp (..), IdpApplication (..), Password (..), diff --git a/src/Network/OAuth2/Experiment/Flows.hs b/src/Network/OAuth2/Experiment/Flows.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Module implementing various OAuth2 flow types and their request/response handling. +-- Provides support for: +-- +-- * Authorization Code Grant +-- * Device Authorization Grant +-- * PKCE Extension +-- * Token Refresh +-- * User Info Endpoints +module Network.OAuth2.Experiment.Flows where + +import Control.Concurrent +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except +import Data.Aeson (FromJSON) +import Data.Bifunctor +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Map.Strict qualified as Map +import Data.Maybe +import Network.HTTP.Client.Contrib +import Network.HTTP.Conduit +import Network.OAuth2 +import Network.OAuth2 qualified as OAuth2 +import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest +import Network.OAuth2.Experiment.Flows.RefreshTokenRequest +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Grants.AuthorizationCode +import Network.OAuth2.Experiment.Grants.DeviceAuthorization +import Network.OAuth2.Experiment.Pkce +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils +import URI.ByteString hiding (UserInfo) + +------------------------------------------------------------------------------- +-- Authorization Requests -- +------------------------------------------------------------------------------- + +-- | Constructs an Authorization Code request URI according to +-- . +-- +-- The generated URI includes: +-- * client_id +-- * response_type (always "code") +-- * redirect_uri +-- * state (if provided) +-- * scope (if provided) +mkAuthorizationRequest :: IdpApplication i AuthorizationCodeApplication -> URI +mkAuthorizationRequest idpApp = + let req = mkAuthorizationRequestParam (application idpApp) + allParams = + map (bimap tlToBS tlToBS) $ + Map.toList $ + toQueryParam req + in appendQueryParams allParams $ + idpAuthorizeEndpoint (idp idpApp) + +-- | Constructs an Authorization Code request URI with PKCE support according to +-- . +-- +-- Returns both the authorization URI and the generated code verifier. +-- The code verifier must be stored securely for later use in the token request. +mkPkceAuthorizeRequest :: + MonadIO m => + IdpApplication i AuthorizationCodeApplication -> + m (URI, CodeVerifier) +mkPkceAuthorizeRequest IdpApplication {..} = do + (req, codeVerifier) <- mkPkceAuthorizeRequestParam application + let allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req + let url = + appendQueryParams allParams $ + idpAuthorizeEndpoint idp + pure (url, codeVerifier) + +------------------------------------------------------------------------------- +-- Device Auth -- +------------------------------------------------------------------------------- + +-- | Makes Device Authorization Request +-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 +conduitDeviceAuthorizationRequest :: + MonadIO m => + IdpApplication i DeviceAuthorizationApplication -> + Manager -> + ExceptT BSL.ByteString m DeviceAuthorizationResponse +conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do + case idpDeviceAuthorizationEndpoint idp of + Nothing -> throwE "[conduitDeviceAuthorizationRequest] Device Authorization Flow is not supported: missing device_authorization_endpoint." + Just deviceAuthEndpoint -> do + let deviceAuthReq = mkDeviceAuthorizationRequestParam application + body = unionMapsToQueryParams [toQueryParam deviceAuthReq] + ExceptT . liftIO $ do + req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint + let req' = + if daAuthorizationRequestAuthenticationMethod application == ClientSecretBasic + then addSecretToHeader (daClientId application) (daClientSecret application) req + else req + resp <- httpLbs (urlEncodedBody body req') mgr + pure $ first ("[conduitDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp + +-- | Polls for a token using the device authorization flow. +-- +-- This implements the polling mechanism described in +-- . +-- Handles automatic retries and interval adjustments based on IdP responses. +pollDeviceTokenRequest :: + MonadIO m => + IdpApplication i DeviceAuthorizationApplication -> + Manager -> + DeviceAuthorizationResponse -> + ExceptT TokenResponseError m TokenResponse +pollDeviceTokenRequest idpApp mgr deviceAuthResp = do + pollDeviceTokenRequestInternal + idpApp + mgr + (deviceCode deviceAuthResp) + (fromMaybe 5 $ interval deviceAuthResp) + +pollDeviceTokenRequestInternal :: + MonadIO m => + IdpApplication i DeviceAuthorizationApplication -> + Manager -> + DeviceCode -> + Int -> + -- | Polling Interval + ExceptT TokenResponseError m TokenResponse +pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds = do + resp <- runExceptT (conduitTokenRequest idpApp mgr deviceCode) + case resp of + Left trRespError -> do + case tokenResponseError trRespError of + -- TODO: Didn't have a good idea to expand the error code + -- specifically for device token request flow + -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5 + UnknownErrorCode "authorization_pending" -> do + liftIO $ threadDelay $ intervalSeconds * 1000000 + pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds + UnknownErrorCode "slow_down" -> do + let newIntervalSeconds = intervalSeconds + 5 + liftIO $ threadDelay $ newIntervalSeconds * 1000000 + pollDeviceTokenRequestInternal idpApp mgr deviceCode newIntervalSeconds + _ -> throwE trRespError + Right v -> pure v + +------------------------------------------------------------------------------- +-- Token Request -- +------------------------------------------------------------------------------- + +-- | Sends a token request according to +-- . +-- +-- This is used for exchanging authorization codes, device codes, or other +-- grant types for access tokens. +conduitTokenRequest :: + (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => + IdpApplication i a -> + Manager -> + ExchangeTokenInfo a -> + ExceptT TokenResponseError m TokenResponse +conduitTokenRequest idpApp mgr exchangeToken = do + let req = mkTokenRequestParam (application idpApp) exchangeToken + body = + unionMapsToQueryParams + [ toQueryParam req + ] + in conduitTokenRequestInternal idpApp mgr body + +------------------------------------------------------------------------------- +-- PKCE Token Request -- +------------------------------------------------------------------------------- + +-- | https://datatracker.ietf.org/doc/html/rfc7636#section-4.5 +conduitPkceTokenRequest :: + (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => + IdpApplication i a -> + Manager -> + (ExchangeTokenInfo a, CodeVerifier) -> + ExceptT TokenResponseError m TokenResponse +conduitPkceTokenRequest idpApp mgr (exchangeToken, codeVerifier) = + let req = mkTokenRequestParam (application idpApp) exchangeToken + body = + unionMapsToQueryParams + [ toQueryParam req + , toQueryParam codeVerifier + ] + in conduitTokenRequestInternal idpApp mgr body + +------------------------------------------------------------------------------- +-- Refresh Token -- +------------------------------------------------------------------------------- + +-- | Makes a Refresh Token Request according to +-- . +-- +-- Used to obtain a new access token using a refresh token. +conduitRefreshTokenRequest :: + (MonadIO m, HasRefreshTokenRequest a) => + IdpApplication i a -> + Manager -> + OAuth2.RefreshToken -> + ExceptT TokenResponseError m TokenResponse +conduitRefreshTokenRequest ia mgr rt = + let tokenReq = mkRefreshTokenRequestParam (application ia) rt + body = unionMapsToQueryParams [toQueryParam tokenReq] + in conduitTokenRequestInternal ia mgr body + +------------------------------------------------------------------------------- +-- User Info -- +------------------------------------------------------------------------------- + +-- | Makes a standard request to the userinfo endpoint using GET method. +-- +-- This is commonly used with OpenID Connect providers to fetch +-- user profile information using an access token. +conduitUserInfoRequest :: + (MonadIO m, HasUserInfoRequest a, FromJSON b) => + IdpApplication i a -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString m b +conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON + +-- | Makes a request to the userinfo endpoint using a custom HTTP method. +-- +-- Some IdPs may require different HTTP methods (instead of GET) or custom headers +-- for fetching user information. This function provides that flexibility. +conduitUserInfoRequestWithCustomMethod :: + (MonadIO m, HasUserInfoRequest a, FromJSON b) => + ( Manager -> + AccessToken -> + URI -> + ExceptT BSL.ByteString m b + ) -> + IdpApplication i a -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString m b +conduitUserInfoRequestWithCustomMethod fetchMethod IdpApplication {..} mgr at = + fetchMethod mgr at (idpUserInfoEndpoint idp) + +------------------------------------------------------------------------------- +-- Internal helpers -- +------------------------------------------------------------------------------- + +conduitTokenRequestInternal :: + ( MonadIO m + , HasClientAuthenticationMethod a + , FromJSON b + ) => + IdpApplication i a -> + -- | HTTP connection manager. + Manager -> + -- | Request body. + PostBody -> + -- | Response as ByteString + ExceptT TokenResponseError m b +conduitTokenRequestInternal IdpApplication {..} manager body = do + let clientAuthMethod = getClientAuthenticationMethod application + url = idpTokenEndpoint idp + updateAuthHeader = + case clientAuthMethod of + ClientSecretBasic -> addClientAuthToHeader application + ClientSecretPost -> id + ClientAssertionJwt -> id + go = do + req <- uriToRequest url + let req' = (updateAuthHeader . addDefaultRequestHeaders) req + httpLbs (urlEncodedBody body req') manager + resp <- ExceptT . liftIO $ fmap handleOAuth2TokenResponse go + case parseResponseFlexible resp of + Right obj -> return obj + Left e -> throwE e diff --git a/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs @@ -1,16 +1,10 @@ module Network.OAuth2.Experiment.Flows.AuthorizationRequest where -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Bifunctor import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.OAuth.OAuth2 hiding (RefreshToken) -import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types -import Network.OAuth2.Experiment.Utils -import URI.ByteString hiding (UserInfo) ------------------------------------------------------------------------------- -- Authorization Request -- @@ -37,42 +31,3 @@ , toQueryParam arRedirectUri , arExtraParams ] - -class HasAuthorizeRequest a where - -- | Constructs Authorization Code request parameters - -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 - mkAuthorizationRequestParam :: a -> AuthorizationRequestParam - --- | Constructs Authorization Code request URI --- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 -mkAuthorizationRequest :: HasAuthorizeRequest a => IdpApplication i a -> URI -mkAuthorizationRequest idpApp = - let req = mkAuthorizationRequestParam (application idpApp) - allParams = - map (bimap tlToBS tlToBS) $ - Map.toList $ - toQueryParam req - in appendQueryParams allParams $ - idpAuthorizeEndpoint (idp idpApp) - -------------------------------------------------------------------------------- --- PKCE -- -------------------------------------------------------------------------------- - --- | https://datatracker.ietf.org/doc/html/rfc7636 -class HasAuthorizeRequest a => HasPkceAuthorizeRequest a where - mkPkceAuthorizeRequestParam :: MonadIO m => a -> m (AuthorizationRequestParam, CodeVerifier) - --- | Constructs Authorization Code (PKCE) request URI and the Code Verifier. --- https://datatracker.ietf.org/doc/html/rfc7636 -mkPkceAuthorizeRequest :: - (MonadIO m, HasPkceAuthorizeRequest a) => - IdpApplication i a -> - m (URI, CodeVerifier) -mkPkceAuthorizeRequest IdpApplication {..} = do - (req, codeVerifier) <- mkPkceAuthorizeRequestParam application - let allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req - let url = - appendQueryParams allParams $ - idpAuthorizeEndpoint idp - pure (url, codeVerifier) diff --git a/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs @@ -3,20 +3,12 @@ module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where import Control.Applicative -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson.Types -import Data.Bifunctor -import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.HTTP.Client.Contrib -import Network.HTTP.Conduit -import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth2.Experiment.Types -import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo) ------------------------------------------------------------------------------- @@ -52,49 +44,16 @@ pure DeviceAuthorizationResponse {..} data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam - { arScope :: Set Scope - , arClientId :: Maybe ClientId - , arExtraParams :: Map Text Text + { darScope :: Set Scope + , darClientId :: Maybe ClientId + , darExtraParams :: Map Text Text } instance ToQueryParam DeviceAuthorizationRequestParam where toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text toQueryParam DeviceAuthorizationRequestParam {..} = Map.unions - [ toQueryParam arScope - , toQueryParam arClientId - , arExtraParams + [ toQueryParam darScope + , toQueryParam darClientId + , darExtraParams ] - -class HasOAuth2Key a => HasDeviceAuthorizationRequest a where - -- | Create Device Authorization Request parameters - -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 - mkDeviceAuthorizationRequestParam :: a -> DeviceAuthorizationRequestParam - --- TODO: There is only (possibly always only) on instance of 'HasDeviceAuthorizationRequest' --- Maybe consider to hard-code the data type instead of use type class. - --- | Makes Device Authorization Request --- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 -conduitDeviceAuthorizationRequest :: - (MonadIO m, HasDeviceAuthorizationRequest a) => - IdpApplication i a -> - Manager -> - ExceptT BSL.ByteString m DeviceAuthorizationResponse -conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do - case idpDeviceAuthorizationEndpoint idp of - Nothing -> throwE "[conduiteDeviceAuthorizationRequest] Device Authorization Flow is not supported due to miss device_authorization_endpoint." - Just deviceAuthEndpoint -> do - let deviceAuthReq = mkDeviceAuthorizationRequestParam application - oauth2Key = mkOAuth2Key application - body = unionMapsToQueryParams [toQueryParam deviceAuthReq] - ExceptT . liftIO $ do - req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint - -- Hacky: - -- Missing clientId implies ClientSecretBasic authentication method. - -- See Grant/DeviceAuthorization.hs - let req' = case arClientId deviceAuthReq of - Nothing -> addBasicAuth oauth2Key req - Just _ -> req - resp <- httpLbs (urlEncodedBody body req') mgr - pure $ first ("[conduiteDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp diff --git a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs @@ -2,18 +2,13 @@ module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.HTTP.Conduit -import Network.OAuth.OAuth2 hiding (RefreshToken) -import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Types -import Network.OAuth2.Experiment.Utils ------------------------------------------------------------------------------- -- RefreshToken Requset -- @@ -38,20 +33,7 @@ , toQueryParam rrClientSecret ] -class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasRefreshTokenRequest a where +class HasClientAuthenticationMethod a => HasRefreshTokenRequest a where -- | Make Refresh Token Request parameters -- | https://www.rfc-editor.org/rfc/rfc6749#section-6 mkRefreshTokenRequestParam :: a -> OAuth2.RefreshToken -> RefreshTokenRequest - --- | Make Refresh Token Request --- https://www.rfc-editor.org/rfc/rfc6749#section-6 -conduitRefreshTokenRequest :: - (MonadIO m, HasRefreshTokenRequest a) => - IdpApplication i a -> - Manager -> - OAuth2.RefreshToken -> - ExceptT TokenResponseError m OAuth2Token -conduitRefreshTokenRequest IdpApplication {..} mgr rt = - let tokenReq = mkRefreshTokenRequestParam application rt - body = unionMapsToQueryParams [toQueryParam tokenReq] - in doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body diff --git a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs @@ -2,37 +2,33 @@ module Network.OAuth2.Experiment.Flows.TokenRequest where -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..), throwE) -import Data.Aeson (FromJSON) +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL import Network.HTTP.Conduit -import Network.OAuth.OAuth2 ( +import Network.OAuth2 ( ClientAuthenticationMethod (..), - OAuth2, - OAuth2Token, - PostBody, - uriToRequest, ) -import Network.OAuth.OAuth2.TokenRequest ( - TokenResponseError, - addBasicAuth, - addDefaultRequestHeaders, - handleOAuth2TokenResponse, - parseResponseFlexible, +import Network.OAuth2.Experiment.Types ( + ClientId (unClientId), + ClientSecret (unClientSecret), ) -import Network.OAuth2.Experiment.Pkce -import Network.OAuth2.Experiment.Types -import Network.OAuth2.Experiment.Utils -import URI.ByteString (URI) -class HasTokenRequestClientAuthenticationMethod a where +addSecretToHeader :: ClientId -> ClientSecret -> Request -> Request +addSecretToHeader cid csecret = + applyBasicAuth + (T.encodeUtf8 $ TL.toStrict $ unClientId cid) + (T.encodeUtf8 $ TL.toStrict $ unClientSecret csecret) + +class HasClientAuthenticationMethod a where getClientAuthenticationMethod :: a -> ClientAuthenticationMethod + addClientAuthToHeader :: a -> Request -> Request + addClientAuthToHeader _ = id -- | Only Authorization Code Grant involves a Exchange Token (Authorization Code). -- ResourceOwnerPassword and Client Credentials make token request directly. data NoNeedExchangeToken = NoNeedExchangeToken -class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasTokenRequest a where +class HasClientAuthenticationMethod a => HasTokenRequest a where -- Each GrantTypeFlow has slightly different request parameter to /token endpoint. data TokenRequest a type ExchangeTokenInfo a @@ -43,86 +39,3 @@ -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token -- type WithExchangeToken a b mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a - -------------------------------------------------------------------------------- --- Token Request -- -------------------------------------------------------------------------------- - --- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 -conduitTokenRequest :: - (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => - IdpApplication i a -> - Manager -> - ExchangeTokenInfo a -> - ExceptT TokenResponseError m OAuth2Token -conduitTokenRequest idpApp mgr exchangeToken = do - conduitTokenRequestInternal idpApp mgr (exchangeToken, Nothing) - -------------------------------------------------------------------------------- --- PKCE Token Request -- -------------------------------------------------------------------------------- - --- | https://datatracker.ietf.org/doc/html/rfc7636#section-4.5 -conduitPkceTokenRequest :: - (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => - IdpApplication i a -> - Manager -> - (ExchangeTokenInfo a, CodeVerifier) -> - ExceptT TokenResponseError m OAuth2Token -conduitPkceTokenRequest idpApp mgr (exchangeToken, codeVerifier) = - conduitTokenRequestInternal idpApp mgr (exchangeToken, Just codeVerifier) - -------------------------------------------------------------------------------- --- Internal helpers -- -------------------------------------------------------------------------------- - -conduitTokenRequestInternal :: - (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => - IdpApplication i a -> - Manager -> - (ExchangeTokenInfo a, Maybe CodeVerifier) -> - ExceptT TokenResponseError m OAuth2Token -conduitTokenRequestInternal IdpApplication {..} mgr (exchangeToken, codeVerifier) = - let req = mkTokenRequestParam application exchangeToken - key = mkOAuth2Key application - body = - unionMapsToQueryParams - [ toQueryParam req - , toQueryParam codeVerifier - ] - in doTokenRequestInternal - (getClientAuthenticationMethod application) - mgr - key - (idpTokenEndpoint idp) - body - -doTokenRequestInternal :: - (MonadIO m, FromJSON a) => - ClientAuthenticationMethod -> - -- | HTTP connection manager. - Manager -> - -- | OAuth options - OAuth2 -> - -- | URL - URI -> - -- | Request body. - PostBody -> - -- | Response as ByteString - ExceptT TokenResponseError m a -doTokenRequestInternal clientAuthMethod manager oa url body = do - resp <- ExceptT . liftIO $ fmap handleOAuth2TokenResponse go - case parseResponseFlexible resp of - Right obj -> return obj - Left e -> throwE e - where - updateAuthHeader = - case clientAuthMethod of - ClientSecretBasic -> addBasicAuth oa - ClientSecretPost -> id - ClientAssertionJwt -> id - - go = do - req <- uriToRequest url - let req' = (updateAuthHeader . addDefaultRequestHeaders) req - httpLbs (urlEncodedBody body req') manager diff --git a/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs @@ -1,44 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} - module Network.OAuth2.Experiment.Flows.UserInfoRequest where -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..)) -import Data.Aeson (FromJSON) -import Data.ByteString.Lazy.Char8 qualified as BSL -import Network.HTTP.Conduit -import Network.OAuth.OAuth2 -import Network.OAuth2.Experiment.Types -import URI.ByteString (URI) - ------------------------------------------------------------------------------- -- User Info Request -- ------------------------------------------------------------------------------- class HasUserInfoRequest a - --- | Standard approach of fetching /userinfo -conduitUserInfoRequest :: - (MonadIO m, HasUserInfoRequest a, FromJSON b) => - IdpApplication i a -> - Manager -> - AccessToken -> - ExceptT BSL.ByteString m b -conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON - --- | Usually 'conduitUserInfoRequest' is good enough. --- But some IdP has different approach to fetch user information rather than GET. --- This method gives the flexiblity. -conduitUserInfoRequestWithCustomMethod :: - (MonadIO m, HasUserInfoRequest a, FromJSON b) => - ( Manager -> - AccessToken -> - URI -> - ExceptT BSL.ByteString m b - ) -> - IdpApplication i a -> - Manager -> - AccessToken -> - ExceptT BSL.ByteString m b -conduitUserInfoRequestWithCustomMethod fetchMethod IdpApplication {..} mgr at = - fetchMethod mgr at (idpUserInfoEndpoint idp) diff --git a/src/Network/OAuth2/Experiment/Grants.hs b/src/Network/OAuth2/Experiment/Grants.hs --- a/src/Network/OAuth2/Experiment/Grants.hs +++ b/src/Network/OAuth2/Experiment/Grants.hs @@ -10,7 +10,6 @@ import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..)) import Network.OAuth2.Experiment.Grants.DeviceAuthorization ( DeviceAuthorizationApplication (..), - pollDeviceTokenRequest, ) import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..)) import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..)) diff --git a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs --- a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs +++ b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs @@ -7,14 +7,15 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..), OAuth2) -import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..)) +import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.AuthorizationRequest import Network.OAuth2.Experiment.Flows.RefreshTokenRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo) -- | An Application that supports "Authorization code" flow @@ -28,41 +29,36 @@ , acRedirectUri :: URI , acAuthorizeState :: AuthorizeState , acAuthorizeRequestExtraParams :: Map Text Text - , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod + , acClientAuthenticationMethod :: ClientAuthenticationMethod } -instance HasOAuth2Key AuthorizationCodeApplication where - mkOAuth2Key :: AuthorizationCodeApplication -> OAuth2 - mkOAuth2Key AuthorizationCodeApplication {..} = toOAuth2Key acClientId acClientSecret - -instance HasTokenRequestClientAuthenticationMethod AuthorizationCodeApplication where +instance HasClientAuthenticationMethod AuthorizationCodeApplication where getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod - getClientAuthenticationMethod AuthorizationCodeApplication {..} = acTokenRequestAuthenticationMethod + getClientAuthenticationMethod AuthorizationCodeApplication {..} = acClientAuthenticationMethod + addClientAuthToHeader AuthorizationCodeApplication {..} = addSecretToHeader acClientId acClientSecret -instance HasAuthorizeRequest AuthorizationCodeApplication where - mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam - mkAuthorizationRequestParam AuthorizationCodeApplication {..} = - AuthorizationRequestParam - { arScope = acScope - , arState = acAuthorizeState - , arClientId = acClientId - , arRedirectUri = Just (RedirectUri acRedirectUri) - , arResponseType = Code - , arExtraParams = acAuthorizeRequestExtraParams - } +mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam +mkAuthorizationRequestParam AuthorizationCodeApplication {..} = + AuthorizationRequestParam + { arScope = acScope + , arState = acAuthorizeState + , arClientId = acClientId + , arRedirectUri = Just (RedirectUri acRedirectUri) + , arResponseType = Code + , arExtraParams = acAuthorizeRequestExtraParams + } -instance HasPkceAuthorizeRequest AuthorizationCodeApplication where - mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier) - mkPkceAuthorizeRequestParam app = do - PkceRequestParam {..} <- mkPkceParam - let authReqParam = mkAuthorizationRequestParam app - combinatedExtraParams = - Map.unions - [ arExtraParams authReqParam - , toQueryParam codeChallenge - , toQueryParam codeChallengeMethod - ] - pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier) +mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier) +mkPkceAuthorizeRequestParam app = do + PkceRequestParam {..} <- mkPkceParam + let authReqParam = mkAuthorizationRequestParam app + combinatedExtraParams = + Map.unions + [ arExtraParams authReqParam + , toQueryParam codeChallenge + , toQueryParam codeChallengeMethod + ] + pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier) -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 instance HasTokenRequest AuthorizationCodeApplication where @@ -71,8 +67,9 @@ { trCode :: ExchangeToken , trGrantType :: GrantTypeValue , trRedirectUri :: RedirectUri - , trClientId :: Maybe ClientId - , trClientSecret :: Maybe ClientSecret + , trClientId :: ClientId + , trClientSecret :: ClientSecret + , trClientAuthenticationMethod :: ClientAuthenticationMethod } mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication @@ -81,20 +78,30 @@ { trCode = authCode , trGrantType = GTAuthorizationCode , trRedirectUri = RedirectUri acRedirectUri - , trClientId = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing - , trClientSecret = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing + , trClientId = acClientId + , trClientSecret = acClientSecret + , trClientAuthenticationMethod = acClientAuthenticationMethod } instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text toQueryParam AuthorizationCodeTokenRequest {..} = - Map.unions - [ toQueryParam trCode - , toQueryParam trGrantType - , toQueryParam trRedirectUri - , toQueryParam trClientId - , toQueryParam trClientSecret - ] + let extraBodyBasedOnClientAuthMethod = + case trClientAuthenticationMethod of + ClientAssertionJwt -> + [ Map.fromList + [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer") + , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret) + ] + ] + ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret] + ClientSecretBasic -> [] + in Map.unions $ + [ toQueryParam trCode + , toQueryParam trGrantType + , toQueryParam trRedirectUri + ] + ++ extraBodyBasedOnClientAuthMethod instance HasUserInfoRequest AuthorizationCodeApplication @@ -105,6 +112,6 @@ { rrScope = acScope , rrGrantType = GTRefreshToken , rrRefreshToken = rt - , rrClientId = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing - , rrClientSecret = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing + , rrClientId = if acClientAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing + , rrClientSecret = if acClientAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing } diff --git a/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs --- a/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs +++ b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs @@ -6,7 +6,7 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2) +import Network.OAuth2 (ClientAuthenticationMethod (..)) import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils @@ -20,17 +20,15 @@ , ccName :: Text , ccScope :: Set Scope , ccTokenRequestExtraParams :: Map Text Text - , ccTokenRequestAuthenticationMethod :: ClientAuthenticationMethod + , ccClientAuthenticationMethod :: ClientAuthenticationMethod } -instance HasOAuth2Key ClientCredentialsApplication where - mkOAuth2Key :: ClientCredentialsApplication -> OAuth2 - mkOAuth2Key ClientCredentialsApplication {..} = toOAuth2Key ccClientId ccClientSecret - -instance HasTokenRequestClientAuthenticationMethod ClientCredentialsApplication where +instance HasClientAuthenticationMethod ClientCredentialsApplication where getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod - getClientAuthenticationMethod ClientCredentialsApplication {..} = ccTokenRequestAuthenticationMethod + getClientAuthenticationMethod ClientCredentialsApplication {..} = ccClientAuthenticationMethod + addClientAuthToHeader ClientCredentialsApplication {..} = addSecretToHeader ccClientId ccClientSecret + -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 instance HasTokenRequest ClientCredentialsApplication where type ExchangeTokenInfo ClientCredentialsApplication = NoNeedExchangeToken @@ -49,7 +47,7 @@ { trScope = ccScope , trGrantType = GTClientCredentials , trClientSecret = ccClientSecret - , trClientAuthenticationMethod = ccTokenRequestAuthenticationMethod + , trClientAuthenticationMethod = ccClientAuthenticationMethod , trExtraParams = ccTokenRequestExtraParams , trClientId = ccClientId } @@ -57,19 +55,19 @@ instance ToQueryParam (TokenRequest ClientCredentialsApplication) where toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text toQueryParam ClientCredentialsTokenRequest {..} = - let jwtAssertionBody = - if trClientAuthenticationMethod == ClientAssertionJwt - then - [ toQueryParam trClientId - , Map.fromList + let extraBodyBasedOnClientAuthMethod = + case trClientAuthenticationMethod of + ClientAssertionJwt -> + [ Map.fromList [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer") , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret) ] ] - else [] + ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret] + ClientSecretBasic -> [] in Map.unions $ [ toQueryParam trGrantType , toQueryParam trScope , trExtraParams ] - ++ jwtAssertionBody + ++ extraBodyBasedOnClientAuthMethod diff --git a/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs --- a/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs +++ b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs @@ -1,20 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} -module Network.OAuth2.Experiment.Grants.DeviceAuthorization ( - DeviceAuthorizationApplication (..), - pollDeviceTokenRequest, -) where +module Network.OAuth2.Experiment.Grants.DeviceAuthorization where -import Control.Concurrent -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.HTTP.Conduit -import Network.OAuth.OAuth2 +import Network.OAuth2 import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest @@ -33,69 +26,26 @@ -- ^ Additional parameters to the device authorization request. -- Most of identity providers follow the spec strictly but -- AzureAD requires "tenant" parameter. - , daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod + , daAuthorizationRequestAuthenticationMethod :: ClientAuthenticationMethod -- ^ The spec requires similar authentication method as /token request. -- Most of identity providers doesn't required it but some does like Okta. } -pollDeviceTokenRequest :: - MonadIO m => - IdpApplication i DeviceAuthorizationApplication -> - Manager -> - DeviceAuthorizationResponse -> - ExceptT TokenResponseError m OAuth2Token -pollDeviceTokenRequest idpApp mgr deviceAuthResp = do - pollDeviceTokenRequestInternal - idpApp - mgr - (deviceCode deviceAuthResp) - (fromMaybe 5 $ interval deviceAuthResp) - -pollDeviceTokenRequestInternal :: - MonadIO m => - IdpApplication i DeviceAuthorizationApplication -> - Manager -> - DeviceCode -> - Int -> - -- | Polling Interval - ExceptT TokenResponseError m OAuth2Token -pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds = do - resp <- runExceptT (conduitTokenRequest idpApp mgr deviceCode) - case resp of - Left trRespError -> do - case tokenResponseError trRespError of - -- TODO: Didn't have a good idea to expand the error code - -- specifically for device token request flow - -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5 - UnknownErrorCode "authorization_pending" -> do - liftIO $ threadDelay $ intervalSeconds * 1000000 - pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds - UnknownErrorCode "slow_down" -> do - let newIntervalSeconds = intervalSeconds + 5 - liftIO $ threadDelay $ newIntervalSeconds * 1000000 - pollDeviceTokenRequestInternal idpApp mgr deviceCode newIntervalSeconds - _ -> throwE trRespError - Right v -> pure v - -instance HasOAuth2Key DeviceAuthorizationApplication where - mkOAuth2Key :: DeviceAuthorizationApplication -> OAuth2 - mkOAuth2Key DeviceAuthorizationApplication {..} = toOAuth2Key daClientId daClientSecret - -instance HasTokenRequestClientAuthenticationMethod DeviceAuthorizationApplication where +instance HasClientAuthenticationMethod DeviceAuthorizationApplication where getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod - getClientAuthenticationMethod _ = ClientSecretBasic + getClientAuthenticationMethod = daAuthorizationRequestAuthenticationMethod + addClientAuthToHeader DeviceAuthorizationApplication {..} = addSecretToHeader daClientId daClientSecret -instance HasDeviceAuthorizationRequest DeviceAuthorizationApplication where - mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam - mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} = - DeviceAuthorizationRequestParam - { arScope = daScope - , arClientId = - if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic - then Nothing - else Just daClientId - , arExtraParams = daAuthorizationRequestExtraParam - } +mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam +mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} = + DeviceAuthorizationRequestParam + { darScope = daScope + , darClientId = + if daAuthorizationRequestAuthenticationMethod == ClientSecretPost + then Just daClientId + else Nothing + , darExtraParams = daAuthorizationRequestExtraParam + } -- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4 instance HasTokenRequest DeviceAuthorizationApplication where @@ -123,9 +73,9 @@ { trCode = deviceCode , trGrantType = GTDeviceCode , trClientId = - if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic - then Nothing - else Just daClientId + if daAuthorizationRequestAuthenticationMethod == ClientSecretPost + then Just daClientId + else Nothing } instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where diff --git a/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs --- a/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs +++ b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs @@ -3,11 +3,10 @@ module Network.OAuth2.Experiment.Grants.JwtBearer where import Data.ByteString qualified as BS -import Data.Default (Default (def)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text.Lazy (Text) -import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2) +import Network.OAuth2 (ClientAuthenticationMethod (..)) import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Types @@ -21,15 +20,7 @@ , jbJwtAssertion :: BS.ByteString } --- JwtBearner doesn't use @client_id@ and @client_secret@ for authentication. --- --- FIXME: The ideal solution shall be do not implement `HasOAuth2Key` --- but it will stop to re-use the method 'conduitTokenRequest' for JwtBearer flow. -instance HasOAuth2Key JwtBearerApplication where - mkOAuth2Key :: JwtBearerApplication -> OAuth2 - mkOAuth2Key _ = def - -instance HasTokenRequestClientAuthenticationMethod JwtBearerApplication where +instance HasClientAuthenticationMethod JwtBearerApplication where getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod getClientAuthenticationMethod _ = ClientAssertionJwt diff --git a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs --- a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs +++ b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs @@ -6,8 +6,8 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text) -import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2 (..)) -import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2 (ClientAuthenticationMethod (..)) +import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.RefreshTokenRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest @@ -24,16 +24,13 @@ , ropUserName :: Username , ropPassword :: Password , ropTokenRequestExtraParams :: Map Text Text - , ropTokenRequestAuthenticationMethod :: ClientAuthenticationMethod + , ropClientAuthenticationMethod :: ClientAuthenticationMethod } -instance HasOAuth2Key ResourceOwnerPasswordApplication where - mkOAuth2Key :: ResourceOwnerPasswordApplication -> OAuth2 - mkOAuth2Key ResourceOwnerPasswordApplication {..} = toOAuth2Key ropClientId ropClientSecret - -instance HasTokenRequestClientAuthenticationMethod ResourceOwnerPasswordApplication where +instance HasClientAuthenticationMethod ResourceOwnerPasswordApplication where getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod - getClientAuthenticationMethod = ropTokenRequestAuthenticationMethod + getClientAuthenticationMethod = ropClientAuthenticationMethod + addClientAuthToHeader ResourceOwnerPasswordApplication {..} = addSecretToHeader ropClientId ropClientSecret -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 instance HasTokenRequest ResourceOwnerPasswordApplication where @@ -76,6 +73,6 @@ { rrScope = ropScope , rrGrantType = GTRefreshToken , rrRefreshToken = rt - , rrClientId = if ropTokenRequestAuthenticationMethod == ClientSecretPost then Just ropClientId else Nothing - , rrClientSecret = if ropTokenRequestAuthenticationMethod == ClientSecretPost then Just ropClientSecret else Nothing + , rrClientId = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientId else Nothing + , rrClientSecret = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientSecret else Nothing } diff --git a/src/Network/OAuth2/Experiment/Types.hs b/src/Network/OAuth2/Experiment/Types.hs --- a/src/Network/OAuth2/Experiment/Types.hs +++ b/src/Network/OAuth2/Experiment/Types.hs @@ -4,7 +4,6 @@ module Network.OAuth2.Experiment.Types where -import Data.Default (Default (def)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) @@ -12,8 +11,8 @@ import Data.String import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL -import Network.OAuth.OAuth2 hiding (RefreshToken) -import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2 hiding (RefreshToken) +import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils import URI.ByteString (URI, serializeURIRef') @@ -24,9 +23,6 @@ ------------------------------------------------------------------------------- --- TODO: Distinct type per endpoint --- Because I made mistake at passing to Authorize and Token Request - -- | @Idp i@ consists various endpoints endpoints. -- -- The @i@ is actually phantom type for information only (Idp name) at this moment. @@ -115,15 +111,6 @@ newtype ClientSecret = ClientSecret {unClientSecret :: Text} deriving (Eq, IsString) --- | In order to reuse some methods from legacy "Network.OAuth.OAuth2". --- Will be removed when Experiment module becomes default. -toOAuth2Key :: ClientId -> ClientSecret -> OAuth2 -toOAuth2Key cid csecret = - def - { oauth2ClientId = TL.toStrict $ unClientId cid - , oauth2ClientSecret = TL.toStrict $ unClientSecret csecret - } - newtype RedirectUri = RedirectUri {unRedirectUri :: URI} deriving (Eq) @@ -229,13 +216,3 @@ instance ToQueryParam ResponseType where toQueryParam :: ResponseType -> Map Text Text toQueryParam Code = Map.singleton "response_type" "code" - -------------------------------------------------------------------------------- --- HasOAuth2Key -- --- -- --- Find a way to reuse some methods from old implementation -- --- Probably will be removed when Experiment module becomes default -- -------------------------------------------------------------------------------- - -class HasOAuth2Key a where - mkOAuth2Key :: a -> OAuth2 diff --git a/src/Network/OAuth2/HttpClient.hs b/src/Network/OAuth2/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/HttpClient.hs @@ -0,0 +1,245 @@ +-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage +-- RFC6750 +module Network.OAuth2.HttpClient ( + -- * AUTH requests + authGetJSON, + authGetBS, + authGetJSONWithAuthMethod, + authGetBSWithAuthMethod, + authPostJSON, + authPostBS, + authPostJSONWithAuthMethod, + authPostBSWithAuthMethod, + + -- * Types + APIAuthenticationMethod (..), +) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson (FromJSON) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Aeson +import Data.Aeson.KeyMap qualified as Aeson +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Text.Encoding qualified as T +import Lens.Micro (over) +import Network.HTTP.Client.Conduit (applyBearerAuth) +import Network.HTTP.Client.Contrib (handleResponse) +import Network.HTTP.Conduit +import Network.HTTP.Types qualified as HT +import Network.OAuth2.Internal +import URI.ByteString (URI, URIRef, queryL, queryPairsL) + +-------------------------------------------------- + +-- * AUTH requests + +-- 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 :: + (MonadIO m, FromJSON a) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader + +-- | Conduct an authorized GET request and return response as JSON. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authGetJSONWithAuthMethod :: + (MonadIO m, FromJSON a) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authGetJSONWithAuthMethod authTypes manager t uri = do + resp <- authGetBSWithAuthMethod authTypes manager t uri + either (throwE . BSL.pack) return (Aeson.eitherDecode resp) + +-- | Conduct an authorized GET request. +-- Inject Access Token to Authorization Header. +authGetBS :: + MonadIO m => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBS = authGetBSWithAuthMethod AuthInRequestHeader + +-- | Conduct an authorized GET request and return response as ByteString. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authGetBSWithAuthMethod :: + MonadIO m => + -- | Specify the way that how to append the 'AccessToken' in the request + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authGetBSWithAuthMethod authTypes manager token url = do + let appendToUrl = AuthInRequestQuery == authTypes + let appendToHeader = AuthInRequestHeader == 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 + +-- | Conduct POST request and return response as JSON. +-- Inject Access Token to Authorization Header. +authPostJSON :: + (MonadIO m, FromJSON a) => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as JSON + ExceptT BSL.ByteString m a +authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader + +-- | Conduct POST request and return response as JSON. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authPostJSONWithAuthMethod :: + (MonadIO m, FromJSON a) => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m a +authPostJSONWithAuthMethod authTypes manager token url body = do + resp <- authPostBSWithAuthMethod authTypes manager token url body + either (throwE . BSL.pack) return (Aeson.eitherDecode resp) + +-- | Conduct POST request. +-- Inject Access Token to http header (Authorization) +authPostBS :: + MonadIO m => + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBS = authPostBSWithAuthMethod AuthInRequestHeader + +-- | Conduct POST request and return response as ByteString. +-- Allow to specify how to append AccessToken. +-- +-- @since 2.6.0 +authPostBSWithAuthMethod :: + MonadIO m => + APIAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + AccessToken -> + URI -> + PostBody -> + -- | Response as ByteString + ExceptT BSL.ByteString m BSL.ByteString +authPostBSWithAuthMethod authTypes manager token url body = do + let appendToBody = AuthInRequestBody == authTypes + let appendToHeader = AuthInRequestHeader == authTypes + let reqBody = if appendToBody then body ++ accessTokenToParam token else body + let upBody = if null reqBody then id else jsonBody reqBody + let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST + let upReq = upHeaders . upBody + + req <- liftIO $ uriToRequest url + authRequest req upReq manager + +jsonBody :: PostBody -> Request -> Request +jsonBody body req = + req + { requestBody = + RequestBodyLBS $ + Aeson.encode $ + Aeson.fromList $ + fmap (\(a, b) -> (Aeson.fromText (T.decodeUtf8 a), T.decodeUtf8 b)) body + , requestHeaders = + (HT.hContentType, "application/json") + : filter (\(x, _) -> x /= HT.hContentType) (requestHeaders req) + } + +-------------------------------------------------- + +-- * Types + +-------------------------------------------------- + +-- | https://www.rfc-editor.org/rfc/rfc6750#section-2 +data APIAuthenticationMethod + = -- | Provides in Authorization header + AuthInRequestHeader + | -- | Provides in request body + AuthInRequestBody + | -- | Provides in request query parameter + AuthInRequestQuery + deriving (Eq, Ord) + +-------------------------------------------------- + +-- * Utilities + +-------------------------------------------------- + +-- | Send an HTTP request. +authRequest :: + MonadIO m => + -- | Request to perform + Request -> + -- | Modify request before sending + (Request -> Request) -> + -- | HTTP connection manager. + Manager -> + ExceptT BSL.ByteString m BSL.ByteString +authRequest req upReq manage = ExceptT $ do + resp <- httpLbs (upReq req) manage + pure (handleResponse resp) + +updateRequestHeaders :: Maybe AccessToken -> Request -> Request +updateRequestHeaders mt = + maybe id (applyBearerAuth . T.encodeUtf8 . atoken) mt + . addDefaultRequestHeaders + +-- | Set the HTTP method to use. +setMethod :: HT.StdMethod -> Request -> Request +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/OAuth2/Internal.hs b/src/Network/OAuth2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Internal.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Network.OAuth2.Internal where + +import Control.Monad.Catch +import Data.Aeson +import Data.Binary.Instances.Aeson () +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.Default +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Version (showVersion) +import Lens.Micro (over) +import Network.HTTP.Conduit as C +import Network.HTTP.Types qualified as HT +import Paths_hoauth2 (version) +import URI.ByteString +import URI.ByteString.Aeson () +import URI.ByteString.QQ + +------------------------------------------------------------------------------- + +-- * OAuth2 Configuration + +------------------------------------------------------------------------------- + +-- | Query Parameter Representation +data OAuth2 = OAuth2 + { oauth2ClientId :: Text + , oauth2ClientSecret :: Text + , oauth2AuthorizeEndpoint :: URIRef Absolute + , oauth2TokenEndpoint :: URIRef Absolute + , oauth2RedirectUri :: URIRef Absolute + } + deriving (Show, Eq) + +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/|] + } + +------------------------------------------------------------------------------- + +-- * Tokens + +------------------------------------------------------------------------------- + +newtype AccessToken = AccessToken {atoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) + +newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) + +newtype IdToken = IdToken {idtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) + +-- | Authorization Code +newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) + +------------------------------------------------------------------------------- + +-- * Client Authentication methods + +------------------------------------------------------------------------------- + +-- | How would the Client (RP) authenticate itself? +-- +-- The client MUST NOT use more than one authentication method in each request. +-- Means use Authorization header or Post body. +-- +-- See more details +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-2.3 +-- https://oauth.net/private-key-jwt/ +-- https://www.rfc-editor.org/rfc/rfc7523.html +data ClientAuthenticationMethod + = ClientSecretBasic + | ClientSecretPost + | ClientAssertionJwt + deriving (Eq, Show) + +------------------------------------------------------------------------------- + +-- * Utilies for Request and URI + +------------------------------------------------------------------------------- + +-- | Type synonym of post body content +type PostBody = [(BS.ByteString, BS.ByteString)] + +-- | Type sysnonym of request query params +type QueryParams = [(BS.ByteString, BS.ByteString)] + +defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] +defaultRequestHeaders = + [ (HT.hUserAgent, "hoauth2-" <> (T.encodeUtf8 . T.pack $ showVersion version)) + , (HT.hAccept, "application/json") + ] + +-- | Set several header values: +-- + userAgennt : "hoauth2" +-- + accept : "application/json" +addDefaultRequestHeaders :: Request -> Request +addDefaultRequestHeaders req = + let headers = defaultRequestHeaders ++ requestHeaders req + in req {requestHeaders = headers} + +appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a +appendQueryParams params = over (queryL . queryPairsL) (params ++) + +uriToRequest :: MonadThrow m => URI -> m Request +uriToRequest = parseRequest . BS8.unpack . serializeURIRef' diff --git a/src/Network/OAuth2/TokenRequest.hs b/src/Network/OAuth2/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/TokenRequest.hs @@ -0,0 +1,362 @@ +-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework +-- RFC6749 +module Network.OAuth2.TokenRequest where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser, explicitParseFieldMaybe) +import Data.Binary (Binary (..)) +import Data.Binary.Instances.Aeson () +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Text (Text, unpack) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Network.HTTP.Conduit +import Network.HTTP.Types qualified as HT +import Network.HTTP.Types.URI (parseQuery) +import Network.OAuth2.Internal +import URI.ByteString +import Prelude hiding (error) + +-------------------------------------------------- + +-- * Token Request Errors + +-------------------------------------------------- + +data TokenResponseError = TokenResponseError + { tokenResponseError :: TokenResponseErrorCode + , tokenResponseErrorDescription :: Maybe Text + , tokenResponseErrorUri :: Maybe (URIRef Absolute) + } + deriving (Show, Eq) + +-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 +data TokenResponseErrorCode + = InvalidRequest + | InvalidClient + | InvalidGrant + | UnauthorizedClient + | UnsupportedGrantType + | InvalidScope + | UnknownErrorCode Text + deriving (Show, Eq) + +instance FromJSON TokenResponseErrorCode where + parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t -> + pure $ case t of + "invalid_request" -> InvalidRequest + "invalid_client" -> InvalidClient + "invalid_grant" -> InvalidGrant + "unauthorized_client" -> UnauthorizedClient + "unsupported_grant_type" -> UnsupportedGrantType + "invalid_scope" -> InvalidScope + _ -> UnknownErrorCode t + +instance FromJSON TokenResponseError where + parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do + tokenResponseError <- t .: "error" + tokenResponseErrorDescription <- t .:? "error_description" + tokenResponseErrorUri <- t .:? "error_uri" + pure TokenResponseError {..} + +parseTokeResponseError :: BSL.ByteString -> TokenResponseError +parseTokeResponseError string = + either (mkDecodeOAuth2Error string) id (eitherDecode string) + where + mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError + mkDecodeOAuth2Error response err = + TokenResponseError + (UnknownErrorCode "") + (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response)) + Nothing + +------------------------------------------------------------------------------- + +-- * Tokens + +------------------------------------------------------------------------------- + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 +data TokenResponse = TokenResponse + { accessToken :: AccessToken + , refreshToken :: Maybe RefreshToken + -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token. + , expiresIn :: Maybe Int + , tokenType :: Maybe Text + -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release. + , idToken :: Maybe IdToken + -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol. + , scope :: Maybe Text + , rawResponse :: Object + } + deriving (Eq) + +instance Show TokenResponse where + show TokenResponse {..} = + "TokenResponse {" + <> "access_token = ***" + <> ", id_token = " + <> showM idToken + <> ", refresh_token = " + <> showM refreshToken + <> ", expires_in = " + <> show expiresIn + <> ", token_type = " + <> show tokenType + <> ", scope = " + <> show scope + <> ", raw_response = ***" + <> "}" + where + showM (Just _) = "***" + showM Nothing = "Nothing" + +instance Binary TokenResponse where + put TokenResponse {..} = put rawResponse + get = do + rawt <- get + case fromJSON (Aeson.Object rawt) of + Success a -> pure a + Error err -> fail err + +-- | Parse JSON data into 'OAuth2Token' +instance FromJSON TokenResponse where + parseJSON :: Value -> Parser TokenResponse + parseJSON = withObject "TokenResponse" $ \v -> + TokenResponse + <$> v .: "access_token" + <*> v .:? "refresh_token" + <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" + <*> v .:? "token_type" + <*> v .:? "id_token" + <*> v .:? "scope" + <*> pure v + where + parseIntFlexible :: Value -> Parser Int + parseIntFlexible (String s) = pure . read $ unpack s + parseIntFlexible v = parseJSON v + +instance ToJSON TokenResponse where + toJSON :: TokenResponse -> Value + toJSON = toJSON . Object . rawResponse + toEncoding :: TokenResponse -> Encoding + toEncoding = toEncoding . Object . rawResponse + +-------------------------------------------------- + +-- * 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) + +-- | 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) + ] + +-------------------------------------------------- + +-- * Token management + +-------------------------------------------------- + +-- | Exchange @code@ for an Access Token with authenticate in request header. +fetchAccessToken :: + MonadIO m => + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | OAuth2 Code + ExchangeToken -> + -- | Access Token + ExceptT TokenResponseError m TokenResponse +fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic + +-- | Exchange @code@ for an Access Token +-- +-- OAuth2 spec allows credential (@client_id@, @client_secret@) to be sent +-- either in the header (a.k.a `ClientSecretBasic`). +-- or as form/url params (a.k.a `ClientSecretPost`). +-- +-- The OAuth provider can choose to implement only one, or both. +-- Look for API document from the OAuth provider you're dealing with. +-- If you`re uncertain, try `fetchAccessToken` which sends credential +-- in authorization http header, which is common case. +-- +-- @since 2.6.0 +fetchAccessTokenWithAuthMethod :: + MonadIO m => + ClientAuthenticationMethod -> + -- | HTTP connection manager + Manager -> + -- | OAuth Data + OAuth2 -> + -- | Authorization Code + ExchangeToken -> + -- | Access Token + ExceptT TokenResponseError m TokenResponse +fetchAccessTokenWithAuthMethod 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) + +-- | Fetch a new AccessToken using the Refresh Token with authentication in request header. +refreshAccessToken :: + MonadIO m => + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT TokenResponseError m TokenResponse +refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic + +-- | Fetch a new AccessToken using the Refresh Token. +-- +-- OAuth2 spec allows credential ("client_id", "client_secret") to be sent +-- either in the header (a.k.a 'ClientSecretBasic'). +-- or as form/url params (a.k.a 'ClientSecretPost'). +-- +-- The OAuth provider can choose to implement only one, or both. +-- Look for API document from the OAuth provider you're dealing with. +-- If you're uncertain, try 'refreshAccessToken' which sends credential +-- in authorization http header, which is common case. +-- +-- @since 2.6.0 +refreshAccessTokenWithAuthMethod :: + MonadIO m => + ClientAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + -- | OAuth context + OAuth2 -> + -- | Refresh Token gained after authorization + RefreshToken -> + ExceptT TokenResponseError m TokenResponse +refreshAccessTokenWithAuthMethod 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 :: + (MonadIO m, FromJSON a) => + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | The URL + URI -> + -- | request body + PostBody -> + -- | Response as JSON + ExceptT TokenResponseError m 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 :: + MonadIO m => + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | URL + URI -> + -- | Request body. + PostBody -> + -- | Response as ByteString + ExceptT TokenResponseError m BSL.ByteString +doSimplePostRequest manager oa url body = + ExceptT . liftIO $ fmap handleOAuth2TokenResponse go + where + go = do + req <- uriToRequest url + let req' = (addBasicAuth oa . addDefaultRequestHeaders) req + httpLbs (urlEncodedBody body req') manager + +-- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth2.TokenRequest.TokenResponseError' +handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString +handleOAuth2TokenResponse rsp = + if HT.statusIsSuccessful (responseStatus rsp) + then Right $ responseBody rsp + else Left $ parseTokeResponseError (responseBody rsp) + +-- | Try to parses response as JSON, if failed, try to parse as like query string. +parseResponseFlexible :: + FromJSON a => + BSL.ByteString -> + Either TokenResponseError a +parseResponseFlexible r = case eitherDecode r of + Left _ -> parseResponseString r + Right x -> Right x + +-- | Parses the response that contains not JSON but a Query String +parseResponseString :: + FromJSON a => + BSL.ByteString -> + Either TokenResponseError 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 = parseTokeResponseError b + +-- | Add Basic Authentication header using client_id and client_secret. +addBasicAuth :: OAuth2 -> Request -> Request +addBasicAuth oa = + applyBasicAuth + (T.encodeUtf8 $ oauth2ClientId oa) + (T.encodeUtf8 $ oauth2ClientSecret oa) + +-- | Add Credential (client_id, client_secret) to the request post body. +clientSecretPost :: OAuth2 -> PostBody +clientSecretPost oa = + [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa) + , ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa) + ] diff --git a/test/Network/OAuth/OAuth2/TokenRequestSpec.hs b/test/Network/OAuth/OAuth2/TokenRequestSpec.hs deleted file mode 100644 --- a/test/Network/OAuth/OAuth2/TokenRequestSpec.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Network.OAuth.OAuth2.TokenRequestSpec where - -import Data.Aeson qualified as Aeson -import Network.OAuth.OAuth2.TokenRequest -import Test.Hspec -import URI.ByteString.QQ -import Prelude hiding (error) - -spec :: Spec -spec = do - describe "parseJSON TokenResponseErrorCode" $ do - it "invalid_request" $ do - Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest - it "invalid_client" $ do - Aeson.eitherDecode "\"invalid_client\"" `shouldBe` Right InvalidClient - it "invalid_grant" $ do - Aeson.eitherDecode "\"invalid_grant\"" `shouldBe` Right InvalidGrant - it "unauthorized_client" $ do - Aeson.eitherDecode "\"unauthorized_client\"" `shouldBe` Right UnauthorizedClient - it "unsupported_grant_type" $ do - Aeson.eitherDecode "\"unsupported_grant_type\"" `shouldBe` Right UnsupportedGrantType - it "invalid_scope" $ do - Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope - it "foo_code" $ do - Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code") - - describe "parseJSON TokenResponseError" $ do - it "parse error" $ do - Aeson.eitherDecode "{\"error\": \"invalid_request\"}" - `shouldBe` Right - ( TokenResponseError - { tokenResponseError = InvalidRequest - , tokenResponseErrorDescription = Nothing - , tokenResponseErrorUri = Nothing - } - ) - it "parse error_description" $ do - Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_description\": \"token request error foo1\"}" - `shouldBe` Right - ( TokenResponseError - { tokenResponseError = InvalidRequest - , tokenResponseErrorDescription = Just "token request error foo1" - , tokenResponseErrorUri = Nothing - } - ) - it "parse error_uri" $ do - Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_uri\": \"https://example.com\"}" - `shouldBe` Right - ( TokenResponseError - { tokenResponseError = InvalidRequest - , tokenResponseErrorDescription = Nothing - , tokenResponseErrorUri = Just [uri|https://example.com|] - } - ) diff --git a/test/Network/OAuth/OAuth2/TokenResponseSpec.hs b/test/Network/OAuth/OAuth2/TokenResponseSpec.hs deleted file mode 100644 --- a/test/Network/OAuth/OAuth2/TokenResponseSpec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Network.OAuth.OAuth2.TokenResponseSpec where - -import Data.Aeson qualified as Aeson -import Data.Binary qualified as Binary -import Data.Maybe (fromJust) -import Network.OAuth.OAuth2 (AccessToken (..), OAuth2Token (..), RefreshToken (..)) -import Test.Hspec - -spec :: Spec -spec = do - describe "decode as JSON" $ do - it "parse access token" $ do - let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}" - Aeson.eitherDecode resp - `shouldBe` Right - ( OAuth2Token - { accessToken = AccessToken "ya29" - , refreshToken = Just (RefreshToken "0gk") - , expiresIn = Just 3600 - , tokenType = Just "Bearer" - , idToken = Nothing - , scope = Nothing - , rawResponse = fromJust (Aeson.decode resp) - } - ) - it "parse access token with scope" $ do - let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\",\"scope\": \"openid profile\"}" - Aeson.eitherDecode resp - `shouldBe` Right - ( OAuth2Token - { accessToken = AccessToken "ya29" - , refreshToken = Just (RefreshToken "0gk") - , expiresIn = Just 3600 - , tokenType = Just "Bearer" - , idToken = Nothing - , scope = Just "openid profile" - , rawResponse = fromJust (Aeson.decode resp) - } - ) - describe "encode/decode binary" $ do - it "support binary encoding" $ do - let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}" - oauth2Token = fromJust (Aeson.decode @OAuth2Token resp) - Binary.decode @OAuth2Token (Binary.encode oauth2Token) - `shouldBe` oauth2Token diff --git a/test/Network/OAuth2/InternalSpec.hs b/test/Network/OAuth2/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/InternalSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Network.OAuth2.InternalSpec where + +import Control.Monad.IO.Class (MonadIO (..)) +import Network.HTTP.Conduit +import Network.OAuth2 +import Test.Hspec +import URI.ByteString.QQ + +spec :: Spec +spec = do + describe "uriToRequest" $ do + it "parse http://localhost:3001/abc/foo?scope=openid&redirect_uri=http://localhost:3001/callback" $ do + req <- liftIO $ uriToRequest [uri|http://localhost:3001/abc/foo?scope=openid&&redirect_uri=http://localhost:3001/callback|] + secure req `shouldBe` False + path req `shouldBe` "/abc/foo" + port req `shouldBe` 3001 + host req `shouldBe` "localhost" + queryString req `shouldBe` "?scope=openid&redirect_uri=http%3A%2F%2Flocalhost%3A3001%2Fcallback" + it "parse http://localhost:3001/abc/foo" $ do + req <- liftIO $ uriToRequest [uri|http://localhost:3001/abc/foo|] + secure req `shouldBe` False + path req `shouldBe` "/abc/foo" + port req `shouldBe` 3001 + host req `shouldBe` "localhost" + queryString req `shouldBe` "" + it "parse http://localhost:3001/" $ do + req <- liftIO $ uriToRequest [uri|http://localhost:3001/|] + secure req `shouldBe` False + path req `shouldBe` "/" + port req `shouldBe` 3001 + host req `shouldBe` "localhost" + queryString req `shouldBe` "" + it "parse https://test.auth0.com/authorize" $ do + req <- liftIO $ uriToRequest [uri|https://test.auth0.com/authorize|] + secure req `shouldBe` True + path req `shouldBe` "/authorize" + port req `shouldBe` 443 + host req `shouldBe` "test.auth0.com" + queryString req `shouldBe` "" + it "parse URL with multiple query parameters" $ do + req <- liftIO $ uriToRequest [uri|https://api.example.com/oauth2/auth?client_id=123&scope=read,write&state=xyz|] + secure req `shouldBe` True + path req `shouldBe` "/oauth2/auth" + port req `shouldBe` 443 + host req `shouldBe` "api.example.com" + queryString req `shouldBe` "?client_id=123&scope=read%2Cwrite&state=xyz" + it "parse URL with special characters in path" $ do + req <- liftIO $ uriToRequest [uri|https://api.example.com/oauth2/user+info/profile%20data|] + secure req `shouldBe` True + path req `shouldBe` "/oauth2/user+info/profile%20data" + port req `shouldBe` 443 + host req `shouldBe` "api.example.com" + queryString req `shouldBe` "" + it "parse URL with fragments (which should be ignored)" $ do + req <- liftIO $ uriToRequest [uri|https://api.example.com/callback#access_token=xyz|] + secure req `shouldBe` True + path req `shouldBe` "/callback" + port req `shouldBe` 443 + host req `shouldBe` "api.example.com" + queryString req `shouldBe` "" + it "parse URL with non-standard HTTPS port" $ do + req <- liftIO $ uriToRequest [uri|https://api.example.com:8443/oauth/token|] + secure req `shouldBe` True + path req `shouldBe` "/oauth/token" + port req `shouldBe` 8443 + host req `shouldBe` "api.example.com" + queryString req `shouldBe` "" diff --git a/test/Network/OAuth2/TokenRequestSpec.hs b/test/Network/OAuth2/TokenRequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/TokenRequestSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Network.OAuth2.TokenRequestSpec where + +import Data.Aeson qualified as Aeson +import Network.OAuth2.TokenRequest +import Test.Hspec +import URI.ByteString.QQ +import Prelude hiding (error) + +spec :: Spec +spec = do + describe "parseJSON TokenResponseErrorCode" $ do + it "invalid_request" $ do + Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest + it "invalid_client" $ do + Aeson.eitherDecode "\"invalid_client\"" `shouldBe` Right InvalidClient + it "invalid_grant" $ do + Aeson.eitherDecode "\"invalid_grant\"" `shouldBe` Right InvalidGrant + it "unauthorized_client" $ do + Aeson.eitherDecode "\"unauthorized_client\"" `shouldBe` Right UnauthorizedClient + it "unsupported_grant_type" $ do + Aeson.eitherDecode "\"unsupported_grant_type\"" `shouldBe` Right UnsupportedGrantType + it "invalid_scope" $ do + Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope + it "foo_code" $ do + Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code") + + describe "parseJSON TokenResponseError" $ do + it "parse error" $ do + Aeson.eitherDecode "{\"error\": \"invalid_request\"}" + `shouldBe` Right + ( TokenResponseError + { tokenResponseError = InvalidRequest + , tokenResponseErrorDescription = Nothing + , tokenResponseErrorUri = Nothing + } + ) + it "parse error_description" $ do + Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_description\": \"token request error foo1\"}" + `shouldBe` Right + ( TokenResponseError + { tokenResponseError = InvalidRequest + , tokenResponseErrorDescription = Just "token request error foo1" + , tokenResponseErrorUri = Nothing + } + ) + it "parse error_uri" $ do + Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_uri\": \"https://example.com\"}" + `shouldBe` Right + ( TokenResponseError + { tokenResponseError = InvalidRequest + , tokenResponseErrorDescription = Nothing + , tokenResponseErrorUri = Just [uri|https://example.com|] + } + ) diff --git a/test/Network/OAuth2/TokenResponseSpec.hs b/test/Network/OAuth2/TokenResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/TokenResponseSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Network.OAuth2.TokenResponseSpec where + +import Data.Aeson qualified as Aeson +import Data.Binary qualified as Binary +import Data.Maybe (fromJust) +import Network.OAuth2 (AccessToken (..), RefreshToken (..), TokenResponse (..)) +import Test.Hspec + +spec :: Spec +spec = do + describe "decode as JSON" $ do + it "parse access token" $ do + let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}" + Aeson.eitherDecode resp + `shouldBe` Right + ( TokenResponse + { accessToken = AccessToken "ya29" + , refreshToken = Just (RefreshToken "0gk") + , expiresIn = Just 3600 + , tokenType = Just "Bearer" + , idToken = Nothing + , scope = Nothing + , rawResponse = fromJust (Aeson.decode resp) + } + ) + it "parse access token with scope" $ do + let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\",\"scope\": \"openid profile\"}" + Aeson.eitherDecode resp + `shouldBe` Right + ( TokenResponse + { accessToken = AccessToken "ya29" + , refreshToken = Just (RefreshToken "0gk") + , expiresIn = Just 3600 + , tokenType = Just "Bearer" + , idToken = Nothing + , scope = Just "openid profile" + , rawResponse = fromJust (Aeson.decode resp) + } + ) + describe "encode/decode binary" $ do + it "support binary encoding" $ do + let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}" + oauth2Token = fromJust (Aeson.decode @TokenResponse resp) + Binary.decode @TokenResponse (Binary.encode oauth2Token) + `shouldBe` oauth2Token