packages feed

hoauth2 2.13.1 → 2.15.1

raw patch · 32 files changed

Files

+ CHANGELOG.md view
@@ -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
+ README.md view
@@ -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)
− README.org 
@@ -1,8 +0,0 @@-* Introduction--Haskell binding for--- [[https://datatracker.ietf.org/doc/html/rfc6749][The OAuth 2.0 Authorization Framework]]-  - If the Identity Provider also implements [[https://openid.net/specs/openid-connect-core-1_0.html][OIDC spec]], ID Token will also be present in token response (see ~OAuth2Token~).-- [[https://www.rfc-editor.org/rfc/rfc7523.html][JWT Profile for OAuth2 Client Authentication and Authorization Grants]]-- [[https://www.rfc-editor.org/rfc/rfc6750][The OAuth 2.0 Authorization Framework: Bearer Token Usage]]
hoauth2.cabal view
@@ -2,10 +2,10 @@ name:               hoauth2  -- http://wiki.haskell.org/Package_versioning_policy-version:            2.13.1+version:            2.15.1 synopsis:           Haskell OAuth2 authentication client description:-  This is Haskell binding of OAuth2 Authorization framework and Bearer Token Usage framework.+  This package provides Haskell bindings for the OAuth2 Authorization Framework and Bearer Token Usage.  homepage:           https://github.com/freizl/hoauth2 license:            MIT@@ -16,12 +16,16 @@ category:           Network build-type:         Simple stability:          Beta-tested-with:        GHC <=9.6.1-extra-source-files: README.org+tested-with:+  GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 || ==9.8.2 +extra-source-files:+  CHANGELOG.md+  README.md+ source-repository head   type:     git-  location: git://github.com/freizl/hoauth2.git+  location: https://github.com/freizl/hoauth2.git  library   hs-source-dirs:     src@@ -29,17 +33,18 @@   autogen-modules:    Paths_hoauth2   other-modules:     Network.HTTP.Client.Contrib-    Network.OAuth.OAuth2.Internal+    Network.OAuth2.Internal     Network.OAuth2.Experiment.Grants     Network.OAuth2.Experiment.Utils     Paths_hoauth2    exposed-modules:-    Network.OAuth.OAuth2-    Network.OAuth.OAuth2.AuthorizationRequest-    Network.OAuth.OAuth2.HttpClient-    Network.OAuth.OAuth2.TokenRequest+    Network.OAuth2+    Network.OAuth2.AuthorizationRequest+    Network.OAuth2.HttpClient+    Network.OAuth2.TokenRequest     Network.OAuth2.Experiment+    Network.OAuth2.Experiment.Flows     Network.OAuth2.Experiment.Flows.AuthorizationRequest     Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest     Network.OAuth2.Experiment.Flows.RefreshTokenRequest@@ -68,18 +73,19 @@     , 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.8-    , crypton               >=0.32   && <0.35-    , data-default          ^>=0.7+    , 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+    , microlens             >=0.4 && <0.6     , text                  >=2.0    && <2.3     , transformers          >=0.4    && <0.7-    , uri-bytestring        >=0.2.3  && <0.4+    , uri-bytestring        >=0.4    && <0.5     , uri-bytestring-aeson  ^>=0.1    ghc-options:@@ -92,13 +98,19 @@   hs-source-dirs:     test   ghc-options:        -Wall   build-depends:-    , aeson           >=2.0   && <2.3-    , base            >=4.11  && <5+    , aeson           >=2.0  && <2.3+    , base            >=4.11 && <5+    , binary          >=0.8  && <0.11     , hoauth2-    , hspec           >=2     && <3-    , uri-bytestring  >=0.2.3 && <0.4+    , hspec           >=2    && <3+    , uri-bytestring  >=0.4  && <0.5+    , http-conduit          >=2.1    && <2.4 -  other-modules:      Network.OAuth.OAuth2.TokenRequestSpec+  other-modules:+    Network.OAuth2.InternalSpec+    Network.OAuth2.TokenRequestSpec+    Network.OAuth2.TokenResponseSpec+   default-language:   Haskell2010   default-extensions:     ImportQualifiedPost
− src/Network/OAuth/OAuth2.hs 
@@ -1,26 +0,0 @@--- | A lightweight oauth2 Haskell binding.--- See Readme for more details-module Network.OAuth.OAuth2 (-  module Network.OAuth.OAuth2.Internal,--  -- * Authorization Requset-  module Network.OAuth.OAuth2.AuthorizationRequest,--  -- * Token Request-  module Network.OAuth.OAuth2.TokenRequest,--  -- * OAuth'ed http client utilities-  module Network.OAuth.OAuth2.HttpClient,-) where--{--  Hiding Errors data type from default.-  Shall qualified import given the naming collision.--}-import Network.OAuth.OAuth2.AuthorizationRequest hiding (-  AuthorizationResponseError (..),-  AuthorizationResponseErrorCode (..),- )-import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2.Internal-import Network.OAuth.OAuth2.TokenRequest
− src/Network/OAuth/OAuth2/AuthorizationRequest.hs 
@@ -1,88 +0,0 @@--- | Bindings Authorization part of The OAuth 2.0 Authorization Framework--- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>-module Network.OAuth.OAuth2.AuthorizationRequest where--import Data.Aeson-import Data.Function (on)-import Data.List qualified as List-import Data.Text (Text)-import Data.Text.Encoding qualified as T-import Lens.Micro (over)-import Network.OAuth.OAuth2.Internal-import URI.ByteString-import Prelude hiding (error)-------------------------------------------------------- * Authorization Request Errors-------------------------------------------------------- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1------ I found hard time to figure a way to test the authorization error flow--- When anything wrong in @/authorize@ request, it will stuck at the Provider page--- hence no way for this library to parse error response.--- In other words, @/authorize@ ends up with 4xx or 5xx.--- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors.-data AuthorizationResponseError = AuthorizationResponseError-  { authorizationResponseError :: AuthorizationResponseErrorCode-  , authorizationResponseErrorDescription :: Maybe Text-  , authorizationResponseErrorUri :: Maybe (URIRef Absolute)-  }-  deriving (Show, Eq)--data AuthorizationResponseErrorCode-  = InvalidRequest-  | UnauthorizedClient-  | AccessDenied-  | UnsupportedResponseType-  | InvalidScope-  | ServerError-  | TemporarilyUnavailable-  | UnknownErrorCode Text-  deriving (Show, Eq)--instance FromJSON AuthorizationResponseErrorCode where-  parseJSON = withText "parseJSON AuthorizationResponseErrorCode" $ \t ->-    pure $ case t of-      "invalid_request" -> InvalidRequest-      "unauthorized_client" -> UnauthorizedClient-      "access_denied" -> AccessDenied-      "unsupported_response_type" -> UnsupportedResponseType-      "invalid_scope" -> InvalidScope-      "server_error" -> ServerError-      "temporarily_unavailable" -> TemporarilyUnavailable-      _ -> UnknownErrorCode t--instance FromJSON AuthorizationResponseError where-  parseJSON = withObject "parseJSON AuthorizationResponseError" $ \t -> do-    authorizationResponseError <- t .: "error"-    authorizationResponseErrorDescription <- t .:? "error_description"-    authorizationResponseErrorUri <- t .:? "error_uri"-    pure AuthorizationResponseError {..}-------------------------------------------------------- * URLs-------------------------------------------------------- | See 'authorizationUrlWithParams'-authorizationUrl :: OAuth2 -> URI-authorizationUrl = authorizationUrlWithParams []---- | Prepare the authorization URL.  Redirect to this URL--- asking for user interactive authentication.------ @since 2.6.0-authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI-authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)-  where-    queryParts =-      List.nubBy ((==) `on` fst) $-        qs-          ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)-             , ("response_type", "code")-             , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)-             ]
− src/Network/OAuth/OAuth2/HttpClient.hs 
@@ -1,332 +0,0 @@--- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage--- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750>-module Network.OAuth.OAuth2.HttpClient (-  -- * AUTH requests-  authGetJSON,-  authGetBS,-  authGetBS2,-  authGetJSONWithAuthMethod,-  authGetJSONInternal,-  authGetBSWithAuthMethod,-  authGetBSInternal,-  authPostJSON,-  authPostBS,-  authPostBS2,-  authPostBS3,-  authPostJSONWithAuthMethod,-  authPostJSONInternal,-  authPostBSWithAuthMethod,-  authPostBSInternal,--  -- * Types-  APIAuthenticationMethod (..),-) where--import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..), throwE)-import Data.Aeson (FromJSON, eitherDecode)-import Data.ByteString.Char8 qualified as BS-import Data.ByteString.Lazy.Char8 qualified as BSL-import Data.Maybe (fromJust, isJust)-import Data.Text.Encoding qualified as T-import Lens.Micro (over)-import Network.HTTP.Client.Contrib (handleResponse)-import Network.HTTP.Conduit-import Network.HTTP.Types qualified as HT-import Network.OAuth.OAuth2.Internal-import URI.ByteString (URI, URIRef, queryL, queryPairsL)-------------------------------------------------------- * AUTH requests---- Making request with Access Token appended to Header, Request body or query string.---------------------------------------------------------- | Conduct an authorized GET request and return response as JSON.---   Inject Access Token to Authorization Header.-authGetJSON ::-  (MonadIO m, FromJSON a) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader---- | Deprecated. Use `authGetJSONWithAuthMethod` instead.-authGetJSONInternal ::-  (MonadIO m, FromJSON a) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authGetJSONInternal = authGetJSONWithAuthMethod-{-# DEPRECATED authGetJSONInternal "use authGetJSONWithAuthMethod" #-}---- | Conduct an authorized GET request and return response as JSON.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authGetJSONWithAuthMethod ::-  (MonadIO m, FromJSON a) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authGetJSONWithAuthMethod authTypes manager t uri = do-  resp <- authGetBSWithAuthMethod authTypes manager t uri-  either (throwE . BSL.pack) return (eitherDecode resp)---- | Conduct an authorized GET request.---   Inject Access Token to Authorization Header.-authGetBS ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBS = authGetBSWithAuthMethod AuthInRequestHeader---- | Same to 'authGetBS' but set access token to query parameter rather than header-authGetBS2 ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBS2 = authGetBSWithAuthMethod AuthInRequestQuery-{-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-}--authGetBSInternal ::-  MonadIO m =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBSInternal = authGetBSWithAuthMethod-{-# DEPRECATED authGetBSInternal "use authGetBSWithAuthMethod" #-}---- | Conduct an authorized GET request and return response as ByteString.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authGetBSWithAuthMethod ::-  MonadIO m =>-  -- | Specify the way that how to append the 'AccessToken' in the request-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBSWithAuthMethod authTypes manager token url = do-  let appendToUrl = AuthInRequestQuery == authTypes-  let appendToHeader = AuthInRequestHeader == authTypes-  let uri = if appendToUrl then url `appendAccessToken` token else url-  let upReq = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.GET-  req <- liftIO $ uriToRequest uri-  authRequest req upReq manager---- | Conduct POST request and return response as JSON.---   Inject Access Token to Authorization Header.-authPostJSON ::-  (MonadIO m, FromJSON a) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader--authPostJSONInternal ::-  (MonadIO m, FromJSON a) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m a-authPostJSONInternal = authPostJSONWithAuthMethod-{-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-}---- | Conduct POST request and return response as JSON.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authPostJSONWithAuthMethod ::-  (MonadIO m, FromJSON a) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m a-authPostJSONWithAuthMethod authTypes manager token url body = do-  resp <- authPostBSWithAuthMethod authTypes manager token url body-  either (throwE . BSL.pack) return (eitherDecode resp)---- | Conduct POST request.---   Inject Access Token to http header (Authorization)-authPostBS ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBS = authPostBSWithAuthMethod AuthInRequestHeader---- | Conduct POST request with access token only in the request body but header.-authPostBS2 ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBS2 = authPostBSWithAuthMethod AuthInRequestBody-{-# DEPRECATED authPostBS2 "use 'authPostBSWithAuthMethod'" #-}---- | Conduct POST request with access token only in the header and not in body-authPostBS3 ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBS3 = authPostBSWithAuthMethod AuthInRequestHeader-{-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-}--authPostBSInternal ::-  MonadIO m =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBSInternal = authPostBSWithAuthMethod-{-# DEPRECATED authPostBSInternal "use 'authPostBSWithAuthMethod'" #-}---- | Conduct POST request and return response as ByteString.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authPostBSWithAuthMethod ::-  MonadIO m =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBSWithAuthMethod authTypes manager token url body = do-  let appendToBody = AuthInRequestBody == authTypes-  let appendToHeader = AuthInRequestHeader == authTypes-  let reqBody = if appendToBody then body ++ accessTokenToParam token else body-  -- TODO: urlEncodedBody send request as 'application/x-www-form-urlencoded'-  -- seems shall go with application/json which is more common?-  let upBody = if null reqBody then id else urlEncodedBody reqBody-  let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST-  let upReq = upHeaders . upBody--  req <- liftIO $ uriToRequest url-  authRequest req upReq manager-------------------------------------------------------- * Types-------------------------------------------------------- | https://www.rfc-editor.org/rfc/rfc6750#section-2-data APIAuthenticationMethod-  = -- | Provides in Authorization header-    AuthInRequestHeader-  | -- | Provides in request body-    AuthInRequestBody-  | -- | Provides in request query parameter-    AuthInRequestQuery-  deriving (Eq, Ord)-------------------------------------------------------- * Utilities-------------------------------------------------------- | Send an HTTP request.-authRequest ::-  MonadIO m =>-  -- | Request to perform-  Request ->-  -- | Modify request before sending-  (Request -> Request) ->-  -- | HTTP connection manager.-  Manager ->-  ExceptT BSL.ByteString m BSL.ByteString-authRequest req upReq manage = ExceptT $ do-  resp <- httpLbs (upReq req) manage-  pure (handleResponse resp)---- | Set several header values:---   + userAgennt    : "hoauth2"---   + accept        : "application/json"---   + authorization : "Bearer xxxxx" if 'Network.OAuth.OAuth2.AccessToken' provided.-updateRequestHeaders :: Maybe AccessToken -> Request -> Request-updateRequestHeaders t req =-  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)]
− src/Network/OAuth/OAuth2/Internal.hs 
@@ -1,190 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Network.OAuth.OAuth2.Internal where--import Control.Arrow (second)-import Control.Monad.Catch-import Data.Aeson-import Data.Aeson.Types (Parser, explicitParseFieldMaybe)-import Data.Binary (Binary)-import Data.ByteString qualified as BS-import Data.ByteString.Char8 qualified as BS8-import Data.Default-import Data.Maybe-import Data.Text (Text, unpack)-import Data.Version (showVersion)-import GHC.Generics-import Lens.Micro-import Lens.Micro.Extras-import Network.HTTP.Conduit as C-import Network.HTTP.Types qualified as H-import Network.HTTP.Types qualified as HT-import Paths_hoauth2 (version)-import URI.ByteString-import URI.ByteString.Aeson ()-import URI.ByteString.QQ------------------------------------------------------------------------------------- * OAuth2 Configuration------------------------------------------------------------------------------------- | Query Parameter Representation-data OAuth2 = OAuth2-  { oauth2ClientId :: Text-  , oauth2ClientSecret :: Text-  , oauth2AuthorizeEndpoint :: URIRef Absolute-  , oauth2TokenEndpoint :: URIRef Absolute-  , oauth2RedirectUri :: URIRef Absolute-  }-  deriving (Show, Eq)--instance Default OAuth2 where-  def =-    OAuth2-      { oauth2ClientId = ""-      , oauth2ClientSecret = ""-      , oauth2AuthorizeEndpoint = [uri|https://www.example.com/|]-      , oauth2TokenEndpoint = [uri|https://www.example.com/|]-      , oauth2RedirectUri = [uri|https://www.example.com/|]-      }------------------------------------------------------------------------------------- * Tokens-----------------------------------------------------------------------------------newtype AccessToken = AccessToken {atoken :: Text} deriving (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)---- FIXME: rename to TokenResponse and move to that module---- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4-data OAuth2Token = OAuth2Token-  { accessToken :: AccessToken-  , refreshToken :: Maybe RefreshToken-  -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token.-  , expiresIn :: Maybe Int-  , tokenType :: Maybe Text-  -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.-  , idToken :: Maybe IdToken-  -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.-  }-  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 '_'}------------------------------------------------------------------------------------- * Client Authentication methods------------------------------------------------------------------------------------- | 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, I found I have to include authentication in the header all the time in real world.------ In other words, `ClientSecretBasic` is always assured. `ClientSecretPost` is optional.------ Maybe consider an alternative implementation that boolean kind of data type is good enough.-data ClientAuthenticationMethod-  = ClientSecretBasic-  | ClientSecretPost-  | ClientAssertionJwt-  deriving (Eq)------------------------------------------------------------------------------------- * Utilies for Request and URI------------------------------------------------------------------------------------- | Type synonym of post body content-type PostBody = [(BS.ByteString, BS.ByteString)]---- | Type sysnonym of request query params-type QueryParams = [(BS.ByteString, BS.ByteString)]--defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]-defaultRequestHeaders =-  [ (HT.hUserAgent, "hoauth2-" <> BS8.pack (showVersion version))-  , (HT.hAccept, "application/json")-  ]--appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a-appendQueryParams params =-  over (queryL . queryPairsL) (params ++)--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 #-}
− src/Network/OAuth/OAuth2/TokenRequest.hs 
@@ -1,346 +0,0 @@--- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework--- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>-module Network.OAuth.OAuth2.TokenRequest where--import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..), throwE)-import Data.Aeson-import Data.Aeson.Key qualified as Key-import Data.Aeson.KeyMap qualified as KeyMap-import Data.ByteString.Lazy.Char8 qualified as BSL-import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.Encoding qualified as T-import Network.HTTP.Conduit-import Network.HTTP.Types qualified as HT-import Network.HTTP.Types.URI (parseQuery)-import Network.OAuth.OAuth2.Internal-import URI.ByteString-import Prelude hiding (error)-------------------------------------------------------- * Token Request Errors------------------------------------------------------data TokenResponseError = TokenResponseError-  { tokenResponseError :: TokenResponseErrorCode-  , tokenResponseErrorDescription :: Maybe Text-  , tokenResponseErrorUri :: Maybe (URIRef Absolute)-  }-  deriving (Show, Eq)---- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2-data TokenResponseErrorCode-  = InvalidRequest-  | InvalidClient-  | InvalidGrant-  | UnauthorizedClient-  | UnsupportedGrantType-  | InvalidScope-  | UnknownErrorCode Text-  deriving (Show, Eq)--instance FromJSON TokenResponseErrorCode where-  parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t ->-    pure $ case t of-      "invalid_request" -> InvalidRequest-      "invalid_client" -> InvalidClient-      "invalid_grant" -> InvalidGrant-      "unauthorized_client" -> UnauthorizedClient-      "unsupported_grant_type" -> UnsupportedGrantType-      "invalid_scope" -> InvalidScope-      _ -> UnknownErrorCode t--instance FromJSON TokenResponseError where-  parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do-    tokenResponseError <- t .: "error"-    tokenResponseErrorDescription <- t .:? "error_description"-    tokenResponseErrorUri <- t .:? "error_uri"-    pure TokenResponseError {..}--parseTokeResponseError :: BSL.ByteString -> TokenResponseError-parseTokeResponseError string =-  either (mkDecodeOAuth2Error string) id (eitherDecode string)-  where-    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError-    mkDecodeOAuth2Error response err =-      TokenResponseError-        (UnknownErrorCode "")-        (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response))-        Nothing-------------------------------------------------------- * URL-------------------------------------------------------- | Prepare the URL and the request body query for fetching an access token.-accessTokenUrl ::-  OAuth2 ->-  -- | access code gained via authorization URL-  ExchangeToken ->-  -- | access token request URL plus the request body.-  (URI, PostBody)-accessTokenUrl oa code =-  let uri = oauth2TokenEndpoint oa-      body =-        [ ("code", T.encodeUtf8 $ extoken code)-        , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)-        , ("grant_type", "authorization_code")-        ]-   in (uri, body)---- | Obtain a new access token by sending a Refresh Token to the Authorization server.-refreshAccessTokenUrl ::-  OAuth2 ->-  -- | Refresh Token gained via authorization URL-  RefreshToken ->-  -- | Refresh Token request URL plus the request body.-  (URI, PostBody)-refreshAccessTokenUrl oa token = (uri, body)-  where-    uri = oauth2TokenEndpoint oa-    body =-      [ ("grant_type", "refresh_token")-      , ("refresh_token", T.encodeUtf8 $ rtoken token)-      ]-------------------------------------------------------- * Token management-------------------------------------------------------- | Exchange @code@ for an Access Token with authenticate in request header.-fetchAccessToken ::-  MonadIO m =>-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | OAuth2 Code-  ExchangeToken ->-  -- | Access Token-  ExceptT TokenResponseError m OAuth2Token-fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic--fetchAccessToken2 ::-  MonadIO m =>-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | Authorization Code-  ExchangeToken ->-  -- | Access Token-  ExceptT TokenResponseError m OAuth2Token-fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost-{-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-}--fetchAccessTokenInternal ::-  MonadIO m =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | Authorization Code-  ExchangeToken ->-  -- | Access Token-  ExceptT TokenResponseError m OAuth2Token-fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod-{-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-}---- | Exchange @code@ for an Access Token------ OAuth2 spec allows credential (@client_id@, @client_secret@) to be sent--- either in the header (a.k.a `ClientSecretBasic`).--- or as form/url params (a.k.a `ClientSecretPost`).------ The OAuth provider can choose to implement only one, or both.--- Look for API document from the OAuth provider you're dealing with.--- If you`re uncertain, try `fetchAccessToken` which sends credential--- in authorization http header, which is common case.------ @since 2.6.0-fetchAccessTokenWithAuthMethod ::-  MonadIO m =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | Authorization Code-  ExchangeToken ->-  -- | Access Token-  ExceptT TokenResponseError m OAuth2Token-fetchAccessTokenWithAuthMethod authMethod manager oa code = do-  let (uri, body) = accessTokenUrl oa code-  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []-  doJSONPostRequest manager oa uri (body ++ extraBody)---- | Fetch a new AccessToken using the Refresh Token with authentication in request header.-refreshAccessToken ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT TokenResponseError m OAuth2Token-refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic--refreshAccessToken2 ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT TokenResponseError m OAuth2Token-refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost-{-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-}--refreshAccessTokenInternal ::-  MonadIO m =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT TokenResponseError m OAuth2Token-refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod-{-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-}---- | Fetch a new AccessToken using the Refresh Token.------ OAuth2 spec allows credential ("client_id", "client_secret") to be sent--- either in the header (a.k.a 'ClientSecretBasic').--- or as form/url params (a.k.a 'ClientSecretPost').------ The OAuth provider can choose to implement only one, or both.--- Look for API document from the OAuth provider you're dealing with.--- If you're uncertain, try 'refreshAccessToken' which sends credential--- in authorization http header, which is common case.------ @since 2.6.0-refreshAccessTokenWithAuthMethod ::-  MonadIO m =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT TokenResponseError m OAuth2Token-refreshAccessTokenWithAuthMethod authMethod manager oa token = do-  let (uri, body) = refreshAccessTokenUrl oa token-  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []-  doJSONPostRequest manager oa uri (body ++ extraBody)-------------------------------------------------------- * Utilies-------------------------------------------------------- | Conduct post request and return response as JSON.-doJSONPostRequest ::-  (MonadIO m, FromJSON a) =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth options-  OAuth2 ->-  -- | The URL-  URI ->-  -- | request body-  PostBody ->-  -- | Response as JSON-  ExceptT TokenResponseError m a-doJSONPostRequest manager oa uri body = do-  resp <- doSimplePostRequest manager oa uri body-  case parseResponseFlexible resp of-    Right obj -> return obj-    Left e -> throwE e---- | Conduct post request.-doSimplePostRequest ::-  MonadIO m =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth options-  OAuth2 ->-  -- | URL-  URI ->-  -- | Request body.-  PostBody ->-  -- | Response as ByteString-  ExceptT TokenResponseError m BSL.ByteString-doSimplePostRequest manager oa url body =-  ExceptT . liftIO $ fmap handleOAuth2TokenResponse go-  where-    go = do-      req <- uriToRequest url-      let req' = (addBasicAuth oa . addDefaultRequestHeaders) req-      httpLbs (urlEncodedBody body req') manager---- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth.OAuth2.TokenRequest.TokenResponseError'-handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString-handleOAuth2TokenResponse rsp =-  if HT.statusIsSuccessful (responseStatus rsp)-    then Right $ responseBody rsp-    else Left $ parseTokeResponseError (responseBody rsp)---- | Try to parses response as JSON, if failed, try to parse as like query string.-parseResponseFlexible ::-  FromJSON a =>-  BSL.ByteString ->-  Either TokenResponseError a-parseResponseFlexible r = case eitherDecode r of-  Left _ -> parseResponseString r-  Right x -> Right x---- | Parses the response that contains not JSON but a Query String-parseResponseString ::-  FromJSON a =>-  BSL.ByteString ->-  Either TokenResponseError a-parseResponseString b = case parseQuery $ BSL.toStrict b of-  [] -> Left errorMessage-  a -> case fromJSON $ queryToValue a of-    Error _ -> Left errorMessage-    Success x -> Right x-  where-    queryToValue = Object . KeyMap.fromList . map paramToPair-    paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = parseTokeResponseError b---- | Add Basic Authentication header using client_id and client_secret.-addBasicAuth :: OAuth2 -> Request -> Request-addBasicAuth oa =-  applyBasicAuth-    (T.encodeUtf8 $ oauth2ClientId oa)-    (T.encodeUtf8 $ oauth2ClientSecret oa)---- | Set several header values:---   + userAgennt    : "hoauth2"---   + accept        : "application/json"-addDefaultRequestHeaders :: Request -> Request-addDefaultRequestHeaders req =-  let headers = defaultRequestHeaders ++ requestHeaders req-   in req {requestHeaders = headers}---- | Add Credential (client_id, client_secret) to the request post body.-clientSecretPost :: OAuth2 -> PostBody-clientSecretPost oa =-  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)-  , ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)-  ]
+ src/Network/OAuth2.hs view
@@ -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
+ src/Network/OAuth2/AuthorizationRequest.hs view
@@ -0,0 +1,88 @@+-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework+-- RFC6749 <https://www.rfc-editor.org/rfc/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)+             ]
src/Network/OAuth2/Experiment.hs view
@@ -1,32 +1,32 @@ -- | 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.+-- This module will become the default in a future release. ----- The key concept/change is to introduce the Grant flow, 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)--- given it is deprecated 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. -- -- @ --@@ -58,89 +58,86 @@ --       acAuthorizeRequestExtraParams = Map.empty, --       acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], --       acName = "sample-google-authorization-code-app",---       acTokenRequestAuthenticationMethod = ClientSecretBasic,+--       acClientAuthenticationMethod = ClientSecretBasic, --     } -- -- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google -- fooIdpApplication = IdpApplication fooApp googleIdp -- @ ----- Secondly, construct the authorize URL.+-- Second, construct the authorize URL. -- -- @ -- 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 fooIdpApplication mgr authorizeCode -- @ ----- If you'd like to fetch user info, uses this method+-- If you'd like to fetch user info, use this method: -- -- @ -- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp) -- @ ----- You could also find example from @hoauth2-providers-tutorials@ module.+-- 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,    -- * Authorization Code-  module Network.OAuth2.Experiment.Flows.AuthorizationRequest,+  mkAuthorizationRequest,+  mkPkceAuthorizeRequest,    -- * Device Authorization   module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest,+  conduitDeviceAuthorizationRequest,+  pollDeviceTokenRequest,    -- * Token Request   module Network.OAuth2.Experiment.Flows.TokenRequest,+  conduitPkceTokenRequest,+  conduitTokenRequest,    -- * Refresh Token Request   module Network.OAuth2.Experiment.Flows.RefreshTokenRequest,+  conduitRefreshTokenRequest,    -- * UserInfo Request   module Network.OAuth2.Experiment.Flows.UserInfoRequest,+  conduitUserInfoRequest,+  conduitUserInfoRequestWithCustomMethod,    -- * Types   module Network.OAuth2.Experiment.Types,   module Network.OAuth2.Experiment.Pkce,-  module Network.OAuth.OAuth2,+  module Network.OAuth2,    -- * Utils   module Network.OAuth2.Experiment.Utils, ) where -import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..))-import Network.OAuth2.Experiment.Flows.AuthorizationRequest (-  HasAuthorizeRequest,-  mkAuthorizationRequest,-  mkPkceAuthorizeRequest,- )+import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2.Experiment.Flows import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest (   DeviceAuthorizationResponse (..),-  HasDeviceAuthorizationRequest,-  conduitDeviceAuthorizationRequest,  ) import Network.OAuth2.Experiment.Flows.RefreshTokenRequest (   HasRefreshTokenRequest,-  conduitRefreshTokenRequest,  ) import Network.OAuth2.Experiment.Flows.TokenRequest (   ExchangeTokenInfo,   HasTokenRequest,   NoNeedExchangeToken (..),   TokenRequest,-  conduitPkceTokenRequest,-  conduitTokenRequest,  ) import Network.OAuth2.Experiment.Flows.UserInfoRequest (   HasUserInfoRequest,-  conduitUserInfoRequest,-  conduitUserInfoRequestWithCustomMethod,  ) import Network.OAuth2.Experiment.Grants import Network.OAuth2.Experiment.Pkce (@@ -150,7 +147,6 @@   AuthorizeState (..),   ClientId (..),   ClientSecret (..),-  HasOAuth2Key,   Idp (..),   IdpApplication (..),   Password (..),
+ src/Network/OAuth2/Experiment/Flows.hs view
@@ -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+-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 RFC 6749 Section 4.1.1>.+--+-- 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+-- <https://datatracker.ietf.org/doc/html/rfc7636 RFC 7636>.+--+-- 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+-- <https://www.rfc-editor.org/rfc/rfc8628#section-3.5 RFC 8628 Section 3.5>.+-- 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+-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 RFC 6749 Section 4.1.3>.+--+-- 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+-- <https://www.rfc-editor.org/rfc/rfc6749#section-6 RFC 6749 Section 6>.+--+-- 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
src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs view
@@ -1,16 +1,10 @@ module Network.OAuth2.Experiment.Flows.AuthorizationRequest where -import Control.Monad.IO.Class (MonadIO (..))-import Data.Bifunctor import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.OAuth.OAuth2 hiding (RefreshToken)-import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types-import Network.OAuth2.Experiment.Utils-import URI.ByteString hiding (UserInfo)  ------------------------------------------------------------------------------- --                           Authorization Request                           --@@ -37,42 +31,3 @@       , toQueryParam arRedirectUri       , arExtraParams       ]--class HasAuthorizeRequest a where-  -- | Constructs Authorization Code request parameters-  -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1-  mkAuthorizationRequestParam :: a -> AuthorizationRequestParam---- | Constructs Authorization Code request URI--- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1-mkAuthorizationRequest :: HasAuthorizeRequest a => IdpApplication i a -> URI-mkAuthorizationRequest idpApp =-  let req = mkAuthorizationRequestParam (application idpApp)-      allParams =-        map (bimap tlToBS tlToBS) $-          Map.toList $-            toQueryParam req-   in appendQueryParams allParams $-        idpAuthorizeEndpoint (idp idpApp)------------------------------------------------------------------------------------                                    PKCE                                   -------------------------------------------------------------------------------------- | https://datatracker.ietf.org/doc/html/rfc7636-class HasAuthorizeRequest a => HasPkceAuthorizeRequest a where-  mkPkceAuthorizeRequestParam :: MonadIO m => a -> m (AuthorizationRequestParam, CodeVerifier)---- | Constructs Authorization Code (PKCE) request URI and the Code Verifier.--- https://datatracker.ietf.org/doc/html/rfc7636-mkPkceAuthorizeRequest ::-  (MonadIO m, HasPkceAuthorizeRequest a) =>-  IdpApplication i a ->-  m (URI, CodeVerifier)-mkPkceAuthorizeRequest IdpApplication {..} = do-  (req, codeVerifier) <- mkPkceAuthorizeRequestParam application-  let allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req-  let url =-        appendQueryParams allParams $-          idpAuthorizeEndpoint idp-  pure (url, codeVerifier)
src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs view
@@ -3,20 +3,12 @@ module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where  import Control.Applicative-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson.Types-import Data.Bifunctor-import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.HTTP.Client.Contrib-import Network.HTTP.Conduit-import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth2.Experiment.Types-import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo)  -------------------------------------------------------------------------------@@ -52,49 +44,16 @@     pure DeviceAuthorizationResponse {..}  data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam-  { arScope :: Set Scope-  , arClientId :: Maybe ClientId-  , arExtraParams :: Map Text Text+  { darScope :: Set Scope+  , darClientId :: Maybe ClientId+  , darExtraParams :: Map Text Text   }  instance ToQueryParam DeviceAuthorizationRequestParam where   toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text   toQueryParam DeviceAuthorizationRequestParam {..} =     Map.unions-      [ toQueryParam arScope-      , toQueryParam arClientId-      , arExtraParams+      [ toQueryParam darScope+      , toQueryParam darClientId+      , darExtraParams       ]--class HasOAuth2Key a => HasDeviceAuthorizationRequest a where-  -- | Create Device Authorization Request parameters-  -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1-  mkDeviceAuthorizationRequestParam :: a -> DeviceAuthorizationRequestParam---- TODO: There is only (possibly always only) on instance of 'HasDeviceAuthorizationRequest'--- Maybe consider to hard-code the data type instead of use type class.---- | Makes Device Authorization Request--- https://www.rfc-editor.org/rfc/rfc8628#section-3.1-conduitDeviceAuthorizationRequest ::-  (MonadIO m, HasDeviceAuthorizationRequest a) =>-  IdpApplication i a ->-  Manager ->-  ExceptT BSL.ByteString m DeviceAuthorizationResponse-conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do-  case idpDeviceAuthorizationEndpoint idp of-    Nothing -> throwE "[conduiteDeviceAuthorizationRequest] Device Authorization Flow is not supported due to miss device_authorization_endpoint."-    Just deviceAuthEndpoint -> do-      let deviceAuthReq = mkDeviceAuthorizationRequestParam application-          oauth2Key = mkOAuth2Key application-          body = unionMapsToQueryParams [toQueryParam deviceAuthReq]-      ExceptT . liftIO $ do-        req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint-        -- Hacky:-        -- Missing clientId implies ClientSecretBasic authentication method.-        -- See Grant/DeviceAuthorization.hs-        let req' = case arClientId deviceAuthReq of-              Nothing -> addBasicAuth oauth2Key req-              Just _ -> req-        resp <- httpLbs (urlEncodedBody body req') mgr-        pure $ first ("[conduiteDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp
src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs view
@@ -2,18 +2,13 @@  module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where -import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.HTTP.Conduit-import Network.OAuth.OAuth2 hiding (RefreshToken)-import Network.OAuth.OAuth2 qualified as OAuth2+import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Types-import Network.OAuth2.Experiment.Utils  ------------------------------------------------------------------------------- --                            RefreshToken Requset                           --@@ -23,6 +18,8 @@   { rrRefreshToken :: OAuth2.RefreshToken   , rrGrantType :: GrantTypeValue   , rrScope :: Set Scope+  , rrClientId :: Maybe ClientId+  , rrClientSecret :: Maybe ClientSecret   }  instance ToQueryParam RefreshTokenRequest where@@ -32,22 +29,11 @@       [ toQueryParam rrGrantType       , toQueryParam rrScope       , toQueryParam rrRefreshToken+      , toQueryParam rrClientId+      , toQueryParam rrClientSecret       ] -class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasRefreshTokenRequest a where+class HasClientAuthenticationMethod a => HasRefreshTokenRequest a where   -- | Make Refresh Token Request parameters   -- | https://www.rfc-editor.org/rfc/rfc6749#section-6   mkRefreshTokenRequestParam :: a -> OAuth2.RefreshToken -> RefreshTokenRequest---- | Make Refresh Token Request--- https://www.rfc-editor.org/rfc/rfc6749#section-6-conduitRefreshTokenRequest ::-  (MonadIO m, HasRefreshTokenRequest a) =>-  IdpApplication i a ->-  Manager ->-  OAuth2.RefreshToken ->-  ExceptT TokenResponseError m OAuth2Token-conduitRefreshTokenRequest IdpApplication {..} mgr rt =-  let tokenReq = mkRefreshTokenRequestParam application rt-      body = unionMapsToQueryParams [toQueryParam tokenReq]-   in doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body
src/Network/OAuth2/Experiment/Flows/TokenRequest.hs view
@@ -2,26 +2,33 @@  module Network.OAuth2.Experiment.Flows.TokenRequest where -import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Data.Text.Encoding qualified as T+import Data.Text.Lazy qualified as TL import Network.HTTP.Conduit-import Network.OAuth.OAuth2 hiding (RefreshToken)-import Network.OAuth2.Experiment.Pkce-import Network.OAuth2.Experiment.Types-import Network.OAuth2.Experiment.Utils+import Network.OAuth2 (+  ClientAuthenticationMethod (..),+ )+import Network.OAuth2.Experiment.Types (+  ClientId (unClientId),+  ClientSecret (unClientSecret),+ ) -----------------------------------------------------------------------------------                               Token Request                               ----------------------------------------------------------------------------------+addSecretToHeader :: ClientId -> ClientSecret -> Request -> Request+addSecretToHeader cid csecret =+  applyBasicAuth+    (T.encodeUtf8 $ TL.toStrict $ unClientId cid)+    (T.encodeUtf8 $ TL.toStrict $ unClientSecret csecret) -class HasTokenRequestClientAuthenticationMethod a where+class HasClientAuthenticationMethod a where   getClientAuthenticationMethod :: a -> ClientAuthenticationMethod+  addClientAuthToHeader :: a -> Request -> Request+  addClientAuthToHeader _ = id  -- | Only Authorization Code Grant involves a Exchange Token (Authorization Code). -- ResourceOwnerPassword and Client Credentials make token request directly. data NoNeedExchangeToken = NoNeedExchangeToken -class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasTokenRequest a where+class HasClientAuthenticationMethod a => HasTokenRequest a where   -- Each GrantTypeFlow has slightly different request parameter to /token endpoint.   data TokenRequest a   type ExchangeTokenInfo a@@ -32,52 +39,3 @@   -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token   -- type WithExchangeToken a b   mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a---- | Make Token Request--- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3-conduitTokenRequest ::-  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>-  IdpApplication i a ->-  Manager ->-  ExchangeTokenInfo a ->-  ExceptT TokenResponseError m OAuth2Token-conduitTokenRequest IdpApplication {..} mgr exchangeToken = do-  let tokenReq = mkTokenRequestParam application exchangeToken-      body = unionMapsToQueryParams [toQueryParam tokenReq]-  if getClientAuthenticationMethod application == ClientAssertionJwt-    then do-      resp <- ExceptT . liftIO $ do-        req <- uriToRequest (idpTokenEndpoint idp)-        let req' = urlEncodedBody body (addDefaultRequestHeaders req)-        handleOAuth2TokenResponse <$> httpLbs req' mgr-      case parseResponseFlexible resp of-        Right obj -> return obj-        Left e -> throwE e-    else doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body------------------------------------------------------------------------------------                                    PKCE                                   -------------------------------------------------------------------------------------- | Make Token Request (PKCE)--- https://datatracker.ietf.org/doc/html/rfc7636#section-4.5-conduitPkceTokenRequest ::-  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>-  IdpApplication i a ->-  Manager ->-  (ExchangeTokenInfo a, CodeVerifier) ->-  ExceptT TokenResponseError m OAuth2Token-conduitPkceTokenRequest IdpApplication {..} mgr (exchangeToken, codeVerifier) =-  let req = mkTokenRequestParam application exchangeToken-      key = mkOAuth2Key application-      clientSecretPostParam =-        if getClientAuthenticationMethod application == ClientSecretPost-          then clientSecretPost key-          else []-      body =-        unionMapsToQueryParams-          [ toQueryParam req-          , toQueryParam codeVerifier-          ]-          ++ clientSecretPostParam-   in doJSONPostRequest mgr key (idpTokenEndpoint idp) body
src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs view
@@ -1,44 +1,7 @@-{-# LANGUAGE FlexibleContexts #-}- module Network.OAuth2.Experiment.Flows.UserInfoRequest where -import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..))-import Data.Aeson (FromJSON)-import Data.ByteString.Lazy.Char8 qualified as BSL-import Network.HTTP.Conduit-import Network.OAuth.OAuth2-import Network.OAuth2.Experiment.Types-import URI.ByteString (URI)- ------------------------------------------------------------------------------- --                             User Info Request                             -- -------------------------------------------------------------------------------  class HasUserInfoRequest a---- | Standard approach of fetching /userinfo-conduitUserInfoRequest ::-  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>-  IdpApplication i a ->-  Manager ->-  AccessToken ->-  ExceptT BSL.ByteString m b-conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON---- | Usually 'conduitUserInfoRequest' is good enough.--- But some IdP has different approach to fetch user information rather than GET.--- This method gives the flexiblity.-conduitUserInfoRequestWithCustomMethod ::-  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>-  ( Manager ->-    AccessToken ->-    URI ->-    ExceptT BSL.ByteString m b-  ) ->-  IdpApplication i a ->-  Manager ->-  AccessToken ->-  ExceptT BSL.ByteString m b-conduitUserInfoRequestWithCustomMethod fetchMethod IdpApplication {..} mgr at =-  fetchMethod mgr at (idpUserInfoEndpoint idp)
src/Network/OAuth2/Experiment/Grants.hs view
@@ -10,7 +10,6 @@ import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..)) import Network.OAuth2.Experiment.Grants.DeviceAuthorization (   DeviceAuthorizationApplication (..),-  pollDeviceTokenRequest,  ) import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..)) import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..))
src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs view
@@ -7,14 +7,15 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..), OAuth2)-import Network.OAuth.OAuth2 qualified as OAuth2+import Network.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..))+import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.AuthorizationRequest import Network.OAuth2.Experiment.Flows.RefreshTokenRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo)  -- | An Application that supports "Authorization code" flow@@ -28,41 +29,36 @@   , acRedirectUri :: URI   , acAuthorizeState :: AuthorizeState   , acAuthorizeRequestExtraParams :: Map Text Text-  , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod+  , acClientAuthenticationMethod :: ClientAuthenticationMethod   } -instance HasOAuth2Key AuthorizationCodeApplication where-  mkOAuth2Key :: AuthorizationCodeApplication -> OAuth2-  mkOAuth2Key AuthorizationCodeApplication {..} = toOAuth2Key acClientId acClientSecret--instance HasTokenRequestClientAuthenticationMethod AuthorizationCodeApplication where+instance HasClientAuthenticationMethod AuthorizationCodeApplication where   getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod-  getClientAuthenticationMethod AuthorizationCodeApplication {..} = acTokenRequestAuthenticationMethod+  getClientAuthenticationMethod AuthorizationCodeApplication {..} = acClientAuthenticationMethod+  addClientAuthToHeader AuthorizationCodeApplication {..} = addSecretToHeader acClientId acClientSecret -instance HasAuthorizeRequest AuthorizationCodeApplication where-  mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam-  mkAuthorizationRequestParam AuthorizationCodeApplication {..} =-    AuthorizationRequestParam-      { arScope = acScope-      , arState = acAuthorizeState-      , arClientId = acClientId-      , arRedirectUri = Just (RedirectUri acRedirectUri)-      , arResponseType = Code-      , arExtraParams = acAuthorizeRequestExtraParams-      }+mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam+mkAuthorizationRequestParam AuthorizationCodeApplication {..} =+  AuthorizationRequestParam+    { arScope = acScope+    , arState = acAuthorizeState+    , arClientId = acClientId+    , arRedirectUri = Just (RedirectUri acRedirectUri)+    , arResponseType = Code+    , arExtraParams = acAuthorizeRequestExtraParams+    } -instance HasPkceAuthorizeRequest AuthorizationCodeApplication where-  mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier)-  mkPkceAuthorizeRequestParam app = do-    PkceRequestParam {..} <- mkPkceParam-    let authReqParam = mkAuthorizationRequestParam app-        combinatedExtraParams =-          Map.unions-            [ arExtraParams authReqParam-            , toQueryParam codeChallenge-            , toQueryParam codeChallengeMethod-            ]-    pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier)+mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier)+mkPkceAuthorizeRequestParam app = do+  PkceRequestParam {..} <- mkPkceParam+  let authReqParam = mkAuthorizationRequestParam app+      combinatedExtraParams =+        Map.unions+          [ arExtraParams authReqParam+          , toQueryParam codeChallenge+          , toQueryParam codeChallengeMethod+          ]+  pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier)  -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 instance HasTokenRequest AuthorizationCodeApplication where@@ -71,6 +67,9 @@     { trCode :: ExchangeToken     , trGrantType :: GrantTypeValue     , trRedirectUri :: RedirectUri+    , trClientId :: ClientId+    , trClientSecret :: ClientSecret+    , trClientAuthenticationMethod :: ClientAuthenticationMethod     }    mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication@@ -79,16 +78,30 @@       { 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 {..} =-    Map.unions-      [ toQueryParam trCode-      , toQueryParam trGrantType-      , toQueryParam trRedirectUri-      ]+    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 @@ -99,4 +112,6 @@       { rrScope = acScope       , rrGrantType = GTRefreshToken       , rrRefreshToken = rt+      , rrClientId = if acClientAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing+      , rrClientSecret = if acClientAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing       }
src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs view
@@ -6,7 +6,7 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2)+import Network.OAuth2 (ClientAuthenticationMethod (..)) import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils@@ -20,17 +20,15 @@   , ccName :: Text   , ccScope :: Set Scope   , ccTokenRequestExtraParams :: Map Text Text-  , ccTokenRequestAuthenticationMethod :: ClientAuthenticationMethod+  , ccClientAuthenticationMethod :: ClientAuthenticationMethod   } -instance HasOAuth2Key ClientCredentialsApplication where-  mkOAuth2Key :: ClientCredentialsApplication -> OAuth2-  mkOAuth2Key ClientCredentialsApplication {..} = toOAuth2Key ccClientId ccClientSecret--instance HasTokenRequestClientAuthenticationMethod ClientCredentialsApplication where+instance HasClientAuthenticationMethod ClientCredentialsApplication where   getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod-  getClientAuthenticationMethod ClientCredentialsApplication {..} = ccTokenRequestAuthenticationMethod+  getClientAuthenticationMethod ClientCredentialsApplication {..} = ccClientAuthenticationMethod +  addClientAuthToHeader ClientCredentialsApplication {..} = addSecretToHeader ccClientId ccClientSecret+ -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 instance HasTokenRequest ClientCredentialsApplication where   type ExchangeTokenInfo ClientCredentialsApplication = NoNeedExchangeToken@@ -49,7 +47,7 @@       { trScope = ccScope       , trGrantType = GTClientCredentials       , trClientSecret = ccClientSecret-      , trClientAuthenticationMethod = ccTokenRequestAuthenticationMethod+      , trClientAuthenticationMethod = ccClientAuthenticationMethod       , trExtraParams = ccTokenRequestExtraParams       , trClientId = ccClientId       }@@ -57,19 +55,19 @@ instance ToQueryParam (TokenRequest ClientCredentialsApplication) where   toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text   toQueryParam ClientCredentialsTokenRequest {..} =-    let jwtAssertionBody =-          if trClientAuthenticationMethod == ClientAssertionJwt-            then-              [ toQueryParam trClientId-              , Map.fromList+    let extraBodyBasedOnClientAuthMethod =+          case trClientAuthenticationMethod of+            ClientAssertionJwt ->+              [ Map.fromList                   [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")                   , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)                   ]               ]-            else []+            ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret]+            ClientSecretBasic -> []      in Map.unions $           [ toQueryParam trGrantType           , toQueryParam trScope           , trExtraParams           ]-            ++ jwtAssertionBody+            ++ extraBodyBasedOnClientAuthMethod
src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs view
@@ -1,20 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} -module Network.OAuth2.Experiment.Grants.DeviceAuthorization (-  DeviceAuthorizationApplication (..),-  pollDeviceTokenRequest,-) where+module Network.OAuth2.Experiment.Grants.DeviceAuthorization where -import Control.Concurrent-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.HTTP.Conduit-import Network.OAuth.OAuth2+import Network.OAuth2 import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest@@ -33,69 +26,26 @@   -- ^ Additional parameters to the device authorization request.   -- Most of identity providers follow the spec strictly but   -- AzureAD requires "tenant" parameter.-  , daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod+  , daAuthorizationRequestAuthenticationMethod :: ClientAuthenticationMethod   -- ^ The spec requires similar authentication method as /token request.   -- Most of identity providers doesn't required it but some does like Okta.   } -pollDeviceTokenRequest ::-  MonadIO m =>-  IdpApplication i DeviceAuthorizationApplication ->-  Manager ->-  DeviceAuthorizationResponse ->-  ExceptT TokenResponseError m OAuth2Token-pollDeviceTokenRequest idpApp mgr deviceAuthResp = do-  pollDeviceTokenRequestInternal-    idpApp-    mgr-    (deviceCode deviceAuthResp)-    (fromMaybe 5 $ interval deviceAuthResp)--pollDeviceTokenRequestInternal ::-  MonadIO m =>-  IdpApplication i DeviceAuthorizationApplication ->-  Manager ->-  DeviceCode ->-  Int ->-  -- | Polling Interval-  ExceptT TokenResponseError m OAuth2Token-pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds = do-  resp <- runExceptT (conduitTokenRequest idpApp mgr deviceCode)-  case resp of-    Left trRespError -> do-      case tokenResponseError trRespError of-        -- TODO: Didn't have a good idea to expand the error code-        -- specifically for device token request flow-        -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5-        UnknownErrorCode "authorization_pending" -> do-          liftIO $ threadDelay $ intervalSeconds * 1000000-          pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds-        UnknownErrorCode "slow_down" -> do-          let newIntervalSeconds = intervalSeconds + 5-          liftIO $ threadDelay $ newIntervalSeconds * 1000000-          pollDeviceTokenRequestInternal idpApp mgr deviceCode newIntervalSeconds-        _ -> throwE trRespError-    Right v -> pure v--instance HasOAuth2Key DeviceAuthorizationApplication where-  mkOAuth2Key :: DeviceAuthorizationApplication -> OAuth2-  mkOAuth2Key DeviceAuthorizationApplication {..} = toOAuth2Key daClientId daClientSecret--instance HasTokenRequestClientAuthenticationMethod DeviceAuthorizationApplication where+instance HasClientAuthenticationMethod DeviceAuthorizationApplication where   getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod-  getClientAuthenticationMethod _ = ClientSecretBasic+  getClientAuthenticationMethod = daAuthorizationRequestAuthenticationMethod+  addClientAuthToHeader DeviceAuthorizationApplication {..} = addSecretToHeader daClientId daClientSecret -instance HasDeviceAuthorizationRequest DeviceAuthorizationApplication where-  mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam-  mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} =-    DeviceAuthorizationRequestParam-      { arScope = daScope-      , arClientId =-          if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic-            then Nothing-            else Just daClientId-      , arExtraParams = daAuthorizationRequestExtraParam-      }+mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam+mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} =+  DeviceAuthorizationRequestParam+    { darScope = daScope+    , darClientId =+        if daAuthorizationRequestAuthenticationMethod == ClientSecretPost+          then Just daClientId+          else Nothing+    , darExtraParams = daAuthorizationRequestExtraParam+    }  -- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4 instance HasTokenRequest DeviceAuthorizationApplication where@@ -123,9 +73,9 @@       { trCode = deviceCode       , trGrantType = GTDeviceCode       , trClientId =-          if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic-            then Nothing-            else Just daClientId+          if daAuthorizationRequestAuthenticationMethod == ClientSecretPost+            then Just daClientId+            else Nothing       }  instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where
src/Network/OAuth2/Experiment/Grants/JwtBearer.hs view
@@ -3,11 +3,10 @@ module Network.OAuth2.Experiment.Grants.JwtBearer where  import Data.ByteString qualified as BS-import Data.Default (Default (def)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text.Lazy (Text)-import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2)+import Network.OAuth2 (ClientAuthenticationMethod (..)) import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest import Network.OAuth2.Experiment.Types@@ -21,15 +20,7 @@   , jbJwtAssertion :: BS.ByteString   } --- JwtBearner doesn't use @client_id@ and @client_secret@ for authentication.------ FIXME: The ideal solution shall be do not implement `HasOAuth2Key`--- but it will stop to re-use the method 'conduitTokenRequest' for JwtBearer flow.-instance HasOAuth2Key JwtBearerApplication where-  mkOAuth2Key :: JwtBearerApplication -> OAuth2-  mkOAuth2Key _ = def--instance HasTokenRequestClientAuthenticationMethod JwtBearerApplication where+instance HasClientAuthenticationMethod JwtBearerApplication where   getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod   getClientAuthenticationMethod _ = ClientAssertionJwt
src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs view
@@ -6,8 +6,8 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text.Lazy (Text)-import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2 (..))-import Network.OAuth.OAuth2 qualified as OAuth2+import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Flows.RefreshTokenRequest import Network.OAuth2.Experiment.Flows.TokenRequest import Network.OAuth2.Experiment.Flows.UserInfoRequest@@ -24,15 +24,13 @@   , ropUserName :: Username   , ropPassword :: Password   , ropTokenRequestExtraParams :: Map Text Text+  , ropClientAuthenticationMethod :: ClientAuthenticationMethod   } -instance HasOAuth2Key ResourceOwnerPasswordApplication where-  mkOAuth2Key :: ResourceOwnerPasswordApplication -> OAuth2-  mkOAuth2Key ResourceOwnerPasswordApplication {..} = toOAuth2Key ropClientId ropClientSecret--instance HasTokenRequestClientAuthenticationMethod ResourceOwnerPasswordApplication where+instance HasClientAuthenticationMethod ResourceOwnerPasswordApplication where   getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod-  getClientAuthenticationMethod _ = ClientSecretBasic+  getClientAuthenticationMethod = ropClientAuthenticationMethod+  addClientAuthToHeader ResourceOwnerPasswordApplication {..} = addSecretToHeader ropClientId ropClientSecret  -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 instance HasTokenRequest ResourceOwnerPasswordApplication where@@ -75,4 +73,6 @@       { rrScope = ropScope       , rrGrantType = GTRefreshToken       , rrRefreshToken = rt+      , rrClientId = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientId else Nothing+      , rrClientSecret = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientSecret else Nothing       }
src/Network/OAuth2/Experiment/Types.hs view
@@ -4,7 +4,6 @@  module Network.OAuth2.Experiment.Types where -import Data.Default (Default (def)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set)@@ -12,8 +11,8 @@ import Data.String import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL-import Network.OAuth.OAuth2 hiding (RefreshToken)-import Network.OAuth.OAuth2 qualified as OAuth2+import Network.OAuth2 hiding (RefreshToken)+import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils import URI.ByteString (URI, serializeURIRef')@@ -24,9 +23,6 @@  ------------------------------------------------------------------------------- --- TODO: Distinct type per endpoint--- Because I made mistake at passing to Authorize and Token Request- -- | @Idp i@ consists various endpoints endpoints. -- -- The @i@ is actually phantom type for information only (Idp name) at this moment.@@ -74,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 (Eq, Ord)+  deriving (Eq, Ord, Show)  instance IsString Scope where   fromString :: String -> Scope@@ -111,19 +107,10 @@ newtype ClientId = ClientId {unClientId :: Text}   deriving (Show, Eq, IsString) --- | Can be either "Client Secret" or JWT base on client authentication method+-- | 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) @@ -201,7 +188,10 @@   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 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@@ -226,13 +216,3 @@ instance ToQueryParam ResponseType where   toQueryParam :: ResponseType -> Map Text Text   toQueryParam Code = Map.singleton "response_type" "code"------------------------------------------------------------------------------------                                HasOAuth2Key                               -----                                                                           ----- Find a way to reuse some methods from old implementation                  ----- Probably will be removed when Experiment module becomes default           ------------------------------------------------------------------------------------class HasOAuth2Key a where-  mkOAuth2Key :: a -> OAuth2
+ src/Network/OAuth2/HttpClient.hs view
@@ -0,0 +1,245 @@+-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage+-- RFC6750 <https://www.rfc-editor.org/rfc/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)]
+ src/Network/OAuth2/Internal.hs view
@@ -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'
+ src/Network/OAuth2/TokenRequest.hs view
@@ -0,0 +1,362 @@+-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework+-- RFC6749 <https://www.rfc-editor.org/rfc/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)+  ]
− test/Network/OAuth/OAuth2/TokenRequestSpec.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Network.OAuth.OAuth2.TokenRequestSpec where--import Data.Aeson qualified as Aeson-import Network.OAuth.OAuth2.TokenRequest-import Test.Hspec-import URI.ByteString.QQ-import Prelude hiding (error)--spec :: Spec-spec = do-  describe "parseJSON TokenResponseErrorCode" $ do-    it "invalid_request" $ do-      Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest-    it "invalid_client" $ do-      Aeson.eitherDecode "\"invalid_client\"" `shouldBe` Right InvalidClient-    it "invalid_grant" $ do-      Aeson.eitherDecode "\"invalid_grant\"" `shouldBe` Right InvalidGrant-    it "unauthorized_client" $ do-      Aeson.eitherDecode "\"unauthorized_client\"" `shouldBe` Right UnauthorizedClient-    it "unsupported_grant_type" $ do-      Aeson.eitherDecode "\"unsupported_grant_type\"" `shouldBe` Right UnsupportedGrantType-    it "invalid_scope" $ do-      Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope-    it "foo_code" $ do-      Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code")--  describe "parseJSON TokenResponseError" $ do-    it "parse error" $ do-      Aeson.eitherDecode "{\"error\": \"invalid_request\"}"-        `shouldBe` Right-          ( TokenResponseError-              { tokenResponseError = InvalidRequest-              , tokenResponseErrorDescription = Nothing-              , tokenResponseErrorUri = Nothing-              }-          )-    it "parse error_description" $ do-      Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_description\": \"token request error foo1\"}"-        `shouldBe` Right-          ( TokenResponseError-              { tokenResponseError = InvalidRequest-              , tokenResponseErrorDescription = Just "token request error foo1"-              , tokenResponseErrorUri = Nothing-              }-          )-    it "parse error_uri" $ do-      Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_uri\": \"https://example.com\"}"-        `shouldBe` Right-          ( TokenResponseError-              { tokenResponseError = InvalidRequest-              , tokenResponseErrorDescription = Nothing-              , tokenResponseErrorUri = Just [uri|https://example.com|]-              }-          )
+ test/Network/OAuth2/InternalSpec.hs view
@@ -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` ""
+ test/Network/OAuth2/TokenRequestSpec.hs view
@@ -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|]+              }+          )
+ test/Network/OAuth2/TokenResponseSpec.hs view
@@ -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