diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -2,9 +2,11 @@ name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -version: 2.8.1 +version: 2.9.0 synopsis: Haskell OAuth2 authentication client -description: See readme for more details. +description: + This is Haskell binding of OAuth2 Authorization framework and Bearer Token Usage framework. + homepage: https://github.com/freizl/hoauth2 license: MIT license-file: LICENSE @@ -26,9 +28,9 @@ default-language: Haskell2010 autogen-modules: Paths_hoauth2 other-modules: + Network.HTTP.Client.Contrib Network.OAuth.OAuth2.Internal - Network.OAuth2.Experiment.Pkce - Network.OAuth2.Experiment.Types + Network.OAuth2.Experiment.Grants Network.OAuth2.Experiment.Utils Paths_hoauth2 @@ -38,15 +40,27 @@ Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.TokenRequest Network.OAuth2.Experiment + Network.OAuth2.Experiment.Grants.AuthorizationCode + Network.OAuth2.Experiment.Grants.ClientCredentials + Network.OAuth2.Experiment.Grants.DeviceAuthorization + Network.OAuth2.Experiment.Grants.JwtBearer + Network.OAuth2.Experiment.Grants.ResourceOwnerPassword + Network.OAuth2.Experiment.Flows.AuthorizationRequest + Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest + Network.OAuth2.Experiment.Flows.RefreshTokenRequest + Network.OAuth2.Experiment.Flows.TokenRequest + Network.OAuth2.Experiment.Flows.UserInfoRequest + Network.OAuth2.Experiment.Types + Network.OAuth2.Experiment.Pkce default-extensions: - DataKinds DeriveGeneric GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs OverloadedStrings + PolyKinds RecordWildCards - TypeApplications TypeFamilies build-depends: @@ -64,13 +78,13 @@ , memory ^>=0.18 , microlens ^>=0.4.0 , text ^>=2.0 - , transformers >=0.6 + , transformers >=0.4 && <0.7 , uri-bytestring >=0.2.3 && <0.4 , uri-bytestring-aeson ^>=0.1 ghc-options: -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields - -Wwarnings-deprecations + -Wwarn -Wwarnings-deprecations test-suite hoauth-tests type: exitcode-stdio-1.0 @@ -78,10 +92,11 @@ hs-source-dirs: test ghc-options: -Wall build-depends: - , aeson >=2.0 && <2.2 - , base >=4 && <5 + , aeson >=2.0 && <2.2 + , base >=4 && <5 , hoauth2 - , hspec >=2 && <3 + , hspec >=2 && <3 + , uri-bytestring >=0.2.3 && <0.4 other-modules: Network.OAuth.OAuth2.TokenRequestSpec default-language: Haskell2010 @@ -90,3 +105,6 @@ OverloadedStrings build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + ghc-options: + -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields + -Wwarn -Wwarnings-deprecations diff --git a/src/Network/HTTP/Client/Contrib.hs b/src/Network/HTTP/Client/Contrib.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Contrib.hs @@ -0,0 +1,25 @@ +module Network.HTTP.Client.Contrib where + +import Data.Aeson +import Data.Bifunctor +import Data.ByteString.Lazy.Char8 qualified as BSL +import Network.HTTP.Conduit +import Network.HTTP.Types qualified as HT + +-- | Get response body out of a @Response@ +handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString +handleResponse rsp + | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp) + -- TODO: better to surface up entire resp so that client can decide what to do when error happens. + -- e.g. when 404, the response body could be empty hence library user has no idea what's happening. + -- Which will be breaking changes. + -- The current work around is surface up entire response as string. + | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp) + | otherwise = Left (responseBody rsp) + +handleResponseJSON :: + FromJSON a => + Response BSL.ByteString -> + Either BSL.ByteString a +handleResponseJSON = + either Left (first BSL.pack . eitherDecode) . handleResponse 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,17 +1,26 @@ -- | A lightweight oauth2 Haskell binding. -- See Readme for more details module Network.OAuth.OAuth2 ( - module Network.OAuth.OAuth2.HttpClient, + module Network.OAuth.OAuth2.Internal, + + -- * Authorization Requset module Network.OAuth.OAuth2.AuthorizationRequest, + + -- * Token Request module Network.OAuth.OAuth2.TokenRequest, - module Network.OAuth.OAuth2.Internal, + + -- * OAuth'ed http client utilities + module Network.OAuth.OAuth2.HttpClient, ) where {- Hiding Errors data type from default. Shall qualified import given the naming collision. -} -import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors (..)) +import Network.OAuth.OAuth2.AuthorizationRequest hiding ( + AuthorizationResponseError (..), + AuthorizationResponseErrorCode (..), + ) import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2.Internal import Network.OAuth.OAuth2.TokenRequest 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 @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Bindings Authorization part of The OAuth 2.0 Authorization Framework -- RFC6749 module Network.OAuth.OAuth2.AuthorizationRequest where @@ -8,28 +5,34 @@ import Data.Aeson import Data.Function (on) import Data.List qualified as List +import Data.Text (Text) import Data.Text.Encoding qualified as T -import GHC.Generics (Generic) import Lens.Micro (over) import Network.OAuth.OAuth2.Internal import URI.ByteString +import Prelude hiding (error) -------------------------------------------------- --- * Errors +-- * Authorization Request Errors -------------------------------------------------- -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_'} - -- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 +-- -- I found hard time to figure a way to test the authorization error flow -- When anything wrong in @/authorize@ request, it will stuck at the Provider page -- hence no way for this library to parse error response. -- In other words, @/authorize@ ends up with 4xx or 5xx. -- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors. -data Errors +data AuthorizationResponseError = AuthorizationResponseError + { authorizationResponseError :: AuthorizationResponseErrorCode + , authorizationResponseErrorDescription :: Maybe Text + , authorizationResponseErrorUri :: Maybe (URIRef Absolute) + } + deriving (Show, Eq) + +data AuthorizationResponseErrorCode = InvalidRequest | UnauthorizedClient | AccessDenied @@ -37,7 +40,27 @@ | InvalidScope | ServerError | TemporarilyUnavailable - deriving (Show, Eq, Generic) + | UnknownErrorCode Text + deriving (Show, Eq) + +instance FromJSON AuthorizationResponseErrorCode where + parseJSON = withText "parseJSON AuthorizationResponseErrorCode" $ \t -> + pure $ case t of + "invalid_request" -> InvalidRequest + "unauthorized_client" -> UnauthorizedClient + "access_denied" -> AccessDenied + "unsupported_response_type" -> UnsupportedResponseType + "invalid_scope" -> InvalidScope + "server_error" -> ServerError + "temporarily_unavailable" -> TemporarilyUnavailable + _ -> UnknownErrorCode t + +instance FromJSON AuthorizationResponseError where + parseJSON = withObject "parseJSON AuthorizationResponseError" $ \t -> do + authorizationResponseError <- t .: "error" + authorizationResponseErrorDescription <- t .:? "error_description" + authorizationResponseErrorUri <- t .:? "error_uri" + pure AuthorizationResponseError {..} -------------------------------------------------- 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 @@ -1,7 +1,3 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage -- RFC6750 module Network.OAuth.OAuth2.HttpClient ( @@ -34,6 +30,7 @@ import Data.Maybe (fromJust, isJust) import Data.Text.Encoding qualified as T import Lens.Micro (over) +import Network.HTTP.Client.Contrib (handleResponse) import Network.HTTP.Conduit import Network.HTTP.Types qualified as HT import Network.OAuth.OAuth2.Internal @@ -50,7 +47,7 @@ -- | Conduct an authorized GET request and return response as JSON. -- Inject Access Token to Authorization Header. authGetJSON :: - (FromJSON a, MonadIO m) => + (MonadIO m, FromJSON a) => -- | HTTP connection manager. Manager -> AccessToken -> @@ -59,8 +56,9 @@ ExceptT BSL.ByteString m a authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader +-- | Deprecated. Use `authGetJSONWithAuthMethod` instead. authGetJSONInternal :: - (FromJSON a, MonadIO m) => + (MonadIO m, FromJSON a) => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -91,7 +89,7 @@ -- | Conduct an authorized GET request. -- Inject Access Token to Authorization Header. authGetBS :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> AccessToken -> @@ -102,7 +100,7 @@ -- | Same to 'authGetBS' but set access token to query parameter rather than header authGetBS2 :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> AccessToken -> @@ -113,7 +111,7 @@ {-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-} authGetBSInternal :: - (MonadIO m) => + MonadIO m => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -129,7 +127,7 @@ -- -- @since 2.6.0 authGetBSWithAuthMethod :: - (MonadIO m) => + MonadIO m => -- | Specify the way that how to append the 'AccessToken' in the request APIAuthenticationMethod -> -- | HTTP connection manager. @@ -149,7 +147,7 @@ -- | Conduct POST request and return response as JSON. -- Inject Access Token to Authorization Header. authPostJSON :: - (FromJSON a, MonadIO m) => + (MonadIO m, FromJSON a) => -- | HTTP connection manager. Manager -> AccessToken -> @@ -160,7 +158,7 @@ authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader authPostJSONInternal :: - (FromJSON a, MonadIO m) => + (MonadIO m, FromJSON a) => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -177,7 +175,7 @@ -- -- @since 2.6.0 authPostJSONWithAuthMethod :: - (FromJSON a, MonadIO m) => + (MonadIO m, FromJSON a) => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -193,7 +191,7 @@ -- | Conduct POST request. -- Inject Access Token to http header (Authorization) authPostBS :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> AccessToken -> @@ -205,7 +203,7 @@ -- | Conduct POST request with access token only in the request body but header. authPostBS2 :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> AccessToken -> @@ -218,7 +216,7 @@ -- | Conduct POST request with access token only in the header and not in body authPostBS3 :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> AccessToken -> @@ -230,7 +228,7 @@ {-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-} authPostBSInternal :: - (MonadIO m) => + MonadIO m => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -247,7 +245,7 @@ -- -- @since 2.6.0 authPostBSWithAuthMethod :: - (MonadIO m) => + MonadIO m => APIAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -293,7 +291,7 @@ -- | Send an HTTP request. authRequest :: - (MonadIO m) => + MonadIO m => -- | Request to perform Request -> -- | Modify request before sending @@ -305,21 +303,10 @@ resp <- httpLbs (upReq req) manage pure (handleResponse resp) --- | Get response body out of a @Response@ -handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString -handleResponse rsp - | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp) - -- FIXME: better to surface up entire resp so that client can decide what to do when error happens. - -- e.g. when 404, the response body could be empty hence library user has no idea what's happening. - -- Which will be breaking changes. - -- The current work around is surface up entire response as string. - | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp) - | otherwise = Left (responseBody rsp) - -- | Set several header values: --- + userAgennt : `hoauth2` --- + accept : `application/json` --- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. +-- + userAgennt : "hoauth2" +-- + accept : "application/json" +-- + authorization : "Bearer xxxxx" if 'Network.OAuth.OAuth2.AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = let bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t] @@ -330,7 +317,7 @@ setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req {method = HT.renderStdMethod m} --- | For `GET` method API. +-- | For @GET@ method API. appendAccessToken :: -- | Base URI URIRef a -> @@ -340,6 +327,6 @@ URIRef a appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri --- | Create 'QueryParams' with given access token value. +-- | Create `QueryParams` with given access token value. accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)] 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 @@ -1,8 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} module Network.OAuth.OAuth2.Internal where @@ -28,11 +24,11 @@ import URI.ByteString.Aeson () import URI.ByteString.QQ --------------------------------------------------- +------------------------------------------------------------------------------- --- * Data Types +-- * OAuth2 Configuration --------------------------------------------------- +------------------------------------------------------------------------------- -- | Query Parameter Representation data OAuth2 = OAuth2 @@ -54,6 +50,12 @@ , oauth2RedirectUri = [uri|https://www.example.com/|] } +------------------------------------------------------------------------------- + +-- * Tokens + +------------------------------------------------------------------------------- + newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) @@ -63,16 +65,18 @@ -- | Authorization Code newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) +-- FIXME: rename to TokenResponse and move to that module + -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4 data OAuth2Token = OAuth2Token { accessToken :: AccessToken , refreshToken :: Maybe RefreshToken - -- ^ Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token. + -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token. , expiresIn :: Maybe Int , tokenType :: Maybe Text -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release. , idToken :: Maybe IdToken - -- ^ Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID. + -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol. } deriving (Eq, Show, Generic) @@ -82,15 +86,11 @@ instance FromJSON OAuth2Token where parseJSON = withObject "OAuth2Token" $ \v -> OAuth2Token - <$> v - .: "access_token" - <*> v - .:? "refresh_token" + <$> v .: "access_token" + <*> v .:? "refresh_token" <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" - <*> v - .:? "token_type" - <*> v - .:? "id_token" + <*> v .:? "token_type" + <*> v .:? "id_token" where parseIntFlexible :: Value -> Parser Int parseIntFlexible (String s) = pure . read $ unpack s @@ -100,6 +100,12 @@ toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} +------------------------------------------------------------------------------- + +-- * Client Authentication methods + +------------------------------------------------------------------------------- + -- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3 -- According to spec: -- @@ -107,33 +113,28 @@ -- -- Which means use Authorization header or Post body. -- --- However, in reality, I always have to include authentication in the header. +-- However, I found I have to include authentication in the header all the time in real world. -- --- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional. +-- In other words, `ClientSecretBasic` is always assured. `ClientSecretPost` is optional. -- -- Maybe consider an alternative implementation that boolean kind of data type is good enough. data ClientAuthenticationMethod = ClientSecretBasic | ClientSecretPost | ClientAssertionJwt - deriving (Eq, Ord) + deriving (Eq) --------------------------------------------------- +------------------------------------------------------------------------------- --- * Types Synonym +-- * Utilies for Request and URI --------------------------------------------------- +------------------------------------------------------------------------------- --- | type synonym of post body content +-- | Type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)] +-- | Type sysnonym of request query params type QueryParams = [(BS.ByteString, BS.ByteString)] - --------------------------------------------------- - --- * Utilies - --------------------------------------------------- defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)] defaultRequestHeaders = 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,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework -- RFC6749 module Network.OAuth.OAuth2.TokenRequest where @@ -13,12 +11,12 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import GHC.Generics (Generic) import Network.HTTP.Conduit import Network.HTTP.Types qualified as HT import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal import URI.ByteString +import Prelude hiding (error) -------------------------------------------------- @@ -26,15 +24,15 @@ -------------------------------------------------- -data TokenRequestError = TokenRequestError - { error :: TokenRequestErrorCode - , errorDescription :: Maybe Text - , errorUri :: Maybe (URIRef Absolute) +data TokenResponseError = TokenResponseError + { tokenResponseError :: TokenResponseErrorCode + , tokenResponseErrorDescription :: Maybe Text + , tokenResponseErrorUri :: Maybe (URIRef Absolute) } - deriving (Show, Eq, Generic) + deriving (Show, Eq) -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 -data TokenRequestErrorCode +data TokenResponseErrorCode = InvalidRequest | InvalidClient | InvalidGrant @@ -44,8 +42,8 @@ | UnknownErrorCode Text deriving (Show, Eq) -instance FromJSON TokenRequestErrorCode where - parseJSON = withText "parseJSON TokenRequestErrorCode" $ \t -> +instance FromJSON TokenResponseErrorCode where + parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t -> pure $ case t of "invalid_request" -> InvalidRequest "invalid_client" -> InvalidClient @@ -55,18 +53,22 @@ "invalid_scope" -> InvalidScope _ -> UnknownErrorCode t -instance FromJSON TokenRequestError where - parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_'} +instance FromJSON TokenResponseError where + parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do + tokenResponseError <- t .: "error" + tokenResponseErrorDescription <- t .:? "error_description" + tokenResponseErrorUri <- t .:? "error_uri" + pure TokenResponseError {..} -parseTokeRequestError :: BSL.ByteString -> TokenRequestError -parseTokeRequestError string = +parseTokeResponseError :: BSL.ByteString -> TokenResponseError +parseTokeResponseError string = either (mkDecodeOAuth2Error string) id (eitherDecode string) where - mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenRequestError + mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError mkDecodeOAuth2Error response err = - TokenRequestError + TokenResponseError (UnknownErrorCode "") - (Just $ T.pack $ "Decode TokenRequestError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response)) + (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response)) Nothing -------------------------------------------------- @@ -114,7 +116,7 @@ -- | Exchange @code@ for an Access Token with authenticate in request header. fetchAccessToken :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager Manager -> -- | OAuth Data @@ -122,11 +124,11 @@ -- | OAuth2 Code ExchangeToken -> -- | Access Token - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic fetchAccessToken2 :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager Manager -> -- | OAuth Data @@ -134,12 +136,12 @@ -- | Authorization Code ExchangeToken -> -- | Access Token - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-} fetchAccessTokenInternal :: - (MonadIO m) => + MonadIO m => ClientAuthenticationMethod -> -- | HTTP connection manager Manager -> @@ -148,24 +150,24 @@ -- | Authorization Code ExchangeToken -> -- | Access Token - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod {-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-} -- | Exchange @code@ for an Access Token -- --- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent --- either in the header (a.k.a 'ClientSecretBasic'). --- or as form/url params (a.k.a 'ClientSecretPost'). +-- OAuth2 spec allows credential (@client_id@, @client_secret@) to be sent +-- either in the header (a.k.a `ClientSecretBasic`). +-- or as form/url params (a.k.a `ClientSecretPost`). -- -- The OAuth provider can choose to implement only one, or both. -- Look for API document from the OAuth provider you're dealing with. --- If you're uncertain, try 'fetchAccessToken' which sends credential +-- If you`re uncertain, try `fetchAccessToken` which sends credential -- in authorization http header, which is common case. -- -- @since 2.6.0 fetchAccessTokenWithAuthMethod :: - (MonadIO m) => + MonadIO m => ClientAuthenticationMethod -> -- | HTTP connection manager Manager -> @@ -174,7 +176,7 @@ -- | Authorization Code ExchangeToken -> -- | Access Token - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token fetchAccessTokenWithAuthMethod authMethod manager oa code = do let (uri, body) = accessTokenUrl oa code let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else [] @@ -182,30 +184,30 @@ -- | Fetch a new AccessToken using the Refresh Token with authentication in request header. refreshAccessToken :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> -- | OAuth context OAuth2 -> -- | Refresh Token gained after authorization RefreshToken -> - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic refreshAccessToken2 :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> -- | OAuth context OAuth2 -> -- | Refresh Token gained after authorization RefreshToken -> - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost {-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-} refreshAccessTokenInternal :: - (MonadIO m) => + MonadIO m => ClientAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -213,13 +215,13 @@ OAuth2 -> -- | Refresh Token gained after authorization RefreshToken -> - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod {-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-} -- | Fetch a new AccessToken using the Refresh Token. -- --- OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent +-- OAuth2 spec allows credential ("client_id", "client_secret") to be sent -- either in the header (a.k.a 'ClientSecretBasic'). -- or as form/url params (a.k.a 'ClientSecretPost'). -- @@ -230,7 +232,7 @@ -- -- @since 2.6.0 refreshAccessTokenWithAuthMethod :: - (MonadIO m) => + MonadIO m => ClientAuthenticationMethod -> -- | HTTP connection manager. Manager -> @@ -238,7 +240,7 @@ OAuth2 -> -- | Refresh Token gained after authorization RefreshToken -> - ExceptT TokenRequestError m OAuth2Token + ExceptT TokenResponseError m OAuth2Token refreshAccessTokenWithAuthMethod authMethod manager oa token = do let (uri, body) = refreshAccessTokenUrl oa token let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else [] @@ -262,7 +264,7 @@ -- | request body PostBody -> -- | Response as JSON - ExceptT TokenRequestError m a + ExceptT TokenResponseError m a doJSONPostRequest manager oa uri body = do resp <- doSimplePostRequest manager oa uri body case parseResponseFlexible resp of @@ -271,7 +273,7 @@ -- | Conduct post request. doSimplePostRequest :: - (MonadIO m) => + MonadIO m => -- | HTTP connection manager. Manager -> -- | OAuth options @@ -281,37 +283,36 @@ -- | Request body. PostBody -> -- | Response as ByteString - ExceptT TokenRequestError m BSL.ByteString + ExceptT TokenResponseError m BSL.ByteString doSimplePostRequest manager oa url body = ExceptT . liftIO $ fmap handleOAuth2TokenResponse go where - addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa) go = do req <- uriToRequest url - let req' = (addBasicAuth . addDefaultRequestHeaders) req + let req' = (addBasicAuth oa . addDefaultRequestHeaders) req httpLbs (urlEncodedBody body req') manager --- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error' -handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenRequestError BSL.ByteString +-- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth.OAuth2.TokenRequest.TokenResponseError' +handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString handleOAuth2TokenResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp - else Left $ parseTokeRequestError (responseBody rsp) + else Left $ parseTokeResponseError (responseBody rsp) -- | Try to parses response as JSON, if failed, try to parse as like query string. parseResponseFlexible :: - (FromJSON a) => + FromJSON a => BSL.ByteString -> - Either TokenRequestError a + Either TokenResponseError a parseResponseFlexible r = case eitherDecode r of Left _ -> parseResponseString r Right x -> Right x -- | Parses the response that contains not JSON but a Query String parseResponseString :: - (FromJSON a) => + FromJSON a => BSL.ByteString -> - Either TokenRequestError a + Either TokenResponseError a parseResponseString b = case parseQuery $ BSL.toStrict b of [] -> Left errorMessage a -> case fromJSON $ queryToValue a of @@ -320,11 +321,18 @@ where queryToValue = Object . KeyMap.fromList . map paramToPair paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) - errorMessage = parseTokeRequestError b + errorMessage = parseTokeResponseError b +-- | Add Basic Authentication header using client_id and client_secret. +addBasicAuth :: OAuth2 -> Request -> Request +addBasicAuth oa = + applyBasicAuth + (T.encodeUtf8 $ oauth2ClientId oa) + (T.encodeUtf8 $ oauth2ClientSecret oa) + -- | Set several header values: --- + userAgennt : `hoauth2` --- + accept : `application/json` +-- + userAgennt : "hoauth2" +-- + accept : "application/json" addDefaultRequestHeaders :: Request -> Request addDefaultRequestHeaders req = let headers = defaultRequestHeaders ++ requestHeaders req 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 @@ -1,17 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -- | This module contains a new way of doing OAuth2 authorization and authentication -- in order to obtain Access Token and maybe Refresh Token base on rfc6749. -- --- This module will become default in future release. (TBD but likely 3.0). +-- This module will become default in future release. -- --- The key concept/change is to introduce the 'GrantTypeFlow', which determines the entire work flow per spec. +-- The key concept/change is to introduce the Grant flow, which determines the entire work flow per spec. -- Each work flow will have slight different request parameters, which often time you'll see -- different configuration when creating OAuth2 application in the IdP developer application page. -- @@ -30,48 +22,53 @@ -- 5. PKCE (rfc7636). This is enhancement on top of authorization code flow. -- -- Implicit flow is not supported because it is more for SPA (single page app) --- and more or less obsolete by Authorization Code flow with PKCE. +-- given it is deprecated by Authorization Code flow with PKCE. -- -- Here is quick sample for how to use vocabularies from this new module. -- -- Firstly, initialize your IdP (use google as example) and the application. -- -- @ --- {\-# LANGUAGE DataKinds #-\} -- +-- import Network.OAuth2.Experiment +-- import URI.ByteString.QQ +-- -- data Google = Google deriving (Eq, Show) +-- -- googleIdp :: Idp Google -- googleIdp = -- Idp --- { idpFetchUserInfo = authGetJSON @(IdpUserInfo Google), --- idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|], --- idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|], --- idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|] +-- { idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|] +-- , idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|] +-- , idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|] +-- , idpDeviceAuthorizationEndpoint = Just [uri|https:\/\/oauth2.googleapis.com\/device\/code|] -- } -- --- fooApp :: IdpApplication 'AuthorizationCode Google +-- fooApp :: AuthorizationCodeApplication -- fooApp = --- AuthorizationCodeIdpApplication --- { idpAppClientId = "xxxxx", --- idpAppClientSecret = "xxxxx", --- idpAppScope = +-- AuthorizationCodeApplication +-- { acClientId = "xxxxx", +-- acClientSecret = "xxxxx", +-- acScope = -- Set.fromList -- [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\", -- \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\" -- ], --- idpAppAuthorizeState = \"CHANGE_ME\", --- idpAppAuthorizeExtraParams = Map.empty, --- idpAppRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], --- idpAppName = "default-google-App", --- idpAppTokenRequestAuthenticationMethod = ClientSecretBasic, --- idp = googleIdp +-- acAuthorizeState = \"CHANGE_ME\", +-- acAuthorizeRequestExtraParams = Map.empty, +-- acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|], +-- acName = "sample-google-authorization-code-app", +-- acTokenRequestAuthenticationMethod = ClientSecretBasic, -- } +-- +-- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google +-- fooIdpApplication = IdpApplication fooApp googleIdp -- @ -- -- Secondly, construct the authorize URL. -- -- @ --- authorizeUrl = mkAuthorizeRequest fooApp +-- authorizeUrl = mkAuthorizationRequest fooIdpApplication -- @ -- -- Thirdly, after a successful redirect with authorize code, @@ -79,20 +76,86 @@ -- -- @ -- mgr <- liftIO $ newManager tlsManagerSettings --- tokenResp <- conduitTokenRequest fooApp mgr authorizeCode +-- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode -- @ -- --- Lastly, you probably like to fetch user info +-- If you'd like to fetch user info, uses this method -- -- @ --- conduitUserInfoRequest fooApp mgr (accessToken tokenResp) +-- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp) -- @ -- --- Also you could find example from @hoauth2-providers-tutorials@ module. +-- You could also find example from @hoauth2-providers-tutorials@ module. module Network.OAuth2.Experiment ( + -- * Application per Grant type + module Network.OAuth2.Experiment.Grants, + + -- * Authorization Code + module Network.OAuth2.Experiment.Flows.AuthorizationRequest, + + -- * Device Authorization + module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest, + + -- * Token Request + module Network.OAuth2.Experiment.Flows.TokenRequest, + + -- * Refresh Token Request + module Network.OAuth2.Experiment.Flows.RefreshTokenRequest, + + -- * UserInfo Request + module Network.OAuth2.Experiment.Flows.UserInfoRequest, + + -- * Types module Network.OAuth2.Experiment.Types, module Network.OAuth2.Experiment.Pkce, + module Network.OAuth.OAuth2, + + -- * Utils + module Network.OAuth2.Experiment.Utils, ) where -import Network.OAuth2.Experiment.Pkce -import Network.OAuth2.Experiment.Types +import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..)) +import Network.OAuth2.Experiment.Flows.AuthorizationRequest ( + HasAuthorizeRequest, + mkAuthorizationRequest, + mkPkceAuthorizeRequest, + ) +import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest ( + DeviceAuthorizationResponse (..), + HasDeviceAuthorizationRequest, + conduitDeviceAuthorizationRequest, + ) +import Network.OAuth2.Experiment.Flows.RefreshTokenRequest ( + HasRefreshTokenRequest, + conduitRefreshTokenRequest, + ) +import Network.OAuth2.Experiment.Flows.TokenRequest ( + ExchangeTokenInfo, + HasTokenRequest, + NoNeedExchangeToken (..), + TokenRequest, + conduitPkceTokenRequest, + conduitTokenRequest, + ) +import Network.OAuth2.Experiment.Flows.UserInfoRequest ( + HasUserInfoRequest, + conduitUserInfoRequest, + conduitUserInfoRequestWithCustomMethod, + ) +import Network.OAuth2.Experiment.Grants +import Network.OAuth2.Experiment.Pkce ( + CodeVerifier (..), + ) +import Network.OAuth2.Experiment.Types ( + AuthorizeState (..), + ClientId (..), + ClientSecret (..), + HasOAuth2Key, + Idp (..), + IdpApplication (..), + Password (..), + RedirectUri (..), + Scope (..), + Username (..), + ) +import Network.OAuth2.Experiment.Utils (uriToText) diff --git a/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs @@ -0,0 +1,78 @@ +module Network.OAuth2.Experiment.Flows.AuthorizationRequest where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth2.Experiment.Pkce +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils +import URI.ByteString hiding (UserInfo) + +------------------------------------------------------------------------------- +-- Authorization Request -- +------------------------------------------------------------------------------- + +data AuthorizationRequestParam = AuthorizationRequestParam + { arScope :: Set Scope + , arState :: AuthorizeState + , arClientId :: ClientId + , arRedirectUri :: Maybe RedirectUri + , arResponseType :: ResponseType + -- ^ It could be optional there is only one redirect_uri registered. + -- See: https://www.rfc-editor.org/rfc/rfc6749#section-3.1.2.3 + , arExtraParams :: Map Text Text + } + +instance ToQueryParam AuthorizationRequestParam where + toQueryParam AuthorizationRequestParam {..} = + Map.unions + [ toQueryParam arResponseType + , toQueryParam arScope + , toQueryParam arClientId + , toQueryParam arState + , toQueryParam arRedirectUri + , arExtraParams + ] + +class HasAuthorizeRequest a where + -- | Constructs Authorization Code request parameters + -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 + mkAuthorizationRequestParam :: a -> AuthorizationRequestParam + +-- | Constructs Authorization Code request URI +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 +mkAuthorizationRequest :: HasAuthorizeRequest a => IdpApplication i a -> URI +mkAuthorizationRequest idpApp = + let req = mkAuthorizationRequestParam (application idpApp) + allParams = + map (bimap tlToBS tlToBS) $ + Map.toList $ + toQueryParam req + in appendQueryParams allParams $ + idpAuthorizeEndpoint (idp idpApp) + +------------------------------------------------------------------------------- +-- PKCE -- +------------------------------------------------------------------------------- + +-- | https://datatracker.ietf.org/doc/html/rfc7636 +class HasAuthorizeRequest a => HasPkceAuthorizeRequest a where + mkPkceAuthorizeRequestParam :: MonadIO m => a -> m (AuthorizationRequestParam, CodeVerifier) + +-- | Constructs Authorization Code (PKCE) request URI and the Code Verifier. +-- https://datatracker.ietf.org/doc/html/rfc7636 +mkPkceAuthorizeRequest :: + (MonadIO m, HasPkceAuthorizeRequest a) => + IdpApplication i a -> + m (URI, CodeVerifier) +mkPkceAuthorizeRequest IdpApplication {..} = do + (req, codeVerifier) <- mkPkceAuthorizeRequestParam application + let allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req + let url = + appendQueryParams allParams $ + idpAuthorizeEndpoint idp + pure (url, codeVerifier) diff --git a/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where + +import Control.Applicative +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson.Types +import Data.Bifunctor +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.HTTP.Client.Contrib +import Network.HTTP.Conduit +import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils +import URI.ByteString hiding (UserInfo) + +------------------------------------------------------------------------------- +-- Device Authorization Request -- +------------------------------------------------------------------------------- +newtype DeviceCode = DeviceCode Text + deriving newtype (FromJSON) + +instance ToQueryParam DeviceCode where + toQueryParam :: DeviceCode -> Map Text Text + toQueryParam (DeviceCode dc) = Map.singleton "device_code" dc + +-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.2 +data DeviceAuthorizationResponse = DeviceAuthorizationResponse + { deviceCode :: DeviceCode + , userCode :: Text + , verificationUri :: URI + , verificationUriComplete :: Maybe URI + , expiresIn :: Integer + , interval :: Maybe Int + } + +instance FromJSON DeviceAuthorizationResponse where + parseJSON :: Value -> Parser DeviceAuthorizationResponse + parseJSON = withObject "parse DeviceAuthorizationResponse" $ \t -> do + deviceCode <- t .: "device_code" + userCode <- t .: "user_code" + -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho + verificationUri <- t .: "verification_uri" <|> t .: "verification_url" + verificationUriComplete <- t .:? "verification_uri_complete" + expiresIn <- t .: "expires_in" + interval <- t .:? "interval" + pure DeviceAuthorizationResponse {..} + +data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam + { arScope :: Set Scope + , arClientId :: Maybe ClientId + , arExtraParams :: Map Text Text + } + +instance ToQueryParam DeviceAuthorizationRequestParam where + toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text + toQueryParam DeviceAuthorizationRequestParam {..} = + Map.unions + [ toQueryParam arScope + , toQueryParam arClientId + , arExtraParams + ] + +class HasOAuth2Key a => HasDeviceAuthorizationRequest a where + -- | Create Device Authorization Request parameters + -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 + mkDeviceAuthorizationRequestParam :: a -> DeviceAuthorizationRequestParam + +-- TODO: There is only (possibly always only) on instance of 'HasDeviceAuthorizationRequest' +-- Maybe consider to hard-code the data type instead of use type class. + +-- | Makes Device Authorization Request +-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 +conduitDeviceAuthorizationRequest :: + (MonadIO m, HasDeviceAuthorizationRequest a) => + IdpApplication i a -> + Manager -> + ExceptT BSL.ByteString m DeviceAuthorizationResponse +conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do + case idpDeviceAuthorizationEndpoint idp of + Nothing -> throwE "[conduiteDeviceAuthorizationRequest] Device Authorization Flow is not supported due to miss device_authorization_endpoint." + Just deviceAuthEndpoint -> do + let deviceAuthReq = mkDeviceAuthorizationRequestParam application + oauth2Key = mkOAuth2Key application + body = unionMapsToQueryParams [toQueryParam deviceAuthReq] + ExceptT . liftIO $ do + req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint + -- Hacky: + -- Missing clientId implies ClientSecretBasic authentication method. + -- See Grant/DeviceAuthorization.hs + let req' = case arClientId deviceAuthReq of + Nothing -> addBasicAuth oauth2Key req + Just _ -> req + resp <- httpLbs (urlEncodedBody body req') mgr + pure $ first ("[conduiteDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp diff --git a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.HTTP.Conduit +import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils + +------------------------------------------------------------------------------- +-- RefreshToken Requset -- +------------------------------------------------------------------------------- + +data RefreshTokenRequest = RefreshTokenRequest + { rrRefreshToken :: OAuth2.RefreshToken + , rrGrantType :: GrantTypeValue + , rrScope :: Set Scope + } + +instance ToQueryParam RefreshTokenRequest where + toQueryParam :: RefreshTokenRequest -> Map Text Text + toQueryParam RefreshTokenRequest {..} = + Map.unions + [ toQueryParam rrGrantType + , toQueryParam rrScope + , toQueryParam rrRefreshToken + ] + +class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasRefreshTokenRequest a where + -- | Make Refresh Token Request parameters + -- | https://www.rfc-editor.org/rfc/rfc6749#section-6 + mkRefreshTokenRequestParam :: a -> OAuth2.RefreshToken -> RefreshTokenRequest + +-- | Make Refresh Token Request +-- https://www.rfc-editor.org/rfc/rfc6749#section-6 +conduitRefreshTokenRequest :: + (MonadIO m, HasRefreshTokenRequest a) => + IdpApplication i a -> + Manager -> + OAuth2.RefreshToken -> + ExceptT TokenResponseError m OAuth2Token +conduitRefreshTokenRequest IdpApplication {..} mgr rt = + let tokenReq = mkRefreshTokenRequestParam application rt + body = unionMapsToQueryParams [toQueryParam tokenReq] + in doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body diff --git a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Network.OAuth2.Experiment.Flows.TokenRequest where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Network.HTTP.Conduit +import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth2.Experiment.Pkce +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils + +------------------------------------------------------------------------------- +-- Token Request -- +------------------------------------------------------------------------------- + +class HasTokenRequestClientAuthenticationMethod a where + getClientAuthenticationMethod :: a -> ClientAuthenticationMethod + +-- | Only Authorization Code Grant involves a Exchange Token (Authorization Code). +-- ResourceOwnerPassword and Client Credentials make token request directly. +data NoNeedExchangeToken = NoNeedExchangeToken + +class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasTokenRequest a where + -- Each GrantTypeFlow has slightly different request parameter to /token endpoint. + data TokenRequest a + type ExchangeTokenInfo a + + -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request + -- create type family to be explicit on it. + -- with 'type instance WithExchangeToken a b = b' implies no exchange token + -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token + -- type WithExchangeToken a b + mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a + +-- | Make Token Request +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 +conduitTokenRequest :: + (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => + IdpApplication i a -> + Manager -> + ExchangeTokenInfo a -> + ExceptT TokenResponseError m OAuth2Token +conduitTokenRequest IdpApplication {..} mgr exchangeToken = do + let tokenReq = mkTokenRequestParam application exchangeToken + body = unionMapsToQueryParams [toQueryParam tokenReq] + if getClientAuthenticationMethod application == ClientAssertionJwt + then do + resp <- ExceptT . liftIO $ do + req <- uriToRequest (idpTokenEndpoint idp) + let req' = urlEncodedBody body (addDefaultRequestHeaders req) + handleOAuth2TokenResponse <$> httpLbs req' mgr + case parseResponseFlexible resp of + Right obj -> return obj + Left e -> throwE e + else doJSONPostRequest mgr (mkOAuth2Key application) (idpTokenEndpoint idp) body + +------------------------------------------------------------------------------- +-- PKCE -- +------------------------------------------------------------------------------- + +-- | Make Token Request (PKCE) +-- https://datatracker.ietf.org/doc/html/rfc7636#section-4.5 +conduitPkceTokenRequest :: + (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => + IdpApplication i a -> + Manager -> + (ExchangeTokenInfo a, CodeVerifier) -> + ExceptT TokenResponseError m OAuth2Token +conduitPkceTokenRequest IdpApplication {..} mgr (exchangeToken, codeVerifier) = + let req = mkTokenRequestParam application exchangeToken + key = mkOAuth2Key application + clientSecretPostParam = + if getClientAuthenticationMethod application == ClientSecretPost + then clientSecretPost key + else [] + body = + unionMapsToQueryParams + [ toQueryParam req + , toQueryParam codeVerifier + ] + ++ clientSecretPostParam + in doJSONPostRequest mgr key (idpTokenEndpoint idp) body diff --git a/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Network.OAuth2.Experiment.Flows.UserInfoRequest where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Aeson (FromJSON) +import Data.ByteString.Lazy.Char8 qualified as BSL +import Network.HTTP.Conduit +import Network.OAuth.OAuth2 +import Network.OAuth2.Experiment.Types +import URI.ByteString (URI) + +------------------------------------------------------------------------------- +-- User Info Request -- +------------------------------------------------------------------------------- + +class HasUserInfoRequest a + +-- | Standard approach of fetching /userinfo +conduitUserInfoRequest :: + (MonadIO m, HasUserInfoRequest a, FromJSON b) => + IdpApplication i a -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString m b +conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON + +-- | Usually 'conduitUserInfoRequest' is good enough. +-- But some IdP has different approach to fetch user information rather than GET. +-- This method gives the flexiblity. +conduitUserInfoRequestWithCustomMethod :: + (MonadIO m, HasUserInfoRequest a, FromJSON b) => + ( Manager -> + AccessToken -> + URI -> + ExceptT BSL.ByteString m b + ) -> + IdpApplication i a -> + Manager -> + AccessToken -> + ExceptT BSL.ByteString m b +conduitUserInfoRequestWithCustomMethod fetchMethod IdpApplication {..} mgr at = + fetchMethod mgr at (idpUserInfoEndpoint idp) diff --git a/src/Network/OAuth2/Experiment/Grants.hs b/src/Network/OAuth2/Experiment/Grants.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants.hs @@ -0,0 +1,16 @@ +module Network.OAuth2.Experiment.Grants ( + module Network.OAuth2.Experiment.Grants.AuthorizationCode, + module Network.OAuth2.Experiment.Grants.DeviceAuthorization, + module Network.OAuth2.Experiment.Grants.ClientCredentials, + module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword, + module Network.OAuth2.Experiment.Grants.JwtBearer, +) where + +import Network.OAuth2.Experiment.Grants.AuthorizationCode (AuthorizationCodeApplication (..)) +import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..)) +import Network.OAuth2.Experiment.Grants.DeviceAuthorization ( + DeviceAuthorizationApplication (..), + pollDeviceTokenRequest, + ) +import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..)) +import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..)) diff --git a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.AuthorizationCode where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..), OAuth2) +import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2.Experiment.Flows.AuthorizationRequest +import Network.OAuth2.Experiment.Flows.RefreshTokenRequest +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Pkce +import Network.OAuth2.Experiment.Types +import URI.ByteString hiding (UserInfo) + +-- | An Application that supports "Authorization code" flow +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1 +data AuthorizationCodeApplication = AuthorizationCodeApplication + { acName :: Text + , acClientId :: ClientId + , acClientSecret :: ClientSecret + , acScope :: Set Scope + , acRedirectUri :: URI + , acAuthorizeState :: AuthorizeState + , acAuthorizeRequestExtraParams :: Map Text Text + , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod + } + +instance HasOAuth2Key AuthorizationCodeApplication where + mkOAuth2Key :: AuthorizationCodeApplication -> OAuth2 + mkOAuth2Key AuthorizationCodeApplication {..} = toOAuth2Key acClientId acClientSecret + +instance HasTokenRequestClientAuthenticationMethod AuthorizationCodeApplication where + getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod AuthorizationCodeApplication {..} = acTokenRequestAuthenticationMethod + +instance HasAuthorizeRequest AuthorizationCodeApplication where + mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam + mkAuthorizationRequestParam AuthorizationCodeApplication {..} = + AuthorizationRequestParam + { arScope = acScope + , arState = acAuthorizeState + , arClientId = acClientId + , arRedirectUri = Just (RedirectUri acRedirectUri) + , arResponseType = Code + , arExtraParams = acAuthorizeRequestExtraParams + } + +instance HasPkceAuthorizeRequest AuthorizationCodeApplication where + mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier) + mkPkceAuthorizeRequestParam app = do + PkceRequestParam {..} <- mkPkceParam + let authReqParam = mkAuthorizationRequestParam app + combinatedExtraParams = + Map.unions + [ arExtraParams authReqParam + , toQueryParam codeChallenge + , toQueryParam codeChallengeMethod + ] + pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier) + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 +instance HasTokenRequest AuthorizationCodeApplication where + type ExchangeTokenInfo AuthorizationCodeApplication = ExchangeToken + data TokenRequest AuthorizationCodeApplication = AuthorizationCodeTokenRequest + { trCode :: ExchangeToken + , trGrantType :: GrantTypeValue + , trRedirectUri :: RedirectUri + } + + mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication + mkTokenRequestParam AuthorizationCodeApplication {..} authCode = + AuthorizationCodeTokenRequest + { trCode = authCode + , trGrantType = GTAuthorizationCode + , trRedirectUri = RedirectUri acRedirectUri + } + +instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where + toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text + toQueryParam AuthorizationCodeTokenRequest {..} = + Map.unions + [ toQueryParam trCode + , toQueryParam trGrantType + , toQueryParam trRedirectUri + ] + +instance HasUserInfoRequest AuthorizationCodeApplication + +instance HasRefreshTokenRequest AuthorizationCodeApplication where + mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest + mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt = + RefreshTokenRequest + { rrScope = acScope + , rrGrantType = GTRefreshToken + , rrRefreshToken = rt + } diff --git a/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.ClientCredentials where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2) +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils + +-- | An Application that supports "Client Credentials" flow +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4 +data ClientCredentialsApplication = ClientCredentialsApplication + { ccClientId :: ClientId + , ccClientSecret :: ClientSecret + , ccName :: Text + , ccScope :: Set Scope + , ccTokenRequestExtraParams :: Map Text Text + , ccTokenRequestAuthenticationMethod :: ClientAuthenticationMethod + } + +instance HasOAuth2Key ClientCredentialsApplication where + mkOAuth2Key :: ClientCredentialsApplication -> OAuth2 + mkOAuth2Key ClientCredentialsApplication {..} = toOAuth2Key ccClientId ccClientSecret + +instance HasTokenRequestClientAuthenticationMethod ClientCredentialsApplication where + getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod ClientCredentialsApplication {..} = ccTokenRequestAuthenticationMethod + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 +instance HasTokenRequest ClientCredentialsApplication where + type ExchangeTokenInfo ClientCredentialsApplication = NoNeedExchangeToken + data TokenRequest ClientCredentialsApplication = ClientCredentialsTokenRequest + { trScope :: Set Scope + , trGrantType :: GrantTypeValue + , trClientSecret :: ClientSecret + , trClientId :: ClientId + , trExtraParams :: Map Text Text + , trClientAuthenticationMethod :: ClientAuthenticationMethod + } + + mkTokenRequestParam :: ClientCredentialsApplication -> NoNeedExchangeToken -> TokenRequest ClientCredentialsApplication + mkTokenRequestParam ClientCredentialsApplication {..} _ = + ClientCredentialsTokenRequest + { trScope = ccScope + , trGrantType = GTClientCredentials + , trClientSecret = ccClientSecret + , trClientAuthenticationMethod = ccTokenRequestAuthenticationMethod + , trExtraParams = ccTokenRequestExtraParams + , trClientId = ccClientId + } + +instance ToQueryParam (TokenRequest ClientCredentialsApplication) where + toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text + toQueryParam ClientCredentialsTokenRequest {..} = + let jwtAssertionBody = + if trClientAuthenticationMethod == ClientAssertionJwt + then + [ toQueryParam trClientId + , Map.fromList + [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer") + , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret) + ] + ] + else [] + in Map.unions $ + [ toQueryParam trGrantType + , toQueryParam trScope + , trExtraParams + ] + ++ jwtAssertionBody diff --git a/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.DeviceAuthorization ( + DeviceAuthorizationApplication (..), + pollDeviceTokenRequest, +) where + +import Control.Concurrent +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.HTTP.Conduit +import Network.OAuth.OAuth2 +import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Types +import Prelude hiding (error) + +-- | An Application that supports "Device Authorization Grant" +-- +-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1 +data DeviceAuthorizationApplication = DeviceAuthorizationApplication + { daName :: Text + , daClientId :: ClientId + , daClientSecret :: ClientSecret + , daScope :: Set Scope + , daAuthorizationRequestExtraParam :: Map Text Text + -- ^ Additional parameters to the device authorization request. + -- Most of identity providers follow the spec strictly but + -- AzureAD requires "tenant" parameter. + , daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod + -- ^ The spec requires similar authentication method as /token request. + -- Most of identity providers doesn't required it but some does like Okta. + } + +pollDeviceTokenRequest :: + MonadIO m => + IdpApplication i DeviceAuthorizationApplication -> + Manager -> + DeviceAuthorizationResponse -> + ExceptT TokenResponseError m OAuth2Token +pollDeviceTokenRequest idpApp mgr deviceAuthResp = do + pollDeviceTokenRequestInternal + idpApp + mgr + (deviceCode deviceAuthResp) + (fromMaybe 5 $ interval deviceAuthResp) + +pollDeviceTokenRequestInternal :: + MonadIO m => + IdpApplication i DeviceAuthorizationApplication -> + Manager -> + DeviceCode -> + Int -> + -- | Polling Interval + ExceptT TokenResponseError m OAuth2Token +pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds = do + resp <- runExceptT (conduitTokenRequest idpApp mgr deviceCode) + case resp of + Left trRespError -> do + case tokenResponseError trRespError of + -- TODO: Didn't have a good idea to expand the error code + -- specifically for device token request flow + -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5 + UnknownErrorCode "authorization_pending" -> do + liftIO $ threadDelay $ intervalSeconds * 1000000 + pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds + UnknownErrorCode "slow_down" -> do + let newIntervalSeconds = intervalSeconds + 5 + liftIO $ threadDelay $ newIntervalSeconds * 1000000 + pollDeviceTokenRequestInternal idpApp mgr deviceCode newIntervalSeconds + _ -> throwE trRespError + Right v -> pure v + +instance HasOAuth2Key DeviceAuthorizationApplication where + mkOAuth2Key :: DeviceAuthorizationApplication -> OAuth2 + mkOAuth2Key DeviceAuthorizationApplication {..} = toOAuth2Key daClientId daClientSecret + +instance HasTokenRequestClientAuthenticationMethod DeviceAuthorizationApplication where + getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod _ = ClientSecretBasic + +instance HasDeviceAuthorizationRequest DeviceAuthorizationApplication where + mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam + mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} = + DeviceAuthorizationRequestParam + { arScope = daScope + , arClientId = + if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic + then Nothing + else Just daClientId + , arExtraParams = daAuthorizationRequestExtraParam + } + +-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4 +instance HasTokenRequest DeviceAuthorizationApplication where + type ExchangeTokenInfo DeviceAuthorizationApplication = DeviceCode + data TokenRequest DeviceAuthorizationApplication = AuthorizationCodeTokenRequest + { trCode :: DeviceCode + , trGrantType :: GrantTypeValue + , trClientId :: Maybe ClientId + } + + mkTokenRequestParam :: + DeviceAuthorizationApplication -> + DeviceCode -> + TokenRequest DeviceAuthorizationApplication + mkTokenRequestParam DeviceAuthorizationApplication {..} deviceCode = + -- + -- This is a bit hacky! + -- The token request use `ClientSecretBasic` by default. (has to pick up one Client Authn Method) + -- ClientId shall be also be in request body per spec. + -- However, for some IdPs, e.g. Okta, when using `ClientSecretBasic` to authn Client, + -- it doesn't allow @client_id@ in the request body + -- 'daAuthorizationRequestAuthenticationMethod' set the tone for Authorization Request, + -- hence just follow it in the token request + AuthorizationCodeTokenRequest + { trCode = deviceCode + , trGrantType = GTDeviceCode + , trClientId = + if daAuthorizationRequestAuthenticationMethod == Just ClientSecretBasic + then Nothing + else Just daClientId + } + +instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where + toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text + toQueryParam AuthorizationCodeTokenRequest {..} = + Map.unions + [ toQueryParam trCode + , toQueryParam trGrantType + , toQueryParam trClientId + ] + +instance HasUserInfoRequest DeviceAuthorizationApplication diff --git a/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.JwtBearer where + +import Data.ByteString qualified as BS +import Data.Default (Default (def)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text.Lazy (Text) +import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2) +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Types +import Network.OAuth2.Experiment.Utils + +-- | An Application that supports "JWT Bearer" flow +-- +-- https://datatracker.ietf.org/doc/html/rfc7523 +data JwtBearerApplication = JwtBearerApplication + { jbName :: Text + , jbJwtAssertion :: BS.ByteString + } + +-- JwtBearner doesn't use @client_id@ and @client_secret@ for authentication. +-- +-- FIXME: The ideal solution shall be do not implement `HasOAuth2Key` +-- but it will stop to re-use the method 'conduitTokenRequest' for JwtBearer flow. +instance HasOAuth2Key JwtBearerApplication where + mkOAuth2Key :: JwtBearerApplication -> OAuth2 + mkOAuth2Key _ = def + +instance HasTokenRequestClientAuthenticationMethod JwtBearerApplication where + getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod _ = ClientAssertionJwt + +instance HasTokenRequest JwtBearerApplication where + type ExchangeTokenInfo JwtBearerApplication = NoNeedExchangeToken + + data TokenRequest JwtBearerApplication = JwtBearerTokenRequest + { trGrantType :: GrantTypeValue -- \| 'GTJwtBearer' + , trAssertion :: BS.ByteString -- \| The the signed JWT token + } + + mkTokenRequestParam :: JwtBearerApplication -> NoNeedExchangeToken -> TokenRequest JwtBearerApplication + mkTokenRequestParam JwtBearerApplication {..} _ = + JwtBearerTokenRequest + { trGrantType = GTJwtBearer + , trAssertion = jbJwtAssertion + } + +instance ToQueryParam (TokenRequest JwtBearerApplication) where + toQueryParam :: TokenRequest JwtBearerApplication -> Map Text Text + toQueryParam JwtBearerTokenRequest {..} = + Map.unions + [ toQueryParam trGrantType + , Map.singleton "assertion" (bs8ToLazyText trAssertion) + ] + +instance HasUserInfoRequest JwtBearerApplication diff --git a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Text.Lazy (Text) +import Network.OAuth.OAuth2 (ClientAuthenticationMethod (..), OAuth2 (..)) +import Network.OAuth.OAuth2 qualified as OAuth2 +import Network.OAuth2.Experiment.Flows.RefreshTokenRequest +import Network.OAuth2.Experiment.Flows.TokenRequest +import Network.OAuth2.Experiment.Flows.UserInfoRequest +import Network.OAuth2.Experiment.Types + +-- | An Application that supports "Resource Owner Password" flow +-- +-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3 +data ResourceOwnerPasswordApplication = ResourceOwnerPasswordApplication + { ropClientId :: ClientId + , ropClientSecret :: ClientSecret + , ropName :: Text + , ropScope :: Set Scope + , ropUserName :: Username + , ropPassword :: Password + , ropTokenRequestExtraParams :: Map Text Text + } + +instance HasOAuth2Key ResourceOwnerPasswordApplication where + mkOAuth2Key :: ResourceOwnerPasswordApplication -> OAuth2 + mkOAuth2Key ResourceOwnerPasswordApplication {..} = toOAuth2Key ropClientId ropClientSecret + +instance HasTokenRequestClientAuthenticationMethod ResourceOwnerPasswordApplication where + getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod + getClientAuthenticationMethod _ = ClientSecretBasic + +-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 +instance HasTokenRequest ResourceOwnerPasswordApplication where + type ExchangeTokenInfo ResourceOwnerPasswordApplication = NoNeedExchangeToken + + data TokenRequest ResourceOwnerPasswordApplication = PasswordTokenRequest + { trScope :: Set Scope + , trUsername :: Username + , trPassword :: Password + , trGrantType :: GrantTypeValue + , trExtraParams :: Map Text Text + } + mkTokenRequestParam :: ResourceOwnerPasswordApplication -> NoNeedExchangeToken -> TokenRequest ResourceOwnerPasswordApplication + mkTokenRequestParam ResourceOwnerPasswordApplication {..} _ = + PasswordTokenRequest + { trUsername = ropUserName + , trPassword = ropPassword + , trGrantType = GTPassword + , trScope = ropScope + , trExtraParams = ropTokenRequestExtraParams + } + +instance ToQueryParam (TokenRequest ResourceOwnerPasswordApplication) where + toQueryParam :: TokenRequest ResourceOwnerPasswordApplication -> Map Text Text + toQueryParam PasswordTokenRequest {..} = + Map.unions + [ toQueryParam trGrantType + , toQueryParam trScope + , toQueryParam trUsername + , toQueryParam trPassword + , trExtraParams + ] + +instance HasUserInfoRequest ResourceOwnerPasswordApplication + +instance HasRefreshTokenRequest ResourceOwnerPasswordApplication where + mkRefreshTokenRequestParam :: ResourceOwnerPasswordApplication -> OAuth2.RefreshToken -> RefreshTokenRequest + mkRefreshTokenRequestParam ResourceOwnerPasswordApplication {..} rt = + RefreshTokenRequest + { rrScope = ropScope + , rrGrantType = GTRefreshToken + , rrRefreshToken = rt + } 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 @@ -18,7 +18,7 @@ newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text} -newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show) +newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} data CodeChallengeMethod = S256 deriving (Show) @@ -27,7 +27,7 @@ { codeVerifier :: CodeVerifier , codeChallenge :: CodeChallenge , codeChallengeMethod :: CodeChallengeMethod - -- ^ spec says optional but really it shall be s256 or can be omitted? + -- ^ spec says optional but in practice it is S256 -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3 } 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 @@ -1,116 +1,107 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Network.OAuth2.Experiment.Types where -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT (..), throwE) -import Data.Aeson (FromJSON) -import Data.Bifunctor -import Data.ByteString qualified as BS -import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Default (Default (def)) -import Data.Kind import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.String -import Data.Text.Encoding qualified as T import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL -import Network.HTTP.Conduit import Network.OAuth.OAuth2 hiding (RefreshToken) import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils -import URI.ByteString hiding (UserInfo) - -{- NOTE - 1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility? --} +import URI.ByteString (URI, serializeURIRef') ------------------------------------------------------------------------------- --- * Grant Type +-- * Idp App ------------------------------------------------------------------------------- -data GrantTypeFlow - = -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1 - AuthorizationCode - | -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3 - ResourceOwnerPassword - | -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4 - ClientCredentials - | -- | https://www.rfc-editor.org/rfc/rfc7523.html#section-2.1 - JwtBearer +-- TODO: Distinct type per endpoint +-- Because I made mistake at passing to Authorize and Token Request -------------------------------------------------------------------------------- +-- | @Idp i@ consists various endpoints endpoints. +-- +-- The @i@ is actually phantom type for information only (Idp name) at this moment. +-- And it is PolyKinds. +-- +-- Hence whenever @Idp i@ or @IdpApplication i a@ is used as function parameter, +-- PolyKinds need to be enabled. +data Idp (i :: k) = Idp + { idpUserInfoEndpoint :: URI + -- ^ Userinfo Endpoint + , idpAuthorizeEndpoint :: URI + -- ^ Authorization Endpoint + , idpTokenEndpoint :: URI + -- ^ Token Endpoint + , idpDeviceAuthorizationEndpoint :: Maybe URI + -- ^ Apparently not all IdP support device code flow + } --- * Response Type value +-- | An OAuth2 Application "a" of IdP "i". +-- "a" can be one of following type: +-- +-- * `Network.OAuth2.Experiment.AuthorizationCodeApplication` +-- * `Network.OAuth2.Experiment.DeviceAuthorizationApplication` +-- * `Network.OAuth2.Experiment.ClientCredentialsApplication` +-- * `Network.OAuth2.Experiment.ResourceOwnerPasswordApplication` +-- * `Network.OAuth2.Experiment.JwtBearerApplication` +data IdpApplication (i :: k) a = IdpApplication + { idp :: Idp i + , application :: a + } ------------------------------------------------------------------------------- -class ToResponseTypeValue (a :: GrantTypeFlow) where - toResponseTypeValue :: IsString b => b +-- * Scope -instance ToResponseTypeValue 'AuthorizationCode where - -- https://www.rfc-editor.org/rfc/rfc6749#section-3.1.1 - -- Only support "authorization code" flow - toResponseTypeValue :: IsString b => b - toResponseTypeValue = "code" +------------------------------------------------------------------------------- -toResponseTypeParam :: forall a b req. (ToResponseTypeValue a, IsString b) => req a -> Map b b -toResponseTypeParam _ = Map.singleton "response_type" (toResponseTypeValue @a) +-- TODO: What's best type for Scope? +-- Use 'Text' isn't super type safe. All cannot specify some standard scopes like openid, email etc. +-- But Following data type is not ideal as Idp would have lots of 'Custom Text' +-- +-- @ +-- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text +-- @ +-- +-- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow. +newtype Scope = Scope {unScope :: Text} + deriving (Eq, Ord) +instance IsString Scope where + fromString :: String -> Scope + fromString = Scope . TL.pack + ------------------------------------------------------------------------------- -- * Grant Type value ------------------------------------------------------------------------------- --- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict. +-- | Grant type query parameter has association with different GrantType flows but not completely strict. -- --- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow. +-- e.g. Both AuthorizationCode and ResourceOwnerPassword flow could support refresh token flow. data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken | GTJwtBearer + | GTDeviceCode deriving (Eq, Show) ------------------------------------------------------------------------------- - --- * Scope - +-- Response Type -- ------------------------------------------------------------------------------- - --- TODO: following data type is not ideal as Idp would have lots of 'Custom Text' --- --- @ --- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text --- @ --- --- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow. -newtype Scope = Scope {unScope :: Text} - deriving (Show, Eq, Ord) - -instance IsString Scope where - fromString :: String -> Scope - fromString = Scope . TL.pack +data ResponseType = Code ------------------------------------------------------------------------------- @@ -180,6 +171,7 @@ val GTClientCredentials = "client_credentials" val GTRefreshToken = "refresh_token" val GTJwtBearer = "urn:ietf:params:oauth:grant-type:jwt-bearer" + val GTDeviceCode = "urn:ietf:params:oauth:grant-type:device_code" instance ToQueryParam ClientId where toQueryParam :: ClientId -> Map Text Text @@ -208,7 +200,7 @@ toQueryParam :: Set Scope -> Map Text Text toQueryParam = toScopeParam . Set.map unScope where - toScopeParam :: (IsString a) => Set Text -> Map a Text + toScopeParam :: IsString a => Set Text -> Map a Text toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) instance ToQueryParam CodeVerifier where @@ -231,546 +223,16 @@ toQueryParam :: OAuth2.RefreshToken -> Map Text Text toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x) -------------------------------------------------------------------------------- - --- * Authorization and Token Requests types - -------------------------------------------------------------------------------- - -class HasAuthorizeRequest (a :: GrantTypeFlow) where - data AuthorizationRequest a - type MkAuthorizationRequestResponse a - mkAuthorizeRequestParameter :: IdpApplication a i -> AuthorizationRequest a - mkAuthorizeRequest :: IdpApplication a i -> MkAuthorizationRequestResponse a - -class HasTokenRequest (a :: GrantTypeFlow) where - -- | Each GrantTypeFlow has slightly different request parameter to /token endpoint. - data TokenRequest a - - -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request - -- create type family to be explicit on it. - -- with 'type instance WithExchangeToken a b = b' implies no exchange token - -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token - type WithExchangeToken a b - - mkTokenRequest :: - IdpApplication a i -> - WithExchangeToken a (TokenRequest a) - - conduitTokenRequest :: - (MonadIO m) => - IdpApplication a i -> - Manager -> - WithExchangeToken a (ExceptT TokenRequestError m OAuth2Token) - -class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where - mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier) - -class HasPkceTokenRequest (b :: GrantTypeFlow) where - conduitPkceTokenRequest :: - (MonadIO m) => - IdpApplication b i -> - Manager -> - (ExchangeToken, CodeVerifier) -> - ExceptT TokenRequestError m OAuth2Token - -class HasRefreshTokenRequest (a :: GrantTypeFlow) where - -- | https://www.rfc-editor.org/rfc/rfc6749#page-47 - data RefreshTokenRequest a - - mkRefreshTokenRequest :: IdpApplication a i -> OAuth2.RefreshToken -> RefreshTokenRequest a - conduitRefreshTokenRequest :: - (MonadIO m) => - IdpApplication a i -> - Manager -> - OAuth2.RefreshToken -> - ExceptT TokenRequestError m OAuth2Token - -------------------------------------------------------------------------------- - --- * User Info types - -------------------------------------------------------------------------------- - -type family IdpUserInfo a - -class HasUserInfoRequest (a :: GrantTypeFlow) where - conduitUserInfoRequest :: - FromJSON (IdpUserInfo i) => - IdpApplication a i -> - Manager -> - AccessToken -> - ExceptT BSL.ByteString IO (IdpUserInfo i) - -------------------------------------------------------------------------------- - --- * Idp App - -------------------------------------------------------------------------------- - --- | Shall IdpApplication has a field of 'Idp a'?? -data Idp a = Idp - { idpUserInfoEndpoint :: URI - , -- NOTE: maybe worth data type to distinguish authorize and token endpoint - -- as I made mistake at passing to Authorize and Token Request - idpAuthorizeEndpoint :: URI - , idpTokenEndpoint :: URI - , idpFetchUserInfo :: - forall m. - (FromJSON (IdpUserInfo a), MonadIO m) => - Manager -> - AccessToken -> - URI -> - ExceptT BSL.ByteString m (IdpUserInfo a) - } - -------------------------------------------------------------------------------- - --- * Idp App Config - -------------------------------------------------------------------------------- - -data family IdpApplication (a :: GrantTypeFlow) (i :: Type) - -------------------------------------------------------------------------------- - --- * Authorization Code flow - -------------------------------------------------------------------------------- - --- | An Application that supports "Authorization code" flow -data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication - { idpAppName :: Text - , idpAppClientId :: ClientId - , idpAppClientSecret :: ClientSecret - , idpAppScope :: Set Scope - , idpAppRedirectUri :: URI - , idpAppAuthorizeState :: AuthorizeState - , idpAppAuthorizeExtraParams :: Map Text Text - -- ^ Though technically one key can have multiple value in query, but who actually does it?! - , idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod - , idp :: Idp i - } - --- NOTE: maybe add function for parase authorization response --- though seems overkill. https://github.com/freizl/hoauth2/issues/149 --- parseAuthorizationResponse :: String -> AuthorizationResponse --- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse - -instance HasAuthorizeRequest 'AuthorizationCode where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 - data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest - { scope :: Set Scope - , state :: AuthorizeState - , clientId :: ClientId - , redirectUri :: Maybe RedirectUri - } - type MkAuthorizationRequestResponse 'AuthorizationCode = Text - - mkAuthorizeRequestParameter :: IdpApplication 'AuthorizationCode i -> AuthorizationRequest 'AuthorizationCode - mkAuthorizeRequestParameter AuthorizationCodeIdpApplication {..} = - AuthorizationCodeAuthorizationRequest - { scope = if null idpAppScope then Set.empty else idpAppScope - , state = idpAppAuthorizeState - , clientId = idpAppClientId - , redirectUri = Just (RedirectUri idpAppRedirectUri) - } - - mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text - mkAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = - let req = mkAuthorizeRequestParameter idpAppConfig - allParams = - map (bimap tlToBS tlToBS) $ - Map.toList $ - Map.unions [idpAppAuthorizeExtraParams, toQueryParam req] - in TL.fromStrict $ - T.decodeUtf8 $ - serializeURIRef' $ - appendQueryParams allParams $ - idpAuthorizeEndpoint idp - -instance HasTokenRequest 'AuthorizationCode where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 - data TokenRequest 'AuthorizationCode = AuthorizationCodeTokenRequest - { code :: ExchangeToken - , clientId :: ClientId - , grantType :: GrantTypeValue - , redirectUri :: RedirectUri - } - type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a - - mkTokenRequest :: - IdpApplication 'AuthorizationCode i -> - ExchangeToken -> - TokenRequest 'AuthorizationCode - mkTokenRequest AuthorizationCodeIdpApplication {..} authCode = - AuthorizationCodeTokenRequest - { code = authCode - , clientId = idpAppClientId - , grantType = GTAuthorizationCode - , redirectUri = RedirectUri idpAppRedirectUri - } - conduitTokenRequest :: - forall m i. - (MonadIO m) => - IdpApplication 'AuthorizationCode i -> - Manager -> - ExchangeToken -> - ExceptT TokenRequestError m OAuth2Token - conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken = - let req = mkTokenRequest idpAppConfig exchangeToken - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = - mapsToParams - [ toQueryParam req - , toQueryParam - ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost - then Just idpAppClientSecret - else Nothing - ) - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance HasPkceAuthorizeRequest 'AuthorizationCode where - mkPkceAuthorizeRequest :: MonadIO m => IdpApplication 'AuthorizationCode i -> m (Text, CodeVerifier) - mkPkceAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = do - PkceRequestParam {..} <- mkPkceParam - let req = mkAuthorizeRequestParameter idpAppConfig - let allParams = - mapsToParams - [ idpAppAuthorizeExtraParams - , toQueryParam req - , toQueryParam codeChallenge - , toQueryParam codeChallengeMethod - ] - - let url = - TL.fromStrict $ - T.decodeUtf8 $ - serializeURIRef' $ - appendQueryParams allParams $ - idpAuthorizeEndpoint idp - pure (url, codeVerifier) - -instance HasPkceTokenRequest 'AuthorizationCode where - conduitPkceTokenRequest :: - MonadIO m => - IdpApplication 'AuthorizationCode i -> - Manager -> - (ExchangeToken, CodeVerifier) -> - ExceptT TokenRequestError m OAuth2Token - conduitPkceTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr (exchangeToken, codeVerifier) = - let req = mkTokenRequest idpAppConfig exchangeToken - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = - mapsToParams - [ toQueryParam req - , toQueryParam codeVerifier - , toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance HasRefreshTokenRequest 'AuthorizationCode where - data RefreshTokenRequest 'AuthorizationCode = AuthorizationCodeTokenRefreshRequest - { refreshToken :: OAuth2.RefreshToken - , grantType :: GrantTypeValue - , scope :: Set Scope - } - - mkRefreshTokenRequest :: IdpApplication 'AuthorizationCode i -> OAuth2.RefreshToken -> RefreshTokenRequest 'AuthorizationCode - mkRefreshTokenRequest AuthorizationCodeIdpApplication {..} rt = - AuthorizationCodeTokenRefreshRequest - { scope = idpAppScope - , grantType = GTRefreshToken - , refreshToken = rt - } - conduitRefreshTokenRequest :: - (MonadIO m) => - IdpApplication 'AuthorizationCode i -> - Manager -> - OAuth2.RefreshToken -> - ExceptT TokenRequestError m OAuth2Token - conduitRefreshTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr rt = - let req = mkRefreshTokenRequest idpAppConfig rt - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = - mapsToParams - [ toQueryParam req - , toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing) - ] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance HasUserInfoRequest 'AuthorizationCode where - conduitUserInfoRequest :: - FromJSON (IdpUserInfo i) => - IdpApplication 'AuthorizationCode i -> - Manager -> - AccessToken -> - ExceptT BSL.ByteString IO (IdpUserInfo i) - conduitUserInfoRequest AuthorizationCodeIdpApplication {..} mgr at = do - idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) - -instance ToQueryParam (AuthorizationRequest 'AuthorizationCode) where - toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text - toQueryParam req@AuthorizationCodeAuthorizationRequest {..} = - Map.unions - [ toResponseTypeParam req - , toQueryParam scope - , toQueryParam clientId - , toQueryParam state - , toQueryParam redirectUri - ] - -instance ToQueryParam (TokenRequest 'AuthorizationCode) where - toQueryParam :: TokenRequest 'AuthorizationCode -> Map Text Text - toQueryParam AuthorizationCodeTokenRequest {..} = - Map.unions - [ toQueryParam grantType - , toQueryParam code - , toQueryParam redirectUri - ] - -instance ToQueryParam (RefreshTokenRequest 'AuthorizationCode) where - toQueryParam :: RefreshTokenRequest 'AuthorizationCode -> Map Text Text - toQueryParam AuthorizationCodeTokenRefreshRequest {..} = - Map.unions - [ toQueryParam grantType - , toQueryParam scope - , toQueryParam refreshToken - ] - -------------------------------------------------------------------------------- - --- * JWTBearer - -------------------------------------------------------------------------------- - --- | An Application that supports "Authorization code" flow -data instance IdpApplication 'JwtBearer i = JwtBearerIdpApplication - { idpAppName :: Text - , idpAppJwt :: BS.ByteString - , idp :: Idp i - } - -instance HasTokenRequest 'JwtBearer where - data TokenRequest 'JwtBearer = JwtBearerTokenRequest - { grantType :: GrantTypeValue -- \| 'GTJwtBearer' - , assertion :: BS.ByteString -- \| The the signed JWT token - } - type WithExchangeToken 'JwtBearer a = a - - mkTokenRequest :: - IdpApplication 'JwtBearer i -> - TokenRequest 'JwtBearer - mkTokenRequest JwtBearerIdpApplication {..} = - JwtBearerTokenRequest - { grantType = GTJwtBearer - , assertion = idpAppJwt - } - - conduitTokenRequest :: - forall m i. - (MonadIO m) => - IdpApplication 'JwtBearer i -> - Manager -> - ExceptT TokenRequestError m OAuth2Token - conduitTokenRequest idpAppConfig@JwtBearerIdpApplication {..} mgr = do - resp <- ExceptT . liftIO $ do - let tokenReq = mkTokenRequest idpAppConfig - let body = mapsToParams [toQueryParam tokenReq] - req <- uriToRequest (idpTokenEndpoint idp) - handleOAuth2TokenResponse <$> httpLbs (urlEncodedBody body (addDefaultRequestHeaders req)) mgr - case parseResponseFlexible resp of - Right obj -> return obj - Left e -> throwE e - -instance ToQueryParam (TokenRequest 'JwtBearer) where - toQueryParam :: TokenRequest 'JwtBearer -> Map Text Text - toQueryParam JwtBearerTokenRequest {..} = - Map.unions - [ toQueryParam grantType - , Map.fromList [("assertion", bs8ToLazyText assertion)] - ] - -instance HasUserInfoRequest 'JwtBearer where - conduitUserInfoRequest JwtBearerIdpApplication {..} mgr at = do - idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) - -------------------------------------------------------------------------------- - --- * Password flow - -------------------------------------------------------------------------------- - --- https://www.rfc-editor.org/rfc/rfc6749#section-4.3.1 --- 4.3.1. Authorization Request and Response (Password grant type) --- The method through which the client obtains the resource owner --- credentials is beyond the scope of this specification. The client --- MUST discard the credentials once an access token has been obtained. --- --- Hence no AuhorizationRequest instance - -data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPApplication - { idpAppClientId :: ClientId - , idpAppClientSecret :: ClientSecret - , idpAppName :: Text - , idpAppScope :: Set Scope - , idpAppUserName :: Username - , idpAppPassword :: Password - , idpAppTokenRequestExtraParams :: Map Text Text - -- ^ Any parameter that required by your Idp and not mentioned in the OAuth2 spec - , idp :: Idp i - } - -instance HasUserInfoRequest 'ResourceOwnerPassword where - conduitUserInfoRequest ResourceOwnerPasswordIDPApplication {..} mgr at = do - idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp) - -instance HasTokenRequest 'ResourceOwnerPassword where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 - data TokenRequest 'ResourceOwnerPassword = PasswordTokenRequest - { scope :: Set Scope - , username :: Username - , password :: Password - , grantType :: GrantTypeValue - } - type WithExchangeToken 'ResourceOwnerPassword a = a - - mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword - mkTokenRequest ResourceOwnerPasswordIDPApplication {..} = - PasswordTokenRequest - { username = idpAppUserName - , password = idpAppPassword - , grantType = GTPassword - , scope = idpAppScope - } - - conduitTokenRequest :: - (MonadIO m) => - IdpApplication 'ResourceOwnerPassword i -> - Manager -> - ExceptT TokenRequestError m OAuth2Token - conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPApplication {..} mgr = - let req = mkTokenRequest idpAppConfig - key = toOAuth2Key idpAppClientId idpAppClientSecret - body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req] - in doJSONPostRequest mgr key (idpTokenEndpoint idp) body - --- | TODO: TBD -instance HasRefreshTokenRequest 'ResourceOwnerPassword where - data RefreshTokenRequest 'ResourceOwnerPassword = PasswordRefreshTokenRequest - - mkRefreshTokenRequest :: - IdpApplication 'ResourceOwnerPassword i -> - OAuth2.RefreshToken -> - RefreshTokenRequest 'ResourceOwnerPassword - mkRefreshTokenRequest = undefined - - conduitRefreshTokenRequest :: - MonadIO m => - IdpApplication 'ResourceOwnerPassword i -> - Manager -> - OAuth2.RefreshToken -> - ExceptT TokenRequestError m OAuth2Token - conduitRefreshTokenRequest = undefined - -instance ToQueryParam (TokenRequest 'ResourceOwnerPassword) where - toQueryParam :: TokenRequest 'ResourceOwnerPassword -> Map Text Text - toQueryParam PasswordTokenRequest {..} = - Map.unions - [ toQueryParam grantType - , toQueryParam scope - , toQueryParam username - , toQueryParam password - ] +instance ToQueryParam ResponseType where + toQueryParam :: ResponseType -> Map Text Text + toQueryParam Code = Map.singleton "response_type" "code" ------------------------------------------------------------------------------- - --- * Client Credentials flow - +-- HasOAuth2Key -- +-- -- +-- Find a way to reuse some methods from old implementation -- +-- Probably will be removed when Experiment module becomes default -- ------------------------------------------------------------------------------- --- https://www.rfc-editor.org/rfc/rfc6749#section-4.4.1 --- 4.4.1. Authorization Request and Response (Client Credentials grant type) --- Since the client authentication is used as the authorization grant, --- no additional authorization request is needed. --- --- Hence no AuhorizationRequest instance - -data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPApplication - { idpAppClientId :: ClientId - , idpAppClientSecret :: ClientSecret - , idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod - -- ^ FIXME: rename to ClientCredential - , idpAppName :: Text - , idpAppScope :: Set Scope - , idpAppTokenRequestExtraParams :: Map Text Text - -- ^ Any parameter that required by your Idp and not mentioned in the OAuth2 spec - , idp :: Idp i - } - -instance HasTokenRequest 'ClientCredentials where - -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2 - data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest - { scope :: Set Scope - , grantType :: GrantTypeValue - , clientAssertionType :: Text - , clientAssertion :: BS.ByteString - , clientAuthenticationMethod :: ClientAuthenticationMethod - } - - type WithExchangeToken 'ClientCredentials a = a - - mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials - mkTokenRequest ClientCredentialsIDPApplication {..} = - ClientCredentialsTokenRequest - { scope = idpAppScope - , grantType = GTClientCredentials - , clientAssertionType = "urn:ietf:params:oauth:client-assertion-type:jwt-bearer" - , clientAssertion = tlToBS $ unClientSecret idpAppClientSecret - , clientAuthenticationMethod = idpAppTokenRequestAuthenticationMethod - } - - conduitTokenRequest :: - (MonadIO m) => - IdpApplication 'ClientCredentials i -> - Manager -> - ExceptT TokenRequestError m OAuth2Token - conduitTokenRequest idpAppConfig@ClientCredentialsIDPApplication {..} mgr = do - let tokenReq = mkTokenRequest idpAppConfig - key = - toOAuth2Key - idpAppClientId - idpAppClientSecret - body = - mapsToParams - [ idpAppTokenRequestExtraParams - , toQueryParam tokenReq - ] - if clientAuthenticationMethod tokenReq == ClientAssertionJwt - then do - resp <- ExceptT . liftIO $ do - req <- uriToRequest (idpTokenEndpoint idp) - let req' = urlEncodedBody body (addDefaultRequestHeaders req) - handleOAuth2TokenResponse <$> httpLbs req' mgr - case parseResponseFlexible resp of - Right obj -> return obj - Left e -> throwE e - else doJSONPostRequest mgr key (idpTokenEndpoint idp) body - -instance ToQueryParam (TokenRequest 'ClientCredentials) where - toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text - toQueryParam ClientCredentialsTokenRequest {..} = - Map.unions $ - [ toQueryParam grantType - , toQueryParam scope - ] - ++ [ Map.fromList - ( if clientAuthenticationMethod == ClientAssertionJwt - then - [ ("client_assertion_type", clientAssertionType) - , ("client_assertion", bs8ToLazyText clientAssertion) - ] - else [] - ) - ] +class HasOAuth2Key a where + mkOAuth2Key :: a -> OAuth2 diff --git a/src/Network/OAuth2/Experiment/Utils.hs b/src/Network/OAuth2/Experiment/Utils.hs --- a/src/Network/OAuth2/Experiment/Utils.hs +++ b/src/Network/OAuth2/Experiment/Utils.hs @@ -5,8 +5,11 @@ import Data.ByteString.Char8 qualified as BS8 import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Lazy qualified as TL +import URI.ByteString (URI, serializeURIRef') tlToBS :: TL.Text -> ByteString tlToBS = TE.encodeUtf8 . TL.toStrict @@ -14,8 +17,11 @@ bs8ToLazyText :: BS8.ByteString -> TL.Text bs8ToLazyText = TL.pack . BS8.unpack -mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] -mapsToParams = +unionMapsToQueryParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)] +unionMapsToQueryParams = map (bimap tlToBS tlToBS) . Map.toList . Map.unions + +uriToText :: URI -> T.Text +uriToText = T.decodeUtf8 . serializeURIRef' diff --git a/test/Network/OAuth/OAuth2/TokenRequestSpec.hs b/test/Network/OAuth/OAuth2/TokenRequestSpec.hs --- a/test/Network/OAuth/OAuth2/TokenRequestSpec.hs +++ b/test/Network/OAuth/OAuth2/TokenRequestSpec.hs @@ -1,12 +1,16 @@ +{-# LANGUAGE QuasiQuotes #-} + module Network.OAuth.OAuth2.TokenRequestSpec where import Data.Aeson qualified as Aeson import Network.OAuth.OAuth2.TokenRequest import Test.Hspec +import URI.ByteString.QQ +import Prelude hiding (error) spec :: Spec -spec = - describe "parseJSON TokenRequestErrorCode" $ do +spec = do + describe "parseJSON TokenResponseErrorCode" $ do it "invalid_request" $ do Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest it "invalid_client" $ do @@ -21,3 +25,32 @@ Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope it "foo_code" $ do Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code") + + describe "parseJSON TokenResponseError" $ do + it "parse error" $ do + Aeson.eitherDecode "{\"error\": \"invalid_request\"}" + `shouldBe` Right + ( TokenResponseError + { tokenResponseError = InvalidRequest + , tokenResponseErrorDescription = Nothing + , tokenResponseErrorUri = Nothing + } + ) + it "parse error_description" $ do + Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_description\": \"token request error foo1\"}" + `shouldBe` Right + ( TokenResponseError + { tokenResponseError = InvalidRequest + , tokenResponseErrorDescription = Just "token request error foo1" + , tokenResponseErrorUri = Nothing + } + ) + it "parse error_uri" $ do + Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_uri\": \"https://example.com\"}" + `shouldBe` Right + ( TokenResponseError + { tokenResponseError = InvalidRequest + , tokenResponseErrorDescription = Nothing + , tokenResponseErrorUri = Just [uri|https://example.com|] + } + )