diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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 diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs --- a/src/Network/OAuth/OAuth2.hs +++ b/src/Network/OAuth/OAuth2.hs @@ -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 diff --git a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs --- a/src/Network/OAuth/OAuth2/AuthorizationRequest.hs +++ b/src/Network/OAuth/OAuth2/AuthorizationRequest.hs @@ -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) ] diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -4,39 +4,38 @@ -- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage -- RFC6750 -module Network.OAuth.OAuth2.HttpClient - ( -- * AUTH requests - authGetJSON, - authGetBS, - authGetBS2, - authGetJSONWithAuthMethod, - authGetJSONInternal, - authGetBSWithAuthMethod, - authGetBSInternal, - authPostJSON, - authPostBS, - authPostBS2, - authPostBS3, - authPostJSONWithAuthMethod, - authPostJSONInternal, - authPostBSWithAuthMethod, - authPostBSInternal, +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` diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -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 diff --git a/src/Network/OAuth/OAuth2/TokenRequest.hs b/src/Network/OAuth/OAuth2/TokenRequest.hs --- a/src/Network/OAuth/OAuth2/TokenRequest.hs +++ b/src/Network/OAuth/OAuth2/TokenRequest.hs @@ -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) ] diff --git a/src/Network/OAuth2/Experiment.hs b/src/Network/OAuth2/Experiment.hs --- a/src/Network/OAuth2/Experiment.hs +++ b/src/Network/OAuth2/Experiment.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Pkce.hs b/src/Network/OAuth2/Experiment/Pkce.hs --- a/src/Network/OAuth2/Experiment/Pkce.hs +++ b/src/Network/OAuth2/Experiment/Pkce.hs @@ -1,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 diff --git a/src/Network/OAuth2/Experiment/Types.hs b/src/Network/OAuth2/Experiment/Types.hs --- a/src/Network/OAuth2/Experiment/Types.hs +++ b/src/Network/OAuth2/Experiment/Types.hs @@ -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 [] + ) + ] diff --git a/test/Network/OAuth/OAuth2/TokenRequestSpec.hs b/test/Network/OAuth/OAuth2/TokenRequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth/OAuth2/TokenRequestSpec.hs @@ -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") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}