mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-09-07 10:23:49 +02:00
bbda0d2f47
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.
122 lines
3.4 KiB
Haskell
122 lines
3.4 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
-- |
|
|
--
|
|
-- Generic OAuth2 plugin for Yesod
|
|
--
|
|
-- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage.
|
|
--
|
|
module Yesod.Auth.OAuth2
|
|
( OAuth2(..)
|
|
, FetchCreds
|
|
, Manager
|
|
, OAuth2Token(..)
|
|
, Creds(..)
|
|
, oauth2Url
|
|
, authOAuth2
|
|
, authOAuth2Widget
|
|
|
|
-- * Alternatives that use 'fetchAccessToken2'
|
|
, authOAuth2'
|
|
, authOAuth2Widget'
|
|
|
|
-- * Reading our @'credsExtra'@ keys
|
|
, getAccessToken
|
|
, getRefreshToken
|
|
, getUserResponse
|
|
, getUserResponseJSON
|
|
)
|
|
where
|
|
|
|
import Control.Error.Util (note)
|
|
import Control.Monad ((<=<))
|
|
import Data.Aeson (FromJSON, eitherDecode)
|
|
import Data.ByteString.Lazy (ByteString, fromStrict)
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Network.HTTP.Conduit (Manager)
|
|
import Network.OAuth.OAuth2
|
|
import Yesod.Auth
|
|
import Yesod.Auth.OAuth2.Dispatch
|
|
import Yesod.Core.Widget
|
|
|
|
oauth2Url :: Text -> AuthRoute
|
|
oauth2Url name = PluginR name ["forward"]
|
|
|
|
-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
|
|
--
|
|
-- Presents a generic @"Login via #{name}"@ link
|
|
--
|
|
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
|
|
-- example.
|
|
--
|
|
authOAuth2Widget
|
|
:: YesodAuth m
|
|
=> WidgetFor m ()
|
|
-> Text
|
|
-> OAuth2
|
|
-> FetchCreds m
|
|
-> AuthPlugin m
|
|
authOAuth2Widget = buildPlugin fetchAccessToken
|
|
|
|
-- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2'
|
|
--
|
|
-- 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
|
|
getAccessToken = (AccessToken <$>) . lookup "accessToken" . credsExtra
|
|
|
|
-- | Read the @'RefreshToken'@ from the values set via @'setExtra'@
|
|
--
|
|
-- N.B. not all providers supply this value.
|
|
--
|
|
getRefreshToken :: Creds m -> Maybe RefreshToken
|
|
getRefreshToken = (RefreshToken <$>) . lookup "refreshToken" . credsExtra
|
|
|
|
-- | Read the original profile response from the values set via @'setExtra'@
|
|
getUserResponse :: Creds m -> Maybe ByteString
|
|
getUserResponse =
|
|
(fromStrict . encodeUtf8 <$>) . lookup "userResponse" . credsExtra
|
|
|
|
-- | @'getUserResponse'@, and decode as JSON
|
|
getUserResponseJSON :: FromJSON a => Creds m -> Either String a
|
|
getUserResponseJSON =
|
|
eitherDecode <=< note "userResponse key not present" . getUserResponse
|