hoauth2 2.14.2 → 2.14.3

raw patch · 9 files changed

+185/−52 lines, 9 filesdep +binary-instancesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: binary-instances

API changes (from Hackage documentation)

Files

• hoauth2.cabal +7/−2
• src/Network/OAuth/OAuth2/HttpClient.hs +1/−0
• src/Network/OAuth/OAuth2/Internal.hs +33/−17
• src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs +4/−0
• src/Network/OAuth2/Experiment/Flows/TokenRequest.hs +75/−30
• src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs +8/−0
• src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs +4/−1
• src/Network/OAuth2/Experiment/Types.hs +5/−2
• test/Network/OAuth/OAuth2/TokenResponseSpec.hs +48/−0

@@ -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

@@ -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}

@@ -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

@@ -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

@@ -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

@@ -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       }

@@ -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       }

@@ -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

@@ -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