hoauth2 2.5.0 → 2.6.0

raw patch · 13 files changed

+1284/−269 lines, 13 filesdep +base64dep +cryptonitedep +memorydep ~binarydep ~containersdep ~data-defaultsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: base64, cryptonite, memory

Dependency ranges changed: binary, containers, data-default, microlens, transformers, uri-bytestring-aeson

API changes (from Hackage documentation)

Files

• LICENSE +17/−26
• README.org +6/−1
• Setup.hs +0/−2
• hoauth2.cabal +68/−63
• src/Network/OAuth/OAuth2.hs +3/−14
• src/Network/OAuth/OAuth2/AuthorizationRequest.hs +25/−9
• src/Network/OAuth/OAuth2/HttpClient.hs +141/−68
• src/Network/OAuth/OAuth2/Internal.hs +29/−24
• src/Network/OAuth/OAuth2/TokenRequest.hs +102/−62
• src/Network/OAuth2/Experiment.hs +97/−0
• src/Network/OAuth2/Experiment/Pkce.hs +82/−0
• src/Network/OAuth2/Experiment/Types.hs +693/−0
• src/Network/OAuth2/Experiment/Utils.hs +21/−0

@@ -1,30 +1,21 @@-Copyright (c)2012-present, Haisheng Wu--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+MIT License -    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+Copyright (c) 2022 Haisheng Wu -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions: -    * Neither the name of Haisheng Wu nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -1,3 +1,8 @@ * Introduction -A mixed Haskell binding of [OAuth2 spec](https://datatracker.ietf.org/doc/html/rfc6749) and a little bit [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html).+Lightweight Haskell binding for++- [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749)+  - If the provider does implement [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html),+    ID Token would also be included in token response (see `OAuth2Token`).+- [The OAuth 2.0 Authorization Framework: Bearer Token Usage](https://www.rfc-editor.org/rfc/rfc6750)

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,70 +1,75 @@-Cabal-version: 2.4-Name:                hoauth2--- http://wiki.haskell.org/Package_versioning_policy-Version:             2.5.0--Synopsis:            Haskell OAuth2 authentication client+cabal-version:      2.4+name:               hoauth2 -Description: Haskell OAuth2 authentication client. Tested with the following services:-             .-             * AzureAD: <https://docs.microsoft.com/en-us/azure/active-directory/develop/v1-protocols-oauth-code>-             .-             * Google: <https://developers.google.com/accounts/docs/OAuth2WebServer>-             .-             * Github: <http://developer.github.com/v3/oauth/>-             .-             * Facebook: <http://developers.facebook.com/docs/facebook-login/>-             .-             * Fitbit: <http://dev.fitbit.com/docs/oauth2/>-             .-             * StackExchange: <https://api.stackexchange.com/docs/authentication>-             .-             * DropBox: <https://www.dropbox.com/developers/reference/oauth-guide>-             .-             * Weibo: <http://open.weibo.com/wiki/Oauth2>-             .-             * Douban: <http://developers.douban.com/wiki/?title=oauth2>+-- http://wiki.haskell.org/Package_versioning_policy+version:            2.6.0+synopsis:           Haskell OAuth2 authentication client+description:+  Haskell OAuth2 authentication client.+  .+  Tutorial <https://github.com/freizl/hoauth2/tree/main/hoauth2-tutorial/>+  .+  Demo application <https://github.com/freizl/hoauth2-demo/tree/main/hoauth2-demo/> -Homepage:            https://github.com/freizl/hoauth2-License:             BSD-3-Clause-License-file:        LICENSE-Author:              Haisheng Wu-Maintainer:          Haisheng Wu <freizl@gmail.com>-Copyright:           Haisheng Wu-Category:            Network-Build-type:          Simple-Stability:           Beta-Tested-With:         GHC <= 8.10.7+homepage:           https://github.com/freizl/hoauth2+license:            MIT+license-file:       LICENSE+author:             Haisheng Wu+maintainer:         Haisheng Wu <freizl@gmail.com>+copyright:          Haisheng Wu+category:           Network+build-type:         Simple+stability:          Beta+tested-with:        GHC <=9.2.2+extra-source-files: README.org -Extra-source-files: README.org+source-repository head+  type:     git+  location: git://github.com/freizl/hoauth2.git -Source-Repository head-  Type:     git-  Location: git://github.com/freizl/hoauth2.git+library+  hs-source-dirs:     src+  default-language:   Haskell2010+  exposed-modules:+    Network.OAuth.OAuth2+    Network.OAuth.OAuth2.AuthorizationRequest+    Network.OAuth.OAuth2.HttpClient+    Network.OAuth.OAuth2.Internal+    Network.OAuth.OAuth2.TokenRequest+    Network.OAuth2.Experiment+    Network.OAuth2.Experiment.Pkce+    Network.OAuth2.Experiment.Types+    Network.OAuth2.Experiment.Utils -Library-  hs-source-dirs:   src-  default-language: Haskell2010-  Exposed-modules: Network.OAuth.OAuth2.HttpClient-                   Network.OAuth.OAuth2.Internal-                   Network.OAuth.OAuth2-                   Network.OAuth.OAuth2.TokenRequest-                   Network.OAuth.OAuth2.AuthorizationRequest+  default-extensions:+    DataKinds+    DeriveGeneric+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    OverloadedStrings+    RecordWildCards+    TypeApplications+    TypeFamilies -  Build-Depends: base                 >= 4     && < 5,-                 data-default         >= 0.7   && < 0.8,-                 binary               >= 0.8   && < 0.9,-                 containers           >= 0.6   && < 0.7,-                 text                 >= 0.11  && < 1.3,-                 bytestring           >= 0.9   && < 0.12,-                 http-conduit         >= 2.1   && < 2.4,-                 http-types           >= 0.11  && < 0.13,-                 aeson                >= 2.0   && < 2.2,-                 transformers         >= 0.5   && < 0.6,-                 uri-bytestring       >= 0.2.3 && < 0.4,-                 uri-bytestring-aeson >= 0.1   && < 0.2,-                 microlens            >= 0.4.0 && < 0.5,-                 exceptions           >= 0.8.3 && < 0.11+  build-depends:+    , aeson                 >=2.0   && <2.2+    , base                  >=4     && <5+    , base64                ^>=0.4+    , binary                ^>=0.8+    , bytestring            >=0.9   && <0.12+    , containers            ^>=0.6+    , cryptonite            ^>=0.30+    , data-default          ^>=0.7+    , exceptions            >=0.8.3 && <0.11+    , http-conduit          >=2.1   && <2.4+    , http-types            >=0.11  && <0.13+    , memory                ^>=0.17+    , microlens             ^>=0.4.0+    , text                  >=0.11  && <1.3+    , transformers          ^>=0.5+    , uri-bytestring        >=0.2.3 && <0.4+    , uri-bytestring-aeson  ^>=0.1 -  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields-               -fno-warn-unused-do-bind -Wunused-packages+  ghc-options:+    -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields+    -Wwarnings-deprecations

@@ -1,17 +1,6 @@------------------------------------------------------------------------------------------------------------------------------- |--- Module      :  Network.OAuth.OAuth2--- Description :  OAuth2 client--- Copyright   :  (c) 2012 Haisheng Wu--- License     :  BSD-style (see the file LICENSE)--- Maintainer  :  Haisheng Wu <freizl@gmail.com>--- Stability   :  Beta--- Portability :  portable+-- | A lightweight oauth2 Haskell binding.+-- See Readme for more details ----- A lightweight oauth2 haskell binding. module Network.OAuth.OAuth2   ( module Network.OAuth.OAuth2.HttpClient,     module Network.OAuth.OAuth2.AuthorizationRequest,@@ -22,7 +11,7 @@  {-   Hiding Errors data type from default.-  Shall qualified import given the naming conflicts.+  Shall qualified import given the naming collision. -} import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..)) import Network.OAuth.OAuth2.HttpClient

@@ -1,12 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | 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 qualified Data.List as List import qualified Data.Text.Encoding as T-import GHC.Generics-import Lens.Micro+import GHC.Generics (Generic)+import Lens.Micro (over) import Network.OAuth.OAuth2.Internal import URI.ByteString @@ -23,7 +27,11 @@   toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}  -- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1--- Implicit Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.2.2.1+-- I found hard time to figure a way to test the authorization error flow+-- When anything wrong in @/authorize@ request (redirect to OAuth2 provider),+-- it will end-up at the Provider page hence no way for this library to parse error response.+-- In other words, @/authorize@ ends up with 4xx or 5xx.+-- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors. data Errors   = InvalidRequest   | UnauthorizedClient@@ -40,13 +48,21 @@  -------------------------------------------------- +-- | See 'authorizationUrlWithParams'+authorizationUrl :: OAuth2 -> URI+authorizationUrl = authorizationUrlWithParams []+ -- | Prepare the authorization URL.  Redirect to this URL -- asking for user interactive authentication.-authorizationUrl :: OAuth2 -> URI-authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)+--+-- @since 2.6.0+authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI+authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)   where     queryParts =-      [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-        ("response_type", "code"),-        ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)-      ]+      List.nubBy ((==) `on` fst) $+        qs+          ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),+               ("response_type", "code"),+               ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+             ]

@@ -2,37 +2,43 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} --- | A simple http client to request OAuth2 tokens and several utils.+-- | 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,-    authPostBS1,     authPostBS2,     authPostBS3,+    authPostJSONWithAuthMethod,     authPostJSONInternal,+    authPostBSWithAuthMethod,     authPostBSInternal,++    -- * Types+    APIAuthenticationMethod (..),   ) where -import qualified Data.Set as Set-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except-import Data.Aeson+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Data.Aeson (FromJSON, eitherDecode) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Maybe+import Data.Maybe (fromJust, isJust) import qualified Data.Text.Encoding as T-import Lens.Micro+import Lens.Micro (over) import Network.HTTP.Conduit import qualified Network.HTTP.Types as HT import Network.OAuth.OAuth2.Internal-import URI.ByteString+import URI.ByteString (URI, URIRef, queryL, queryPairsL)  -------------------------------------------------- @@ -45,67 +51,97 @@ -- | Conduct an authorized GET request and return response as JSON. --   Inject Access Token to Authorization Header. authGetJSON ::-  (FromJSON b) =>+  (FromJSON a, MonadIO m) =>   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   -- | Response as JSON-  ExceptT BSL.ByteString IO b-authGetJSON = authGetJSONInternal (Set.fromList [AuthInRequestHeader])-{-# DEPRECATED authGetJSON "use authGetJSONInternal" #-}+  ExceptT BSL.ByteString m a+authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader +authGetJSONInternal ::+  (FromJSON a, MonadIO m) =>+  APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as JSON+  ExceptT BSL.ByteString m a+authGetJSONInternal = authGetJSONWithAuthMethod+{-# DEPRECATED authGetJSONInternal "use authGetJSONWithAuthMethod" #-}+ -- | Conduct an authorized GET request and return response as JSON. --   Allow to specify how to append AccessToken.-authGetJSONInternal ::-  (FromJSON b) =>-  Set.Set APIAuthenticationMethod ->+--+-- @since 2.6.0+authGetJSONWithAuthMethod ::+  (MonadIO m, FromJSON a) =>+  APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   -- | Response as JSON-  ExceptT BSL.ByteString IO b-authGetJSONInternal authTypes manager t uri = do-  resp <- authGetBSInternal authTypes manager t uri+  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 IO BSL.ByteString-authGetBS = authGetBSInternal $ Set.fromList [AuthInRequestHeader]+  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 IO BSL.ByteString-authGetBS2 = authGetBSInternal $ Set.fromList [AuthInRequestQuery]-{-# DEPRECATED authGetBS2 "use authGetBSInternal" #-}+  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.-authGetBSInternal ::-  -- |-  Set.Set APIAuthenticationMethod ->+--+-- @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 IO BSL.ByteString-authGetBSInternal authTypes manager token url = do-  let appendToUrl = AuthInRequestQuery `Set.member` authTypes-  let appendToHeader = AuthInRequestHeader `Set.member` authTypes+  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@@ -114,96 +150,116 @@ -- | Conduct POST request and return response as JSON. --   Inject Access Token to Authorization Header. authPostJSON ::-  (FromJSON b) =>+  (FromJSON a, MonadIO m) =>   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   PostBody ->   -- | Response as JSON-  ExceptT BSL.ByteString IO b-authPostJSON = authPostJSONInternal $ Set.fromList [AuthInRequestHeader]-{-# DEPRECATED authPostJSON "use authPostJSONInternal" #-}+  ExceptT BSL.ByteString m a+authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader --- | Conduct POST request and return response as JSON.---   Allow to specify how to append AccessToken. authPostJSONInternal ::-  FromJSON a =>-  Set.Set APIAuthenticationMethod ->+  (FromJSON a, MonadIO m) =>+  APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   PostBody ->   -- | Response as ByteString-  ExceptT BSL.ByteString IO a-authPostJSONInternal authTypes manager token url body = do-  resp <- authPostBSInternal authTypes manager token url body-  either (throwE . BSL.pack) return (eitherDecode resp)+  ExceptT BSL.ByteString m a+authPostJSONInternal = authPostJSONWithAuthMethod+{-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-} --- | Conduct POST request.---   Inject Access Token to http header (Authorization)-authPostBS ::+-- | Conduct POST request and return response as JSON.+--   Allow to specify how to append AccessToken.+--+-- @since 2.6.0+authPostJSONWithAuthMethod ::+  (FromJSON a, MonadIO m) =>+  APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   PostBody ->   -- | Response as ByteString-  ExceptT BSL.ByteString IO BSL.ByteString-authPostBS = authPostBSInternal $ Set.fromList [AuthInRequestHeader]+  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 both http header (Authorization) and request body.-authPostBS1 ::+--   Inject Access Token to http header (Authorization)+authPostBS ::+  (MonadIO m) =>   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   PostBody ->   -- | Response as ByteString-  ExceptT BSL.ByteString IO BSL.ByteString-authPostBS1 = authPostBSInternal $ Set.fromList [AuthInRequestBody, AuthInRequestHeader]-{-# DEPRECATED authPostBS1 "use authPostBSInternal" #-}+  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 IO BSL.ByteString-authPostBS2 = authPostBSInternal $ Set.fromList [AuthInRequestBody]-{-# DEPRECATED authPostBS2 "use authPostBSInternal" #-}+  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 IO BSL.ByteString-authPostBS3 = authPostBSInternal $ Set.fromList [AuthInRequestHeader]-{-# DEPRECATED authPostBS3 "use authPostBSInternal" #-}+  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.-authPostBSInternal ::-  Set.Set APIAuthenticationMethod ->+--+-- @since 2.6.0+authPostBSWithAuthMethod ::+  (MonadIO m) =>+  APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->   AccessToken ->   URI ->   PostBody ->   -- | Response as ByteString-  ExceptT BSL.ByteString IO BSL.ByteString-authPostBSInternal authTypes manager token url body = do-  let appendToBody = AuthInRequestBody `Set.member` authTypes-  let appendToHeader = AuthInRequestHeader `Set.member` authTypes+  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?@@ -211,27 +267,44 @@   let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST   let upReq = upHeaders . upBody -  req <- uriToRequest url+  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 IO BSL.ByteString+  ExceptT BSL.ByteString m BSL.ByteString authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage --- | Parses a @Response@ to to @OAuth2Result@+-- | Get response body out of a @Response@ handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp =   if HT.statusIsSuccessful (responseStatus rsp)

@@ -3,10 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK -ignore-exports #-} --- | A simple OAuth2 Haskell binding.  (This is supposed to be--- independent of the http client used.) module Network.OAuth.OAuth2.Internal where  import Control.Applicative@@ -63,36 +60,41 @@  newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +-- | Authorization Code newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) --- | The gained Access Token. Use @Data.Aeson.decode@ to--- decode string to @AccessToken@.  The @refreshToken@ is--- special in some cases,--- e.g. <https://developers.google.com/accounts/docs/OAuth2>+-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 data OAuth2Token = OAuth2Token   { accessToken :: AccessToken,+    -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token.     refreshToken :: Maybe RefreshToken,     expiresIn :: Maybe Int,+    -- | See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.     tokenType :: Maybe Text,+    -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID.     idToken :: Maybe IdToken   }   deriving (Eq, Show, Generic)  instance Binary OAuth2Token -parseIntFlexible :: Value -> Parser Int-parseIntFlexible (String s) = pure . read $ unpack s-parseIntFlexible v = parseJSON v- -- | Parse JSON data into 'OAuth2Token' instance FromJSON OAuth2Token where   parseJSON = withObject "OAuth2Token" $ \v ->     OAuth2Token-      <$> v .: "access_token"-      <*> v .:? "refresh_token"+      <$> v+      .: "access_token"+      <*> v+      .:? "refresh_token"       <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"-      <*> v .:? "token_type"-      <*> v .:? "id_token"+      <*> 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 '_'}@@ -129,15 +131,18 @@     (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response))     Nothing -data APIAuthenticationMethod-  = -- | Provides in Authorization header-    AuthInRequestHeader-  | -- | Provides in request body-    AuthInRequestBody-  | -- | Provides in request query parameter-    AuthInRequestQuery-  deriving (Eq, Ord)-+-- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3+-- According to spec:+--+-- The client MUST NOT use more than one authentication method in each request.+--+-- Which means use Authorization header or Post body.+--+-- However, in reality, I always have to include authentication in the header.+--+-- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional.+--+-- Maybe consider an alternative implementation that boolean kind of data type is good enough. data ClientAuthenticationMethod   = ClientSecretBasic   | ClientSecretPost

@@ -1,20 +1,23 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +-- | 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.Trans.Except+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text.Encoding as T-import GHC.Generics+import GHC.Generics (Generic) import Network.HTTP.Conduit import qualified Network.HTTP.Types as HT import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal-import URI.ByteString+import URI.ByteString (URI, serializeURIRef')  -------------------------------------------------- @@ -60,13 +63,12 @@         ]    in (uri, body) --- | Using a Refresh Token.  Obtain a new access token by--- sending a refresh token to the Authorization server.+-- | Obtain a new access token by sending a Refresh Token to the Authorization server. refreshAccessTokenUrl ::   OAuth2 ->-  -- | refresh token gained via authorization URL+  -- | Refresh Token gained via authorization URL   RefreshToken ->-  -- | refresh token request URL plus the request body.+  -- | Refresh Token request URL plus the request body.   (URI, PostBody) refreshAccessTokenUrl oa token = (uri, body)   where@@ -76,29 +78,15 @@         ("refresh_token", T.encodeUtf8 $ rtoken token)       ] -clientSecretPost :: OAuth2 -> PostBody-clientSecretPost oa =-  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-    ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)-  ]- --------------------------------------------------  -- * Token management  -------------------------------------------------- --- | Fetch OAuth2 Token with authenticate in request header.------ OAuth2 spec allows `client_id` and `client_secret` to--- either be sent in the header (as basic authentication)--- OR as form/url params.--- The OAuth server can choose to implement only one, or both.--- Unfortunately, there is no way for the OAuth client (i.e. this library) to--- know which method to use.--- Please take a look at the documentation of the--- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2`+-- | Exchange @code@ for an Access Token with authenticate in request header. fetchAccessToken ::+  (MonadIO m) =>   -- | HTTP connection manager   Manager ->   -- | OAuth Data@@ -106,79 +94,124 @@   -- | OAuth2 Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) IO OAuth2Token-fetchAccessToken = fetchAccessTokenInternal ClientSecretBasic+  ExceptT (OAuth2Error Errors) m OAuth2Token+fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic  fetchAccessToken2 ::+  (MonadIO m) =>   -- | HTTP connection manager   Manager ->   -- | OAuth Data   OAuth2 ->-  -- | OAuth 2 Tokens+  -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) IO OAuth2Token-fetchAccessToken2 = fetchAccessTokenInternal ClientSecretPost-{-# DEPRECATED fetchAccessToken2 "renamed to fetchAccessTokenInternal" #-}+  ExceptT (OAuth2Error Errors) m OAuth2Token+fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost+{-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-}  fetchAccessTokenInternal ::+  (MonadIO m) =>   ClientAuthenticationMethod ->   -- | HTTP connection manager   Manager ->   -- | OAuth Data   OAuth2 ->-  -- | OAuth 2 Tokens+  -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) IO OAuth2Token-fetchAccessTokenInternal authMethod manager oa code = do+  ExceptT (OAuth2Error Errors) m OAuth2Token+fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod+{-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-}++-- | Exchange @code@ for an Access Token+--+-- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent+-- either in the header (a.k.a 'ClientSecretBasic').+-- or as form/url params (a.k.a 'ClientSecretPost').+--+-- The OAuth provider can choose to implement only one, or both.+-- Look for API document from the OAuth provider you're dealing with.+-- If you're uncertain, try 'fetchAccessToken' which sends credential+-- in authorization http header, which is common case.+--+-- @since 2.6.0+fetchAccessTokenWithAuthMethod ::+  (MonadIO m) =>+  ClientAuthenticationMethod ->+  -- | HTTP connection manager+  Manager ->+  -- | OAuth Data+  OAuth2 ->+  -- | Authorization Code+  ExchangeToken ->+  -- | Access Token+  ExceptT (OAuth2Error Errors) m OAuth2Token+fetchAccessTokenWithAuthMethod authMethod manager oa code = do   let (uri, body) = accessTokenUrl oa code   let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []   doJSONPostRequest manager oa uri (body ++ extraBody) --- doJSONPostRequest append client secret to header which is needed for both--- client_secret_post and client_secret_basic---- | Fetch a new AccessToken with the Refresh Token with authentication in request header.------ OAuth2 spec allows `client_id` and `client_secret` to--- either be sent in the header (as basic authentication)--- OR as form/url params.--- The OAuth server can choose to implement only one, or both.--- Unfortunately, there is no way for the OAuth client (i.e. this library) to--- know which method to use. Please take a look at the documentation of the--- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2`+-- | 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+  -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) IO OAuth2Token-refreshAccessToken = refreshAccessTokenInternal ClientSecretBasic+  ExceptT (OAuth2Error Errors) m OAuth2Token+refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic  refreshAccessToken2 ::+  (MonadIO m) =>   -- | HTTP connection manager.   Manager ->   -- | OAuth context   OAuth2 ->-  -- | refresh token gained after authorization+  -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) IO OAuth2Token-refreshAccessToken2 = refreshAccessTokenInternal ClientSecretPost-{-# DEPRECATED refreshAccessToken2 "renamed to fetchAccessTokenInternal" #-}+  ExceptT (OAuth2Error Errors) m OAuth2Token+refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost+{-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-}  refreshAccessTokenInternal ::+  (MonadIO m) =>   ClientAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->   -- | OAuth context   OAuth2 ->-  -- | refresh token gained after authorization+  -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) IO OAuth2Token-refreshAccessTokenInternal authMethod manager oa token = do+  ExceptT (OAuth2Error Errors) m OAuth2Token+refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod+{-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-}++-- | Fetch a new AccessToken using the Refresh Token.+--+-- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent+-- either in the header (a.k.a 'ClientSecretBasic').+-- or as form/url params (a.k.a 'ClientSecretPost').+--+-- The OAuth provider can choose to implement only one, or both.+-- Look for API document from the OAuth provider you're dealing with.+-- If you're uncertain, try 'refreshAccessToken' which sends credential+-- in authorization http header, which is common case.+--+-- @since 2.6.0+refreshAccessTokenWithAuthMethod ::+  (MonadIO m) =>+  ClientAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth context+  OAuth2 ->+  -- | Refresh Token gained after authorization+  RefreshToken ->+  ExceptT (OAuth2Error Errors) m OAuth2Token+refreshAccessTokenWithAuthMethod authMethod manager oa token = do   let (uri, body) = refreshAccessTokenUrl oa token   let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []   doJSONPostRequest manager oa uri (body ++ extraBody)@@ -191,7 +224,7 @@  -- | Conduct post request and return response as JSON. doJSONPostRequest ::-  (FromJSON err, FromJSON a) =>+  (MonadIO m, FromJSON err, FromJSON a) =>   -- | HTTP connection manager.   Manager ->   -- | OAuth options@@ -201,7 +234,7 @@   -- | request body   PostBody ->   -- | Response as JSON-  ExceptT (OAuth2Error err) IO a+  ExceptT (OAuth2Error err) m a doJSONPostRequest manager oa uri body = do   resp <- doSimplePostRequest manager oa uri body   case parseResponseFlexible resp of@@ -210,7 +243,7 @@  -- | Conduct post request. doSimplePostRequest ::-  FromJSON err =>+  (MonadIO m, FromJSON err) =>   -- | HTTP connection manager.   Manager ->   -- | OAuth options@@ -220,9 +253,9 @@   -- | Request body.   PostBody ->   -- | Response as ByteString-  ExceptT (OAuth2Error err) IO BSL.ByteString+  ExceptT (OAuth2Error err) m BSL.ByteString doSimplePostRequest manager oa url body =-  ExceptT $ fmap handleOAuth2TokenResponse go+  ExceptT . liftIO $ fmap handleOAuth2TokenResponse go   where     addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa)     go = do@@ -230,14 +263,14 @@       let req' = (addBasicAuth . addDefaultRequestHeaders) req       httpLbs (urlEncodedBody body req') manager --- | Parses a @Response@ to to @OAuth2Result@+-- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error' handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString handleOAuth2TokenResponse rsp =   if HT.statusIsSuccessful (responseStatus rsp)     then Right $ responseBody rsp     else Left $ parseOAuth2Error (responseBody rsp) --- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String.+-- | Try to parses response as JSON, if failed, try to parse as like query string. parseResponseFlexible ::   (FromJSON err, FromJSON a) =>   BSL.ByteString ->@@ -246,7 +279,7 @@   Left _ -> parseResponseString r   Right x -> Right x --- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String+-- | Parses the response that contains not JSON but a Query String parseResponseString ::   (FromJSON err, FromJSON a) =>   BSL.ByteString ->@@ -268,3 +301,10 @@ 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)+  ]

@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module contains a new way of doing OAuth2 authorization and authentication+-- in order to obtain Access Token and maybe Refresh Token base on rfc6749.+--+-- This module will become default in future release. (TBD but likely 3.0).+--+-- The key concept/change is to introduce the 'GrantTypeFlow', which determines the entire work flow per spec.+-- Each work flow will have slight different request parameters, which often time you'll see+-- different configuration when creating OAuth2 application in the IdP developer application page.+--+-- Here are supported flows+--+-- 1. Authorization Code. This flow requires authorize call to obtain an authorize code,+-- then exchange the code for tokens.+--+-- 2. Resource Owner Password. This flow only requires to hit 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.+--+-- 5. PKCE (rfc7636). This is enhancement on top of authorization code flow.+--+-- Implicit flow is not supported because it is more for SPA (single page app)+-- and more or less obsolete by Authorization Code flow with PKCE.+--+-- Here is quick sample for how to use vocabularies from this new module.+--+-- Firstly, initialize your IdP (use google as example) and the application.+--+-- @+-- data Google = Google deriving (Eq, Show)+-- googleIdp = Idp Google+--   Idp+--     { idpFetchUserInfo = authGetJSON @(IdpUserInfo Google),+--       idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|],+--       idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|],+--       idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|]+--     }+--+-- fooApp :: IdpApplication 'AuthorizationCode Google+-- fooApp =+--   AuthorizationCodeIdpApplication+--     { idpAppClientId = "xxxxx",+--       idpAppClientSecret = "xxxxx",+--       idpAppScope =+--         Set.fromList+--           [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\",+--             \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\"+--           ],+--       idpAppAuthorizeState = \"CHANGE_ME\",+--       idpAppAuthorizeExtraParams = Map.empty,+--       idpAppRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|],+--       idpAppName = "default-google-App",+--       idpAppTokenRequestAuthenticationMethod = ClientSecretBasic,+--       idp = googleIdp+--     }+-- @+--+-- Secondly, construct the authorize URL.+--+-- @+-- authorizeUrl = mkAuthorizeRequest fooApp+-- @+--+-- Thirdly, after a successful redirect with authorize code,+-- you could exchange for access token+--+-- @+-- mgr <- liftIO $ newManager tlsManagerSettings+-- tokenResp <- conduitTokenRequest fooApp mgr authorizeCode+-- @+--+-- Lastly, you probably like to fetch user info+--+-- @+-- conduitUserInfoRequest fooApp mgr (accessToken tokenResp)+-- @+--+-- Also you could find example from @hoauth2-providers-tutorials@ module.+--+module Network.OAuth2.Experiment+  ( module Network.OAuth2.Experiment.Types,+    module Network.OAuth2.Experiment.Pkce+  )+where++import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Types

@@ -0,0 +1,82 @@+module Network.OAuth2.Experiment.Pkce+  ( mkPkceParam,+    CodeChallenge (..),+    CodeVerifier (..),+    CodeChallengeMethod (..),+    PkceRequestParam (..),+  )+where++import Control.Monad.IO.Class+import Crypto.Hash qualified as H+import Crypto.Random qualified as Crypto+import Data.ByteArray qualified as ByteArray+import Data.ByteString qualified as BS+import Data.ByteString.Base64.URL qualified as B64+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Word++newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text}++newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show)++data CodeChallengeMethod = S256+  deriving (Show)++data PkceRequestParam = PkceRequestParam+  { codeVerifier :: CodeVerifier,+    codeChallenge :: CodeChallenge,+    -- | spec says optional but really it shall be s256 or can be omitted?+    -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3+    codeChallengeMethod :: CodeChallengeMethod+  }++mkPkceParam :: MonadIO m => m PkceRequestParam+mkPkceParam = do+  codeV <- genCodeVerifier+  pure+    PkceRequestParam+      { codeVerifier = CodeVerifier (T.decodeUtf8 codeV),+        codeChallenge = CodeChallenge (encodeCodeVerifier codeV),+        codeChallengeMethod = S256+      }++encodeCodeVerifier :: BS.ByteString -> Text+encodeCodeVerifier = B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256++genCodeVerifier :: MonadIO m => m BS.ByteString+genCodeVerifier = liftIO $ getBytesInternal BS.empty++cvMaxLen :: Int+cvMaxLen = 128++-- The default 'getRandomBytes' generates bytes out of unreverved characters scope.+-- code-verifier = 43*128unreserved+--   unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"+--   ALPHA = %x41-5A / %x61-7A+--   DIGIT = %x30-39+getBytesInternal :: BS.ByteString -> IO BS.ByteString+getBytesInternal ba+  | BS.length ba >= cvMaxLen = pure (BS.take cvMaxLen ba)+  | otherwise = do+      bs <- Crypto.getRandomBytes cvMaxLen+      let bsUnreserved = ba `BS.append` BS.filter isUnreversed bs+      getBytesInternal bsUnreserved++hashSHA256 :: BS.ByteString -> H.Digest H.SHA256+hashSHA256 = H.hash++isUnreversed :: Word8 -> Bool+isUnreversed w = w `BS.elem` unreverseBS++{-+a-z: 97-122+A-Z: 65-90+-: 45+.: 46+_: 95+~: 126+-}+unreverseBS :: BS.ByteString+unreverseBS = BS.pack $ [97 .. 122] ++ [65 .. 90] ++ [45, 46, 95, 126]

@@ -0,0 +1,693 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Network.OAuth2.Experiment.Types where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT)+import Data.Aeson (FromJSON)+import Data.Bifunctor+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Default (Default (def))+import Data.Kind+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String+import Data.Text.Encoding qualified as T+import Data.Text.Lazy (Text)+import Data.Text.Lazy qualified as TL+import Network.HTTP.Conduit (Manager)+import Network.OAuth.OAuth2 hiding (RefreshToken)+import Network.OAuth.OAuth2 qualified as OAuth2+import Network.OAuth.OAuth2.TokenRequest qualified as TR+import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Utils+import URI.ByteString hiding (UserInfo)++{- NOTE+  1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility?+-}++-------------------------------------------------------------------------------++-- * Grant Type++-------------------------------------------------------------------------------++data GrantTypeFlow = AuthorizationCode | ResourceOwnerPassword | ClientCredentials++-------------------------------------------------------------------------------++-- * Response Type value++-------------------------------------------------------------------------------++class ToResponseTypeValue (a :: GrantTypeFlow) where+  toResponseTypeValue :: IsString b => b++instance ToResponseTypeValue 'AuthorizationCode where+  -- https://www.rfc-editor.org/rfc/rfc6749#section-3.1.1+  -- Only support "authorization code" flow+  toResponseTypeValue :: IsString b => b+  toResponseTypeValue = "code"++toResponseTypeParam :: forall a b req. (ToResponseTypeValue a, IsString b) => req a -> Map b b+toResponseTypeParam _ = Map.singleton "response_type" (toResponseTypeValue @a)++-------------------------------------------------------------------------------++-- * Grant Type value++-------------------------------------------------------------------------------++-- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict.+--+-- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow.+data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken+  deriving (Eq, Show)++-------------------------------------------------------------------------------++-- * Scope++-------------------------------------------------------------------------------++-- TODO: following data type is not ideal as Idp would have lots of 'Custom Text'+--+-- @+-- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text+-- @+--+-- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow.+newtype Scope = Scope {unScope :: Text}+  deriving (Show, Eq, Ord)++instance IsString Scope where+  fromString :: String -> Scope+  fromString = Scope . TL.pack++-------------------------------------------------------------------------------++-- * Credentials++-------------------------------------------------------------------------------+newtype ClientId = ClientId {unClientId :: Text}+  deriving (Show, Eq, IsString)++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)++newtype AuthorizeState = AuthorizeState {unAuthorizeState :: Text}+  deriving (Eq)++instance IsString AuthorizeState where+  fromString :: String -> AuthorizeState+  fromString = AuthorizeState . TL.pack++newtype Username = Username {unUsername :: Text}+  deriving (Eq)++instance IsString Username where+  fromString :: String -> Username+  fromString = Username . TL.pack++newtype Password = Password {unPassword :: Text}+  deriving (Eq)++instance IsString Password where+  fromString :: String -> Password+  fromString = Password . TL.pack++-------------------------------------------------------------------------------++-- * Query parameters++-------------------------------------------------------------------------------+class ToQueryParam a where+  toQueryParam :: a -> Map Text Text++instance ToQueryParam a => ToQueryParam (Maybe a) where+  toQueryParam :: ToQueryParam a => Maybe a -> Map Text Text+  toQueryParam Nothing = Map.empty+  toQueryParam (Just a) = toQueryParam a++instance ToQueryParam GrantTypeValue where+  toQueryParam :: GrantTypeValue -> Map Text Text+  toQueryParam x = Map.singleton "grant_type" (val x)+    where+      val :: GrantTypeValue -> Text+      val GTAuthorizationCode = "authorization_code"+      val GTPassword = "password"+      val GTClientCredentials = "client_credentials"+      val GTRefreshToken = "refresh_token"++instance ToQueryParam ClientId where+  toQueryParam :: ClientId -> Map Text Text+  toQueryParam (ClientId i) = Map.singleton "client_id" i++instance ToQueryParam ClientSecret where+  toQueryParam :: ClientSecret -> Map Text Text+  toQueryParam (ClientSecret x) = Map.singleton "client_secret" x++instance ToQueryParam Username where+  toQueryParam :: Username -> Map Text Text+  toQueryParam (Username x) = Map.singleton "username" x++instance ToQueryParam Password where+  toQueryParam :: Password -> Map Text Text+  toQueryParam (Password x) = Map.singleton "password" x++instance ToQueryParam AuthorizeState where+  toQueryParam :: AuthorizeState -> Map Text Text+  toQueryParam (AuthorizeState x) = Map.singleton "state" x++instance ToQueryParam RedirectUri where+  toQueryParam (RedirectUri uri) = Map.singleton "redirect_uri" (bs8ToLazyText $ serializeURIRef' uri)++instance ToQueryParam (Set Scope) where+  toQueryParam :: Set Scope -> Map Text Text+  toQueryParam = toScopeParam . Set.map unScope+    where+      toScopeParam :: (IsString a) => Set Text -> Map a Text+      toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope)++instance ToQueryParam CodeVerifier where+  toQueryParam :: CodeVerifier -> Map Text Text+  toQueryParam (CodeVerifier x) = Map.singleton "code_verifier" (TL.fromStrict x)++instance ToQueryParam CodeChallenge where+  toQueryParam :: CodeChallenge -> Map Text Text+  toQueryParam (CodeChallenge x) = Map.singleton "code_challenge" (TL.fromStrict x)++instance ToQueryParam CodeChallengeMethod where+  toQueryParam :: CodeChallengeMethod -> Map Text Text+  toQueryParam x = Map.singleton "code_challenge_method" (TL.pack $ show x)++instance ToQueryParam ExchangeToken where+  toQueryParam :: ExchangeToken -> Map Text Text+  toQueryParam (ExchangeToken x) = Map.singleton "code" (TL.fromStrict x)++instance ToQueryParam OAuth2.RefreshToken where+  toQueryParam :: OAuth2.RefreshToken -> Map Text Text+  toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x)++-------------------------------------------------------------------------------++-- * Authorization and Token Requests types++-------------------------------------------------------------------------------++class HasIdpAppName (a :: GrantTypeFlow) where+  getIdpAppName :: IdpApplication a i -> Text++class HasAuthorizeRequest (a :: GrantTypeFlow) where+  data AuthorizationRequest a+  type MkAuthorizationRequestResponse a+  mkAuthorizeRequestParameter :: IdpApplication a i -> AuthorizationRequest a+  mkAuthorizeRequest :: IdpApplication a i -> MkAuthorizationRequestResponse a++class HasTokenRequest (a :: GrantTypeFlow) where+  -- | Each GrantTypeFlow has slightly different request parameter to /token endpoint.+  data TokenRequest a++  -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request+  -- create type family to be explicit on it.+  -- with 'type instance WithExchangeToken a b = b' implies no exchange token+  -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token+  type WithExchangeToken a b++  mkTokenRequest ::+    IdpApplication a i ->+    WithExchangeToken a (TokenRequest a)++  conduitTokenRequest ::+    (MonadIO m) =>+    IdpApplication a i ->+    Manager ->+    WithExchangeToken a (ExceptT (OAuth2Error TR.Errors) m OAuth2Token)++class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where+  mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier)++class HasPkceTokenRequest (b :: GrantTypeFlow) where+  conduitPkceTokenRequest ::+    (MonadIO m) =>+    IdpApplication b i ->+    Manager ->+    (ExchangeToken, CodeVerifier) ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token++class HasRefreshTokenRequest (a :: GrantTypeFlow) where+  -- | https://www.rfc-editor.org/rfc/rfc6749#page-47+  data RefreshTokenRequest a++  mkRefreshTokenRequest :: IdpApplication a i -> OAuth2.RefreshToken -> RefreshTokenRequest a+  conduitRefreshTokenRequest ::+    (MonadIO m) =>+    IdpApplication a i ->+    Manager ->+    OAuth2.RefreshToken ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token++-------------------------------------------------------------------------------++-- * User Info types++-------------------------------------------------------------------------------++type family IdpUserInfo a++class HasUserInfoRequest (a :: GrantTypeFlow) where+  conduitUserInfoRequest ::+    FromJSON (IdpUserInfo i) =>+    IdpApplication a i ->+    Manager ->+    AccessToken ->+    ExceptT BSL.ByteString IO (IdpUserInfo i)++-------------------------------------------------------------------------------++-- * Idp App++-------------------------------------------------------------------------------++-- | Shall IdpApplication has a field of 'Idp a'??+data Idp a = Idp+  { idpUserInfoEndpoint :: URI,+    -- NOTE: maybe worth data type to distinguish authorize and token endpoint+    -- as I made mistake at passing to Authorize and Token Request+    idpAuthorizeEndpoint :: URI,+    idpTokenEndpoint :: URI,+    idpFetchUserInfo ::+      forall m.+      (FromJSON (IdpUserInfo a), MonadIO m) =>+      Manager ->+      AccessToken ->+      URI ->+      ExceptT BSL.ByteString m (IdpUserInfo a)+  }++-------------------------------------------------------------------------------++-- * Idp App Config++-------------------------------------------------------------------------------++data family IdpApplication (a :: GrantTypeFlow) (i :: Type)++-------------------------------------------------------------------------------++-- * Authorization Code flow++-------------------------------------------------------------------------------++-- | An Application that supports "Authorization code" flow+data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication+  { idpAppName :: Text,+    idpAppClientId :: ClientId,+    idpAppClientSecret :: ClientSecret,+    idpAppScope :: Set Scope,+    idpAppRedirectUri :: URI,+    idpAppAuthorizeState :: AuthorizeState,+    -- | Though technically one key can have multiple value in query, but who actually does it?!+    idpAppAuthorizeExtraParams :: Map Text Text,+    idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod,+    idp :: Idp i+  }++-- NOTE: maybe add function for parase authorization response+-- though seems overkill. https://github.com/freizl/hoauth2/issues/149+-- parseAuthorizationResponse :: String -> AuthorizationResponse+-- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse++instance HasIdpAppName 'AuthorizationCode where+  getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text+  getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName++instance HasAuthorizeRequest 'AuthorizationCode where+  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1+  data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest+    { scope :: Set Scope,+      state :: AuthorizeState,+      clientId :: ClientId,+      redirectUri :: Maybe RedirectUri+    }+  type MkAuthorizationRequestResponse 'AuthorizationCode = Text++  mkAuthorizeRequestParameter :: IdpApplication 'AuthorizationCode i -> AuthorizationRequest 'AuthorizationCode+  mkAuthorizeRequestParameter AuthorizationCodeIdpApplication {..} =+    AuthorizationCodeAuthorizationRequest+      { scope = if null idpAppScope then Set.empty else idpAppScope,+        state = idpAppAuthorizeState,+        clientId = idpAppClientId,+        redirectUri = Just (RedirectUri idpAppRedirectUri)+      }++  mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text+  mkAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} =+    let req = mkAuthorizeRequestParameter idpAppConfig+        allParams =+          map (bimap tlToBS tlToBS) $+            Map.toList $+              Map.unions [idpAppAuthorizeExtraParams, toQueryParam req]+     in TL.fromStrict $+          T.decodeUtf8 $+            serializeURIRef' $+              appendQueryParams allParams $+                idpAuthorizeEndpoint idp++instance HasTokenRequest 'AuthorizationCode where+  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3+  data TokenRequest 'AuthorizationCode = AuthorizationCodeTokenRequest+    { code :: ExchangeToken,+      clientId :: ClientId,+      grantType :: GrantTypeValue,+      redirectUri :: RedirectUri+    }+  type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a++  mkTokenRequest ::+    IdpApplication 'AuthorizationCode i ->+    ExchangeToken ->+    TokenRequest 'AuthorizationCode+  mkTokenRequest AuthorizationCodeIdpApplication {..} authCode =+    AuthorizationCodeTokenRequest+      { code = authCode,+        clientId = idpAppClientId,+        grantType = GTAuthorizationCode,+        redirectUri = RedirectUri idpAppRedirectUri+      }+  conduitTokenRequest ::+    forall m i.+    (MonadIO m) =>+    IdpApplication 'AuthorizationCode i ->+    Manager ->+    ExchangeToken ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+  conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken =+    let req = mkTokenRequest idpAppConfig exchangeToken+        key = toOAuth2Key idpAppClientId idpAppClientSecret+        body =+          mapsToParams+            [ toQueryParam req,+              toQueryParam+                ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost+                    then Just idpAppClientSecret+                    else Nothing+                )+            ]+     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body++instance HasPkceAuthorizeRequest 'AuthorizationCode where+  mkPkceAuthorizeRequest :: MonadIO m => IdpApplication 'AuthorizationCode i -> m (Text, CodeVerifier)+  mkPkceAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = do+    PkceRequestParam {..} <- mkPkceParam+    let req = mkAuthorizeRequestParameter idpAppConfig+    let allParams =+          mapsToParams+            [ idpAppAuthorizeExtraParams,+              toQueryParam req,+              toQueryParam codeChallenge,+              toQueryParam codeChallengeMethod+            ]++    let url =+          TL.fromStrict $+            T.decodeUtf8 $+              serializeURIRef' $+                appendQueryParams allParams $+                  idpAuthorizeEndpoint idp+    pure (url, codeVerifier)++instance HasPkceTokenRequest 'AuthorizationCode where+  conduitPkceTokenRequest ::+    MonadIO m =>+    IdpApplication 'AuthorizationCode i ->+    Manager ->+    (ExchangeToken, CodeVerifier) ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+  conduitPkceTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr (exchangeToken, codeVerifier) =+    let req = mkTokenRequest idpAppConfig exchangeToken+        key = toOAuth2Key idpAppClientId idpAppClientSecret+        body =+          mapsToParams+            [ toQueryParam req,+              toQueryParam codeVerifier,+              toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing)+            ]+     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body++instance HasRefreshTokenRequest 'AuthorizationCode where+  data RefreshTokenRequest 'AuthorizationCode = AuthorizationCodeTokenRefreshRequest+    { refreshToken :: OAuth2.RefreshToken,+      grantType :: GrantTypeValue,+      scope :: Set Scope+    }++  mkRefreshTokenRequest :: IdpApplication 'AuthorizationCode i -> OAuth2.RefreshToken -> RefreshTokenRequest 'AuthorizationCode+  mkRefreshTokenRequest AuthorizationCodeIdpApplication {..} rt =+    AuthorizationCodeTokenRefreshRequest+      { scope = idpAppScope,+        grantType = GTRefreshToken,+        refreshToken = rt+      }+  conduitRefreshTokenRequest ::+    (MonadIO m) =>+    IdpApplication 'AuthorizationCode i ->+    Manager ->+    OAuth2.RefreshToken ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+  conduitRefreshTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr rt =+    let req = mkRefreshTokenRequest idpAppConfig rt+        key = toOAuth2Key idpAppClientId idpAppClientSecret+        body =+          mapsToParams+            [ toQueryParam req,+              toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing)+            ]+     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body++instance HasUserInfoRequest 'AuthorizationCode where+  conduitUserInfoRequest ::+    FromJSON (IdpUserInfo i) =>+    IdpApplication 'AuthorizationCode i ->+    Manager ->+    AccessToken ->+    ExceptT BSL.ByteString IO (IdpUserInfo i)+  conduitUserInfoRequest AuthorizationCodeIdpApplication {..} mgr at = do+    idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp)++instance ToQueryParam (AuthorizationRequest 'AuthorizationCode) where+  toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text+  toQueryParam req@AuthorizationCodeAuthorizationRequest {..} =+    Map.unions+      [ toResponseTypeParam req,+        toQueryParam scope,+        toQueryParam clientId,+        toQueryParam state,+        toQueryParam redirectUri+      ]++instance ToQueryParam (TokenRequest 'AuthorizationCode) where+  toQueryParam :: TokenRequest 'AuthorizationCode -> Map Text Text+  toQueryParam AuthorizationCodeTokenRequest {..} =+    Map.unions+      [ toQueryParam grantType,+        toQueryParam code,+        toQueryParam redirectUri+      ]++instance ToQueryParam (RefreshTokenRequest 'AuthorizationCode) where+  toQueryParam :: RefreshTokenRequest 'AuthorizationCode -> Map Text Text+  toQueryParam AuthorizationCodeTokenRefreshRequest {..} =+    Map.unions+      [ toQueryParam grantType,+        toQueryParam scope,+        toQueryParam refreshToken+      ]++-------------------------------------------------------------------------------++-- * Password flow++-------------------------------------------------------------------------------++-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3.1+-- 4.3.1.  Authorization Request and Response (Password grant type)+-- The method through which the client obtains the resource owner+-- credentials is beyond the scope of this specification.  The client+-- MUST discard the credentials once an access token has been obtained.+--+-- Hence no AuhorizationRequest instance++data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPAppConfig+  { idpAppClientId :: ClientId,+    idpAppClientSecret :: ClientSecret,+    idpAppName :: Text,+    idpAppScope :: Set Scope,+    idpAppUserName :: Username,+    idpAppPassword :: Password,+    -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec+    idpAppTokenRequestExtraParams :: Map Text Text,+    idp :: Idp i+  }++instance HasIdpAppName 'ResourceOwnerPassword where+  getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text+  getIdpAppName ResourceOwnerPasswordIDPAppConfig {..} = idpAppName++instance HasUserInfoRequest 'ResourceOwnerPassword where+  conduitUserInfoRequest ResourceOwnerPasswordIDPAppConfig {..} mgr at = do+    idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp)++instance HasTokenRequest 'ResourceOwnerPassword where+  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2+  data TokenRequest 'ResourceOwnerPassword = PasswordTokenRequest+    { scope :: Set Scope,+      username :: Username,+      password :: Password,+      grantType :: GrantTypeValue+    }+  type WithExchangeToken 'ResourceOwnerPassword a = a++  mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword+  mkTokenRequest ResourceOwnerPasswordIDPAppConfig {..} =+    PasswordTokenRequest+      { username = idpAppUserName,+        password = idpAppPassword,+        grantType = GTPassword,+        scope = idpAppScope+      }++  conduitTokenRequest ::+    (MonadIO m) =>+    IdpApplication 'ResourceOwnerPassword i ->+    Manager ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+  conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPAppConfig {..} mgr =+    let req = mkTokenRequest idpAppConfig+        key = toOAuth2Key idpAppClientId idpAppClientSecret+        body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req]+     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body++-- | TODO: TBD+instance HasRefreshTokenRequest 'ResourceOwnerPassword where+  data RefreshTokenRequest 'ResourceOwnerPassword = PasswordRefreshTokenRequest++  mkRefreshTokenRequest ::+    IdpApplication 'ResourceOwnerPassword i ->+    OAuth2.RefreshToken ->+    RefreshTokenRequest 'ResourceOwnerPassword+  mkRefreshTokenRequest = undefined++  conduitRefreshTokenRequest ::+    MonadIO m =>+    IdpApplication 'ResourceOwnerPassword i ->+    Manager ->+    OAuth2.RefreshToken ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+  conduitRefreshTokenRequest = undefined++instance ToQueryParam (TokenRequest 'ResourceOwnerPassword) where+  toQueryParam :: TokenRequest 'ResourceOwnerPassword -> Map Text Text+  toQueryParam PasswordTokenRequest {..} =+    Map.unions+      [ toQueryParam grantType,+        toQueryParam scope,+        toQueryParam username,+        toQueryParam password+      ]++-------------------------------------------------------------------------------++-- * Client Credentials flow++-------------------------------------------------------------------------------++-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4.1+-- 4.4.1.  Authorization Request and Response (Client Credentials grant type)+-- Since the client authentication is used as the authorization grant,+-- no additional authorization request is needed.+--+-- Hence no AuhorizationRequest instance++data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPAppConfig+  { idpAppClientId :: ClientId,+    idpAppClientSecret :: ClientSecret,+    idpAppName :: Text,+    idpAppScope :: Set Scope,+    -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec+    idpAppTokenRequestExtraParams :: Map Text Text,+    idp :: Idp i+  }++instance HasIdpAppName 'ClientCredentials where+  getIdpAppName :: IdpApplication 'ClientCredentials i -> Text+  getIdpAppName ClientCredentialsIDPAppConfig {..} = idpAppName++instance HasTokenRequest 'ClientCredentials where+  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2+  data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest+    { scope :: Set Scope,+      grantType :: GrantTypeValue+    }++  type WithExchangeToken 'ClientCredentials a = a++  mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials+  mkTokenRequest ClientCredentialsIDPAppConfig {..} =+    ClientCredentialsTokenRequest+      { scope = idpAppScope,+        grantType = GTClientCredentials+      }++  conduitTokenRequest ::+    (MonadIO m) =>+    IdpApplication 'ClientCredentials i ->+    Manager ->+    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+  conduitTokenRequest idpAppConfig@ClientCredentialsIDPAppConfig {..} mgr =+    let req = mkTokenRequest idpAppConfig+        key =+          toOAuth2Key+            idpAppClientId+            idpAppClientSecret+        body =+          mapsToParams+            [ idpAppTokenRequestExtraParams,+              toQueryParam req+            ]+     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body++instance ToQueryParam (TokenRequest 'ClientCredentials) where+  toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text+  toQueryParam ClientCredentialsTokenRequest {..} =+    Map.unions+      [ toQueryParam grantType,+        toQueryParam scope+      ]

@@ -0,0 +1,21 @@+module Network.OAuth2.Experiment.Utils where++import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text.Encoding qualified as TE+import Data.Text.Lazy qualified as TL++tlToBS :: TL.Text -> ByteString+tlToBS = TE.encodeUtf8 . TL.toStrict++bs8ToLazyText :: BS8.ByteString -> TL.Text+bs8ToLazyText = TL.pack . BS8.unpack++mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)]+mapsToParams =+  map (bimap tlToBS tlToBS)+    . Map.toList+    . Map.unions