hoauth2 2.6.0 → 2.7.0

raw patch · 11 files changed

+450/−323 lines, 11 filesdep +hoauth2dep +hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: hoauth2, hspec

API changes (from Hackage documentation)

Files

• hoauth2.cabal +36/−13
• src/Network/OAuth/OAuth2.hs +8/−10
• src/Network/OAuth/OAuth2/AuthorizationRequest.hs +8/−11
• src/Network/OAuth/OAuth2/HttpClient.hs +35/−31
• src/Network/OAuth/OAuth2/Internal.hs +30/−60
• src/Network/OAuth/OAuth2/TokenRequest.hs +68/−40
• src/Network/OAuth2/Experiment.hs +4/−6
• src/Network/OAuth2/Experiment/Pkce.hs +15/−16
• src/Network/OAuth2/Experiment/Types.hs +221/−136
• test/Network/OAuth/OAuth2/TokenRequestSpec.hs +23/−0
• test/Spec.hs +2/−0

@@ -2,7 +2,7 @@ name:               hoauth2  -- http://wiki.haskell.org/Package_versioning_policy-version:            2.6.0+version:            2.7.0 synopsis:           Haskell OAuth2 authentication client description:   Haskell OAuth2 authentication client.@@ -30,16 +30,20 @@ library   hs-source-dirs:     src   default-language:   Haskell2010+  autogen-modules:    Paths_hoauth2+  other-modules:+    Network.OAuth.OAuth2.Internal+    Network.OAuth2.Experiment.Pkce+    Network.OAuth2.Experiment.Types+    Network.OAuth2.Experiment.Utils+    Paths_hoauth2+   exposed-modules:     Network.OAuth.OAuth2     Network.OAuth.OAuth2.AuthorizationRequest     Network.OAuth.OAuth2.HttpClient-    Network.OAuth.OAuth2.Internal     Network.OAuth.OAuth2.TokenRequest     Network.OAuth2.Experiment-    Network.OAuth2.Experiment.Pkce-    Network.OAuth2.Experiment.Types-    Network.OAuth2.Experiment.Utils    default-extensions:     DataKinds@@ -52,24 +56,43 @@     TypeFamilies    build-depends:-    , aeson                 >=2.0   && <2.2-    , base                  >=4     && <5+    , aeson                 >=2.0    && <2.2+    , base                  >=4      && <5     , base64                ^>=0.4     , binary                ^>=0.8-    , bytestring            >=0.9   && <0.12+    , bytestring            >=0.9    && <0.12     , containers            ^>=0.6     , cryptonite            ^>=0.30     , data-default          ^>=0.7-    , exceptions            >=0.8.3 && <0.11-    , http-conduit          >=2.1   && <2.4-    , http-types            >=0.11  && <0.13+    , exceptions            >=0.8.3  && <0.11+    , http-conduit          >=2.1    && <2.4+    , http-types            >=0.11   && <0.13     , memory                ^>=0.17     , microlens             ^>=0.4.0-    , text                  >=0.11  && <1.3+    , text                  >=0.11   && <1.3     , transformers          ^>=0.5-    , uri-bytestring        >=0.2.3 && <0.4+    , 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++test-suite hoauth-tests+  type:               exitcode-stdio-1.0+  main-is:            Spec.hs+  hs-source-dirs:     test+  ghc-options:        -Wall+  build-depends:+    , aeson    >=2.0 && <2.2+    , base     >=4   && <5+    , hoauth2+    , hspec    >=2   && <3++  other-modules:      Network.OAuth.OAuth2.TokenRequestSpec+  default-language:   Haskell2010+  default-extensions:+    ImportQualifiedPost+    OverloadedStrings++  build-tool-depends: hspec-discover:hspec-discover >=2 && <3

@@ -1,19 +1,17 @@ -- | A lightweight oauth2 Haskell binding. -- See Readme for more details----module Network.OAuth.OAuth2-  ( module Network.OAuth.OAuth2.HttpClient,-    module Network.OAuth.OAuth2.AuthorizationRequest,-    module Network.OAuth.OAuth2.TokenRequest,-    module Network.OAuth.OAuth2.Internal,-  )-where+module Network.OAuth.OAuth2 (+  module Network.OAuth.OAuth2.HttpClient,+  module Network.OAuth.OAuth2.AuthorizationRequest,+  module Network.OAuth.OAuth2.TokenRequest,+  module Network.OAuth.OAuth2.Internal,+) where  {-   Hiding Errors data type from default.   Shall qualified import given the naming collision. -}-import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..))+import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors (..)) import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2.Internal-import Network.OAuth.OAuth2.TokenRequest hiding (Errors(..))+import Network.OAuth.OAuth2.TokenRequest

@@ -7,8 +7,8 @@  import Data.Aeson import Data.Function (on)-import qualified Data.List as List-import qualified Data.Text.Encoding as T+import Data.List qualified as List+import Data.Text.Encoding qualified as T import GHC.Generics (Generic) import Lens.Micro (over) import Network.OAuth.OAuth2.Internal@@ -21,15 +21,12 @@ --------------------------------------------------  instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--instance ToJSON Errors where-  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}+  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 (redirect to OAuth2 provider),--- it will end-up at the Provider page hence no way for this library to parse error response.+-- 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@@ -62,7 +59,7 @@     queryParts =       List.nubBy ((==) `on` fst) $         qs-          ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-               ("response_type", "code"),-               ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+          ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)+             , ("response_type", "code")+             , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)              ]

@@ -4,39 +4,38 @@  -- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage -- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750>-module Network.OAuth.OAuth2.HttpClient-  ( -- * AUTH requests-    authGetJSON,-    authGetBS,-    authGetBS2,-    authGetJSONWithAuthMethod,-    authGetJSONInternal,-    authGetBSWithAuthMethod,-    authGetBSInternal,-    authPostJSON,-    authPostBS,-    authPostBS2,-    authPostBS3,-    authPostJSONWithAuthMethod,-    authPostJSONInternal,-    authPostBSWithAuthMethod,-    authPostBSInternal,+module Network.OAuth.OAuth2.HttpClient (+  -- * AUTH requests+  authGetJSON,+  authGetBS,+  authGetBS2,+  authGetJSONWithAuthMethod,+  authGetJSONInternal,+  authGetBSWithAuthMethod,+  authGetBSInternal,+  authPostJSON,+  authPostBS,+  authPostBS2,+  authPostBS3,+  authPostJSONWithAuthMethod,+  authPostJSONInternal,+  authPostBSWithAuthMethod,+  authPostBSInternal, -    -- * Types-    APIAuthenticationMethod (..),-  )-where+  -- * Types+  APIAuthenticationMethod (..),+) where  import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson (FromJSON, eitherDecode)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Maybe (fromJust, isJust)-import qualified Data.Text.Encoding as T+import Data.Text.Encoding qualified as T import Lens.Micro (over) import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT+import Network.HTTP.Types qualified as HT import Network.OAuth.OAuth2.Internal import URI.ByteString (URI, URIRef, queryL, queryPairsL) @@ -302,15 +301,20 @@   -- | HTTP connection manager.   Manager ->   ExceptT BSL.ByteString m BSL.ByteString-authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage+authRequest req upReq manage = ExceptT $ do+  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 =-  if HT.statusIsSuccessful (responseStatus rsp)-    then Right $ responseBody rsp-    else -- TODO: better to surface up entire resp so that client can decide what to do when error happens.-      Left $ responseBody rsp+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`

@@ -6,24 +6,24 @@  module Network.OAuth.OAuth2.Internal where -import Control.Applicative import Control.Arrow (second) import Control.Monad.Catch import Data.Aeson import Data.Aeson.Types (Parser, explicitParseFieldMaybe) import Data.Binary (Binary)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8 import Data.Default import Data.Maybe-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding+import Data.Text (Text, unpack)+import Data.Version (showVersion) import GHC.Generics import Lens.Micro import Lens.Micro.Extras import Network.HTTP.Conduit as C-import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types as HT+import Network.HTTP.Types qualified as H+import Network.HTTP.Types qualified as HT+import Paths_hoauth2 (version) import URI.ByteString import URI.ByteString.Aeson () import URI.ByteString.QQ@@ -36,22 +36,22 @@  -- | Query Parameter Representation data OAuth2 = OAuth2-  { oauth2ClientId :: Text,-    oauth2ClientSecret :: Text,-    oauth2AuthorizeEndpoint :: URIRef Absolute,-    oauth2TokenEndpoint :: URIRef Absolute,-    oauth2RedirectUri :: URIRef Absolute+  { oauth2ClientId :: Text+  , oauth2ClientSecret :: Text+  , oauth2AuthorizeEndpoint :: URIRef Absolute+  , oauth2TokenEndpoint :: URIRef Absolute+  , oauth2RedirectUri :: URIRef Absolute   }   deriving (Show, Eq)  instance Default OAuth2 where   def =     OAuth2-      { oauth2ClientId = "",-        oauth2ClientSecret = "",-        oauth2AuthorizeEndpoint = [uri|https://www.example.com/|],-        oauth2TokenEndpoint = [uri|https://www.example.com/|],-        oauth2RedirectUri = [uri|https://www.example.com/|]+      { oauth2ClientId = ""+      , oauth2ClientSecret = ""+      , oauth2AuthorizeEndpoint = [uri|https://www.example.com/|]+      , oauth2TokenEndpoint = [uri|https://www.example.com/|]+      , oauth2RedirectUri = [uri|https://www.example.com/|]       }  newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)@@ -65,14 +65,14 @@  -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 data OAuth2Token = OAuth2Token-  { accessToken :: AccessToken,-    -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token.-    refreshToken :: Maybe RefreshToken,-    expiresIn :: Maybe Int,-    -- | See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.-    tokenType :: Maybe Text,-    -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID.-    idToken :: Maybe IdToken+  { accessToken :: AccessToken+  , refreshToken :: Maybe RefreshToken+  -- ^ Exists when @offline_access@ scope is in the 'authorizeUrl' 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.   }   deriving (Eq, Show, Generic) @@ -100,37 +100,6 @@   toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}   toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} -data OAuth2Error a = OAuth2Error-  { error :: Either Text a,-    errorDescription :: Maybe Text,-    errorUri :: Maybe (URIRef Absolute)-  }-  deriving (Show, Eq, Generic)--instance FromJSON err => FromJSON (OAuth2Error err) where-  parseJSON (Object a) =-    do-      err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str)-      desc <- a .:? "error_description"-      errorUri <- a .:? "error_uri"-      return $ OAuth2Error err desc errorUri-  parseJSON _ = fail "Expected an object"--instance ToJSON err => ToJSON (OAuth2Error err) where-  toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}-  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err-parseOAuth2Error string =-  either (mkDecodeOAuth2Error string) id (eitherDecode string)--mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err-mkDecodeOAuth2Error response err =-  OAuth2Error-    (Left "Decode error")-    (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response))-    Nothing- -- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3 -- According to spec: --@@ -146,6 +115,7 @@ data ClientAuthenticationMethod   = ClientSecretBasic   | ClientSecretPost+  | ClientAssertionJwt   deriving (Eq, Ord)  --------------------------------------------------@@ -167,8 +137,8 @@  defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] defaultRequestHeaders =-  [ (HT.hUserAgent, "hoauth2"),-    (HT.hAccept, "application/json")+  [ (HT.hUserAgent, "hoauth2-" <> BS8.pack (showVersion version))+  , (HT.hAccept, "application/json")   ]  appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a@@ -189,8 +159,8 @@       req =         setQueryString query $           defaultRequest-            { secure = ssl,-              path = view pathL auri+            { secure = ssl+            , path = view pathL auri             }       req2 = (over hostLens . maybe id const . preview hostL) auri req       req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) auri req2

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}  -- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework@@ -8,16 +7,18 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) import Data.Aeson-import qualified Data.Aeson.Key as Key-import qualified Data.Aeson.KeyMap as KeyMap-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text.Encoding as T+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T import GHC.Generics (Generic) import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT+import Network.HTTP.Types qualified as HT import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal-import URI.ByteString (URI, serializeURIRef')+import URI.ByteString  -------------------------------------------------- @@ -25,22 +26,49 @@  -------------------------------------------------- -instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--instance ToJSON Errors where-  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}+data TokenRequestError = TokenRequestError+  { error :: TokenRequestErrorCode+  , errorDescription :: Maybe Text+  , errorUri :: Maybe (URIRef Absolute)+  }+  deriving (Show, Eq, Generic)  -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2-data Errors+data TokenRequestErrorCode   = InvalidRequest   | InvalidClient   | InvalidGrant   | UnauthorizedClient   | UnsupportedGrantType   | InvalidScope-  deriving (Show, Eq, Generic)+  | UnknownErrorCode Text+  deriving (Show, Eq) +instance FromJSON TokenRequestErrorCode where+  parseJSON = withText "parseJSON TokenRequestErrorCode" $ \t ->+    pure $ case t of+      "invalid_request" -> InvalidRequest+      "invalid_client" -> InvalidClient+      "invalid_grant" -> InvalidGrant+      "unauthorized_client" -> UnauthorizedClient+      "unsupported_grant_type" -> UnsupportedGrantType+      "invalid_scope" -> InvalidScope+      _ -> UnknownErrorCode t++instance FromJSON TokenRequestError where+  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_'}++parseTokeRequestError :: BSL.ByteString -> TokenRequestError+parseTokeRequestError string =+  either (mkDecodeOAuth2Error string) id (eitherDecode string)+  where+    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenRequestError+    mkDecodeOAuth2Error response err =+      TokenRequestError+        (UnknownErrorCode "")+        (Just $ T.pack $ "Decode TokenRequestError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response))+        Nothing+ --------------------------------------------------  -- * URL@@ -57,9 +85,9 @@ accessTokenUrl oa code =   let uri = oauth2TokenEndpoint oa       body =-        [ ("code", T.encodeUtf8 $ extoken code),-          ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa),-          ("grant_type", "authorization_code")+        [ ("code", T.encodeUtf8 $ extoken code)+        , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+        , ("grant_type", "authorization_code")         ]    in (uri, body) @@ -74,8 +102,8 @@   where     uri = oauth2TokenEndpoint oa     body =-      [ ("grant_type", "refresh_token"),-        ("refresh_token", T.encodeUtf8 $ rtoken token)+      [ ("grant_type", "refresh_token")+      , ("refresh_token", T.encodeUtf8 $ rtoken token)       ]  --------------------------------------------------@@ -94,7 +122,7 @@   -- | OAuth2 Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic  fetchAccessToken2 ::@@ -106,7 +134,7 @@   -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-} @@ -120,7 +148,7 @@   -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod {-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-} @@ -146,7 +174,7 @@   -- | Authorization Code   ExchangeToken ->   -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token fetchAccessTokenWithAuthMethod authMethod manager oa code = do   let (uri, body) = accessTokenUrl oa code   let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []@@ -161,7 +189,7 @@   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic  refreshAccessToken2 ::@@ -172,7 +200,7 @@   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-} @@ -185,7 +213,7 @@   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod {-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-} @@ -210,7 +238,7 @@   OAuth2 ->   -- | Refresh Token gained after authorization   RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token+  ExceptT TokenRequestError m OAuth2Token refreshAccessTokenWithAuthMethod authMethod manager oa token = do   let (uri, body) = refreshAccessTokenUrl oa token   let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []@@ -224,7 +252,7 @@  -- | Conduct post request and return response as JSON. doJSONPostRequest ::-  (MonadIO m, FromJSON err, FromJSON a) =>+  (MonadIO m, FromJSON a) =>   -- | HTTP connection manager.   Manager ->   -- | OAuth options@@ -234,7 +262,7 @@   -- | request body   PostBody ->   -- | Response as JSON-  ExceptT (OAuth2Error err) m a+  ExceptT TokenRequestError m a doJSONPostRequest manager oa uri body = do   resp <- doSimplePostRequest manager oa uri body   case parseResponseFlexible resp of@@ -243,7 +271,7 @@  -- | Conduct post request. doSimplePostRequest ::-  (MonadIO m, FromJSON err) =>+  (MonadIO m) =>   -- | HTTP connection manager.   Manager ->   -- | OAuth options@@ -253,7 +281,7 @@   -- | Request body.   PostBody ->   -- | Response as ByteString-  ExceptT (OAuth2Error err) m BSL.ByteString+  ExceptT TokenRequestError m BSL.ByteString doSimplePostRequest manager oa url body =   ExceptT . liftIO $ fmap handleOAuth2TokenResponse go   where@@ -264,26 +292,26 @@       httpLbs (urlEncodedBody body req') manager  -- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error'-handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString+handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenRequestError BSL.ByteString handleOAuth2TokenResponse rsp =   if HT.statusIsSuccessful (responseStatus rsp)     then Right $ responseBody rsp-    else Left $ parseOAuth2Error (responseBody rsp)+    else Left $ parseTokeRequestError (responseBody rsp)  -- | Try to parses response as JSON, if failed, try to parse as like query string. parseResponseFlexible ::-  (FromJSON err, FromJSON a) =>+  (FromJSON a) =>   BSL.ByteString ->-  Either (OAuth2Error err) a+  Either TokenRequestError a parseResponseFlexible r = case eitherDecode r of   Left _ -> parseResponseString r   Right x -> Right x  -- | Parses the response that contains not JSON but a Query String parseResponseString ::-  (FromJSON err, FromJSON a) =>+  (FromJSON a) =>   BSL.ByteString ->-  Either (OAuth2Error err) a+  Either TokenRequestError a parseResponseString b = case parseQuery $ BSL.toStrict b of   [] -> Left errorMessage   a -> case fromJSON $ queryToValue a of@@ -292,7 +320,7 @@   where     queryToValue = Object . KeyMap.fromList . map paramToPair     paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = parseOAuth2Error b+    errorMessage = parseTokeRequestError b  -- | Set several header values: --   + userAgennt    : `hoauth2`@@ -305,6 +333,6 @@ -- | Add Credential (client_id, client_secret) to the request post body. clientSecretPost :: OAuth2 -> PostBody clientSecretPost oa =-  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-    ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)+  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)+  , ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)   ]

@@ -86,12 +86,10 @@ -- @ -- -- Also you could find example from @hoauth2-providers-tutorials@ module.----module Network.OAuth2.Experiment-  ( module Network.OAuth2.Experiment.Types,-    module Network.OAuth2.Experiment.Pkce-  )-where+module Network.OAuth2.Experiment (+  module Network.OAuth2.Experiment.Types,+  module Network.OAuth2.Experiment.Pkce,+) where  import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types

@@ -1,11 +1,10 @@-module Network.OAuth2.Experiment.Pkce-  ( mkPkceParam,-    CodeChallenge (..),-    CodeVerifier (..),-    CodeChallengeMethod (..),-    PkceRequestParam (..),-  )-where+module Network.OAuth2.Experiment.Pkce (+  mkPkceParam,+  CodeChallenge (..),+  CodeVerifier (..),+  CodeChallengeMethod (..),+  PkceRequestParam (..),+) where  import Control.Monad.IO.Class import Crypto.Hash qualified as H@@ -25,11 +24,11 @@   deriving (Show)  data PkceRequestParam = PkceRequestParam-  { codeVerifier :: CodeVerifier,-    codeChallenge :: CodeChallenge,-    -- | spec says optional but really it shall be s256 or can be omitted?-    -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3-    codeChallengeMethod :: CodeChallengeMethod+  { codeVerifier :: CodeVerifier+  , codeChallenge :: CodeChallenge+  , codeChallengeMethod :: CodeChallengeMethod+  -- ^ spec says optional but really it shall be s256 or can be omitted?+  -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3   }  mkPkceParam :: MonadIO m => m PkceRequestParam@@ -37,9 +36,9 @@   codeV <- genCodeVerifier   pure     PkceRequestParam-      { codeVerifier = CodeVerifier (T.decodeUtf8 codeV),-        codeChallenge = CodeChallenge (encodeCodeVerifier codeV),-        codeChallengeMethod = S256+      { codeVerifier = CodeVerifier (T.decodeUtf8 codeV)+      , codeChallenge = CodeChallenge (encodeCodeVerifier codeV)+      , codeChallengeMethod = S256       }  encodeCodeVerifier :: BS.ByteString -> Text

@@ -15,9 +15,10 @@ module Network.OAuth2.Experiment.Types where  import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT)+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@@ -29,10 +30,9 @@ import Data.Text.Encoding qualified as T import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL-import Network.HTTP.Conduit (Manager)+import Network.HTTP.Conduit import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth.OAuth2 qualified as OAuth2-import Network.OAuth.OAuth2.TokenRequest qualified as TR import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils import URI.ByteString hiding (UserInfo)@@ -47,7 +47,15 @@  ------------------------------------------------------------------------------- -data GrantTypeFlow = AuthorizationCode | ResourceOwnerPassword | ClientCredentials+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  ------------------------------------------------------------------------------- @@ -73,10 +81,17 @@  ------------------------------------------------------------------------------- +newtype UrnOAuthParam a = UrnOAuthParam a+ -- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict. -- -- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow.-data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken+data GrantTypeValue+  = GTAuthorizationCode+  | GTPassword+  | GTClientCredentials+  | GTRefreshToken+  | GTJwtBearer   deriving (Eq, Show)  -------------------------------------------------------------------------------@@ -107,6 +122,7 @@ newtype ClientId = ClientId {unClientId :: Text}   deriving (Show, Eq, IsString) +-- | Can be either "Client Secret" or JWT base on client authentication method newtype ClientSecret = ClientSecret {unClientSecret :: Text}   deriving (Eq, IsString) @@ -115,8 +131,8 @@ toOAuth2Key :: ClientId -> ClientSecret -> OAuth2 toOAuth2Key cid csecret =   def-    { oauth2ClientId = TL.toStrict $ unClientId cid,-      oauth2ClientSecret = TL.toStrict $ unClientSecret csecret+    { oauth2ClientId = TL.toStrict $ unClientId cid+    , oauth2ClientSecret = TL.toStrict $ unClientSecret csecret     }  newtype RedirectUri = RedirectUri {unRedirectUri :: URI}@@ -165,6 +181,7 @@       val GTPassword = "password"       val GTClientCredentials = "client_credentials"       val GTRefreshToken = "refresh_token"+      val GTJwtBearer = "urn:ietf:params:oauth:grant-type:jwt-bearer"  instance ToQueryParam ClientId where   toQueryParam :: ClientId -> Map Text Text@@ -222,9 +239,6 @@  ------------------------------------------------------------------------------- -class HasIdpAppName (a :: GrantTypeFlow) where-  getIdpAppName :: IdpApplication a i -> Text- class HasAuthorizeRequest (a :: GrantTypeFlow) where   data AuthorizationRequest a   type MkAuthorizationRequestResponse a@@ -249,7 +263,7 @@     (MonadIO m) =>     IdpApplication a i ->     Manager ->-    WithExchangeToken a (ExceptT (OAuth2Error TR.Errors) m OAuth2Token)+    WithExchangeToken a (ExceptT TokenRequestError m OAuth2Token)  class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where   mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier)@@ -260,7 +274,7 @@     IdpApplication b i ->     Manager ->     (ExchangeToken, CodeVerifier) ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+    ExceptT TokenRequestError m OAuth2Token  class HasRefreshTokenRequest (a :: GrantTypeFlow) where   -- | https://www.rfc-editor.org/rfc/rfc6749#page-47@@ -272,7 +286,7 @@     IdpApplication a i ->     Manager ->     OAuth2.RefreshToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+    ExceptT TokenRequestError m OAuth2Token  ------------------------------------------------------------------------------- @@ -298,12 +312,12 @@  -- | 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+  { 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 ::+    idpAuthorizeEndpoint :: URI+  , idpTokenEndpoint :: URI+  , idpFetchUserInfo ::       forall m.       (FromJSON (IdpUserInfo a), MonadIO m) =>       Manager ->@@ -328,16 +342,16 @@  -- | An Application that supports "Authorization code" flow data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication-  { idpAppName :: Text,-    idpAppClientId :: ClientId,-    idpAppClientSecret :: ClientSecret,-    idpAppScope :: Set Scope,-    idpAppRedirectUri :: URI,-    idpAppAuthorizeState :: AuthorizeState,-    -- | Though technically one key can have multiple value in query, but who actually does it?!-    idpAppAuthorizeExtraParams :: Map Text Text,-    idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod,-    idp :: Idp i+  { 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@@ -345,27 +359,23 @@ -- parseAuthorizationResponse :: String -> AuthorizationResponse -- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse -instance HasIdpAppName 'AuthorizationCode where-  getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text-  getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName- instance HasAuthorizeRequest 'AuthorizationCode where   -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1   data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest-    { scope :: Set Scope,-      state :: AuthorizeState,-      clientId :: ClientId,-      redirectUri :: Maybe RedirectUri+    { 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)+      { scope = if null idpAppScope then Set.empty else idpAppScope+      , state = idpAppAuthorizeState+      , clientId = idpAppClientId+      , redirectUri = Just (RedirectUri idpAppRedirectUri)       }    mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text@@ -384,10 +394,10 @@ 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+    { code :: ExchangeToken+    , clientId :: ClientId+    , grantType :: GrantTypeValue+    , redirectUri :: RedirectUri     }   type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a @@ -397,10 +407,10 @@     TokenRequest 'AuthorizationCode   mkTokenRequest AuthorizationCodeIdpApplication {..} authCode =     AuthorizationCodeTokenRequest-      { code = authCode,-        clientId = idpAppClientId,-        grantType = GTAuthorizationCode,-        redirectUri = RedirectUri idpAppRedirectUri+      { code = authCode+      , clientId = idpAppClientId+      , grantType = GTAuthorizationCode+      , redirectUri = RedirectUri idpAppRedirectUri       }   conduitTokenRequest ::     forall m i.@@ -408,14 +418,14 @@     IdpApplication 'AuthorizationCode i ->     Manager ->     ExchangeToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+    ExceptT TokenRequestError m OAuth2Token   conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken =     let req = mkTokenRequest idpAppConfig exchangeToken         key = toOAuth2Key idpAppClientId idpAppClientSecret         body =           mapsToParams-            [ toQueryParam req,-              toQueryParam+            [ toQueryParam req+            , toQueryParam                 ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost                     then Just idpAppClientSecret                     else Nothing@@ -430,10 +440,10 @@     let req = mkAuthorizeRequestParameter idpAppConfig     let allParams =           mapsToParams-            [ idpAppAuthorizeExtraParams,-              toQueryParam req,-              toQueryParam codeChallenge,-              toQueryParam codeChallengeMethod+            [ idpAppAuthorizeExtraParams+            , toQueryParam req+            , toQueryParam codeChallenge+            , toQueryParam codeChallengeMethod             ]      let url =@@ -450,45 +460,45 @@     IdpApplication 'AuthorizationCode i ->     Manager ->     (ExchangeToken, CodeVerifier) ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+    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)+            [ 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+    { 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+      { scope = idpAppScope+      , grantType = GTRefreshToken+      , refreshToken = rt       }   conduitRefreshTokenRequest ::     (MonadIO m) =>     IdpApplication 'AuthorizationCode i ->     Manager ->     OAuth2.RefreshToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+    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)+            [ toQueryParam req+            , toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing)             ]      in doJSONPostRequest mgr key (idpTokenEndpoint idp) body @@ -506,33 +516,90 @@   toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text   toQueryParam req@AuthorizationCodeAuthorizationRequest {..} =     Map.unions-      [ toResponseTypeParam req,-        toQueryParam scope,-        toQueryParam clientId,-        toQueryParam state,-        toQueryParam redirectUri+      [ 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+      [ 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+      [ 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  -------------------------------------------------------------------------------@@ -545,51 +612,47 @@ -- -- Hence no AuhorizationRequest instance -data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPAppConfig-  { idpAppClientId :: ClientId,-    idpAppClientSecret :: ClientSecret,-    idpAppName :: Text,-    idpAppScope :: Set Scope,-    idpAppUserName :: Username,-    idpAppPassword :: Password,-    -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec-    idpAppTokenRequestExtraParams :: Map Text Text,-    idp :: Idp i+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 HasIdpAppName 'ResourceOwnerPassword where-  getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text-  getIdpAppName ResourceOwnerPasswordIDPAppConfig {..} = idpAppName- instance HasUserInfoRequest 'ResourceOwnerPassword where-  conduitUserInfoRequest ResourceOwnerPasswordIDPAppConfig {..} mgr at = do+  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+    { scope :: Set Scope+    , username :: Username+    , password :: Password+    , grantType :: GrantTypeValue     }   type WithExchangeToken 'ResourceOwnerPassword a = a    mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword-  mkTokenRequest ResourceOwnerPasswordIDPAppConfig {..} =+  mkTokenRequest ResourceOwnerPasswordIDPApplication {..} =     PasswordTokenRequest-      { username = idpAppUserName,-        password = idpAppPassword,-        grantType = GTPassword,-        scope = idpAppScope+      { username = idpAppUserName+      , password = idpAppPassword+      , grantType = GTPassword+      , scope = idpAppScope       }    conduitTokenRequest ::     (MonadIO m) =>     IdpApplication 'ResourceOwnerPassword i ->     Manager ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPAppConfig {..} mgr =+    ExceptT TokenRequestError m OAuth2Token+  conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPApplication {..} mgr =     let req = mkTokenRequest idpAppConfig         key = toOAuth2Key idpAppClientId idpAppClientSecret         body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req]@@ -610,17 +673,17 @@     IdpApplication 'ResourceOwnerPassword i ->     Manager ->     OAuth2.RefreshToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token+    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+      [ toQueryParam grantType+      , toQueryParam scope+      , toQueryParam username+      , toQueryParam password       ]  -------------------------------------------------------------------------------@@ -636,58 +699,80 @@ -- -- Hence no AuhorizationRequest instance -data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPAppConfig-  { idpAppClientId :: ClientId,-    idpAppClientSecret :: ClientSecret,-    idpAppName :: Text,-    idpAppScope :: Set Scope,-    -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec-    idpAppTokenRequestExtraParams :: Map Text Text,-    idp :: Idp i+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 HasIdpAppName 'ClientCredentials where-  getIdpAppName :: IdpApplication 'ClientCredentials i -> Text-  getIdpAppName ClientCredentialsIDPAppConfig {..} = idpAppName- instance HasTokenRequest 'ClientCredentials where   -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2   data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest-    { scope :: Set Scope,-      grantType :: GrantTypeValue+    { scope :: Set Scope+    , grantType :: GrantTypeValue+    , clientAssertionType :: Text+    , clientAssertion :: BS.ByteString+    , clientAuthenticationMethod :: ClientAuthenticationMethod     }    type WithExchangeToken 'ClientCredentials a = a    mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials-  mkTokenRequest ClientCredentialsIDPAppConfig {..} =+  mkTokenRequest ClientCredentialsIDPApplication {..} =     ClientCredentialsTokenRequest-      { scope = idpAppScope,-        grantType = GTClientCredentials+      { 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 (OAuth2Error TR.Errors) m OAuth2Token-  conduitTokenRequest idpAppConfig@ClientCredentialsIDPAppConfig {..} mgr =-    let req = mkTokenRequest idpAppConfig+    ExceptT TokenRequestError m OAuth2Token+  conduitTokenRequest idpAppConfig@ClientCredentialsIDPApplication {..} mgr = do+    let tokenReq = mkTokenRequest idpAppConfig         key =           toOAuth2Key             idpAppClientId             idpAppClientSecret         body =           mapsToParams-            [ idpAppTokenRequestExtraParams,-              toQueryParam req+            [ idpAppTokenRequestExtraParams+            , toQueryParam tokenReq             ]-     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body+    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.unions $+      [ toQueryParam grantType+      , toQueryParam scope       ]+        ++ [ Map.fromList+              ( if clientAuthenticationMethod == ClientAssertionJwt+                  then+                    [ ("client_assertion_type", clientAssertionType)+                    , ("client_assertion", bs8ToLazyText clientAssertion)+                    ]+                  else []+              )+           ]

@@ -0,0 +1,23 @@+module Network.OAuth.OAuth2.TokenRequestSpec where++import Data.Aeson qualified as Aeson+import Network.OAuth.OAuth2.TokenRequest+import Test.Hspec++spec :: Spec+spec =+  describe "parseJSON TokenRequestErrorCode" $ do+    it "invalid_request" $ do+      Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest+    it "invalid_client" $ do+      Aeson.eitherDecode "\"invalid_client\"" `shouldBe` Right InvalidClient+    it "invalid_grant" $ do+      Aeson.eitherDecode "\"invalid_grant\"" `shouldBe` Right InvalidGrant+    it "unauthorized_client" $ do+      Aeson.eitherDecode "\"unauthorized_client\"" `shouldBe` Right UnauthorizedClient+    it "unsupported_grant_type" $ do+      Aeson.eitherDecode "\"unsupported_grant_type\"" `shouldBe` Right UnsupportedGrantType+    it "invalid_scope" $ do+      Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope+    it "foo_code" $ do+      Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code")

@@ -0,0 +1,2 @@+-- file test/Spec.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}