mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-09-11 03:44:57 +02:00
a8de561848
This adds support for `ghc-9.12` / `hoauth2-2.15` and drops support for
`ghc < 9.4` / `hoauth2 < 2.8`.
Since this would be a major version bump no matter what, I've changed
the interface we present to align with `hoauth2-2.15`. This means using
the newer `fetch` functions, and `TokenResponse{,Error}` type names.
I've maintained our own `OAuth2` type so that the redirect-uri can
remain a `Maybe` field. The way plugins are constructed, we need to
build an `OAuth2` value in a pure context without one, which is then
supplied later, when we have `MonadHandler` and so can render URLs.
118 lines
3.3 KiB
Haskell
118 lines
3.3 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
|
|
, TokenResponse
|
|
, Creds (..)
|
|
, oauth2Url
|
|
, authOAuth2
|
|
, authOAuth2Widget
|
|
|
|
-- * Alternatives that use 'fetchAccessTokenPost'
|
|
, 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 'fetchAccessTokenPost'
|
|
--
|
|
-- 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 fetchAccessTokenBasic
|
|
|
|
-- | A version of 'authOAuth2Widget' that uses 'fetchAccessTokenPost'
|
|
--
|
|
-- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
|
|
authOAuth2Widget'
|
|
:: YesodAuth m
|
|
=> WidgetFor m ()
|
|
-> Text
|
|
-> OAuth2
|
|
-> FetchCreds m
|
|
-> AuthPlugin m
|
|
authOAuth2Widget' = buildPlugin fetchAccessTokenPost
|
|
|
|
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
|