hoauth2 2.8.1 → 2.9.0

raw patch · 23 files changed

+1250/−787 lines, 23 filesdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• hoauth2.cabal +29/−11
• src/Network/HTTP/Client/Contrib.hs +25/−0
• src/Network/OAuth/OAuth2.hs +12/−3
• src/Network/OAuth/OAuth2/AuthorizationRequest.hs +33/−10
• src/Network/OAuth/OAuth2/HttpClient.hs +22/−35
• src/Network/OAuth/OAuth2/Internal.hs +31/−30
• src/Network/OAuth/OAuth2/TokenRequest.hs +62/−54
• src/Network/OAuth2/Experiment.hs +97/−34
• src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs +78/−0
• src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs +100/−0
• src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs +53/−0
• src/Network/OAuth2/Experiment/Flows/TokenRequest.hs +83/−0
• src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs +44/−0
• src/Network/OAuth2/Experiment/Grants.hs +16/−0
• src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs +102/−0
• src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs +75/−0
• src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs +140/−0
• src/Network/OAuth2/Experiment/Grants/JwtBearer.hs +59/−0
• src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs +78/−0
• src/Network/OAuth2/Experiment/Pkce.hs +2/−2
• src/Network/OAuth2/Experiment/Types.hs +66/−604
• src/Network/OAuth2/Experiment/Utils.hs +8/−2
• test/Network/OAuth/OAuth2/TokenRequestSpec.hs +35/−2

@@ -2,9 +2,11 @@ name:               hoauth2  -- http://wiki.haskell.org/Package_versioning_policy-version:            2.8.1+version:            2.9.0 synopsis:           Haskell OAuth2 authentication client-description:        See readme for more details.+description:+  This is Haskell binding of OAuth2 Authorization framework and Bearer Token Usage framework.+ homepage:           https://github.com/freizl/hoauth2 license:            MIT license-file:       LICENSE@@ -26,9 +28,9 @@   default-language:   Haskell2010   autogen-modules:    Paths_hoauth2   other-modules:+    Network.HTTP.Client.Contrib     Network.OAuth.OAuth2.Internal-    Network.OAuth2.Experiment.Pkce-    Network.OAuth2.Experiment.Types+    Network.OAuth2.Experiment.Grants     Network.OAuth2.Experiment.Utils     Paths_hoauth2 @@ -38,15 +40,27 @@     Network.OAuth.OAuth2.HttpClient     Network.OAuth.OAuth2.TokenRequest     Network.OAuth2.Experiment+    Network.OAuth2.Experiment.Grants.AuthorizationCode+    Network.OAuth2.Experiment.Grants.ClientCredentials+    Network.OAuth2.Experiment.Grants.DeviceAuthorization+    Network.OAuth2.Experiment.Grants.JwtBearer+    Network.OAuth2.Experiment.Grants.ResourceOwnerPassword+    Network.OAuth2.Experiment.Flows.AuthorizationRequest+    Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest+    Network.OAuth2.Experiment.Flows.RefreshTokenRequest+    Network.OAuth2.Experiment.Flows.TokenRequest+    Network.OAuth2.Experiment.Flows.UserInfoRequest+    Network.OAuth2.Experiment.Types+    Network.OAuth2.Experiment.Pkce    default-extensions:-    DataKinds     DeriveGeneric     GeneralizedNewtypeDeriving     ImportQualifiedPost+    InstanceSigs     OverloadedStrings+    PolyKinds     RecordWildCards-    TypeApplications     TypeFamilies    build-depends:@@ -64,13 +78,13 @@     , memory                ^>=0.18     , microlens             ^>=0.4.0     , text                  ^>=2.0-    , transformers          >=0.6+    , transformers          >=0.4    && <0.7     , uri-bytestring        >=0.2.3  && <0.4     , uri-bytestring-aeson  ^>=0.1    ghc-options:     -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields-    -Wwarnings-deprecations+    -Wwarn -Wwarnings-deprecations  test-suite hoauth-tests   type:               exitcode-stdio-1.0@@ -78,10 +92,11 @@   hs-source-dirs:     test   ghc-options:        -Wall   build-depends:-    , aeson    >=2.0 && <2.2-    , base     >=4   && <5+    , aeson           >=2.0   && <2.2+    , base            >=4     && <5     , hoauth2-    , hspec    >=2   && <3+    , hspec           >=2     && <3+    , uri-bytestring  >=0.2.3 && <0.4    other-modules:      Network.OAuth.OAuth2.TokenRequestSpec   default-language:   Haskell2010@@ -90,3 +105,6 @@     OverloadedStrings    build-tool-depends: hspec-discover:hspec-discover >=2 && <3+  ghc-options:+    -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields+    -Wwarn -Wwarnings-deprecations

@@ -0,0 +1,25 @@+module Network.HTTP.Client.Contrib where++import Data.Aeson+import Data.Bifunctor+import Data.ByteString.Lazy.Char8 qualified as BSL+import Network.HTTP.Conduit+import Network.HTTP.Types qualified as HT++-- | Get response body out of a @Response@+handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString+handleResponse rsp+  | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp)+  -- TODO: better to surface up entire resp so that client can decide what to do when error happens.+  -- e.g. when 404, the response body could be empty hence library user has no idea what's happening.+  -- Which will be breaking changes.+  -- The current work around is surface up entire response as string.+  | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp)+  | otherwise = Left (responseBody rsp)++handleResponseJSON ::+  FromJSON a =>+  Response BSL.ByteString ->+  Either BSL.ByteString a+handleResponseJSON =+  either Left (first BSL.pack . eitherDecode) . handleResponse

@@ -1,17 +1,26 @@ -- | A lightweight oauth2 Haskell binding. -- See Readme for more details module Network.OAuth.OAuth2 (-  module Network.OAuth.OAuth2.HttpClient,+  module Network.OAuth.OAuth2.Internal,++  -- * Authorization Requset   module Network.OAuth.OAuth2.AuthorizationRequest,++  -- * Token Request   module Network.OAuth.OAuth2.TokenRequest,-  module Network.OAuth.OAuth2.Internal,++  -- * 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 (Errors (..))+import Network.OAuth.OAuth2.AuthorizationRequest hiding (+  AuthorizationResponseError (..),+  AuthorizationResponseErrorCode (..),+ ) import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2.Internal import Network.OAuth.OAuth2.TokenRequest

@@ -1,6 +1,3 @@-{-# 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@@ -8,28 +5,34 @@ 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 GHC.Generics (Generic) import Lens.Micro (over) import Network.OAuth.OAuth2.Internal import URI.ByteString+import Prelude hiding (error)  -------------------------------------------------- --- * Errors+-- * Authorization Request Errors  -------------------------------------------------- -instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_'}- -- | 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 Errors+data AuthorizationResponseError = AuthorizationResponseError+  { authorizationResponseError :: AuthorizationResponseErrorCode+  , authorizationResponseErrorDescription :: Maybe Text+  , authorizationResponseErrorUri :: Maybe (URIRef Absolute)+  }+  deriving (Show, Eq)++data AuthorizationResponseErrorCode   = InvalidRequest   | UnauthorizedClient   | AccessDenied@@ -37,7 +40,27 @@   | InvalidScope   | ServerError   | TemporarilyUnavailable-  deriving (Show, Eq, Generic)+  | 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 {..}  -------------------------------------------------- 

@@ -1,7 +1,3 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}- -- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage -- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750> module Network.OAuth.OAuth2.HttpClient (@@ -34,6 +30,7 @@ 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@@ -50,7 +47,7 @@ -- | Conduct an authorized GET request and return response as JSON. --   Inject Access Token to Authorization Header. authGetJSON ::-  (FromJSON a, MonadIO m) =>+  (MonadIO m, FromJSON a) =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -59,8 +56,9 @@   ExceptT BSL.ByteString m a authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader +-- | Deprecated. Use `authGetJSONWithAuthMethod` instead. authGetJSONInternal ::-  (FromJSON a, MonadIO m) =>+  (MonadIO m, FromJSON a) =>   APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -91,7 +89,7 @@ -- | Conduct an authorized GET request. --   Inject Access Token to Authorization Header. authGetBS ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -102,7 +100,7 @@  -- | Same to 'authGetBS' but set access token to query parameter rather than header authGetBS2 ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -113,7 +111,7 @@ {-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-}  authGetBSInternal ::-  (MonadIO m) =>+  MonadIO m =>   APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -129,7 +127,7 @@ -- -- @since 2.6.0 authGetBSWithAuthMethod ::-  (MonadIO m) =>+  MonadIO m =>   -- | Specify the way that how to append the 'AccessToken' in the request   APIAuthenticationMethod ->   -- | HTTP connection manager.@@ -149,7 +147,7 @@ -- | Conduct POST request and return response as JSON. --   Inject Access Token to Authorization Header. authPostJSON ::-  (FromJSON a, MonadIO m) =>+  (MonadIO m, FromJSON a) =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -160,7 +158,7 @@ authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader  authPostJSONInternal ::-  (FromJSON a, MonadIO m) =>+  (MonadIO m, FromJSON a) =>   APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -177,7 +175,7 @@ -- -- @since 2.6.0 authPostJSONWithAuthMethod ::-  (FromJSON a, MonadIO m) =>+  (MonadIO m, FromJSON a) =>   APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -193,7 +191,7 @@ -- | Conduct POST request. --   Inject Access Token to http header (Authorization) authPostBS ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -205,7 +203,7 @@  -- | Conduct POST request with access token only in the request body but header. authPostBS2 ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -218,7 +216,7 @@  -- | Conduct POST request with access token only in the header and not in body authPostBS3 ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   AccessToken ->@@ -230,7 +228,7 @@ {-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-}  authPostBSInternal ::-  (MonadIO m) =>+  MonadIO m =>   APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -247,7 +245,7 @@ -- -- @since 2.6.0 authPostBSWithAuthMethod ::-  (MonadIO m) =>+  MonadIO m =>   APIAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -293,7 +291,7 @@  -- | Send an HTTP request. authRequest ::-  (MonadIO m) =>+  MonadIO m =>   -- | Request to perform   Request ->   -- | Modify request before sending@@ -305,21 +303,10 @@   resp <- httpLbs (upReq req) manage   pure (handleResponse resp) --- | Get response body out of a @Response@-handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString-handleResponse rsp-  | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp)-  -- FIXME: better to surface up entire resp so that client can decide what to do when error happens.-  -- e.g. when 404, the response body could be empty hence library user has no idea what's happening.-  -- Which will be breaking changes.-  -- The current work around is surface up entire response as string.-  | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp)-  | otherwise = Left (responseBody rsp)- -- | Set several header values:---   + userAgennt    : `hoauth2`---   + accept        : `application/json`---   + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided.+--   + 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]@@ -330,7 +317,7 @@ setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req {method = HT.renderStdMethod m} --- | For `GET` method API.+-- | For @GET@ method API. appendAccessToken ::   -- | Base URI   URIRef a ->@@ -340,6 +327,6 @@   URIRef a appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri --- | Create 'QueryParams' with given access token value.+-- | Create `QueryParams` with given access token value. accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)]

@@ -1,8 +1,4 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}  module Network.OAuth.OAuth2.Internal where @@ -28,11 +24,11 @@ import URI.ByteString.Aeson () import URI.ByteString.QQ ---------------------------------------------------+------------------------------------------------------------------------------- --- * Data Types+-- * OAuth2 Configuration ---------------------------------------------------+-------------------------------------------------------------------------------  -- | Query Parameter Representation data OAuth2 = OAuth2@@ -54,6 +50,12 @@       , 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)@@ -63,16 +65,18 @@ -- | 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 'authorizeUrl' and the provider supports Refresh Access Token.+  -- ^ 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 'authorizeUrl' and the provider supports OpenID.+  -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.   }   deriving (Eq, Show, Generic) @@ -82,15 +86,11 @@ 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@@ -100,6 +100,12 @@   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: --@@ -107,33 +113,28 @@ -- -- Which means use Authorization header or Post body. ----- However, in reality, I always have to include authentication in the header.+-- However, I found I have to include authentication in the header all the time in real world. ----- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional.+-- 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, Ord)+  deriving (Eq) ---------------------------------------------------+------------------------------------------------------------------------------- --- * Types Synonym+-- * Utilies for Request and URI ---------------------------------------------------+------------------------------------------------------------------------------- --- | type synonym of post body content+-- | Type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)] +-- | Type sysnonym of request query params type QueryParams = [(BS.ByteString, BS.ByteString)]-------------------------------------------------------- * Utilies----------------------------------------------------  defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] defaultRequestHeaders =

@@ -1,5 +1,3 @@-{-# 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@@ -13,12 +11,12 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T-import GHC.Generics (Generic) 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)  -------------------------------------------------- @@ -26,15 +24,15 @@  -------------------------------------------------- -data TokenRequestError = TokenRequestError-  { error :: TokenRequestErrorCode-  , errorDescription :: Maybe Text-  , errorUri :: Maybe (URIRef Absolute)+data TokenResponseError = TokenResponseError+  { tokenResponseError :: TokenResponseErrorCode+  , tokenResponseErrorDescription :: Maybe Text+  , tokenResponseErrorUri :: Maybe (URIRef Absolute)   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq)  -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2-data TokenRequestErrorCode+data TokenResponseErrorCode   = InvalidRequest   | InvalidClient   | InvalidGrant@@ -44,8 +42,8 @@   | UnknownErrorCode Text   deriving (Show, Eq) -instance FromJSON TokenRequestErrorCode where-  parseJSON = withText "parseJSON TokenRequestErrorCode" $ \t ->+instance FromJSON TokenResponseErrorCode where+  parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t ->     pure $ case t of       "invalid_request" -> InvalidRequest       "invalid_client" -> InvalidClient@@ -55,18 +53,22 @@       "invalid_scope" -> InvalidScope       _ -> UnknownErrorCode t -instance FromJSON TokenRequestError where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_'}+instance FromJSON TokenResponseError where+  parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do+    tokenResponseError <- t .: "error"+    tokenResponseErrorDescription <- t .:? "error_description"+    tokenResponseErrorUri <- t .:? "error_uri"+    pure TokenResponseError {..} -parseTokeRequestError :: BSL.ByteString -> TokenRequestError-parseTokeRequestError string =+parseTokeResponseError :: BSL.ByteString -> TokenResponseError+parseTokeResponseError string =   either (mkDecodeOAuth2Error string) id (eitherDecode string)   where-    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenRequestError+    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError     mkDecodeOAuth2Error response err =-      TokenRequestError+      TokenResponseError         (UnknownErrorCode "")-        (Just $ T.pack $ "Decode TokenRequestError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response))+        (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response))         Nothing  --------------------------------------------------@@ -114,7 +116,7 @@  -- | Exchange @code@ for an Access Token with authenticate in request header. fetchAccessToken ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager   Manager ->   -- | OAuth Data@@ -122,11 +124,11 @@   -- | OAuth2 Code   ExchangeToken ->   -- | Access Token-  ExceptT TokenRequestError m OAuth2Token+  ExceptT TokenResponseError m OAuth2Token fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic  fetchAccessToken2 ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager   Manager ->   -- | OAuth Data@@ -134,12 +136,12 @@   -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT TokenRequestError m OAuth2Token+  ExceptT TokenResponseError m OAuth2Token fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-}  fetchAccessTokenInternal ::-  (MonadIO m) =>+  MonadIO m =>   ClientAuthenticationMethod ->   -- | HTTP connection manager   Manager ->@@ -148,24 +150,24 @@   -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT TokenRequestError m OAuth2Token+  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').+-- 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+-- If you`re uncertain, try `fetchAccessToken` which sends credential -- in authorization http header, which is common case. -- -- @since 2.6.0 fetchAccessTokenWithAuthMethod ::-  (MonadIO m) =>+  MonadIO m =>   ClientAuthenticationMethod ->   -- | HTTP connection manager   Manager ->@@ -174,7 +176,7 @@   -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT TokenRequestError m OAuth2Token+  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 []@@ -182,30 +184,30 @@  -- | Fetch a new AccessToken using the Refresh Token with authentication in request header. refreshAccessToken ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   -- | OAuth context   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT TokenRequestError m OAuth2Token+  ExceptT TokenResponseError m OAuth2Token refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic  refreshAccessToken2 ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   -- | OAuth context   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT TokenRequestError m OAuth2Token+  ExceptT TokenResponseError m OAuth2Token refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-}  refreshAccessTokenInternal ::-  (MonadIO m) =>+  MonadIO m =>   ClientAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -213,13 +215,13 @@   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT TokenRequestError m OAuth2Token+  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+-- 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'). --@@ -230,7 +232,7 @@ -- -- @since 2.6.0 refreshAccessTokenWithAuthMethod ::-  (MonadIO m) =>+  MonadIO m =>   ClientAuthenticationMethod ->   -- | HTTP connection manager.   Manager ->@@ -238,7 +240,7 @@   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT TokenRequestError m OAuth2Token+  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 []@@ -262,7 +264,7 @@   -- | request body   PostBody ->   -- | Response as JSON-  ExceptT TokenRequestError m a+  ExceptT TokenResponseError m a doJSONPostRequest manager oa uri body = do   resp <- doSimplePostRequest manager oa uri body   case parseResponseFlexible resp of@@ -271,7 +273,7 @@  -- | Conduct post request. doSimplePostRequest ::-  (MonadIO m) =>+  MonadIO m =>   -- | HTTP connection manager.   Manager ->   -- | OAuth options@@ -281,37 +283,36 @@   -- | Request body.   PostBody ->   -- | Response as ByteString-  ExceptT TokenRequestError m BSL.ByteString+  ExceptT TokenResponseError m BSL.ByteString doSimplePostRequest manager oa url body =   ExceptT . liftIO $ fmap handleOAuth2TokenResponse go   where-    addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa)     go = do       req <- uriToRequest url-      let req' = (addBasicAuth . addDefaultRequestHeaders) req+      let req' = (addBasicAuth oa . addDefaultRequestHeaders) req       httpLbs (urlEncodedBody body req') manager --- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error'-handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenRequestError BSL.ByteString+-- | 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 $ parseTokeRequestError (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) =>+  FromJSON a =>   BSL.ByteString ->-  Either TokenRequestError a+  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) =>+  FromJSON a =>   BSL.ByteString ->-  Either TokenRequestError a+  Either TokenResponseError a parseResponseString b = case parseQuery $ BSL.toStrict b of   [] -> Left errorMessage   a -> case fromJSON $ queryToValue a of@@ -320,11 +321,18 @@   where     queryToValue = Object . KeyMap.fromList . map paramToPair     paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = parseTokeRequestError b+    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`+--   + userAgennt    : "hoauth2"+--   + accept        : "application/json" addDefaultRequestHeaders :: Request -> Request addDefaultRequestHeaders req =   let headers = defaultRequestHeaders ++ requestHeaders req

@@ -1,17 +1,9 @@-{-# 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).+-- This module will become default in future release. ----- The key concept/change is to introduce the 'GrantTypeFlow', which determines the entire work flow per spec.+-- 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. --@@ -30,48 +22,53 @@ -- 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.+-- given it is deprecated 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. -- -- @--- {\-# LANGUAGE DataKinds #-\} --+-- import Network.OAuth2.Experiment+-- import URI.ByteString.QQ+-- -- data Google = Google deriving (Eq, Show)+-- -- googleIdp :: Idp Google -- googleIdp = --   Idp---     { idpFetchUserInfo = authGetJSON @(IdpUserInfo Google),---       idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|],---       idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|],---       idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|]+--     { idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|]+--     , idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|]+--     , idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|]+--     , idpDeviceAuthorizationEndpoint = Just [uri|https:\/\/oauth2.googleapis.com\/device\/code|] --     } ----- fooApp :: IdpApplication 'AuthorizationCode Google+-- fooApp :: AuthorizationCodeApplication -- fooApp =---   AuthorizationCodeIdpApplication---     { idpAppClientId = "xxxxx",---       idpAppClientSecret = "xxxxx",---       idpAppScope =+--   AuthorizationCodeApplication+--     { acClientId = "xxxxx",+--       acClientSecret = "xxxxx",+--       acScope = --         Set.fromList --           [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\", --             \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\" --           ],---       idpAppAuthorizeState = \"CHANGE_ME\",---       idpAppAuthorizeExtraParams = Map.empty,---       idpAppRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|],---       idpAppName = "default-google-App",---       idpAppTokenRequestAuthenticationMethod = ClientSecretBasic,---       idp = googleIdp+--       acAuthorizeState = \"CHANGE_ME\",+--       acAuthorizeRequestExtraParams = Map.empty,+--       acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|],+--       acName = "sample-google-authorization-code-app",+--       acTokenRequestAuthenticationMethod = ClientSecretBasic, --     }+--+-- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google+-- fooIdpApplication = IdpApplication fooApp googleIdp -- @ -- -- Secondly, construct the authorize URL. -- -- @--- authorizeUrl = mkAuthorizeRequest fooApp+-- authorizeUrl = mkAuthorizationRequest fooIdpApplication -- @ -- -- Thirdly, after a successful redirect with authorize code,@@ -79,20 +76,86 @@ -- -- @ -- mgr <- liftIO $ newManager tlsManagerSettings--- tokenResp <- conduitTokenRequest fooApp mgr authorizeCode+-- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode -- @ ----- Lastly, you probably like to fetch user info+-- If you'd like to fetch user info, uses this method -- -- @--- conduitUserInfoRequest fooApp mgr (accessToken tokenResp)+-- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp) -- @ ----- Also you could find example from @hoauth2-providers-tutorials@ module.+-- You could also find example from @hoauth2-providers-tutorials@ module. module Network.OAuth2.Experiment (+  -- * Application per Grant type+  module Network.OAuth2.Experiment.Grants,++  -- * Authorization Code+  module Network.OAuth2.Experiment.Flows.AuthorizationRequest,++  -- * Device Authorization+  module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest,++  -- * Token Request+  module Network.OAuth2.Experiment.Flows.TokenRequest,++  -- * Refresh Token Request+  module Network.OAuth2.Experiment.Flows.RefreshTokenRequest,++  -- * UserInfo Request+  module Network.OAuth2.Experiment.Flows.UserInfoRequest,++  -- * Types   module Network.OAuth2.Experiment.Types,   module Network.OAuth2.Experiment.Pkce,+  module Network.OAuth.OAuth2,++  -- * Utils+  module Network.OAuth2.Experiment.Utils, ) where -import Network.OAuth2.Experiment.Pkce-import Network.OAuth2.Experiment.Types+import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2.Experiment.Flows.AuthorizationRequest (+  HasAuthorizeRequest,+  mkAuthorizationRequest,+  mkPkceAuthorizeRequest,+ )+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 (+  CodeVerifier (..),+ )+import Network.OAuth2.Experiment.Types (+  AuthorizeState (..),+  ClientId (..),+  ClientSecret (..),+  HasOAuth2Key,+  Idp (..),+  IdpApplication (..),+  Password (..),+  RedirectUri (..),+  Scope (..),+  Username (..),+ )+import Network.OAuth2.Experiment.Utils (uriToText)

@@ -0,0 +1,78 @@+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                           --+-------------------------------------------------------------------------------++data AuthorizationRequestParam = AuthorizationRequestParam+  { arScope :: Set Scope+  , arState :: AuthorizeState+  , arClientId :: ClientId+  , arRedirectUri :: Maybe RedirectUri+  , arResponseType :: ResponseType+  -- ^ It could be optional there is only one redirect_uri registered.+  -- See: https://www.rfc-editor.org/rfc/rfc6749#section-3.1.2.3+  , arExtraParams :: Map Text Text+  }++instance ToQueryParam AuthorizationRequestParam where+  toQueryParam AuthorizationRequestParam {..} =+    Map.unions+      [ toQueryParam arResponseType+      , toQueryParam arScope+      , toQueryParam arClientId+      , toQueryParam arState+      , toQueryParam arRedirectUri+      , arExtraParams+      ]++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)

@@ -0,0 +1,100 @@+{-# LANGUAGE DerivingStrategies #-}++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)++-------------------------------------------------------------------------------+--                    Device Authorization Request                           --+-------------------------------------------------------------------------------+newtype DeviceCode = DeviceCode Text+  deriving newtype (FromJSON)++instance ToQueryParam DeviceCode where+  toQueryParam :: DeviceCode -> Map Text Text+  toQueryParam (DeviceCode dc) = Map.singleton "device_code" dc++-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.2+data DeviceAuthorizationResponse = DeviceAuthorizationResponse+  { deviceCode :: DeviceCode+  , userCode :: Text+  , verificationUri :: URI+  , verificationUriComplete :: Maybe URI+  , expiresIn :: Integer+  , interval :: Maybe Int+  }++instance FromJSON DeviceAuthorizationResponse where+  parseJSON :: Value -> Parser DeviceAuthorizationResponse+  parseJSON = withObject "parse DeviceAuthorizationResponse" $ \t -> do+    deviceCode <- t .: "device_code"+    userCode <- t .: "user_code"+    -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho+    verificationUri <- t .: "verification_uri" <|> t .: "verification_url"+    verificationUriComplete <- t .:? "verification_uri_complete"+    expiresIn <- t .: "expires_in"+    interval <- t .:? "interval"+    pure DeviceAuthorizationResponse {..}++data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam+  { arScope :: Set Scope+  , arClientId :: Maybe ClientId+  , arExtraParams :: Map Text Text+  }++instance ToQueryParam DeviceAuthorizationRequestParam where+  toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text+  toQueryParam DeviceAuthorizationRequestParam {..} =+    Map.unions+      [ toQueryParam arScope+      , toQueryParam arClientId+      , arExtraParams+      ]++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

@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}++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.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils++-------------------------------------------------------------------------------+--                            RefreshToken Requset                           --+-------------------------------------------------------------------------------++data RefreshTokenRequest = RefreshTokenRequest+  { rrRefreshToken :: OAuth2.RefreshToken+  , rrGrantType :: GrantTypeValue+  , rrScope :: Set Scope+  }++instance ToQueryParam RefreshTokenRequest where+  toQueryParam :: RefreshTokenRequest -> Map Text Text+  toQueryParam RefreshTokenRequest {..} =+    Map.unions+      [ toQueryParam rrGrantType+      , toQueryParam rrScope+      , toQueryParam rrRefreshToken+      ]++class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod 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

@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.OAuth2.Experiment.Flows.TokenRequest where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE)+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++-------------------------------------------------------------------------------+--                               Token Request                               --+-------------------------------------------------------------------------------++class HasTokenRequestClientAuthenticationMethod a where+  getClientAuthenticationMethod :: a -> ClientAuthenticationMethod++-- | 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+  -- Each GrantTypeFlow has slightly different request parameter to /token endpoint.+  data TokenRequest a+  type ExchangeTokenInfo a++  -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request+  -- create type family to be explicit on it.+  -- with 'type instance WithExchangeToken a b = b' implies no exchange token+  -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token+  -- type WithExchangeToken a b+  mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a++-- | 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

@@ -0,0 +1,44 @@+{-# 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)

@@ -0,0 +1,16 @@+module Network.OAuth2.Experiment.Grants (+  module Network.OAuth2.Experiment.Grants.AuthorizationCode,+  module Network.OAuth2.Experiment.Grants.DeviceAuthorization,+  module Network.OAuth2.Experiment.Grants.ClientCredentials,+  module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword,+  module Network.OAuth2.Experiment.Grants.JwtBearer,+) where++import Network.OAuth2.Experiment.Grants.AuthorizationCode (AuthorizationCodeApplication (..))+import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..))+import Network.OAuth2.Experiment.Grants.DeviceAuthorization (+  DeviceAuthorizationApplication (..),+  pollDeviceTokenRequest,+ )+import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..))+import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..))

@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.AuthorizationCode where++import Control.Monad.IO.Class (MonadIO (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..), OAuth2)+import Network.OAuth.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 URI.ByteString hiding (UserInfo)++-- | An Application that supports "Authorization code" flow+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1+data AuthorizationCodeApplication = AuthorizationCodeApplication+  { acName :: Text+  , acClientId :: ClientId+  , acClientSecret :: ClientSecret+  , acScope :: Set Scope+  , acRedirectUri :: URI+  , acAuthorizeState :: AuthorizeState+  , acAuthorizeRequestExtraParams :: Map Text Text+  , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod+  }++instance HasOAuth2Key AuthorizationCodeApplication where+  mkOAuth2Key :: AuthorizationCodeApplication -> OAuth2+  mkOAuth2Key AuthorizationCodeApplication {..} = toOAuth2Key acClientId acClientSecret++instance HasTokenRequestClientAuthenticationMethod AuthorizationCodeApplication where+  getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod AuthorizationCodeApplication {..} = acTokenRequestAuthenticationMethod++instance HasAuthorizeRequest AuthorizationCodeApplication where+  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)++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3+instance HasTokenRequest AuthorizationCodeApplication where+  type ExchangeTokenInfo AuthorizationCodeApplication = ExchangeToken+  data TokenRequest AuthorizationCodeApplication = AuthorizationCodeTokenRequest+    { trCode :: ExchangeToken+    , trGrantType :: GrantTypeValue+    , trRedirectUri :: RedirectUri+    }++  mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication+  mkTokenRequestParam AuthorizationCodeApplication {..} authCode =+    AuthorizationCodeTokenRequest+      { trCode = authCode+      , trGrantType = GTAuthorizationCode+      , trRedirectUri = RedirectUri acRedirectUri+      }++instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where+  toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text+  toQueryParam AuthorizationCodeTokenRequest {..} =+    Map.unions+      [ toQueryParam trCode+      , toQueryParam trGrantType+      , toQueryParam trRedirectUri+      ]++instance HasUserInfoRequest AuthorizationCodeApplication++instance HasRefreshTokenRequest AuthorizationCodeApplication where+  mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest+  mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt =+    RefreshTokenRequest+      { rrScope = acScope+      , rrGrantType = GTRefreshToken+      , rrRefreshToken = rt+      }

@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.ClientCredentials where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2)+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils++-- | An Application that supports "Client Credentials" flow+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4+data ClientCredentialsApplication = ClientCredentialsApplication+  { ccClientId :: ClientId+  , ccClientSecret :: ClientSecret+  , ccName :: Text+  , ccScope :: Set Scope+  , ccTokenRequestExtraParams :: Map Text Text+  , ccTokenRequestAuthenticationMethod :: ClientAuthenticationMethod+  }++instance HasOAuth2Key ClientCredentialsApplication where+  mkOAuth2Key :: ClientCredentialsApplication -> OAuth2+  mkOAuth2Key ClientCredentialsApplication {..} = toOAuth2Key ccClientId ccClientSecret++instance HasTokenRequestClientAuthenticationMethod ClientCredentialsApplication where+  getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod ClientCredentialsApplication {..} = ccTokenRequestAuthenticationMethod++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2+instance HasTokenRequest ClientCredentialsApplication where+  type ExchangeTokenInfo ClientCredentialsApplication = NoNeedExchangeToken+  data TokenRequest ClientCredentialsApplication = ClientCredentialsTokenRequest+    { trScope :: Set Scope+    , trGrantType :: GrantTypeValue+    , trClientSecret :: ClientSecret+    , trClientId :: ClientId+    , trExtraParams :: Map Text Text+    , trClientAuthenticationMethod :: ClientAuthenticationMethod+    }++  mkTokenRequestParam :: ClientCredentialsApplication -> NoNeedExchangeToken -> TokenRequest ClientCredentialsApplication+  mkTokenRequestParam ClientCredentialsApplication {..} _ =+    ClientCredentialsTokenRequest+      { trScope = ccScope+      , trGrantType = GTClientCredentials+      , trClientSecret = ccClientSecret+      , trClientAuthenticationMethod = ccTokenRequestAuthenticationMethod+      , trExtraParams = ccTokenRequestExtraParams+      , trClientId = ccClientId+      }++instance ToQueryParam (TokenRequest ClientCredentialsApplication) where+  toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text+  toQueryParam ClientCredentialsTokenRequest {..} =+    let jwtAssertionBody =+          if trClientAuthenticationMethod == ClientAssertionJwt+            then+              [ toQueryParam trClientId+              , Map.fromList+                  [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+                  , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)+                  ]+              ]+            else []+     in Map.unions $+          [ toQueryParam trGrantType+          , toQueryParam trScope+          , trExtraParams+          ]+            ++ jwtAssertionBody

@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.DeviceAuthorization (+  DeviceAuthorizationApplication (..),+  pollDeviceTokenRequest,+) 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.Experiment.Flows.DeviceAuthorizationRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Types+import Prelude hiding (error)++-- | An Application that supports "Device Authorization Grant"+--+-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1+data DeviceAuthorizationApplication = DeviceAuthorizationApplication+  { daName :: Text+  , daClientId :: ClientId+  , daClientSecret :: ClientSecret+  , daScope :: Set Scope+  , daAuthorizationRequestExtraParam :: Map Text Text+  -- ^ Additional parameters to the device authorization request.+  -- Most of identity providers follow the spec strictly but+  -- AzureAD requires "tenant" parameter.+  , daAuthorizationRequestAuthenticationMethod :: Maybe 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+  getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod _ = ClientSecretBasic++instance HasDeviceAuthorizationRequest DeviceAuthorizationApplication where+  mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam+  mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} =+    DeviceAuthorizationRequestParam+      { arScope = daScope+      , arClientId =+          if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic+            then Nothing+            else Just daClientId+      , arExtraParams = daAuthorizationRequestExtraParam+      }++-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4+instance HasTokenRequest DeviceAuthorizationApplication where+  type ExchangeTokenInfo DeviceAuthorizationApplication = DeviceCode+  data TokenRequest DeviceAuthorizationApplication = AuthorizationCodeTokenRequest+    { trCode :: DeviceCode+    , trGrantType :: GrantTypeValue+    , trClientId :: Maybe ClientId+    }++  mkTokenRequestParam ::+    DeviceAuthorizationApplication ->+    DeviceCode ->+    TokenRequest DeviceAuthorizationApplication+  mkTokenRequestParam DeviceAuthorizationApplication {..} deviceCode =+    --+    -- This is a bit hacky!+    -- The token request use `ClientSecretBasic` by default. (has to pick up one Client Authn Method)+    -- ClientId shall be also be in request body per spec.+    -- However, for some IdPs, e.g. Okta, when using `ClientSecretBasic` to authn Client,+    -- it doesn't allow @client_id@ in the request body+    -- 'daAuthorizationRequestAuthenticationMethod' set the tone for Authorization Request,+    -- hence just follow it in the token request+    AuthorizationCodeTokenRequest+      { trCode = deviceCode+      , trGrantType = GTDeviceCode+      , trClientId =+          if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic+            then Nothing+            else Just daClientId+      }++instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where+  toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text+  toQueryParam AuthorizationCodeTokenRequest {..} =+    Map.unions+      [ toQueryParam trCode+      , toQueryParam trGrantType+      , toQueryParam trClientId+      ]++instance HasUserInfoRequest DeviceAuthorizationApplication

@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleInstances #-}++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.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils++-- | An Application that supports "JWT Bearer" flow+--+-- https://datatracker.ietf.org/doc/html/rfc7523+data JwtBearerApplication = JwtBearerApplication+  { jbName :: Text+  , jbJwtAssertion :: BS.ByteString+  }++-- 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+  getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod _ = ClientAssertionJwt++instance HasTokenRequest JwtBearerApplication where+  type ExchangeTokenInfo JwtBearerApplication = NoNeedExchangeToken++  data TokenRequest JwtBearerApplication = JwtBearerTokenRequest+    { trGrantType :: GrantTypeValue -- \| 'GTJwtBearer'+    , trAssertion :: BS.ByteString -- \| The the signed JWT token+    }++  mkTokenRequestParam :: JwtBearerApplication -> NoNeedExchangeToken -> TokenRequest JwtBearerApplication+  mkTokenRequestParam JwtBearerApplication {..} _ =+    JwtBearerTokenRequest+      { trGrantType = GTJwtBearer+      , trAssertion = jbJwtAssertion+      }++instance ToQueryParam (TokenRequest JwtBearerApplication) where+  toQueryParam :: TokenRequest JwtBearerApplication -> Map Text Text+  toQueryParam JwtBearerTokenRequest {..} =+    Map.unions+      [ toQueryParam trGrantType+      , Map.singleton "assertion" (bs8ToLazyText trAssertion)+      ]++instance HasUserInfoRequest JwtBearerApplication

@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2 (..))+import Network.OAuth.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Types++-- | An Application that supports "Resource Owner Password" flow+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3+data ResourceOwnerPasswordApplication = ResourceOwnerPasswordApplication+  { ropClientId :: ClientId+  , ropClientSecret :: ClientSecret+  , ropName :: Text+  , ropScope :: Set Scope+  , ropUserName :: Username+  , ropPassword :: Password+  , ropTokenRequestExtraParams :: Map Text Text+  }++instance HasOAuth2Key ResourceOwnerPasswordApplication where+  mkOAuth2Key :: ResourceOwnerPasswordApplication -> OAuth2+  mkOAuth2Key ResourceOwnerPasswordApplication {..} = toOAuth2Key ropClientId ropClientSecret++instance HasTokenRequestClientAuthenticationMethod ResourceOwnerPasswordApplication where+  getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod _ = ClientSecretBasic++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2+instance HasTokenRequest ResourceOwnerPasswordApplication where+  type ExchangeTokenInfo ResourceOwnerPasswordApplication = NoNeedExchangeToken++  data TokenRequest ResourceOwnerPasswordApplication = PasswordTokenRequest+    { trScope :: Set Scope+    , trUsername :: Username+    , trPassword :: Password+    , trGrantType :: GrantTypeValue+    , trExtraParams :: Map Text Text+    }+  mkTokenRequestParam :: ResourceOwnerPasswordApplication -> NoNeedExchangeToken -> TokenRequest ResourceOwnerPasswordApplication+  mkTokenRequestParam ResourceOwnerPasswordApplication {..} _ =+    PasswordTokenRequest+      { trUsername = ropUserName+      , trPassword = ropPassword+      , trGrantType = GTPassword+      , trScope = ropScope+      , trExtraParams = ropTokenRequestExtraParams+      }++instance ToQueryParam (TokenRequest ResourceOwnerPasswordApplication) where+  toQueryParam :: TokenRequest ResourceOwnerPasswordApplication -> Map Text Text+  toQueryParam PasswordTokenRequest {..} =+    Map.unions+      [ toQueryParam trGrantType+      , toQueryParam trScope+      , toQueryParam trUsername+      , toQueryParam trPassword+      , trExtraParams+      ]++instance HasUserInfoRequest ResourceOwnerPasswordApplication++instance HasRefreshTokenRequest ResourceOwnerPasswordApplication where+  mkRefreshTokenRequestParam :: ResourceOwnerPasswordApplication -> OAuth2.RefreshToken -> RefreshTokenRequest+  mkRefreshTokenRequestParam ResourceOwnerPasswordApplication {..} rt =+    RefreshTokenRequest+      { rrScope = ropScope+      , rrGrantType = GTRefreshToken+      , rrRefreshToken = rt+      }

@@ -18,7 +18,7 @@  newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text} -newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show)+newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text}  data CodeChallengeMethod = S256   deriving (Show)@@ -27,7 +27,7 @@   { codeVerifier :: CodeVerifier   , codeChallenge :: CodeChallenge   , codeChallengeMethod :: CodeChallengeMethod-  -- ^ spec says optional but really it shall be s256 or can be omitted?+  -- ^ spec says optional but in practice it is S256   -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3   } 

@@ -1,116 +1,107 @@-{-# 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 (..), throwE)-import Data.Aeson (FromJSON)-import Data.Bifunctor-import Data.ByteString qualified as BS-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 import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils-import URI.ByteString hiding (UserInfo)--{- NOTE-  1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility?--}+import URI.ByteString (URI, serializeURIRef')  ------------------------------------------------------------------------------- --- * Grant Type+-- * Idp App  ------------------------------------------------------------------------------- -data GrantTypeFlow-  = -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1-    AuthorizationCode-  | -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3-    ResourceOwnerPassword-  | -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4-    ClientCredentials-  | -- | https://www.rfc-editor.org/rfc/rfc7523.html#section-2.1-    JwtBearer+-- 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.+-- And it is PolyKinds.+--+-- Hence whenever @Idp i@ or @IdpApplication i a@ is used as function parameter,+-- PolyKinds need to be enabled.+data Idp (i :: k) = Idp+  { idpUserInfoEndpoint :: URI+  -- ^ Userinfo Endpoint+  , idpAuthorizeEndpoint :: URI+  -- ^ Authorization Endpoint+  , idpTokenEndpoint :: URI+  -- ^ Token Endpoint+  , idpDeviceAuthorizationEndpoint :: Maybe URI+  -- ^ Apparently not all IdP support device code flow+  } --- * Response Type value+-- | An OAuth2 Application "a" of IdP "i".+-- "a" can be one of following type:+--+-- * `Network.OAuth2.Experiment.AuthorizationCodeApplication`+-- * `Network.OAuth2.Experiment.DeviceAuthorizationApplication`+-- * `Network.OAuth2.Experiment.ClientCredentialsApplication`+-- * `Network.OAuth2.Experiment.ResourceOwnerPasswordApplication`+-- * `Network.OAuth2.Experiment.JwtBearerApplication`+data IdpApplication (i :: k) a = IdpApplication+  { idp :: Idp i+  , application :: a+  }  ------------------------------------------------------------------------------- -class ToResponseTypeValue (a :: GrantTypeFlow) where-  toResponseTypeValue :: IsString b => b+-- * Scope -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)+-- TODO: What's best type for Scope?+-- Use 'Text' isn't super type safe. All cannot specify some standard scopes like openid, email etc.+-- But Following data type is not ideal as Idp would have lots of 'Custom Text'+--+-- @+-- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text+-- @+--+-- 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) +instance IsString Scope where+  fromString :: String -> Scope+  fromString = Scope . TL.pack+ -------------------------------------------------------------------------------  -- * Grant Type value  ------------------------------------------------------------------------------- --- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict.+-- | Grant type query parameter has association with different GrantType flows but not completely strict. ----- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow.+-- e.g. Both AuthorizationCode and ResourceOwnerPassword flow could support refresh token flow. data GrantTypeValue   = GTAuthorizationCode   | GTPassword   | GTClientCredentials   | GTRefreshToken   | GTJwtBearer+  | GTDeviceCode   deriving (Eq, Show)  ----------------------------------------------------------------------------------- * Scope-+--                               Response Type                               -- ----------------------------------------------------------------------------------- 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+data ResponseType = Code  ------------------------------------------------------------------------------- @@ -180,6 +171,7 @@       val GTClientCredentials = "client_credentials"       val GTRefreshToken = "refresh_token"       val GTJwtBearer = "urn:ietf:params:oauth:grant-type:jwt-bearer"+      val GTDeviceCode = "urn:ietf:params:oauth:grant-type:device_code"  instance ToQueryParam ClientId where   toQueryParam :: ClientId -> Map Text Text@@ -208,7 +200,7 @@   toQueryParam :: Set Scope -> Map Text Text   toQueryParam = toScopeParam . Set.map unScope     where-      toScopeParam :: (IsString a) => Set Text -> Map a Text+      toScopeParam :: IsString a => Set Text -> Map a Text       toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope)  instance ToQueryParam CodeVerifier where@@ -231,546 +223,16 @@   toQueryParam :: OAuth2.RefreshToken -> Map Text Text   toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x) ------------------------------------------------------------------------------------ * Authorization and Token Requests types-----------------------------------------------------------------------------------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 TokenRequestError 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 TokenRequestError 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 TokenRequestError 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-  , idpAppAuthorizeExtraParams :: Map Text Text-  -- ^ Though technically one key can have multiple value in query, but who actually does it?!-  , 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 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 TokenRequestError 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 TokenRequestError 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 TokenRequestError 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-      ]------------------------------------------------------------------------------------- * JWTBearer------------------------------------------------------------------------------------- | An Application that supports "Authorization code" flow-data instance IdpApplication 'JwtBearer i = JwtBearerIdpApplication-  { idpAppName :: Text-  , idpAppJwt :: BS.ByteString-  , idp :: Idp i-  }--instance HasTokenRequest 'JwtBearer where-  data TokenRequest 'JwtBearer = JwtBearerTokenRequest-    { grantType :: GrantTypeValue -- \| 'GTJwtBearer'-    , assertion :: BS.ByteString -- \| The the signed JWT token-    }-  type WithExchangeToken 'JwtBearer a = a--  mkTokenRequest ::-    IdpApplication 'JwtBearer i ->-    TokenRequest 'JwtBearer-  mkTokenRequest JwtBearerIdpApplication {..} =-    JwtBearerTokenRequest-      { grantType = GTJwtBearer-      , assertion = idpAppJwt-      }--  conduitTokenRequest ::-    forall m i.-    (MonadIO m) =>-    IdpApplication 'JwtBearer i ->-    Manager ->-    ExceptT TokenRequestError m OAuth2Token-  conduitTokenRequest idpAppConfig@JwtBearerIdpApplication {..} mgr = do-    resp <- ExceptT . liftIO $ do-      let tokenReq = mkTokenRequest idpAppConfig-      let body = mapsToParams [toQueryParam tokenReq]-      req <- uriToRequest (idpTokenEndpoint idp)-      handleOAuth2TokenResponse <$> httpLbs (urlEncodedBody body (addDefaultRequestHeaders req)) mgr-    case parseResponseFlexible resp of-      Right obj -> return obj-      Left e -> throwE e--instance ToQueryParam (TokenRequest 'JwtBearer) where-  toQueryParam :: TokenRequest 'JwtBearer -> Map Text Text-  toQueryParam JwtBearerTokenRequest {..} =-    Map.unions-      [ toQueryParam grantType-      , Map.fromList [("assertion", bs8ToLazyText assertion)]-      ]--instance HasUserInfoRequest 'JwtBearer where-  conduitUserInfoRequest JwtBearerIdpApplication {..} mgr at = do-    idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp)------------------------------------------------------------------------------------- * 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 = ResourceOwnerPasswordIDPApplication-  { idpAppClientId :: ClientId-  , idpAppClientSecret :: ClientSecret-  , idpAppName :: Text-  , idpAppScope :: Set Scope-  , idpAppUserName :: Username-  , idpAppPassword :: Password-  , idpAppTokenRequestExtraParams :: Map Text Text-  -- ^ Any parameter that required by your Idp and not mentioned in the OAuth2 spec-  , idp :: Idp i-  }--instance HasUserInfoRequest 'ResourceOwnerPassword where-  conduitUserInfoRequest ResourceOwnerPasswordIDPApplication {..} 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 ResourceOwnerPasswordIDPApplication {..} =-    PasswordTokenRequest-      { username = idpAppUserName-      , password = idpAppPassword-      , grantType = GTPassword-      , scope = idpAppScope-      }--  conduitTokenRequest ::-    (MonadIO m) =>-    IdpApplication 'ResourceOwnerPassword i ->-    Manager ->-    ExceptT TokenRequestError m OAuth2Token-  conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPApplication {..} 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 TokenRequestError 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-      ]+instance ToQueryParam ResponseType where+  toQueryParam :: ResponseType -> Map Text Text+  toQueryParam Code = Map.singleton "response_type" "code"  ----------------------------------------------------------------------------------- * Client Credentials flow-+--                                HasOAuth2Key                               --+--                                                                           --+-- Find a way to reuse some methods from old implementation                  --+-- Probably will be removed when Experiment module becomes default           -- ------------------------------------------------------------------------------- --- 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 = ClientCredentialsIDPApplication-  { idpAppClientId :: ClientId-  , idpAppClientSecret :: ClientSecret-  , idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod-  -- ^ FIXME: rename to ClientCredential-  , idpAppName :: Text-  , idpAppScope :: Set Scope-  , idpAppTokenRequestExtraParams :: Map Text Text-  -- ^ Any parameter that required by your Idp and not mentioned in the OAuth2 spec-  , idp :: Idp i-  }--instance HasTokenRequest 'ClientCredentials where-  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2-  data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest-    { scope :: Set Scope-    , grantType :: GrantTypeValue-    , clientAssertionType :: Text-    , clientAssertion :: BS.ByteString-    , clientAuthenticationMethod :: ClientAuthenticationMethod-    }--  type WithExchangeToken 'ClientCredentials a = a--  mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials-  mkTokenRequest ClientCredentialsIDPApplication {..} =-    ClientCredentialsTokenRequest-      { scope = idpAppScope-      , grantType = GTClientCredentials-      , clientAssertionType = "urn:ietf:params:oauth:client-assertion-type:jwt-bearer"-      , clientAssertion = tlToBS $ unClientSecret idpAppClientSecret-      , clientAuthenticationMethod = idpAppTokenRequestAuthenticationMethod-      }--  conduitTokenRequest ::-    (MonadIO m) =>-    IdpApplication 'ClientCredentials i ->-    Manager ->-    ExceptT TokenRequestError m OAuth2Token-  conduitTokenRequest idpAppConfig@ClientCredentialsIDPApplication {..} mgr = do-    let tokenReq = mkTokenRequest idpAppConfig-        key =-          toOAuth2Key-            idpAppClientId-            idpAppClientSecret-        body =-          mapsToParams-            [ idpAppTokenRequestExtraParams-            , toQueryParam tokenReq-            ]-    if clientAuthenticationMethod tokenReq == 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 key (idpTokenEndpoint idp) body--instance ToQueryParam (TokenRequest 'ClientCredentials) where-  toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text-  toQueryParam ClientCredentialsTokenRequest {..} =-    Map.unions $-      [ toQueryParam grantType-      , toQueryParam scope-      ]-        ++ [ Map.fromList-              ( if clientAuthenticationMethod == ClientAssertionJwt-                  then-                    [ ("client_assertion_type", clientAssertionType)-                    , ("client_assertion", bs8ToLazyText clientAssertion)-                    ]-                  else []-              )-           ]+class HasOAuth2Key a where+  mkOAuth2Key :: a -> OAuth2

@@ -5,8 +5,11 @@ import Data.ByteString.Char8 qualified as BS8 import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Lazy qualified as TL+import URI.ByteString (URI, serializeURIRef')  tlToBS :: TL.Text -> ByteString tlToBS = TE.encodeUtf8 . TL.toStrict@@ -14,8 +17,11 @@ bs8ToLazyText :: BS8.ByteString -> TL.Text bs8ToLazyText = TL.pack . BS8.unpack -mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)]-mapsToParams =+unionMapsToQueryParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)]+unionMapsToQueryParams =   map (bimap tlToBS tlToBS)     . Map.toList     . Map.unions++uriToText :: URI -> T.Text+uriToText = T.decodeUtf8 . serializeURIRef'

@@ -1,12 +1,16 @@+{-# 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 =-  describe "parseJSON TokenRequestErrorCode" $ do+spec = do+  describe "parseJSON TokenResponseErrorCode" $ do     it "invalid_request" $ do       Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest     it "invalid_client" $ do@@ -21,3 +25,32 @@       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|]+              }+          )