diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -2,7 +2,7 @@ name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -version: 2.14.2 +version: 2.14.3 synopsis: Haskell OAuth2 authentication client description: This is Haskell binding of OAuth2 Authorization framework and Bearer Token Usage framework. @@ -68,6 +68,7 @@ , base >=4.11 && <5 , base64 >=1.0 && <1.1 , binary >=0.8 && <0.11 + , binary-instances >=1.0 && <1.1 , bytestring >=0.9 && <0.13 , containers >=0.6 && <0.8 , crypton >=0.32 && <1.1 @@ -94,11 +95,15 @@ build-depends: , aeson >=2.0 && <2.3 , base >=4.11 && <5 + , binary >=0.8 && <0.11 , hoauth2 , hspec >=2 && <3 , uri-bytestring >=0.3 && <0.5 - other-modules: Network.OAuth.OAuth2.TokenRequestSpec + other-modules: + Network.OAuth.OAuth2.TokenRequestSpec + Network.OAuth.OAuth2.TokenResponseSpec + default-language: Haskell2010 default-extensions: ImportQualifiedPost 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 @@ -309,6 +309,7 @@ -- + authorization : "Bearer xxxxx" if 'Network.OAuth.OAuth2.AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = + -- FIXME: use `applyBearerAuth` let bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t] headers = bearer ++ defaultRequestHeaders ++ requestHeaders req in req {requestHeaders = headers} 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 @@ -5,15 +5,16 @@ import Control.Arrow (second) import Control.Monad.Catch import Data.Aeson +import Data.Aeson qualified as Aeson import Data.Aeson.Types (Parser, explicitParseFieldMaybe) -import Data.Binary (Binary) +import Data.Binary (Binary (..)) +import Data.Binary.Instances.Aeson () import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BS8 import Data.Default import Data.Maybe import Data.Text (Text, unpack) import Data.Version (showVersion) -import GHC.Generics import Lens.Micro import Lens.Micro.Extras import Network.HTTP.Conduit as C @@ -56,11 +57,11 @@ ------------------------------------------------------------------------------- -newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +newtype AccessToken = AccessToken {atoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) -newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) -newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +newtype IdToken = IdToken {idtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON) -- | Authorization Code newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON) @@ -77,13 +78,22 @@ -- ^ 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 Authorization Request and the provider supports OpenID protocol. + , scope :: Maybe Text + , rawResponse :: Object } - deriving (Eq, Show, Generic) + deriving (Eq, Show) -instance Binary OAuth2Token +instance Binary OAuth2Token where + put OAuth2Token {..} = put rawResponse + get = do + rawt <- get + case fromJSON (Aeson.Object rawt) of + Success a -> pure a + Error err -> fail err -- | Parse JSON data into 'OAuth2Token' instance FromJSON OAuth2Token where + parseJSON :: Value -> Parser OAuth2Token parseJSON = withObject "OAuth2Token" $ \v -> OAuth2Token <$> v .: "access_token" @@ -91,14 +101,18 @@ <*> explicitParseFieldMaybe parseIntFlexible v "expires_in" <*> v .:? "token_type" <*> v .:? "id_token" + <*> v .:? "scope" + <*> pure v where parseIntFlexible :: Value -> Parser Int parseIntFlexible (String s) = pure . read $ unpack s parseIntFlexible v = parseJSON v instance ToJSON OAuth2Token where - toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} - toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} + toJSON :: OAuth2Token -> Value + toJSON = toJSON . Object . rawResponse + toEncoding :: OAuth2Token -> Encoding + toEncoding = toEncoding . Object . rawResponse ------------------------------------------------------------------------------- @@ -106,23 +120,22 @@ ------------------------------------------------------------------------------- --- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3 --- According to spec: +-- | How would the Client (RP) authenticate itself? -- -- The client MUST NOT use more than one authentication method in each request. --- --- Which means use Authorization header or Post body. +-- Means use Authorization header or Post body. -- --- However, I found I have to include authentication in the header all the time in real world. +-- See more details -- --- In other words, `ClientSecretBasic` is always assured. `ClientSecretPost` is optional. +-- https://www.rfc-editor.org/rfc/rfc6749#section-2.3 +-- https://oauth.net/private-key-jwt/ +-- https://www.rfc-editor.org/rfc/rfc7523.html -- --- Maybe consider an alternative implementation that boolean kind of data type is good enough. data ClientAuthenticationMethod = ClientSecretBasic | ClientSecretPost | ClientAssertionJwt - deriving (Eq) + deriving (Eq, Show) ------------------------------------------------------------------------------- @@ -146,6 +159,9 @@ appendQueryParams params = over (queryL . queryPairsL) (params ++) +-- TODO: why we need this method instead of `parseRequest` +-- https://hackage.haskell.org/package/http-client-0.7.18/docs/Network-HTTP-Client.html#v:parseRequest +-- uriToRequest :: MonadThrow m => URI -> m Request uriToRequest auri = do ssl <- case view (uriSchemeL . schemeBSL) auri of diff --git a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs @@ -23,6 +23,8 @@ { rrRefreshToken :: OAuth2.RefreshToken , rrGrantType :: GrantTypeValue , rrScope :: Set Scope + , rrClientId :: Maybe ClientId + , rrClientSecret :: Maybe ClientSecret } instance ToQueryParam RefreshTokenRequest where @@ -32,6 +34,8 @@ [ toQueryParam rrGrantType , toQueryParam rrScope , toQueryParam rrRefreshToken + , toQueryParam rrClientId + , toQueryParam rrClientSecret ] class (HasOAuth2Key a, HasTokenRequestClientAuthenticationMethod a) => HasRefreshTokenRequest a where diff --git a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs --- a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs +++ b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs @@ -4,15 +4,26 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Data.Aeson (FromJSON) import Network.HTTP.Conduit -import Network.OAuth.OAuth2 hiding (RefreshToken) +import Network.OAuth.OAuth2 ( + ClientAuthenticationMethod (..), + OAuth2, + OAuth2Token, + PostBody, + uriToRequest, + ) +import Network.OAuth.OAuth2.TokenRequest ( + TokenResponseError, + addBasicAuth, + addDefaultRequestHeaders, + handleOAuth2TokenResponse, + parseResponseFlexible, + ) import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Types import Network.OAuth2.Experiment.Utils - -------------------------------------------------------------------------------- --- Token Request -- -------------------------------------------------------------------------------- +import URI.ByteString (URI) class HasTokenRequestClientAuthenticationMethod a where getClientAuthenticationMethod :: a -> ClientAuthenticationMethod @@ -33,51 +44,85 @@ -- type WithExchangeToken a b mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a --- | Make Token Request --- https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 +------------------------------------------------------------------------------- +-- 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 +conduitTokenRequest idpApp mgr exchangeToken = do + conduitTokenRequestInternal idpApp mgr (exchangeToken, Nothing) ------------------------------------------------------------------------------- --- PKCE -- +-- PKCE Token Request -- ------------------------------------------------------------------------------- --- | Make Token Request (PKCE) --- https://datatracker.ietf.org/doc/html/rfc7636#section-4.5 +-- | 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) = +conduitPkceTokenRequest idpApp mgr (exchangeToken, codeVerifier) = + conduitTokenRequestInternal idpApp mgr (exchangeToken, Just codeVerifier) + +------------------------------------------------------------------------------- +-- Internal helpers -- +------------------------------------------------------------------------------- + +conduitTokenRequestInternal :: + (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) => + IdpApplication i a -> + Manager -> + (ExchangeTokenInfo a, Maybe CodeVerifier) -> + ExceptT TokenResponseError m OAuth2Token +conduitTokenRequestInternal 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 + in doTokenRequestInternal + (getClientAuthenticationMethod application) + mgr + key + (idpTokenEndpoint idp) + body + +doTokenRequestInternal :: + (MonadIO m, FromJSON a) => + ClientAuthenticationMethod -> + -- | HTTP connection manager. + Manager -> + -- | OAuth options + OAuth2 -> + -- | URL + URI -> + -- | Request body. + PostBody -> + -- | Response as ByteString + ExceptT TokenResponseError m a +doTokenRequestInternal clientAuthMethod manager oa url body = do + resp <- ExceptT . liftIO $ fmap handleOAuth2TokenResponse go + case parseResponseFlexible resp of + Right obj -> return obj + Left e -> throwE e + where + updateAuthHeader = + case clientAuthMethod of + ClientSecretBasic -> addBasicAuth oa + ClientSecretPost -> id + ClientAssertionJwt -> id + + go = do + req <- uriToRequest url + let req' = (updateAuthHeader . addDefaultRequestHeaders) req + httpLbs (urlEncodedBody body req') manager diff --git a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs --- a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs +++ b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs @@ -71,6 +71,8 @@ { trCode :: ExchangeToken , trGrantType :: GrantTypeValue , trRedirectUri :: RedirectUri + , trClientId :: Maybe ClientId + , trClientSecret :: Maybe ClientSecret } mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication @@ -79,6 +81,8 @@ { trCode = authCode , trGrantType = GTAuthorizationCode , trRedirectUri = RedirectUri acRedirectUri + , trClientId = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing + , trClientSecret = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing } instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where @@ -88,6 +92,8 @@ [ toQueryParam trCode , toQueryParam trGrantType , toQueryParam trRedirectUri + , toQueryParam trClientId + , toQueryParam trClientSecret ] instance HasUserInfoRequest AuthorizationCodeApplication @@ -99,4 +105,6 @@ { rrScope = acScope , rrGrantType = GTRefreshToken , rrRefreshToken = rt + , rrClientId = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing + , rrClientSecret = if acTokenRequestAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing } diff --git a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs --- a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs +++ b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs @@ -24,6 +24,7 @@ , ropUserName :: Username , ropPassword :: Password , ropTokenRequestExtraParams :: Map Text Text + , ropTokenRequestAuthenticationMethod :: ClientAuthenticationMethod } instance HasOAuth2Key ResourceOwnerPasswordApplication where @@ -32,7 +33,7 @@ instance HasTokenRequestClientAuthenticationMethod ResourceOwnerPasswordApplication where getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod - getClientAuthenticationMethod _ = ClientSecretBasic + getClientAuthenticationMethod = ropTokenRequestAuthenticationMethod -- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2 instance HasTokenRequest ResourceOwnerPasswordApplication where @@ -75,4 +76,6 @@ { rrScope = ropScope , rrGrantType = GTRefreshToken , rrRefreshToken = rt + , rrClientId = if ropTokenRequestAuthenticationMethod == ClientSecretPost then Just ropClientId else Nothing + , rrClientSecret = if ropTokenRequestAuthenticationMethod == ClientSecretPost then Just ropClientSecret else Nothing } 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 @@ -74,7 +74,7 @@ -- -- 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) + deriving (Eq, Ord, Show) instance IsString Scope where fromString :: String -> Scope @@ -201,7 +201,10 @@ toQueryParam = toScopeParam . Set.map unScope where toScopeParam :: IsString a => Set Text -> Map a Text - toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) + toScopeParam scope = + if Set.null scope + then Map.empty + else Map.singleton "scope" (TL.intercalate " " $ Set.toList scope) instance ToQueryParam CodeVerifier where toQueryParam :: CodeVerifier -> Map Text Text diff --git a/test/Network/OAuth/OAuth2/TokenResponseSpec.hs b/test/Network/OAuth/OAuth2/TokenResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth/OAuth2/TokenResponseSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Network.OAuth.OAuth2.TokenResponseSpec where + +import Data.Aeson qualified as Aeson +import Data.Binary qualified as Binary +import Data.Maybe (fromJust) +import Network.OAuth.OAuth2 (AccessToken (..), OAuth2Token (..), RefreshToken (..)) +import Test.Hspec + +spec :: Spec +spec = do + describe "decode as JSON" $ do + it "parse access token" $ do + let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}" + Aeson.eitherDecode resp + `shouldBe` Right + ( OAuth2Token + { accessToken = AccessToken "ya29" + , refreshToken = Just (RefreshToken "0gk") + , expiresIn = Just 3600 + , tokenType = Just "Bearer" + , idToken = Nothing + , scope = Nothing + , rawResponse = fromJust (Aeson.decode resp) + } + ) + it "parse access token with scope" $ do + let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\",\"scope\": \"openid profile\"}" + Aeson.eitherDecode resp + `shouldBe` Right + ( OAuth2Token + { accessToken = AccessToken "ya29" + , refreshToken = Just (RefreshToken "0gk") + , expiresIn = Just 3600 + , tokenType = Just "Bearer" + , idToken = Nothing + , scope = Just "openid profile" + , rawResponse = fromJust (Aeson.decode resp) + } + ) + describe "encode/decode binary" $ do + it "support binary encoding" $ do + let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}" + oauth2Token = fromJust (Aeson.decode @OAuth2Token resp) + Binary.decode @OAuth2Token (Binary.encode oauth2Token) + `shouldBe` oauth2Token