mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-19 07:31:55 +01:00
dd66460fcf
The new major version improves the naming of the fields of the OAuth2
record type. This type is central to this library and we leak it freely.
Users who make their own plugins are expected to construct values of
this type to pass into our functions, this makes the new version
disruptive to our code and our users'.
We have two options:
1. Update and release our own new major version
The major downside is that the current LTS resolver will then not
update beyond our currently-released version. We have no immediate
plans for new features in this library, but if we have bugs reported
to be fixed we would either have to manage a complex backporting or
ask our Stack users to wait for the next major LTS, which has
historically been many months.
Users who wish to use our new version would need to also bring in
hoauth2, and who knows what else.
2. Release a fully-compatible update
As mentioned, we leak OAuth2(..) through this library's interface. In
order to be truly backwards-compatible, we would have to use CCP to
define an "old style" OAuth2 and use that throughout, such that
in-the-wild OAuth2 values continue to work as-is.
This would not be a good long-term solution as it introduces a fair
amount of naming confusion and will lead to import conflicts for any
users who also import hoauth2-2.0 modules in the same project.
3. Release a mostly-compatible update
This is the path this commit explores. We can update our own code to
be hoauth2-2.0 compatible and use CPP to define the hoauth2-2.0-like
OAuth2 if we're still on hoauth2-1.x.
This gets us compiling in either case and "forward functional", with
the exception of users who define their own plugins (which is rare).
Because of that use-case, this should technically be a major version
bump for ourselves (though I'm open to the argument we could treat
the local-provider use-case differently), however it is still better
than Option 1 in a few ways:
- We still compile with hoauth2-1.x, so can be brought in easily as
an isolated extra-dep
- If there is a reported bug that we decide to only fix in the newer
versions, the path for the user is better: they can pull us as an
extra-dep and likely need no changes. Even if they're doing a
custom plugin, the required changes are minor
121 lines
3.4 KiB
Haskell
121 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.Compat
|
|
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
|