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

@@ -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 <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
+--
+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 =
+authOAuth2Widget = buildPlugin fetchAccessToken
-    AuthPlugin name (dispatchAuthRequest name oauth getCreds) login
+
-  where
+-- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2'
-    login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
+--
+-- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
+--
+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|<a href=@{tm $ oauth2Url name}>^{widget}|]
 
 -- | Read the @'AccessToken'@ from the values set via @'setExtra'@
 getAccessToken :: Creds m -> Maybe AccessToken

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"] =
+dispatchAuthRequest name oauth2 getToken getCreds "GET" ["callback"] =
-    dispatchCallback name oauth2 getCreds
+    dispatchCallback name oauth2 getToken getCreds
-dispatchAuthRequest _ _ _ _ _ = notFound
+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