diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,161 @@ +# hoauth2 Changelog + +## 2.15.1 (2026-04-17) +- Dependency changes + - Relax the `containers` upper bound to `< 0.9` so `containers-0.8` is supported. + - No API or behavior changes. + +## 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 bindings 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 the token response (see + `TokenResponse`). +- [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 - -Lightweight Haskell binding for - -- [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749) - - If the provider does implement [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html), - ID Token would also be included in token response (see `OAuth2Token`). -- [The OAuth 2.0 Authorization Framework: Bearer Token Usage](https://www.rfc-editor.org/rfc/rfc6750) diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -2,14 +2,10 @@ name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -version: 2.6.0 +version: 2.15.1 synopsis: Haskell OAuth2 authentication client description: - Haskell OAuth2 authentication client. - . - Tutorial - . - Demo application + This package provides Haskell bindings for the OAuth2 Authorization Framework and Bearer Token Usage. homepage: https://github.com/freizl/hoauth2 license: MIT @@ -20,56 +16,107 @@ category: Network build-type: Simple stability: Beta -tested-with: GHC <=9.2.2 -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 + location: https://github.com/freizl/hoauth2.git library hs-source-dirs: src default-language: Haskell2010 + autogen-modules: Paths_hoauth2 + other-modules: + Network.HTTP.Client.Contrib + 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.Internal - 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 + Network.OAuth2.Experiment.Flows.TokenRequest + Network.OAuth2.Experiment.Flows.UserInfoRequest + Network.OAuth2.Experiment.Grants.AuthorizationCode + Network.OAuth2.Experiment.Grants.ClientCredentials + Network.OAuth2.Experiment.Grants.DeviceAuthorization + Network.OAuth2.Experiment.Grants.JwtBearer + Network.OAuth2.Experiment.Grants.ResourceOwnerPassword Network.OAuth2.Experiment.Pkce Network.OAuth2.Experiment.Types - Network.OAuth2.Experiment.Utils default-extensions: - DataKinds DeriveGeneric GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs OverloadedStrings + PolyKinds RecordWildCards - TypeApplications TypeFamilies build-depends: - , aeson >=2.0 && <2.2 - , base >=4 && <5 - , base64 ^>=0.4 - , binary ^>=0.8 - , bytestring >=0.9 && <0.12 - , containers ^>=0.6 - , cryptonite ^>=0.30 - , data-default ^>=0.7 - , exceptions >=0.8.3 && <0.11 - , http-conduit >=2.1 && <2.4 - , http-types >=0.11 && <0.13 - , memory ^>=0.17 - , microlens ^>=0.4.0 - , text >=0.11 && <1.3 - , transformers ^>=0.5 - , uri-bytestring >=0.2.3 && <0.4 + , aeson >=2.0 && <2.3 + , base >=4.11 && <5 + , base64 >=1.0 && <1.1 + , binary >=0.8 && <0.11 + , binary-instances >=1.0 && <1.1 + , bytestring >=0.9 && <0.13 + , containers >=0.6 && <0.9 + , crypton >=0.32 && <1.1 + , data-default ^>=0.8 + , exceptions >=0.8.3 && <0.11 + , http-conduit >=2.1 && <2.4 + , http-types >=0.11 && <0.13 + , memory ^>=0.18 + , microlens >=0.4 && <0.6 + , text >=2.0 && <2.3 + , transformers >=0.4 && <0.7 + , uri-bytestring >=0.4 && <0.5 , uri-bytestring-aeson ^>=0.1 ghc-options: -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields - -Wwarnings-deprecations + -Wwarn -Wwarnings-deprecations + +test-suite hoauth-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -Wall + build-depends: + , aeson >=2.0 && <2.3 + , base >=4.11 && <5 + , binary >=0.8 && <0.11 + , hoauth2 + , hspec >=2 && <3 + , uri-bytestring >=0.4 && <0.5 + , http-conduit >=2.1 && <2.4 + + other-modules: + Network.OAuth2.InternalSpec + Network.OAuth2.TokenRequestSpec + Network.OAuth2.TokenResponseSpec + + default-language: Haskell2010 + default-extensions: + ImportQualifiedPost + OverloadedStrings + + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + ghc-options: + -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields + -Wwarn -Wwarnings-deprecations diff --git a/src/Network/HTTP/Client/Contrib.hs b/src/Network/HTTP/Client/Contrib.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Contrib.hs @@ -0,0 +1,25 @@ +module Network.HTTP.Client.Contrib where + +import Data.Aeson +import Data.Bifunctor +import Data.ByteString.Lazy.Char8 qualified as BSL +import Network.HTTP.Conduit +import Network.HTTP.Types qualified as HT + +-- | Get response body out of a @Response@ +handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString +handleResponse rsp + | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp) + -- TODO: better to surface up entire resp so that client can decide what to do when error happens. + -- e.g. when 404, the response body could be empty hence library user has no idea what's happening. + -- Which will be breaking changes. + -- The current work around is surface up entire response as string. + | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp) + | otherwise = Left (responseBody rsp) + +handleResponseJSON :: + FromJSON a => + Response BSL.ByteString -> + Either BSL.ByteString a +handleResponseJSON = + either Left (first BSL.pack . eitherDecode) . handleResponse 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,19 +0,0 @@ --- | A lightweight oauth2 Haskell binding. --- See Readme for more details --- -module Network.OAuth.OAuth2 - ( module Network.OAuth.OAuth2.HttpClient, - module Network.OAuth.OAuth2.AuthorizationRequest, - module Network.OAuth.OAuth2.TokenRequest, - module Network.OAuth.OAuth2.Internal, - ) -where - -{- - Hiding Errors data type from default. - Shall qualified import given the naming collision. --} -import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..)) -import Network.OAuth.OAuth2.HttpClient -import Network.OAuth.OAuth2.Internal -import Network.OAuth.OAuth2.TokenRequest hiding (Errors(..)) diff --git a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - --- | 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 qualified Data.List as List -import qualified Data.Text.Encoding as T -import GHC.Generics (Generic) -import Lens.Micro (over) -import Network.OAuth.OAuth2.Internal -import URI.ByteString - --------------------------------------------------- - --- * Errors - --------------------------------------------------- - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} - -instance ToJSON Errors where - toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} - --- | 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 (redirect to OAuth2 provider), --- it will end-up 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 Errors - = InvalidRequest - | UnauthorizedClient - | AccessDenied - | UnsupportedResponseType - | InvalidScope - | ServerError - | TemporarilyUnavailable - deriving (Show, Eq, Generic) - --------------------------------------------------- - --- * 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,341 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - --- | 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 qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Maybe (fromJust, isJust) -import qualified Data.Text.Encoding as T -import Lens.Micro (over) -import Network.HTTP.Conduit -import qualified Network.HTTP.Types 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 :: - (FromJSON a, MonadIO m) => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - -- | Response as JSON - ExceptT BSL.ByteString m a -authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader - -authGetJSONInternal :: - (FromJSON a, MonadIO m) => - 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 :: - (FromJSON a, MonadIO m) => - -- | HTTP connection manager. - Manager -> - AccessToken -> - URI -> - PostBody -> - -- | Response as JSON - ExceptT BSL.ByteString m a -authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader - -authPostJSONInternal :: - (FromJSON a, MonadIO m) => - 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 :: - (FromJSON a, MonadIO m) => - 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 $ handleResponse <$> httpLbs (upReq req) manage - --- | Get response body out of a @Response@ -handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString -handleResponse rsp = - if HT.statusIsSuccessful (responseStatus rsp) - then Right $ responseBody rsp - else -- TODO: better to surface up entire resp so that client can decide what to do when error happens. - Left $ responseBody rsp - --- | Set several header values: --- + userAgennt : `hoauth2` --- + accept : `application/json` --- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. -updateRequestHeaders :: Maybe AccessToken -> Request -> Request -updateRequestHeaders t req = - 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,219 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} - -module Network.OAuth.OAuth2.Internal where - -import Control.Applicative -import Control.Arrow (second) -import Control.Monad.Catch -import Data.Aeson -import Data.Aeson.Types (Parser, explicitParseFieldMaybe) -import Data.Binary (Binary) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.Default -import Data.Maybe -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding -import GHC.Generics -import Lens.Micro -import Lens.Micro.Extras -import Network.HTTP.Conduit as C -import qualified Network.HTTP.Types as H -import qualified Network.HTTP.Types as HT -import URI.ByteString -import URI.ByteString.Aeson () -import URI.ByteString.QQ - --------------------------------------------------- - --- * Data Types - --------------------------------------------------- - --- | 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/|] - } - -newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) - -newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) - -newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) - --- | Authorization Code -newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) - --- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 -data OAuth2Token = OAuth2Token - { accessToken :: AccessToken, - -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token. - refreshToken :: Maybe RefreshToken, - expiresIn :: Maybe Int, - -- | 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. - tokenType :: Maybe Text, - -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID. - idToken :: Maybe IdToken - } - deriving (Eq, Show, Generic) - -instance Binary OAuth2Token - --- | Parse JSON data into 'OAuth2Token' -instance FromJSON OAuth2Token where - parseJSON = withObject "OAuth2Token" $ \v -> - OAuth2Token - <$> v - .: "access_token" - <*> v - .:? "refresh_token" - <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" - <*> v - .:? "token_type" - <*> v - .:? "id_token" - where - parseIntFlexible :: Value -> Parser Int - parseIntFlexible (String s) = pure . read $ unpack s - parseIntFlexible v = parseJSON v - -instance ToJSON OAuth2Token where - toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} - toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} - -data OAuth2Error a = OAuth2Error - { error :: Either Text a, - errorDescription :: Maybe Text, - errorUri :: Maybe (URIRef Absolute) - } - deriving (Show, Eq, Generic) - -instance FromJSON err => FromJSON (OAuth2Error err) where - parseJSON (Object a) = - do - err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str) - desc <- a .:? "error_description" - errorUri <- a .:? "error_uri" - return $ OAuth2Error err desc errorUri - parseJSON _ = fail "Expected an object" - -instance ToJSON err => ToJSON (OAuth2Error err) where - toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} - toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} - -parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err -parseOAuth2Error string = - either (mkDecodeOAuth2Error string) id (eitherDecode string) - -mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err -mkDecodeOAuth2Error response err = - OAuth2Error - (Left "Decode error") - (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response)) - Nothing - --- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3 --- According to spec: --- --- The client MUST NOT use more than one authentication method in each request. --- --- Which means use Authorization header or Post body. --- --- However, in reality, I always have to include authentication in the header. --- --- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional. --- --- Maybe consider an alternative implementation that boolean kind of data type is good enough. -data ClientAuthenticationMethod - = ClientSecretBasic - | ClientSecretPost - deriving (Eq, Ord) - --------------------------------------------------- - --- * Types Synonym - --------------------------------------------------- - --- | type synonym of post body content -type PostBody = [(BS.ByteString, BS.ByteString)] - -type QueryParams = [(BS.ByteString, BS.ByteString)] - --------------------------------------------------- - --- * Utilies - --------------------------------------------------- - -defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] -defaultRequestHeaders = - [ (HT.hUserAgent, "hoauth2"), - (HT.hAccept, "application/json") - ] - -appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a -appendQueryParams params = - over (queryL . queryPairsL) (params ++) - -uriToRequest :: MonadThrow m => URI -> m Request -uriToRequest 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,310 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - --- | 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 qualified Data.Aeson.Key as Key -import qualified Data.Aeson.KeyMap as KeyMap -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Text.Encoding as T -import GHC.Generics (Generic) -import Network.HTTP.Conduit -import qualified Network.HTTP.Types as HT -import Network.HTTP.Types.URI (parseQuery) -import Network.OAuth.OAuth2.Internal -import URI.ByteString (URI, serializeURIRef') - --------------------------------------------------- - --- * Token Request Errors - --------------------------------------------------- - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} - -instance ToJSON Errors where - toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} - --- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 -data Errors - = InvalidRequest - | InvalidClient - | InvalidGrant - | UnauthorizedClient - | UnsupportedGrantType - | InvalidScope - deriving (Show, Eq, Generic) - --------------------------------------------------- - --- * URL - --------------------------------------------------- - --- | Prepare the URL and the request body query for fetching an access token. -accessTokenUrl :: - OAuth2 -> - -- | access code gained via authorization URL - ExchangeToken -> - -- | access token request URL plus the request body. - (URI, PostBody) -accessTokenUrl oa code = - let uri = oauth2TokenEndpoint oa - body = - [ ("code", T.encodeUtf8 $ extoken code), - ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa), - ("grant_type", "authorization_code") - ] - in (uri, body) - --- | 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 (OAuth2Error Errors) m OAuth2Token -fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic - -fetchAccessToken2 :: - (MonadIO m) => - -- | HTTP connection manager - Manager -> - -- | OAuth Data - OAuth2 -> - -- | Authorization Code - ExchangeToken -> - -- | Access Token - ExceptT (OAuth2Error Errors) 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 (OAuth2Error Errors) 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 (OAuth2Error Errors) 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 (OAuth2Error Errors) m OAuth2Token -refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic - -refreshAccessToken2 :: - (MonadIO m) => - -- | HTTP connection manager. - Manager -> - -- | OAuth context - OAuth2 -> - -- | Refresh Token gained after authorization - RefreshToken -> - ExceptT (OAuth2Error Errors) 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 (OAuth2Error Errors) 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 (OAuth2Error Errors) 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 err, FromJSON a) => - -- | HTTP connection manager. - Manager -> - -- | OAuth options - OAuth2 -> - -- | The URL - URI -> - -- | request body - PostBody -> - -- | Response as JSON - ExceptT (OAuth2Error err) 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, FromJSON err) => - -- | HTTP connection manager. - Manager -> - -- | OAuth options - OAuth2 -> - -- | URL - URI -> - -- | Request body. - PostBody -> - -- | Response as ByteString - ExceptT (OAuth2Error err) m BSL.ByteString -doSimplePostRequest manager oa url body = - ExceptT . liftIO $ fmap handleOAuth2TokenResponse go - where - addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) - go = do - req <- uriToRequest url - let req' = (addBasicAuth . addDefaultRequestHeaders) req - httpLbs (urlEncodedBody body req') manager - --- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error' -handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString -handleOAuth2TokenResponse rsp = - if HT.statusIsSuccessful (responseStatus rsp) - then Right $ responseBody rsp - else Left $ parseOAuth2Error (responseBody rsp) - --- | Try to parses response as JSON, if failed, try to parse as like query string. -parseResponseFlexible :: - (FromJSON err, FromJSON a) => - BSL.ByteString -> - Either (OAuth2Error err) a -parseResponseFlexible r = case eitherDecode r of - Left _ -> parseResponseString r - Right x -> Right x - --- | Parses the response that contains not JSON but a Query String -parseResponseString :: - (FromJSON err, FromJSON a) => - BSL.ByteString -> - Either (OAuth2Error err) a -parseResponseString b = case parseQuery $ BSL.toStrict b of - [] -> Left errorMessage - a -> case fromJSON $ queryToValue a of - Error _ -> Left errorMessage - Success x -> Right x - where - queryToValue = Object . KeyMap.fromList . map paramToPair - paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) - errorMessage = parseOAuth2Error b - --- | Set several header values: --- + userAgennt : `hoauth2` --- + accept : `application/json` -addDefaultRequestHeaders :: Request -> Request -addDefaultRequestHeaders req = - let headers = defaultRequestHeaders ++ requestHeaders req - in req {requestHeaders = headers} - --- | 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 it hard to figure out a way to test the authorization error flow. +-- When anything goes wrong in an @/authorize@ request, it gets 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 you find a case where an OAuth2 provider redirects back to the 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 @@ -1,97 +1,157 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -- | This module contains a new way of doing OAuth2 authorization and authentication --- in order to obtain Access Token and maybe Refresh Token base on rfc6749. +-- in order to obtain an access token and maybe a refresh token based on RFC 6749. -- --- This module will become default in future release. (TBD but likely 3.0). +-- This module will become the default in a future release. -- --- The key concept/change is to introduce the 'GrantTypeFlow', which determines the entire work flow per spec. --- Each work flow will have slight different request parameters, which often time you'll see --- different configuration when creating OAuth2 application in the IdP developer application page. +-- The key concept is introducing grant flows, which determine the entire workflow per the spec. +-- Each workflow has slightly different request parameters, which is why you'll often see +-- different configuration options when creating an OAuth2 application in an IdP developer console. -- --- Here are supported flows +-- Here are the supported flows: -- --- 1. Authorization Code. This flow requires authorize call to obtain an authorize code, +-- 1. Authorization Code. This flow requires an authorize call to obtain an authorization code, -- then exchange the code for tokens. -- --- 2. Resource Owner Password. This flow only requires to hit token endpoint with, of course, +-- 2. Resource Owner Password. This flow only requires hitting the token endpoint with, of course, -- username and password, to obtain tokens. -- --- 3. Client Credentials. This flow also only requires to hit token endpoint but with different parameters. --- Client credentials flow does not involve an end user hence you won't be able to hit userinfo endpoint --- with access token obtained. +-- 3. Client Credentials. This flow also only requires hitting the token endpoint, but with different parameters. +-- The client credentials flow does not involve an end user, so you won't be able to hit the userinfo endpoint +-- with the access token you obtain. -- --- 5. PKCE (rfc7636). This is enhancement on top of authorization code flow. +-- 4. PKCE (RFC 7636). This is an enhancement on top of the authorization code flow. -- --- Implicit flow is not supported because it is more for SPA (single page app) --- and more or less obsolete by Authorization Code flow with PKCE. +-- The implicit flow is not supported because it is primarily for SPAs (single-page apps), +-- and it has been deprecated in favor of the authorization code flow with PKCE. -- --- Here is quick sample for how to use vocabularies from this new module. +-- Here is a quick sample showing how to use the vocabulary from this module. -- --- Firstly, initialize your IdP (use google as example) and the application. +-- First, initialize your IdP (using Google as an example) and the application. -- -- @ +-- +-- import Network.OAuth2.Experiment +-- import URI.ByteString.QQ +-- -- data Google = Google deriving (Eq, Show) --- googleIdp = Idp Google +-- +-- googleIdp :: Idp Google +-- googleIdp = -- Idp --- { idpFetchUserInfo = authGetJSON @(IdpUserInfo Google), --- idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|], --- idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|], --- idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|] +-- { idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|] +-- , idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|] +-- , idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|] +-- , idpDeviceAuthorizationEndpoint = Just [uri|https:\/\/oauth2.googleapis.com\/device\/code|] -- } -- --- fooApp :: IdpApplication 'AuthorizationCode Google +-- fooApp :: AuthorizationCodeApplication -- fooApp = --- AuthorizationCodeIdpApplication --- { idpAppClientId = "xxxxx", --- idpAppClientSecret = "xxxxx", --- idpAppScope = +-- AuthorizationCodeApplication +-- { acClientId = "xxxxx", +-- acClientSecret = "xxxxx", +-- acScope = -- Set.fromList -- [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\", -- \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\" -- ], --- idpAppAuthorizeState = \"CHANGE_ME\", --- idpAppAuthorizeExtraParams = Map.empty, --- idpAppRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], --- idpAppName = "default-google-App", --- idpAppTokenRequestAuthenticationMethod = ClientSecretBasic, --- idp = googleIdp +-- acAuthorizeState = \"CHANGE_ME\", +-- acAuthorizeRequestExtraParams = Map.empty, +-- acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], +-- acName = "sample-google-authorization-code-app", +-- acClientAuthenticationMethod = ClientSecretBasic, -- } +-- +-- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google +-- fooIdpApplication = IdpApplication fooApp googleIdp -- @ -- --- Secondly, construct the authorize URL. +-- Second, construct the authorize URL. -- -- @ --- authorizeUrl = mkAuthorizeRequest fooApp +-- authorizeUrl = mkAuthorizationRequest fooIdpApplication -- @ -- --- Thirdly, after a successful redirect with authorize code, --- you could exchange for access token +-- Third, after a successful redirect with an authorization code, +-- you can exchange it for an access token. -- -- @ -- mgr <- liftIO $ newManager tlsManagerSettings --- tokenResp <- conduitTokenRequest fooApp mgr authorizeCode +-- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode -- @ -- --- Lastly, you probably like to fetch user info +-- If you'd like to fetch user info, use this method: -- -- @ --- conduitUserInfoRequest fooApp mgr (accessToken tokenResp) +-- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp) -- @ -- --- Also you could find example from @hoauth2-providers-tutorials@ module. --- -module Network.OAuth2.Experiment - ( module Network.OAuth2.Experiment.Types, - module Network.OAuth2.Experiment.Pkce - ) -where +-- You can also find an example in the @hoauth2-providers-tutorial@ module. +module Network.OAuth2.Experiment ( + -- * Application per Grant type + module Network.OAuth2.Experiment.Grants, -import Network.OAuth2.Experiment.Pkce -import Network.OAuth2.Experiment.Types + -- * Authorization Code + 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.OAuth2, + + -- * Utils + module Network.OAuth2.Experiment.Utils, +) where + +import Network.OAuth2 (ClientAuthenticationMethod (..)) +import Network.OAuth2.Experiment.Flows +import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest ( + DeviceAuthorizationResponse (..), + ) +import Network.OAuth2.Experiment.Flows.RefreshTokenRequest ( + HasRefreshTokenRequest, + ) +import Network.OAuth2.Experiment.Flows.TokenRequest ( + ExchangeTokenInfo, + HasTokenRequest, + NoNeedExchangeToken (..), + TokenRequest, + ) +import Network.OAuth2.Experiment.Flows.UserInfoRequest ( + HasUserInfoRequest, + ) +import Network.OAuth2.Experiment.Grants +import Network.OAuth2.Experiment.Pkce ( + CodeVerifier (..), + ) +import Network.OAuth2.Experiment.Types ( + AuthorizeState (..), + ClientId (..), + ClientSecret (..), + Idp (..), + IdpApplication (..), + Password (..), + RedirectUri (..), + Scope (..), + Username (..), + ) +import Network.OAuth2.Experiment.Utils (uriToText) 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 new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs @@ -0,0 +1,33 @@ +module Network.OAuth2.Experiment.Flows.AuthorizationRequest where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth2.Experiment.Types + +------------------------------------------------------------------------------- +-- Authorization Request -- +------------------------------------------------------------------------------- + +data AuthorizationRequestParam = AuthorizationRequestParam + { arScope :: Set Scope + , arState :: AuthorizeState + , arClientId :: ClientId + , arRedirectUri :: Maybe RedirectUri + , arResponseType :: ResponseType + -- ^ It could be optional there is only one redirect_uri registered. + -- See: https://www.rfc-editor.org/rfc/rfc6749#section-3.1.2.3 + , arExtraParams :: Map Text Text + } + +instance ToQueryParam AuthorizationRequestParam where + toQueryParam AuthorizationRequestParam {..} = + Map.unions + [ toQueryParam arResponseType + , toQueryParam arScope + , toQueryParam arClientId + , toQueryParam arState + , toQueryParam arRedirectUri + , arExtraParams + ] diff --git a/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where + +import Control.Applicative +import Data.Aeson.Types +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth2.Experiment.Types +import URI.ByteString hiding (UserInfo) + +------------------------------------------------------------------------------- +-- Device Authorization Request -- +------------------------------------------------------------------------------- +newtype DeviceCode = DeviceCode Text + deriving newtype (FromJSON) + +instance ToQueryParam DeviceCode where + toQueryParam :: DeviceCode -> Map Text Text + toQueryParam (DeviceCode dc) = Map.singleton "device_code" dc + +-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.2 +data DeviceAuthorizationResponse = DeviceAuthorizationResponse + { deviceCode :: DeviceCode + , userCode :: Text + , verificationUri :: URI + , verificationUriComplete :: Maybe URI + , expiresIn :: Integer + , interval :: Maybe Int + } + +instance FromJSON DeviceAuthorizationResponse where + parseJSON :: Value -> Parser DeviceAuthorizationResponse + parseJSON = withObject "parse DeviceAuthorizationResponse" $ \t -> do + deviceCode <- t .: "device_code" + userCode <- t .: "user_code" + -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho + verificationUri <- t .: "verification_uri" <|> t .: "verification_url" + verificationUriComplete <- t .:? "verification_uri_complete" + expiresIn <- t .: "expires_in" + interval <- t .:? "interval" + pure DeviceAuthorizationResponse {..} + +data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam + { darScope :: Set Scope + , darClientId :: Maybe ClientId + , darExtraParams :: Map Text Text + } + +instance ToQueryParam DeviceAuthorizationRequestParam where + toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text + toQueryParam DeviceAuthorizationRequestParam {..} = + Map.unions + [ toQueryParam darScope + , toQueryParam darClientId + , darExtraParams + ] diff --git a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth2 qualified as OAuth2 +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Types + +------------------------------------------------------------------------------- +-- RefreshToken Requset -- +------------------------------------------------------------------------------- + +data RefreshTokenRequest = RefreshTokenRequest + { rrRefreshToken :: OAuth2.RefreshToken + , rrGrantType :: GrantTypeValue + , rrScope :: Set Scope + , rrClientId :: Maybe ClientId + , rrClientSecret :: Maybe ClientSecret + } + +instance ToQueryParam RefreshTokenRequest where + toQueryParam :: RefreshTokenRequest -> Map Text Text + toQueryParam RefreshTokenRequest {..} = + Map.unions + [ toQueryParam rrGrantType + , toQueryParam rrScope + , toQueryParam rrRefreshToken + , toQueryParam rrClientId + , toQueryParam rrClientSecret + ] + +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 diff --git a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Network.OAuth2.Experiment.Flows.TokenRequest where + +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL +import Network.HTTP.Conduit +import Network.OAuth2 ( + ClientAuthenticationMethod (..), + ) +import Network.OAuth2.Experiment.Types ( + ClientId (unClientId), + ClientSecret (unClientSecret), + ) + +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 HasClientAuthenticationMethod a => HasTokenRequest a where + -- Each GrantTypeFlow has slightly different request parameter to /token endpoint. + data TokenRequest a + type ExchangeTokenInfo a + + -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request + -- create type family to be explicit on it. + -- with 'type instance WithExchangeToken a b = b' implies no exchange token + -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token + -- type WithExchangeToken a b + mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a diff --git a/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs @@ -0,0 +1,7 @@ +module Network.OAuth2.Experiment.Flows.UserInfoRequest where + +------------------------------------------------------------------------------- +-- User Info Request -- +------------------------------------------------------------------------------- + +class HasUserInfoRequest a diff --git a/src/Network/OAuth2/Experiment/Grants.hs b/src/Network/OAuth2/Experiment/Grants.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants.hs @@ -0,0 +1,15 @@ +module Network.OAuth2.Experiment.Grants ( + module Network.OAuth2.Experiment.Grants.AuthorizationCode, + module Network.OAuth2.Experiment.Grants.DeviceAuthorization, + module Network.OAuth2.Experiment.Grants.ClientCredentials, + module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword, + module Network.OAuth2.Experiment.Grants.JwtBearer, +) where + +import Network.OAuth2.Experiment.Grants.AuthorizationCode (AuthorizationCodeApplication (..)) +import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..)) +import Network.OAuth2.Experiment.Grants.DeviceAuthorization ( + DeviceAuthorizationApplication (..), + ) +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 new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.AuthorizationCode where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +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 +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1 +data AuthorizationCodeApplication = AuthorizationCodeApplication + { acName :: Text + , acClientId :: ClientId + , acClientSecret :: ClientSecret + , acScope :: Set Scope + , acRedirectUri :: URI + , acAuthorizeState :: AuthorizeState + , acAuthorizeRequestExtraParams :: Map Text Text + , acClientAuthenticationMethod :: ClientAuthenticationMethod + } + +instance HasClientAuthenticationMethod AuthorizationCodeApplication where + getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod AuthorizationCodeApplication {..} = acClientAuthenticationMethod + addClientAuthToHeader AuthorizationCodeApplication {..} = addSecretToHeader acClientId acClientSecret + +mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam +mkAuthorizationRequestParam AuthorizationCodeApplication {..} = + AuthorizationRequestParam + { arScope = acScope + , arState = acAuthorizeState + , arClientId = acClientId + , arRedirectUri = Just (RedirectUri acRedirectUri) + , arResponseType = Code + , arExtraParams = acAuthorizeRequestExtraParams + } + +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 + type ExchangeTokenInfo AuthorizationCodeApplication = ExchangeToken + data TokenRequest AuthorizationCodeApplication = AuthorizationCodeTokenRequest + { trCode :: ExchangeToken + , trGrantType :: GrantTypeValue + , trRedirectUri :: RedirectUri + , trClientId :: ClientId + , trClientSecret :: ClientSecret + , trClientAuthenticationMethod :: ClientAuthenticationMethod + } + + mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication + mkTokenRequestParam AuthorizationCodeApplication {..} authCode = + AuthorizationCodeTokenRequest + { trCode = authCode + , trGrantType = GTAuthorizationCode + , trRedirectUri = RedirectUri acRedirectUri + , trClientId = acClientId + , trClientSecret = acClientSecret + , trClientAuthenticationMethod = acClientAuthenticationMethod + } + +instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where + toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text + toQueryParam AuthorizationCodeTokenRequest {..} = + 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 + +instance HasRefreshTokenRequest AuthorizationCodeApplication where + mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest + mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt = + RefreshTokenRequest + { rrScope = acScope + , rrGrantType = GTRefreshToken + , rrRefreshToken = rt + , 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 new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.ClientCredentials where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth2 (ClientAuthenticationMethod (..)) +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils + +-- | An Application that supports "Client Credentials" flow +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4 +data ClientCredentialsApplication = ClientCredentialsApplication + { ccClientId :: ClientId + , ccClientSecret :: ClientSecret + , ccName :: Text + , ccScope :: Set Scope + , ccTokenRequestExtraParams :: Map Text Text + , ccClientAuthenticationMethod :: ClientAuthenticationMethod + } + +instance HasClientAuthenticationMethod ClientCredentialsApplication where + getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod + 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 + data TokenRequest ClientCredentialsApplication = ClientCredentialsTokenRequest + { trScope :: Set Scope + , trGrantType :: GrantTypeValue + , trClientSecret :: ClientSecret + , trClientId :: ClientId + , trExtraParams :: Map Text Text + , trClientAuthenticationMethod :: ClientAuthenticationMethod + } + + mkTokenRequestParam :: ClientCredentialsApplication -> NoNeedExchangeToken -> TokenRequest ClientCredentialsApplication + mkTokenRequestParam ClientCredentialsApplication {..} _ = + ClientCredentialsTokenRequest + { trScope = ccScope + , trGrantType = GTClientCredentials + , trClientSecret = ccClientSecret + , trClientAuthenticationMethod = ccClientAuthenticationMethod + , trExtraParams = ccTokenRequestExtraParams + , trClientId = ccClientId + } + +instance ToQueryParam (TokenRequest ClientCredentialsApplication) where + toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text + toQueryParam ClientCredentialsTokenRequest {..} = + 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 trGrantType + , toQueryParam trScope + , trExtraParams + ] + ++ extraBodyBasedOnClientAuthMethod diff --git a/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.DeviceAuthorization where + +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.OAuth2 +import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Types +import Prelude hiding (error) + +-- | An Application that supports "Device Authorization Grant" +-- +-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 +data DeviceAuthorizationApplication = DeviceAuthorizationApplication + { daName :: Text + , daClientId :: ClientId + , daClientSecret :: ClientSecret + , daScope :: Set Scope + , daAuthorizationRequestExtraParam :: Map Text Text + -- ^ Additional parameters to the device authorization request. + -- Most of identity providers follow the spec strictly but + -- AzureAD requires "tenant" parameter. + , daAuthorizationRequestAuthenticationMethod :: ClientAuthenticationMethod + -- ^ The spec requires similar authentication method as /token request. + -- Most of identity providers doesn't required it but some does like Okta. + } + +instance HasClientAuthenticationMethod DeviceAuthorizationApplication where + getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod = daAuthorizationRequestAuthenticationMethod + addClientAuthToHeader DeviceAuthorizationApplication {..} = addSecretToHeader daClientId daClientSecret + +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 + type ExchangeTokenInfo DeviceAuthorizationApplication = DeviceCode + data TokenRequest DeviceAuthorizationApplication = AuthorizationCodeTokenRequest + { trCode :: DeviceCode + , trGrantType :: GrantTypeValue + , trClientId :: Maybe ClientId + } + + mkTokenRequestParam :: + DeviceAuthorizationApplication -> + DeviceCode -> + TokenRequest DeviceAuthorizationApplication + mkTokenRequestParam DeviceAuthorizationApplication {..} deviceCode = + -- + -- This is a bit hacky! + -- The token request use `ClientSecretBasic` by default. (has to pick up one Client Authn Method) + -- ClientId shall be also be in request body per spec. + -- However, for some IdPs, e.g. Okta, when using `ClientSecretBasic` to authn Client, + -- it doesn't allow @client_id@ in the request body + -- 'daAuthorizationRequestAuthenticationMethod' set the tone for Authorization Request, + -- hence just follow it in the token request + AuthorizationCodeTokenRequest + { trCode = deviceCode + , trGrantType = GTDeviceCode + , trClientId = + if daAuthorizationRequestAuthenticationMethod == ClientSecretPost + then Just daClientId + else Nothing + } + +instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where + toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text + toQueryParam AuthorizationCodeTokenRequest {..} = + Map.unions + [ toQueryParam trCode + , toQueryParam trGrantType + , toQueryParam trClientId + ] + +instance HasUserInfoRequest DeviceAuthorizationApplication diff --git a/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.JwtBearer where + +import Data.ByteString qualified as BS +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text.Lazy (Text) +import Network.OAuth2 (ClientAuthenticationMethod (..)) +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils + +-- | An Application that supports "JWT Bearer" flow +-- +-- https://datatracker.ietf.org/doc/html/rfc7523 +data JwtBearerApplication = JwtBearerApplication + { jbName :: Text + , jbJwtAssertion :: BS.ByteString + } + +instance HasClientAuthenticationMethod JwtBearerApplication where + getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod _ = ClientAssertionJwt + +instance HasTokenRequest JwtBearerApplication where + type ExchangeTokenInfo JwtBearerApplication = NoNeedExchangeToken + + data TokenRequest JwtBearerApplication = JwtBearerTokenRequest + { trGrantType :: GrantTypeValue -- \| 'GTJwtBearer' + , trAssertion :: BS.ByteString -- \| The the signed JWT token + } + + mkTokenRequestParam :: JwtBearerApplication -> NoNeedExchangeToken -> TokenRequest JwtBearerApplication + mkTokenRequestParam JwtBearerApplication {..} _ = + JwtBearerTokenRequest + { trGrantType = GTJwtBearer + , trAssertion = jbJwtAssertion + } + +instance ToQueryParam (TokenRequest JwtBearerApplication) where + toQueryParam :: TokenRequest JwtBearerApplication -> Map Text Text + toQueryParam JwtBearerTokenRequest {..} = + Map.unions + [ toQueryParam trGrantType + , Map.singleton "assertion" (bs8ToLazyText trAssertion) + ] + +instance HasUserInfoRequest JwtBearerApplication diff --git a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +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 +import Network.OAuth2.Experiment.Types + +-- | An Application that supports "Resource Owner Password" flow +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3 +data ResourceOwnerPasswordApplication = ResourceOwnerPasswordApplication + { ropClientId :: ClientId + , ropClientSecret :: ClientSecret + , ropName :: Text + , ropScope :: Set Scope + , ropUserName :: Username + , ropPassword :: Password + , ropTokenRequestExtraParams :: Map Text Text + , ropClientAuthenticationMethod :: ClientAuthenticationMethod + } + +instance HasClientAuthenticationMethod ResourceOwnerPasswordApplication where + getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod = ropClientAuthenticationMethod + addClientAuthToHeader ResourceOwnerPasswordApplication {..} = addSecretToHeader ropClientId ropClientSecret + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 +instance HasTokenRequest ResourceOwnerPasswordApplication where + type ExchangeTokenInfo ResourceOwnerPasswordApplication = NoNeedExchangeToken + + data TokenRequest ResourceOwnerPasswordApplication = PasswordTokenRequest + { trScope :: Set Scope + , trUsername :: Username + , trPassword :: Password + , trGrantType :: GrantTypeValue + , trExtraParams :: Map Text Text + } + mkTokenRequestParam :: ResourceOwnerPasswordApplication -> NoNeedExchangeToken -> TokenRequest ResourceOwnerPasswordApplication + mkTokenRequestParam ResourceOwnerPasswordApplication {..} _ = + PasswordTokenRequest + { trUsername = ropUserName + , trPassword = ropPassword + , trGrantType = GTPassword + , trScope = ropScope + , trExtraParams = ropTokenRequestExtraParams + } + +instance ToQueryParam (TokenRequest ResourceOwnerPasswordApplication) where + toQueryParam :: TokenRequest ResourceOwnerPasswordApplication -> Map Text Text + toQueryParam PasswordTokenRequest {..} = + Map.unions + [ toQueryParam trGrantType + , toQueryParam trScope + , toQueryParam trUsername + , toQueryParam trPassword + , trExtraParams + ] + +instance HasUserInfoRequest ResourceOwnerPasswordApplication + +instance HasRefreshTokenRequest ResourceOwnerPasswordApplication where + mkRefreshTokenRequestParam :: ResourceOwnerPasswordApplication -> OAuth2.RefreshToken -> RefreshTokenRequest + mkRefreshTokenRequestParam ResourceOwnerPasswordApplication {..} rt = + RefreshTokenRequest + { rrScope = ropScope + , rrGrantType = GTRefreshToken + , rrRefreshToken = rt + , 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/Pkce.hs b/src/Network/OAuth2/Experiment/Pkce.hs --- a/src/Network/OAuth2/Experiment/Pkce.hs +++ b/src/Network/OAuth2/Experiment/Pkce.hs @@ -1,15 +1,15 @@ -module Network.OAuth2.Experiment.Pkce - ( mkPkceParam, - CodeChallenge (..), - CodeVerifier (..), - CodeChallengeMethod (..), - PkceRequestParam (..), - ) -where +module Network.OAuth2.Experiment.Pkce ( + mkPkceParam, + CodeChallenge (..), + CodeVerifier (..), + CodeChallengeMethod (..), + PkceRequestParam (..), +) where import Control.Monad.IO.Class import Crypto.Hash qualified as H import Crypto.Random qualified as Crypto +import Data.Base64.Types qualified as B64 import Data.ByteArray qualified as ByteArray import Data.ByteString qualified as BS import Data.ByteString.Base64.URL qualified as B64 @@ -19,17 +19,17 @@ newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text} -newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show) +newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} data CodeChallengeMethod = S256 deriving (Show) data PkceRequestParam = PkceRequestParam - { codeVerifier :: CodeVerifier, - codeChallenge :: CodeChallenge, - -- | spec says optional but really it shall be s256 or can be omitted? - -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3 - codeChallengeMethod :: CodeChallengeMethod + { codeVerifier :: CodeVerifier + , codeChallenge :: CodeChallenge + , codeChallengeMethod :: CodeChallengeMethod + -- ^ spec says optional but in practice it is S256 + -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3 } mkPkceParam :: MonadIO m => m PkceRequestParam @@ -37,13 +37,13 @@ codeV <- genCodeVerifier pure PkceRequestParam - { codeVerifier = CodeVerifier (T.decodeUtf8 codeV), - codeChallenge = CodeChallenge (encodeCodeVerifier codeV), - codeChallengeMethod = S256 + { codeVerifier = CodeVerifier (T.decodeUtf8 codeV) + , codeChallenge = CodeChallenge (encodeCodeVerifier codeV) + , codeChallengeMethod = S256 } encodeCodeVerifier :: BS.ByteString -> Text -encodeCodeVerifier = B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256 +encodeCodeVerifier = B64.extractBase64 . B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256 genCodeVerifier :: MonadIO m => m BS.ByteString genCodeVerifier = liftIO $ getBytesInternal BS.empty 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 @@ -1,83 +1,58 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Network.OAuth2.Experiment.Types where -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT) -import Data.Aeson (FromJSON) -import Data.Bifunctor -import Data.ByteString.Lazy.Char8 qualified as BSL -import Data.Default (Default (def)) -import Data.Kind import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.String -import Data.Text.Encoding qualified as T import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL -import Network.HTTP.Conduit (Manager) -import Network.OAuth.OAuth2 hiding (RefreshToken) -import Network.OAuth.OAuth2 qualified as OAuth2 -import Network.OAuth.OAuth2.TokenRequest qualified as TR +import Network.OAuth2 hiding (RefreshToken) +import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils -import URI.ByteString hiding (UserInfo) - -{- NOTE - 1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility? --} - -------------------------------------------------------------------------------- - --- * Grant Type - -------------------------------------------------------------------------------- - -data GrantTypeFlow = AuthorizationCode | ResourceOwnerPassword | ClientCredentials - -------------------------------------------------------------------------------- - --- * Response Type value +import URI.ByteString (URI, serializeURIRef') ------------------------------------------------------------------------------- -class ToResponseTypeValue (a :: GrantTypeFlow) where - toResponseTypeValue :: IsString b => b - -instance ToResponseTypeValue 'AuthorizationCode where - -- https://www.rfc-editor.org/rfc/rfc6749#section-3.1.1 - -- Only support "authorization code" flow - toResponseTypeValue :: IsString b => b - toResponseTypeValue = "code" - -toResponseTypeParam :: forall a b req. (ToResponseTypeValue a, IsString b) => req a -> Map b b -toResponseTypeParam _ = Map.singleton "response_type" (toResponseTypeValue @a) +-- * Idp App ------------------------------------------------------------------------------- --- * Grant Type value - -------------------------------------------------------------------------------- +-- | @Idp i@ consists various endpoints endpoints. +-- +-- The @i@ is actually phantom type for information only (Idp name) at this moment. +-- And it is PolyKinds. +-- +-- Hence whenever @Idp i@ or @IdpApplication i a@ is used as function parameter, +-- PolyKinds need to be enabled. +data Idp (i :: k) = Idp + { idpUserInfoEndpoint :: URI + -- ^ Userinfo Endpoint + , idpAuthorizeEndpoint :: URI + -- ^ Authorization Endpoint + , idpTokenEndpoint :: URI + -- ^ Token Endpoint + , idpDeviceAuthorizationEndpoint :: Maybe URI + -- ^ Apparently not all IdP support device code flow + } --- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict. +-- | An OAuth2 Application "a" of IdP "i". +-- "a" can be one of following type: -- --- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow. -data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken - deriving (Eq, Show) +-- * `Network.OAuth2.Experiment.AuthorizationCodeApplication` +-- * `Network.OAuth2.Experiment.DeviceAuthorizationApplication` +-- * `Network.OAuth2.Experiment.ClientCredentialsApplication` +-- * `Network.OAuth2.Experiment.ResourceOwnerPasswordApplication` +-- * `Network.OAuth2.Experiment.JwtBearerApplication` +data IdpApplication (i :: k) a = IdpApplication + { idp :: Idp i + , application :: a + } ------------------------------------------------------------------------------- @@ -85,7 +60,9 @@ ------------------------------------------------------------------------------- --- TODO: following data type is not ideal as Idp would have lots of 'Custom Text' +-- TODO: What's best type for Scope? +-- Use 'Text' isn't super type safe. All cannot specify some standard scopes like openid, email etc. +-- But Following data type is not ideal as Idp would have lots of 'Custom Text' -- -- @ -- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text @@ -93,7 +70,7 @@ -- -- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow. newtype Scope = Scope {unScope :: Text} - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show) instance IsString Scope where fromString :: String -> Scope @@ -101,24 +78,39 @@ ------------------------------------------------------------------------------- +-- * Grant Type value + +------------------------------------------------------------------------------- + +-- | Grant type query parameter has association with different GrantType flows but not completely strict. +-- +-- e.g. Both AuthorizationCode and ResourceOwnerPassword flow could support refresh token flow. +data GrantTypeValue + = GTAuthorizationCode + | GTPassword + | GTClientCredentials + | GTRefreshToken + | GTJwtBearer + | GTDeviceCode + deriving (Eq, Show) + +------------------------------------------------------------------------------- +-- Response Type -- +------------------------------------------------------------------------------- +data ResponseType = Code + +------------------------------------------------------------------------------- + -- * Credentials ------------------------------------------------------------------------------- newtype ClientId = ClientId {unClientId :: Text} deriving (Show, Eq, IsString) +-- | Can be either "Client Secret" or JWT based on the client authentication method 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) @@ -165,6 +157,8 @@ val GTPassword = "password" val GTClientCredentials = "client_credentials" val GTRefreshToken = "refresh_token" + val GTJwtBearer = "urn:ietf:params:oauth:grant-type:jwt-bearer" + val GTDeviceCode = "urn:ietf:params:oauth:grant-type:device_code" instance ToQueryParam ClientId where toQueryParam :: ClientId -> Map Text Text @@ -193,8 +187,11 @@ toQueryParam :: Set Scope -> Map Text Text toQueryParam = toScopeParam . Set.map unScope where - toScopeParam :: (IsString a) => Set Text -> Map a Text - toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) + toScopeParam :: IsString a => Set Text -> Map a Text + toScopeParam scope = + if Set.null scope + then Map.empty + else Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) instance ToQueryParam CodeVerifier where toQueryParam :: CodeVerifier -> Map Text Text @@ -216,478 +213,6 @@ toQueryParam :: OAuth2.RefreshToken -> Map Text Text toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x) -------------------------------------------------------------------------------- - --- * Authorization and Token Requests types - -------------------------------------------------------------------------------- - -class HasIdpAppName (a :: GrantTypeFlow) where - getIdpAppName :: IdpApplication a i -> Text - -class HasAuthorizeRequest (a :: GrantTypeFlow) where - data AuthorizationRequest a - type MkAuthorizationRequestResponse a - mkAuthorizeRequestParameter :: IdpApplication a i -> AuthorizationRequest a - mkAuthorizeRequest :: IdpApplication a i -> MkAuthorizationRequestResponse a - -class HasTokenRequest (a :: GrantTypeFlow) where - -- | Each GrantTypeFlow has slightly different request parameter to /token endpoint. - data TokenRequest a - - -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request - -- create type family to be explicit on it. - -- with 'type instance WithExchangeToken a b = b' implies no exchange token - -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token - type WithExchangeToken a b - - mkTokenRequest :: - IdpApplication a i -> - WithExchangeToken a (TokenRequest a) - - conduitTokenRequest :: - (MonadIO m) => - IdpApplication a i -> - Manager -> - WithExchangeToken a (ExceptT (OAuth2Error TR.Errors) m OAuth2Token) - -class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where - mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier) - -class HasPkceTokenRequest (b :: GrantTypeFlow) where - conduitPkceTokenRequest :: - (MonadIO m) => - IdpApplication b i -> - Manager -> - (ExchangeToken, CodeVerifier) -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - -class HasRefreshTokenRequest (a :: GrantTypeFlow) where - -- | https://www.rfc-editor.org/rfc/rfc6749#page-47 - data RefreshTokenRequest a - - mkRefreshTokenRequest :: IdpApplication a i -> OAuth2.RefreshToken -> RefreshTokenRequest a - conduitRefreshTokenRequest :: - (MonadIO m) => - IdpApplication a i -> - Manager -> - OAuth2.RefreshToken -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - -------------------------------------------------------------------------------- - --- * User Info types - -------------------------------------------------------------------------------- - -type family IdpUserInfo a - -class HasUserInfoRequest (a :: GrantTypeFlow) where - conduitUserInfoRequest :: - FromJSON (IdpUserInfo i) => - IdpApplication a i -> - Manager -> - AccessToken -> - ExceptT BSL.ByteString IO (IdpUserInfo i) - -------------------------------------------------------------------------------- - --- * Idp App - -------------------------------------------------------------------------------- - --- | Shall IdpApplication has a field of 'Idp a'?? -data Idp a = Idp - { idpUserInfoEndpoint :: URI, - -- NOTE: maybe worth data type to distinguish authorize and token endpoint - -- as I made mistake at passing to Authorize and Token Request - idpAuthorizeEndpoint :: URI, - idpTokenEndpoint :: URI, - idpFetchUserInfo :: - forall m. - (FromJSON (IdpUserInfo a), MonadIO m) => - Manager -> - AccessToken -> - URI -> - ExceptT BSL.ByteString m (IdpUserInfo a) - } - -------------------------------------------------------------------------------- - --- * Idp App Config - -------------------------------------------------------------------------------- - -data family IdpApplication (a :: GrantTypeFlow) (i :: Type) - -------------------------------------------------------------------------------- - --- * Authorization Code flow - -------------------------------------------------------------------------------- - --- | An Application that supports "Authorization code" flow -data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication - { idpAppName :: Text, - idpAppClientId :: ClientId, - idpAppClientSecret :: ClientSecret, - idpAppScope :: Set Scope, - idpAppRedirectUri :: URI, - idpAppAuthorizeState :: AuthorizeState, - -- | Though technically one key can have multiple value in query, but who actually does it?! - idpAppAuthorizeExtraParams :: Map Text Text, - idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod, - idp :: Idp i - } - --- NOTE: maybe add function for parase authorization response --- though seems overkill. https://github.com/freizl/hoauth2/issues/149 --- parseAuthorizationResponse :: String -> AuthorizationResponse --- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse - -instance HasIdpAppName 'AuthorizationCode where - getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text - getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName - -instance HasAuthorizeRequest 'AuthorizationCode where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 - data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest - { scope :: Set Scope, - state :: AuthorizeState, - clientId :: ClientId, - redirectUri :: Maybe RedirectUri - } - type MkAuthorizationRequestResponse 'AuthorizationCode = Text - - mkAuthorizeRequestParameter :: IdpApplication 'AuthorizationCode i -> AuthorizationRequest 'AuthorizationCode - mkAuthorizeRequestParameter AuthorizationCodeIdpApplication {..} = - AuthorizationCodeAuthorizationRequest - { scope = if null idpAppScope then Set.empty else idpAppScope, - state = idpAppAuthorizeState, - clientId = idpAppClientId, - redirectUri = Just (RedirectUri idpAppRedirectUri) - } - - mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text - mkAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = - let req = mkAuthorizeRequestParameter idpAppConfig - allParams = - map (bimap tlToBS tlToBS) $ - Map.toList $ - Map.unions [idpAppAuthorizeExtraParams, toQueryParam req] - in TL.fromStrict $ - T.decodeUtf8 $ - serializeURIRef' $ - appendQueryParams allParams $ - idpAuthorizeEndpoint idp - -instance HasTokenRequest 'AuthorizationCode where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 - data TokenRequest 'AuthorizationCode = AuthorizationCodeTokenRequest - { code :: ExchangeToken, - clientId :: ClientId, - grantType :: GrantTypeValue, - redirectUri :: RedirectUri - } - type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a - - mkTokenRequest :: - IdpApplication 'AuthorizationCode i -> - ExchangeToken -> - TokenRequest 'AuthorizationCode - mkTokenRequest AuthorizationCodeIdpApplication {..} authCode = - AuthorizationCodeTokenRequest - { code = authCode, - clientId = idpAppClientId, - grantType = GTAuthorizationCode, - redirectUri = RedirectUri idpAppRedirectUri - } - conduitTokenRequest :: - forall m i. - (MonadIO m) => - IdpApplication 'AuthorizationCode i -> - Manager -> - ExchangeToken -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken = - let req = mkTokenRequest idpAppConfig exchangeToken - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = - mapsToParams - [ toQueryParam req, - toQueryParam - ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost - then Just idpAppClientSecret - else Nothing - ) - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance HasPkceAuthorizeRequest 'AuthorizationCode where - mkPkceAuthorizeRequest :: MonadIO m => IdpApplication 'AuthorizationCode i -> m (Text, CodeVerifier) - mkPkceAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = do - PkceRequestParam {..} <- mkPkceParam - let req = mkAuthorizeRequestParameter idpAppConfig - let allParams = - mapsToParams - [ idpAppAuthorizeExtraParams, - toQueryParam req, - toQueryParam codeChallenge, - toQueryParam codeChallengeMethod - ] - - let url = - TL.fromStrict $ - T.decodeUtf8 $ - serializeURIRef' $ - appendQueryParams allParams $ - idpAuthorizeEndpoint idp - pure (url, codeVerifier) - -instance HasPkceTokenRequest 'AuthorizationCode where - conduitPkceTokenRequest :: - MonadIO m => - IdpApplication 'AuthorizationCode i -> - Manager -> - (ExchangeToken, CodeVerifier) -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - conduitPkceTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr (exchangeToken, codeVerifier) = - let req = mkTokenRequest idpAppConfig exchangeToken - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = - mapsToParams - [ toQueryParam req, - toQueryParam codeVerifier, - toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance HasRefreshTokenRequest 'AuthorizationCode where - data RefreshTokenRequest 'AuthorizationCode = AuthorizationCodeTokenRefreshRequest - { refreshToken :: OAuth2.RefreshToken, - grantType :: GrantTypeValue, - scope :: Set Scope - } - - mkRefreshTokenRequest :: IdpApplication 'AuthorizationCode i -> OAuth2.RefreshToken -> RefreshTokenRequest 'AuthorizationCode - mkRefreshTokenRequest AuthorizationCodeIdpApplication {..} rt = - AuthorizationCodeTokenRefreshRequest - { scope = idpAppScope, - grantType = GTRefreshToken, - refreshToken = rt - } - conduitRefreshTokenRequest :: - (MonadIO m) => - IdpApplication 'AuthorizationCode i -> - Manager -> - OAuth2.RefreshToken -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - conduitRefreshTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr rt = - let req = mkRefreshTokenRequest idpAppConfig rt - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = - mapsToParams - [ toQueryParam req, - toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance HasUserInfoRequest 'AuthorizationCode where - conduitUserInfoRequest :: - FromJSON (IdpUserInfo i) => - IdpApplication 'AuthorizationCode i -> - Manager -> - AccessToken -> - ExceptT BSL.ByteString IO (IdpUserInfo i) - conduitUserInfoRequest AuthorizationCodeIdpApplication {..} mgr at = do - idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) - -instance ToQueryParam (AuthorizationRequest 'AuthorizationCode) where - toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text - toQueryParam req@AuthorizationCodeAuthorizationRequest {..} = - Map.unions - [ toResponseTypeParam req, - toQueryParam scope, - toQueryParam clientId, - toQueryParam state, - toQueryParam redirectUri - ] - -instance ToQueryParam (TokenRequest 'AuthorizationCode) where - toQueryParam :: TokenRequest 'AuthorizationCode -> Map Text Text - toQueryParam AuthorizationCodeTokenRequest {..} = - Map.unions - [ toQueryParam grantType, - toQueryParam code, - toQueryParam redirectUri - ] - -instance ToQueryParam (RefreshTokenRequest 'AuthorizationCode) where - toQueryParam :: RefreshTokenRequest 'AuthorizationCode -> Map Text Text - toQueryParam AuthorizationCodeTokenRefreshRequest {..} = - Map.unions - [ toQueryParam grantType, - toQueryParam scope, - toQueryParam refreshToken - ] - -------------------------------------------------------------------------------- - --- * Password flow - -------------------------------------------------------------------------------- - --- https://www.rfc-editor.org/rfc/rfc6749#section-4.3.1 --- 4.3.1. Authorization Request and Response (Password grant type) --- The method through which the client obtains the resource owner --- credentials is beyond the scope of this specification. The client --- MUST discard the credentials once an access token has been obtained. --- --- Hence no AuhorizationRequest instance - -data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPAppConfig - { idpAppClientId :: ClientId, - idpAppClientSecret :: ClientSecret, - idpAppName :: Text, - idpAppScope :: Set Scope, - idpAppUserName :: Username, - idpAppPassword :: Password, - -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec - idpAppTokenRequestExtraParams :: Map Text Text, - idp :: Idp i - } - -instance HasIdpAppName 'ResourceOwnerPassword where - getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text - getIdpAppName ResourceOwnerPasswordIDPAppConfig {..} = idpAppName - -instance HasUserInfoRequest 'ResourceOwnerPassword where - conduitUserInfoRequest ResourceOwnerPasswordIDPAppConfig {..} mgr at = do - idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) - -instance HasTokenRequest 'ResourceOwnerPassword where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 - data TokenRequest 'ResourceOwnerPassword = PasswordTokenRequest - { scope :: Set Scope, - username :: Username, - password :: Password, - grantType :: GrantTypeValue - } - type WithExchangeToken 'ResourceOwnerPassword a = a - - mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword - mkTokenRequest ResourceOwnerPasswordIDPAppConfig {..} = - PasswordTokenRequest - { username = idpAppUserName, - password = idpAppPassword, - grantType = GTPassword, - scope = idpAppScope - } - - conduitTokenRequest :: - (MonadIO m) => - IdpApplication 'ResourceOwnerPassword i -> - Manager -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPAppConfig {..} mgr = - let req = mkTokenRequest idpAppConfig - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - --- | TODO: TBD -instance HasRefreshTokenRequest 'ResourceOwnerPassword where - data RefreshTokenRequest 'ResourceOwnerPassword = PasswordRefreshTokenRequest - - mkRefreshTokenRequest :: - IdpApplication 'ResourceOwnerPassword i -> - OAuth2.RefreshToken -> - RefreshTokenRequest 'ResourceOwnerPassword - mkRefreshTokenRequest = undefined - - conduitRefreshTokenRequest :: - MonadIO m => - IdpApplication 'ResourceOwnerPassword i -> - Manager -> - OAuth2.RefreshToken -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - conduitRefreshTokenRequest = undefined - -instance ToQueryParam (TokenRequest 'ResourceOwnerPassword) where - toQueryParam :: TokenRequest 'ResourceOwnerPassword -> Map Text Text - toQueryParam PasswordTokenRequest {..} = - Map.unions - [ toQueryParam grantType, - toQueryParam scope, - toQueryParam username, - toQueryParam password - ] - -------------------------------------------------------------------------------- - --- * Client Credentials flow - -------------------------------------------------------------------------------- - --- https://www.rfc-editor.org/rfc/rfc6749#section-4.4.1 --- 4.4.1. Authorization Request and Response (Client Credentials grant type) --- Since the client authentication is used as the authorization grant, --- no additional authorization request is needed. --- --- Hence no AuhorizationRequest instance - -data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPAppConfig - { idpAppClientId :: ClientId, - idpAppClientSecret :: ClientSecret, - idpAppName :: Text, - idpAppScope :: Set Scope, - -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec - idpAppTokenRequestExtraParams :: Map Text Text, - idp :: Idp i - } - -instance HasIdpAppName 'ClientCredentials where - getIdpAppName :: IdpApplication 'ClientCredentials i -> Text - getIdpAppName ClientCredentialsIDPAppConfig {..} = idpAppName - -instance HasTokenRequest 'ClientCredentials where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 - data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest - { scope :: Set Scope, - grantType :: GrantTypeValue - } - - type WithExchangeToken 'ClientCredentials a = a - - mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials - mkTokenRequest ClientCredentialsIDPAppConfig {..} = - ClientCredentialsTokenRequest - { scope = idpAppScope, - grantType = GTClientCredentials - } - - conduitTokenRequest :: - (MonadIO m) => - IdpApplication 'ClientCredentials i -> - Manager -> - ExceptT (OAuth2Error TR.Errors) m OAuth2Token - conduitTokenRequest idpAppConfig@ClientCredentialsIDPAppConfig {..} mgr = - let req = mkTokenRequest idpAppConfig - key = - toOAuth2Key - idpAppClientId - idpAppClientSecret - body = - mapsToParams - [ idpAppTokenRequestExtraParams, - toQueryParam req - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance ToQueryParam (TokenRequest 'ClientCredentials) where - toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text - toQueryParam ClientCredentialsTokenRequest {..} = - Map.unions - [ toQueryParam grantType, - toQueryParam scope - ] +instance ToQueryParam ResponseType where + toQueryParam :: ResponseType -> Map Text Text + toQueryParam Code = Map.singleton "response_type" "code" diff --git a/src/Network/OAuth2/Experiment/Utils.hs b/src/Network/OAuth2/Experiment/Utils.hs --- a/src/Network/OAuth2/Experiment/Utils.hs +++ b/src/Network/OAuth2/Experiment/Utils.hs @@ -5,8 +5,11 @@ import Data.ByteString.Char8 qualified as BS8 import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Lazy qualified as TL +import URI.ByteString (URI, serializeURIRef') tlToBS :: TL.Text -> ByteString tlToBS = TE.encodeUtf8 . TL.toStrict @@ -14,8 +17,11 @@ bs8ToLazyText :: BS8.ByteString -> TL.Text bs8ToLazyText = TL.pack . BS8.unpack -mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] -mapsToParams = +unionMapsToQueryParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] +unionMapsToQueryParams = map (bimap tlToBS tlToBS) . Map.toList . Map.unions + +uriToText :: URI -> T.Text +uriToText = T.decodeUtf8 . serializeURIRef' 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 by spec, but OAuth2 provider implementations vary. We may remove 'Maybe' in a 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 'TokenResponse' +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/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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}