From bbda0d2f479553f2b35859879368a5ed198d3669 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Thu, 10 Dec 2020 11:10:35 -0500 Subject: [PATCH] Support injecting fetchAccessToken hoauth2's fetchAccessToken provides credentials in the Authorization header, while fetchAccessToken2 provides them in that header but also the POST body. It was discovered that some providers only support one or the other, so using fetchAccessToken2 would be preferred since it should work with either. This happened in #129. However, we discovered at least one provider (Okta) that actively rejects requests unless they're supplying credentials in exactly one place: Cannot supply multiple client credentials. Use one of the following: credentials in the Authorization header, credentials in the post body, or a client_assertion in the post body." This patch reverts back to fetchAccessToken, but makes it possible to for client to use fetchAccessToken2 if necessary via alternative functions. --- src/Yesod/Auth/OAuth2.hs | 43 ++++++++++++++++++++++++++++--- src/Yesod/Auth/OAuth2/Dispatch.hs | 27 ++++++++++++++----- 2 files changed, 59 insertions(+), 11 deletions(-) diff --git a/src/Yesod/Auth/OAuth2.hs b/src/Yesod/Auth/OAuth2.hs index 17aa670..92e5951 100644 --- a/src/Yesod/Auth/OAuth2.hs +++ b/src/Yesod/Auth/OAuth2.hs @@ -17,6 +17,10 @@ module Yesod.Auth.OAuth2 , authOAuth2 , authOAuth2Widget + -- * Alternatives that use 'fetchAccessToken2' + , authOAuth2' + , authOAuth2Widget' + -- * Reading our @'credsExtra'@ keys , getAccessToken , getRefreshToken @@ -47,6 +51,13 @@ oauth2Url name = PluginR name ["forward"] authOAuth2 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name +-- | A version of 'authOAuth2' that uses 'fetchAccessToken2' +-- +-- See +-- +authOAuth2' :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m +authOAuth2' name = authOAuth2Widget' [whamlet|Login via #{name}|] name + -- | Create an @'AuthPlugin'@ for the given OAuth2 provider -- -- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an @@ -59,10 +70,34 @@ authOAuth2Widget -> OAuth2 -> FetchCreds m -> AuthPlugin m -authOAuth2Widget widget name oauth getCreds = - AuthPlugin name (dispatchAuthRequest name oauth getCreds) login - where - login tm = [whamlet|^{widget}|] +authOAuth2Widget = buildPlugin fetchAccessToken + +-- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2' +-- +-- See +-- +authOAuth2Widget' + :: YesodAuth m + => WidgetFor m () + -> Text + -> OAuth2 + -> FetchCreds m + -> AuthPlugin m +authOAuth2Widget' = buildPlugin fetchAccessToken2 + +buildPlugin + :: YesodAuth m + => FetchToken + -> WidgetFor m () + -> Text + -> OAuth2 + -> FetchCreds m + -> AuthPlugin m +buildPlugin getToken widget name oauth getCreds = AuthPlugin + name + (dispatchAuthRequest name oauth getToken getCreds) + login + where login tm = [whamlet|^{widget}|] -- | Read the @'AccessToken'@ from the values set via @'setExtra'@ getAccessToken :: Creds m -> Maybe AccessToken diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs index b0f7dfc..fb6dd8d 100644 --- a/src/Yesod/Auth/OAuth2/Dispatch.hs +++ b/src/Yesod/Auth/OAuth2/Dispatch.hs @@ -8,7 +8,10 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Yesod.Auth.OAuth2.Dispatch - ( FetchCreds + ( FetchToken + , fetchAccessToken + , fetchAccessToken2 + , FetchCreds , dispatchAuthRequest ) where @@ -23,12 +26,20 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Network.HTTP.Conduit (Manager) import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.TokenRequest (Errors) import URI.ByteString.Extension import Yesod.Auth hiding (ServerError) import Yesod.Auth.OAuth2.ErrorResponse import Yesod.Auth.OAuth2.Exception import Yesod.Core hiding (ErrorResponse) +-- | How to fetch an @'OAuth2Token'@ +-- +-- This will be 'fetchAccessToken' or 'fetchAccessToken2' +-- +type FetchToken + = Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token) + -- | How to take an @'OAuth2Token'@ and retrieve user credentials type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m) @@ -36,15 +47,16 @@ type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m) dispatchAuthRequest :: Text -- ^ Name -> OAuth2 -- ^ Service details + -> FetchToken -- ^ How to get a token -> FetchCreds m -- ^ How to get credentials -> Text -- ^ Method -> [Text] -- ^ Path pieces -> AuthHandler m TypedContent -dispatchAuthRequest name oauth2 _ "GET" ["forward"] = +dispatchAuthRequest name oauth2 _ _ "GET" ["forward"] = dispatchForward name oauth2 -dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = - dispatchCallback name oauth2 getCreds -dispatchAuthRequest _ _ _ _ _ = notFound +dispatchAuthRequest name oauth2 getToken getCreds "GET" ["callback"] = + dispatchCallback name oauth2 getToken getCreds +dispatchAuthRequest _ _ _ _ _ _ = notFound -- | Handle @GET \/forward@ -- @@ -66,15 +78,16 @@ dispatchForward name oauth2 = do dispatchCallback :: Text -> OAuth2 + -> FetchToken -> FetchCreds m -> AuthHandler m TypedContent -dispatchCallback name oauth2 getCreds = do +dispatchCallback name oauth2 getToken getCreds = do csrf <- verifySessionCSRF $ tokenSessionKey name onErrorResponse $ oauth2HandshakeError name code <- requireGetParam "code" manager <- authHttpManager oauth2' <- withCallbackAndState name oauth2 csrf - token <- errLeft $ fetchAccessToken2 manager oauth2' $ ExchangeToken code + token <- errLeft $ getToken manager oauth2' $ ExchangeToken code creds <- errLeft $ tryFetchCreds $ getCreds manager token setCredsRedirect creds where