haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-01-11 19:58:28 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Convert project to Fourmolu

Browse Source
This commit is contained in:
patrick brisbin 2023-08-01 07:59:37 -04:00 committed by Pat Brisbin
parent 5d4e4f8d7b
commit 08d0f0eaa4
33 changed files with 673 additions and 660 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.restyled.yaml
View File

@ -1,10 +1,4 @@
restylers:
- brittany:
include:
- "**/*.hs"
- "!src/Network/OAuth/OAuth2/Compat.hs" # CPP
- stylish-haskell:
include:
- "**/*.hs"
- "!src/Network/OAuth/OAuth2/Compat.hs" # CPP
- fourmolu
- "!stylish-haskell"
- "*"

21
.stylish-haskell.yaml
View File

@ -1,21 +0,0 @@
steps:
- simple_align:
cases: false
top_level_patterns: false
records: false
- imports:
align: none
list_align: after_alias
pad_module_names: false
long_list_align: new_line_multiline
empty_list_align: right_after
list_padding: 4
separate_lists: false
space_surround: false
- language_pragmas:
style: vertical
align: false
remove_redundant: true
- trailing_whitespace: {}
columns: 80
newline: native

44
brittany.yaml
View File

@ -1,44 +0,0 @@
---
conf_debug:
dconf_roundtrip_exactprint_only: false
dconf_dump_bridoc_simpl_par: false
dconf_dump_ast_unknown: false
dconf_dump_bridoc_simpl_floating: false
dconf_dump_config: false
dconf_dump_bridoc_raw: false
dconf_dump_bridoc_final: false
dconf_dump_bridoc_simpl_alt: false
dconf_dump_bridoc_simpl_indent: false
dconf_dump_annotations: false
dconf_dump_bridoc_simpl_columns: false
dconf_dump_ast_full: false
conf_errorHandling:
econf_ExactPrintFallback: ExactPrintFallbackModeInline
econf_Werror: false
econf_omit_output_valid_check: false
econf_produceOutputOnErrors: false
conf_preprocessor:
ppconf_CPPMode: CPPModeAbort
ppconf_hackAroundIncludes: false
conf_obfuscate: false
conf_roundtrip_exactprint_only: false
conf_version: 1
conf_layout:
lconfig_reformatModulePreamble: true
lconfig_altChooser:
tag: AltChooserBoundedSearch
contents: 3
lconfig_allowSingleLineExportList: false
lconfig_importColumn: 60
lconfig_hangingTypeSignature: false
lconfig_importAsColumn: 50
lconfig_alignmentLimit: 1
lconfig_indentListSpecial: true
lconfig_indentAmount: 2
lconfig_alignmentBreakOnMultiline: true
lconfig_cols: 80
lconfig_indentPolicy: IndentPolicyLeft
lconfig_indentWhereSpecial: true
lconfig_columnAlignMode:
tag: ColumnAlignModeDisabled
contents: 0.7

22
example/Main.hs
View File

@ -13,7 +13,7 @@ import Data.Aeson.Encode.Pretty
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Data.String (IsString(fromString))
import Data.String (IsString (fromString))
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
@ -46,7 +46,9 @@ data App = App
, appAuthPlugins :: [AuthPlugin App]
}
mkYesod "App" [parseRoutes|
mkYesod
"App"
[parseRoutes|
/ RootR GET
/auth AuthR Auth getAuth
|]
@ -65,8 +67,8 @@ instance YesodAuth App where
-- Copy the Creds response into the session for viewing after
authenticate c = do
mapM_ (uncurry setSession)
$ [("credsIdent", credsIdent c), ("credsPlugin", credsPlugin c)]
mapM_ (uncurry setSession) $
[("credsIdent", credsIdent c), ("credsPlugin", credsPlugin c)]
++ credsExtra c
return $ Authenticated "1"
@ -83,8 +85,8 @@ getRootR = do
sess <- getSession
let
prettify
= decodeUtf8
prettify =
decodeUtf8
. toStrict
. encodePretty
. fromJust
@ -96,7 +98,8 @@ getRootR = do
mAccessToken = decodeUtf8 <$> M.lookup "accessToken" sess
mUserResponse = prettify <$> M.lookup "userResponse" sess
defaultLayout [whamlet|
defaultLayout
[whamlet|
<h1>Yesod Auth OAuth2 Example
<h2>
<a href=@{AuthR LoginR}>Log in
@ -123,7 +126,8 @@ mkFoundation = do
azureTenant <- getEnv "AZURE_ADV2_TENANT_ID"
appHttpManager <- newManager tlsManagerSettings
appAuthPlugins <- sequence
appAuthPlugins <-
sequence
-- When Providers are added, add them here and update .env.example.
-- Nothing else should need changing.
--
@ -148,7 +152,7 @@ mkFoundation = do
, loadPlugin oauth2Upcase "UPCASE"
]
return App { .. }
return App {..}
where
loadPlugin f prefix = do
clientId <- getEnv $ prefix <> "_CLIENT_ID"

15
fourmolu.yaml Normal file
View File

@ -0,0 +1,15 @@
indentation: 2
column-limit: 80 # ignored until v12 / ghc-9.6
function-arrows: leading
comma-style: leading # default
import-export-style: leading
indent-wheres: false # default
record-brace-space: true
newlines-between-decls: 1 # default
haddock-style: single-line
let-style: mixed
in-style: left-align
single-constraint-parens: never # ignored until v12 / ghc-9.6
unicode: never # default
respectful: true # default
fixities: [] # default

2
src/Network/OAuth/OAuth2/Compat.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-}
module Network.OAuth.OAuth2.Compat
( OAuth2(..)
( OAuth2 (..)
, OAuth2Result
, Errors
, authorizationUrl

8
src/URI/ByteString/Extension.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module URI.ByteString.Extension where
import Data.ByteString (ByteString)
import Data.String (IsString(..))
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Lens.Micro
@ -41,7 +42,10 @@ fromRelative :: Scheme -> Host -> RelativeRef -> URI
fromRelative s h = flip withHost h . toAbsolute s
withHost :: URIRef a -> Host -> URIRef a
withHost u h = u & authorityL %~ maybe
withHost u h =
u
& authorityL
%~ maybe
(Just $ Authority Nothing h Nothing)
(\a -> Just $ a & authorityHostL .~ h)

3
src/UnliftIO/Except.hs
View File

@ -1,7 +1,6 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module UnliftIO.Except
() where
module UnliftIO.Except () where
import Control.Monad.Except
import UnliftIO

19
src/Yesod/Auth/OAuth2.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
-- |
--
-- Generic OAuth2 plugin for Yesod
--
-- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage.
--
module Yesod.Auth.OAuth2
( OAuth2(..)
( OAuth2 (..)
, FetchCreds
, Manager
, OAuth2Token(..)
, Creds(..)
, OAuth2Token (..)
, Creds (..)
, oauth2Url
, authOAuth2
, authOAuth2Widget
@ -46,14 +46,12 @@ 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
@ -61,7 +59,6 @@ authOAuth2' name = authOAuth2Widget' [whamlet|Login via #{name}|] name
--
-- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an
-- example.
--
authOAuth2Widget
:: YesodAuth m
=> WidgetFor m ()
@ -74,7 +71,6 @@ 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 ()
@ -92,11 +88,13 @@ buildPlugin
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
buildPlugin getToken widget name oauth getCreds = AuthPlugin
buildPlugin getToken widget name oauth getCreds =
AuthPlugin
name
(dispatchAuthRequest name oauth getToken getCreds)
login
where login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
where
login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
-- | Read the @'AccessToken'@ from the values set via @'setExtra'@
getAccessToken :: Creds m -> Maybe AccessToken
@ -105,7 +103,6 @@ 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

13
src/Yesod/Auth/OAuth2/Auth0.hs
View File

@ -1,10 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- OAuth2 plugin for <https://auth0.com>
--
-- * Authenticates against specific auth0 tenant
-- * Uses Auth0 user id (a.k.a [sub](https://auth0.com/docs/api/authentication#get-user-info)) as credentials identifier
--
module Yesod.Auth.OAuth2.Auth0
( oauth2Auth0HostScopes
, oauth2Auth0Host
@ -13,8 +13,8 @@ module Yesod.Auth.OAuth2.Auth0
import Data.Aeson as Aeson
import qualified Data.Text as T
import Prelude
import Yesod.Auth.OAuth2.Prelude
import Prelude
-- | https://auth0.com/docs/api/authentication#get-user-info
newtype User = User T.Text
@ -36,18 +36,21 @@ oauth2Auth0HostScopes
:: YesodAuth m => URI -> [Text] -> Text -> Text -> AuthPlugin m
oauth2Auth0HostScopes host scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User uid, userResponse) <- authGetProfile
(User uid, userResponse) <-
authGetProfile
pluginName
manager
token
(host `withPath` "/userinfo")
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = uid
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

13
src/Yesod/Auth/OAuth2/AzureAD.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for Azure AD.
--
-- * Authenticates against Azure AD
-- * Uses email as credentials identifier
--
module Yesod.Auth.OAuth2.AzureAD
( oauth2AzureAD
, oauth2AzureADScoped
) where
import Prelude
import Yesod.Auth.OAuth2.Prelude
import Prelude
newtype User = User Text
@ -31,19 +31,22 @@ oauth2AzureAD = oauth2AzureADScoped defaultScopes
oauth2AzureADScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2AzureADScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://graph.microsoft.com/v1.0/me"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

34
src/Yesod/Auth/OAuth2/AzureADv2.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for Azure AD using the new v2 endpoints.
--
-- * Authenticates against Azure AD
-- * Uses email as credentials identifier
--
module Yesod.Auth.OAuth2.AzureADv2
( oauth2AzureADv2
, oauth2AzureADv2Scoped
) where
import Prelude
import Yesod.Auth.OAuth2.Prelude
import Prelude
import Data.String
import Data.Text (unpack)
@ -34,38 +34,44 @@ oauth2AzureADv2
-- ^ Tenant Id
--
-- If using a multi-tenant App, @common@ can be given here.
--
-> Text -- ^ Client Id
-> Text -- ^ Client secret
-> Text
-- ^ Client Id
-> Text
-- ^ Client secret
-> AuthPlugin m
oauth2AzureADv2 = oauth2AzureADv2Scoped defaultScopes
oauth2AzureADv2Scoped
:: YesodAuth m
=> [Text] -- ^ Scopes
=> [Text]
-- ^ Scopes
-> Text
-- ^ Tenant Id
--
-- If using a multi-tenant App, @common@ can be given here.
--
-> Text -- ^ Client Id
-> Text -- ^ Client Secret
-> Text
-- ^ Client Id
-> Text
-- ^ Client Secret
-> AuthPlugin m
oauth2AzureADv2Scoped scopes tenantId clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://graph.microsoft.com/v1.0/me"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
@ -75,8 +81,8 @@ oauth2AzureADv2Scoped scopes tenantId clientId clientSecret =
}
tenantUrl path =
fromString
$ "https://login.microsoftonline.com/"
fromString $
"https://login.microsoftonline.com/"
<> unpack tenantId
<> "/oauth2/v2.0"
<> path

24
src/Yesod/Auth/OAuth2/BattleNet.hs
View File

@ -7,7 +7,6 @@
-- * Authenticates against battle.net.
-- * Uses user's id as credentials identifier.
-- * Returns user's battletag in extras.
--
module Yesod.Auth.OAuth2.BattleNet
( oauth2BattleNet
, oAuth2BattleNet
@ -28,25 +27,31 @@ pluginName = "battle.net"
oauth2BattleNet
:: YesodAuth m
=> WidgetFor m () -- ^ Login widget
-> Text -- ^ User region (e.g. "eu", "cn", "us")
-> Text -- ^ Client ID
-> Text -- ^ Client Secret
=> WidgetFor m ()
-- ^ Login widget
-> Text
-- ^ User region (e.g. "eu", "cn", "us")
-> Text
-- ^ Client ID
-> Text
-- ^ Client Secret
-> AuthPlugin m
oauth2BattleNet widget region clientId clientSecret =
authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <-
authGetProfile pluginName manager token
$ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
authGetProfile pluginName manager token $
fromRelative "https" (apiHost $ T.toLower region) "/account/user"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
host = wwwHost $ T.toLower region
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
@ -54,7 +59,6 @@ oauth2BattleNet widget region clientId clientSecret =
, oauth2RedirectUri = Nothing
}
apiHost :: Text -> Host
apiHost "cn" = "api.battlenet.com.cn"
apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"

15
src/Yesod/Auth/OAuth2/Bitbucket.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://bitbucket.com
--
-- * Authenticates against bitbucket
-- * Uses bitbucket uuid as credentials identifier
--
module Yesod.Auth.OAuth2.Bitbucket
( oauth2Bitbucket
, oauth2BitbucketScoped
@ -32,25 +32,28 @@ oauth2Bitbucket = oauth2BitbucketScoped defaultScopes
oauth2BitbucketScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2BitbucketScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://api.bitbucket.com/2.0/user"
pure Creds
pure
Creds
{ credsPlugin = pluginName
-- FIXME: Preserved bug. This should just be userId (it's already
, -- FIXME: Preserved bug. This should just be userId (it's already
-- a Text), but because this code was shipped, folks likely have
-- Idents in their database like @"\"...\""@, and if we fixed this
-- they would need migrating. We're keeping it for now as it's a
-- minor wart. Breaking typed APIs is one thing, causing data to go
-- invalid is another.
, credsIdent = T.pack $ show userId
credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

9
src/Yesod/Auth/OAuth2/ClassLink.hs
View File

@ -26,19 +26,22 @@ oauth2ClassLink = oauth2ClassLinkScoped defaultScopes
oauth2ClassLinkScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2ClassLinkScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://nodeapi.classlink.com/v2/my/info"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

40
src/Yesod/Auth/OAuth2/Dispatch.hs
View File

@ -18,8 +18,8 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2.Compat
import UnliftIO.Exception
import URI.ByteString.Extension
import UnliftIO.Exception
import Yesod.Auth hiding (ServerError)
import Yesod.Auth.OAuth2.DispatchError
import Yesod.Auth.OAuth2.ErrorResponse
@ -29,21 +29,26 @@ 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)
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)
-- | Dispatch the various OAuth2 handshake routes
dispatchAuthRequest
:: Text -- ^ Name
-> OAuth2 -- ^ Service details
-> FetchToken -- ^ How to get a token
-> FetchCreds m -- ^ How to get credentials
-> Text -- ^ Method
-> [Text] -- ^ Path pieces
:: 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"] =
handleDispatchError $ dispatchForward name oauth2
@ -55,7 +60,6 @@ dispatchAuthRequest _ _ _ _ _ _ = notFound
--
-- 1. Set a random CSRF token in our session
-- 2. Redirect to the Provider's authorization URL
--
dispatchForward
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
@ -71,7 +75,6 @@ dispatchForward name oauth2 = do
-- 1. Verify the URL's CSRF token matches our session
-- 2. Use the code parameter to fetch an AccessToken for the Provider
-- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider
--
dispatchCallback
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
@ -85,7 +88,8 @@ dispatchCallback name oauth2 getToken getCreds = do
code <- requireGetParam "code"
manager <- authHttpManager
oauth2' <- withCallbackAndState name oauth2 csrf
token <- either (throwError . OAuth2ResultError) pure
token <-
either (throwError . OAuth2ResultError) pure
=<< liftIO (getToken manager oauth2' $ ExchangeToken code)
creds <-
liftIO (getCreds manager token)
@ -102,7 +106,8 @@ withCallbackAndState
withCallbackAndState name oauth2 csrf = do
uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender
callback <- maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri
pure oauth2
pure
oauth2
{ oauth2RedirectUri = Just callback
, oauth2AuthorizeEndpoint =
oauth2AuthorizeEndpoint oauth2 `withQuery` [("state", encodeUtf8 csrf)]
@ -119,12 +124,12 @@ getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
--
-- Therefore, we just exclude @+@ in our tokens, which means this function may
-- return slightly less than 30 characters.
--
setSessionCSRF :: MonadHandler m => Text -> m Text
setSessionCSRF sessionKey = do
csrfToken <- liftIO randomToken
csrfToken <$ setSession sessionKey csrfToken
where randomToken = T.filter (/= '+') <$> randomText 64
where
randomToken = T.filter (/= '+') <$> randomText 64
-- | Verify the callback provided the same CSRF token as in our session
verifySessionCSRF
@ -133,7 +138,8 @@ verifySessionCSRF sessionKey = do
token <- requireGetParam "state"
sessionToken <- lookupSession sessionKey
deleteSession sessionKey
token <$ unless
token
<$ unless
(sessionToken == Just token)
(throwError $ InvalidStateToken sessionToken token)

19
src/Yesod/Auth/OAuth2/DispatchError.hs
View File

@ -9,7 +9,7 @@
{-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.OAuth2.DispatchError
( DispatchError(..)
( DispatchError (..)
, handleDispatchError
, onDispatchError
) where
@ -34,26 +34,25 @@ data DispatchError
| FetchCredsIOException IOException
| FetchCredsYesodOAuth2Exception YesodOAuth2Exception
| OtherDispatchError Text
deriving stock Show
deriving anyclass Exception
deriving stock (Show)
deriving anyclass (Exception)
-- | User-friendly message for any given 'DispatchError'
--
-- Most of these are opaque to the user. The exception details are present for
-- the server logs.
--
dispatchErrorMessage :: DispatchError -> Text
dispatchErrorMessage = \case
MissingParameter name ->
"Parameter '" <> name <> "' is required, but not present in the URL"
InvalidStateToken{} -> "State token is invalid, please try again"
InvalidCallbackUri{} ->
InvalidStateToken {} -> "State token is invalid, please try again"
InvalidCallbackUri {} ->
"Callback URI was not valid, this server may be misconfigured (no approot)"
OAuth2HandshakeError er -> "OAuth2 handshake failure: " <> erUserMessage er
OAuth2ResultError{} -> "Login failed, please try again"
FetchCredsIOException{} -> "Login failed, please try again"
FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again"
OtherDispatchError{} -> "Login failed, please try again"
OAuth2ResultError {} -> "Login failed, please try again"
FetchCredsIOException {} -> "Login failed, please try again"
FetchCredsYesodOAuth2Exception {} -> "Login failed, please try again"
OtherDispatchError {} -> "Login failed, please try again"
handleDispatchError
:: MonadAuthHandler site m

13
src/Yesod/Auth/OAuth2/ErrorResponse.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
-- | OAuth callback error response
--
-- <https://tools.ietf.org/html/rfc6749#section-4.1.2.1>
--
module Yesod.Auth.OAuth2.ErrorResponse
( ErrorResponse(..)
( ErrorResponse (..)
, erUserMessage
, ErrorName(..)
, ErrorName (..)
, onErrorResponse
, unknownError
) where
@ -25,14 +25,14 @@ data ErrorName
| ServerError
| TemporarilyUnavailable
| Unknown Text
deriving Show
deriving (Show)
data ErrorResponse = ErrorResponse
{ erName :: ErrorName
, erDescription :: Maybe Text
, erURI :: Maybe Text
}
deriving Show
deriving (Show)
-- | Textual value suitable for display to a User
erUserMessage :: ErrorResponse -> Text
@ -48,13 +48,12 @@ erUserMessage err = case erName err of
unknownError :: Text -> ErrorResponse
unknownError x =
ErrorResponse { erName = Unknown x, erDescription = Nothing, erURI = Nothing }
ErrorResponse {erName = Unknown x, erDescription = Nothing, erURI = Nothing}
-- | Check query parameters for an error, if found run the given action
--
-- The action is expected to use a short-circuit response function like
-- @'permissionDenied'@, hence this returning @()@.
--
onErrorResponse :: MonadHandler m => (ErrorResponse -> m a) -> m ()
onErrorResponse f = traverse_ f =<< checkErrorResponse

32
src/Yesod/Auth/OAuth2/EveOnline.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
-- |
--
-- OAuth2 plugin for http://eveonline.com
--
-- * Authenticates against eveonline
-- * Uses EVEs unique account-user-char-hash as credentials identifier
--
module Yesod.Auth.OAuth2.EveOnline
( oauth2Eve
, oauth2EveScoped
, WidgetType(..)
, WidgetType (..)
) where
import Yesod.Auth.OAuth2.Prelude
@ -24,7 +24,8 @@ instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "CharacterOwnerHash"
data WidgetType m
= Plain -- ^ Simple "Login via eveonline" text
= -- | Simple "Login via eveonline" text
Plain
| BigWhite
| SmallWhite
| BigBlack
@ -35,12 +36,12 @@ asWidget :: YesodAuth m => WidgetType m -> WidgetFor m ()
asWidget Plain = [whamlet|Login via eveonline|]
asWidget BigWhite =
[whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/4PTzeiAshqiM8osU2giO0Y/5cc4cb60bac52422da2e45db87b6819c/EVE_SSO_Login_Buttons_Large_White.png?w=270&h=45">|]
asWidget BigBlack
= [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/4fSjj56uD6CYwYyus4KmES/4f6385c91e6de56274d99496e6adebab/EVE_SSO_Login_Buttons_Large_Black.png?w=270&h=45">|]
asWidget SmallWhite
= [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/18BxKSXCymyqY4QKo8KwKe/c2bdded6118472dd587c8107f24104d7/EVE_SSO_Login_Buttons_Small_White.png?w=195&h=30">|]
asWidget SmallBlack
= [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/12vrPsIMBQi28QwCGOAqGk/33234da7672c6b0cdca394fc8e0b1c2b/EVE_SSO_Login_Buttons_Small_Black.png?w=195&h=30">|]
asWidget BigBlack =
[whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/4fSjj56uD6CYwYyus4KmES/4f6385c91e6de56274d99496e6adebab/EVE_SSO_Login_Buttons_Large_Black.png?w=270&h=45">|]
asWidget SmallWhite =
[whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/18BxKSXCymyqY4QKo8KwKe/c2bdded6118472dd587c8107f24104d7/EVE_SSO_Login_Buttons_Small_White.png?w=195&h=30">|]
asWidget SmallBlack =
[whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/12vrPsIMBQi28QwCGOAqGk/33234da7672c6b0cdca394fc8e0b1c2b/EVE_SSO_Login_Buttons_Small_Black.png?w=195&h=30">|]
asWidget (Custom a) = a
pluginName :: Text
@ -57,20 +58,23 @@ oauth2EveScoped
oauth2EveScoped scopes widgetType clientId clientSecret =
authOAuth2Widget (asWidget widgetType) pluginName oauth2 $ \manager token ->
do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://login.eveonline.com/oauth/verify"
pure Creds
pure
Creds
{ credsPlugin = "eveonline"
-- FIXME: Preserved bug. See similar comment in Bitbucket provider.
, credsIdent = T.pack $ show userId
, -- FIXME: Preserved bug. See similar comment in Bitbucket provider.
credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

17
src/Yesod/Auth/OAuth2/Exception.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Yesod.Auth.OAuth2.Exception
( YesodOAuth2Exception(..)
( YesodOAuth2Exception (..)
) where
import Control.Exception.Safe
@ -9,21 +9,18 @@ import Data.ByteString.Lazy (ByteString)
import Data.Text (Text)
data YesodOAuth2Exception
= OAuth2Error Text ByteString
-- ^ HTTP error during OAuth2 handshake
= -- | HTTP error during OAuth2 handshake
--
-- Plugin name and JSON-encoded @OAuth2Error@ from @hoauth2@.
--
| JSONDecodingError Text String
-- ^ User profile was not as expected
OAuth2Error Text ByteString
| -- | User profile was not as expected
--
-- Plugin name and Aeson parse error message.
--
| GenericError Text String
-- ^ Other error conditions
JSONDecodingError Text String
| -- | Other error conditions
--
-- Plugin name and error message.
--
GenericError Text String
deriving (Show, Typeable)
instance Exception YesodOAuth2Exception

11
src/Yesod/Auth/OAuth2/GitHub.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://github.com
--
-- * Authenticates against github
-- * Uses github user id as credentials identifier
--
module Yesod.Auth.OAuth2.GitHub
( oauth2GitHub
, oauth2GitHubScoped
@ -32,19 +32,22 @@ oauth2GitHub = oauth2GitHubScoped defaultScopes
oauth2GitHubScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2GitHubScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://api.github.com/user"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

8
src/Yesod/Auth/OAuth2/GitLab.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.GitLab
( oauth2GitLab
, oauth2GitLabHostScopes
@ -32,7 +33,6 @@ defaultScopes = ["read_user"]
--
-- > oauth2GitLabHostScopes defaultHost ["api", "read_user"]
-- > oauth2GitLabHostScopes "https://gitlab.example.com" defaultScopes
--
oauth2GitLab :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2GitLab = oauth2GitLabHostScopes defaultHost defaultScopes
@ -43,13 +43,15 @@ oauth2GitLabHostScopes host scopes clientId clientSecret =
(User userId, userResponse) <-
authGetProfile pluginName manager token $ host `withPath` "/api/v4/user"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

14
src/Yesod/Auth/OAuth2/Google.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
-- |
--
-- OAuth2 plugin for http://www.google.com
@ -23,7 +24,6 @@
-- > updatedCreds = creds { credsIdent = email }
-- >
-- > -- continue normally with updatedCreds
--
module Yesod.Auth.OAuth2.Google
( oauth2Google
, oauth2GoogleWidget
@ -38,7 +38,8 @@ newtype User = User Text
instance FromJSON User where
parseJSON =
withObject "User" $ \o -> User
withObject "User" $ \o ->
User
-- Required for data backwards-compatibility
<$> (("google-uid:" <>) <$> o .: "sub")
@ -63,19 +64,22 @@ oauth2GoogleScopedWidget
:: YesodAuth m => WidgetFor m () -> [Text] -> Text -> Text -> AuthPlugin m
oauth2GoogleScopedWidget widget scopes clientId clientSecret =
authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://www.googleapis.com/oauth2/v3/userinfo"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

22
src/Yesod/Auth/OAuth2/Nylas.hs
View File

@ -26,22 +26,25 @@ defaultScopes = ["email"]
oauth2Nylas :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Nylas clientId clientSecret =
authOAuth2 pluginName oauth $ \manager token -> do
req <- applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
req <-
applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
<$> parseRequest "https://api.nylas.com/account"
resp <- httpLbs req manager
let userResponse = responseBody resp
-- FIXME: was this working? I'm 95% sure that the client will throw its
-- own exception on unsuccessful status codes.
unless (HT.statusIsSuccessful $ responseStatus resp)
$ throwIO
$ YesodOAuth2Exception.GenericError pluginName
$ "Unsuccessful HTTP response: "
unless (HT.statusIsSuccessful $ responseStatus resp) $
throwIO $
YesodOAuth2Exception.GenericError pluginName $
"Unsuccessful HTTP response: "
<> BL8.unpack userResponse
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(User userId) -> pure Creds
( \(User userId) ->
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
@ -49,17 +52,18 @@ oauth2Nylas clientId clientSecret =
)
$ eitherDecode userResponse
where
oauth = OAuth2
oauth =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://api.nylas.com/oauth/authorize"
`withQuery` [ ("response_type", "code")
, ("client_id", encodeUtf8 clientId)
-- N.B. The scopes delimeter is unknown/untested. Verify that before
, -- N.B. The scopes delimeter is unknown/untested. Verify that before
-- extracting this to an argument and offering a Scoped function. In
-- its current state, it doesn't matter because it's only one scope.
, scopeParam "," defaultScopes
scopeParam "," defaultScopes
]
, oauth2TokenEndpoint = "https://api.nylas.com/oauth/token"
, oauth2RedirectUri = Nothing

28
src/Yesod/Auth/OAuth2/Prelude.hs
View File

@ -1,10 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- |
--
-- Modules and support functions required by most or all provider
-- implementations. May also be useful for writing local providers.
--
module Yesod.Auth.OAuth2.Prelude
( authGetProfile
, scopeParam
@ -20,8 +20,8 @@ module Yesod.Auth.OAuth2.Prelude
, (.:?)
, (.=)
, (<>)
, FromJSON(..)
, ToJSON(..)
, FromJSON (..)
, ToJSON (..)
, eitherDecode
, withObject
@ -29,22 +29,22 @@ module Yesod.Auth.OAuth2.Prelude
, throwIO
-- * OAuth2
, OAuth2(..)
, OAuth2Token(..)
, AccessToken(..)
, RefreshToken(..)
, OAuth2 (..)
, OAuth2Token (..)
, AccessToken (..)
, RefreshToken (..)
-- * HTTP
, Manager
-- * Yesod
, YesodAuth(..)
, AuthPlugin(..)
, Creds(..)
, YesodAuth (..)
, AuthPlugin (..)
, Creds (..)
-- * Bytestring URI types
, URI
, Host(..)
, Host (..)
-- * Bytestring URI extensions
, module URI.ByteString.Extension
@ -74,7 +74,6 @@ import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
-- The response should be parsed only far enough to read the required
-- @'credsIdent'@. Additional information should either be re-parsed by or
-- fetched via additional requests by consumers.
--
authGetProfile
:: FromJSON a
=> Text
@ -101,7 +100,7 @@ fromAuthJSON name =
-- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter
scopeParam :: Text -> [Text] -> (ByteString, ByteString)
scopeParam d = ("scope", ) . encodeUtf8 . T.intercalate d
scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
-- brittany-disable-next-binding
@ -115,10 +114,9 @@ scopeParam d = ("scope", ) . encodeUtf8 . T.intercalate d
-- May set the following keys:
--
-- - @refreshToken@: if the provider supports refreshing the @accessToken@
--
setExtra :: OAuth2Token -> BL.ByteString -> [(Text, Text)]
setExtra token userResponse =
[ ("accessToken", atoken $ accessToken token)
, ("userResponse", decodeUtf8 $ BL.toStrict userResponse)
]
<> maybe [] (pure . ("refreshToken", ) . rtoken) (refreshToken token)
<> maybe [] (pure . ("refreshToken",) . rtoken) (refreshToken token)

2
src/Yesod/Auth/OAuth2/Random.hs
View File

@ -5,7 +5,7 @@ module Yesod.Auth.OAuth2.Random
) where
import Crypto.Random (MonadRandom, getRandomBytes)
import Data.ByteArray.Encoding (Base(Base64), convertToBase)
import Data.ByteArray.Encoding (Base (Base64), convertToBase)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)

27
src/Yesod/Auth/OAuth2/Salesforce.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://login.salesforce.com
--
-- * Authenticates against Salesforce (or sandbox)
-- * Uses Salesforce user id as credentials identifier
--
module Yesod.Auth.OAuth2.Salesforce
( oauth2Salesforce
, oauth2SalesforceScoped
@ -30,7 +30,8 @@ oauth2Salesforce :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Salesforce = oauth2SalesforceScoped defaultScopes
oauth2SalesforceScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2SalesforceScoped = salesforceHelper
oauth2SalesforceScoped =
salesforceHelper
pluginName
"https://login.salesforce.com/services/oauth2/userinfo"
"https://login.salesforce.com/services/oauth2/authorize"
@ -41,7 +42,8 @@ oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped defaultScopes
oauth2SalesforceSandboxScoped
:: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2SalesforceSandboxScoped = salesforceHelper
oauth2SalesforceSandboxScoped =
salesforceHelper
(pluginName <> "-sandbox")
"https://test.salesforce.com/services/oauth2/userinfo"
"https://test.salesforce.com/services/oauth2/authorize"
@ -50,24 +52,29 @@ oauth2SalesforceSandboxScoped = salesforceHelper
salesforceHelper
:: YesodAuth m
=> Text
-> URI -- ^ User profile
-> URI -- ^ Authorize
-> URI -- ^ Token
-> URI
-- ^ User profile
-> URI
-- ^ Authorize
-> URI
-- ^ Token
-> [Text]
-> Text
-> Text
-> AuthPlugin m
salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSecret
= authOAuth2 name oauth2 $ \manager token -> do
salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSecret =
authOAuth2 name oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile name manager token profileUri
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = authorizeUri `withQuery` [scopeParam " " scopes]

20
src/Yesod/Auth/OAuth2/Slack.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- OAuth2 plugin for https://slack.com/
--
-- * Authenticates against slack
-- * Uses slack user id as credentials identifier
--
module Yesod.Auth.OAuth2.Slack
( SlackScope(..)
( SlackScope (..)
, oauth2Slack
, oauth2SlackScoped
) where
@ -14,7 +14,11 @@ module Yesod.Auth.OAuth2.Slack
import Yesod.Auth.OAuth2.Prelude
import Network.HTTP.Client
(httpLbs, parseUrlThrow, responseBody, setQueryString)
( httpLbs
, parseUrlThrow
, responseBody
, setQueryString
)
import Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
data SlackScope
@ -50,13 +54,16 @@ oauth2SlackScoped
oauth2SlackScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
let param = encodeUtf8 $ atoken $ accessToken token
req <- setQueryString [("token", Just param)]
req <-
setQueryString [("token", Just param)]
<$> parseUrlThrow "https://slack.com/api/users.identity"
userResponse <- responseBody <$> httpLbs req manager
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(User userId) -> pure Creds
( \(User userId) ->
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
@ -64,7 +71,8 @@ oauth2SlackScoped scopes clientId clientSecret =
)
$ eitherDecode userResponse
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

11
src/Yesod/Auth/OAuth2/Spotify.hs
View File

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://spotify.com
--
module Yesod.Auth.OAuth2.Spotify
( oauth2Spotify
) where
@ -20,19 +20,22 @@ pluginName = "spotify"
oauth2Spotify :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2Spotify scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://api.spotify.com/v1/me"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

11
src/Yesod/Auth/OAuth2/Twitch.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://twitch.tv
--
-- * Authenticates against twitch
-- * Uses twitch user id as credentials identifier
--
module Yesod.Auth.OAuth2.Twitch
( oauth2Twitch
, oauth2TwitchScoped
@ -32,19 +32,22 @@ oauth2Twitch = oauth2TwitchScoped defaultScopes
oauth2TwitchScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2TwitchScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://id.twitch.tv/oauth2/validate"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

11
src/Yesod/Auth/OAuth2/Upcase.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://upcase.com
--
-- * Authenticates against upcase
-- * Uses upcase user id as credentials identifier
--
module Yesod.Auth.OAuth2.Upcase
( oauth2Upcase
) where
@ -27,19 +27,22 @@ pluginName = "upcase"
oauth2Upcase :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Upcase clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
(User userId, userResponse) <-
authGetProfile
pluginName
manager
token
"http://upcase.com/api/v1/me.json"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "http://upcase.com/oauth/authorize"

18
src/Yesod/Auth/OAuth2/WordPressDotCom.hs
View File

@ -16,26 +16,30 @@ instance FromJSON WpUser where
parseJSON = withObject "WpUser" $ \o -> WpUser <$> o .: "ID"
oauth2WordPressDotCom
:: (YesodAuth m)
=> Text -- ^ Client Id
-> Text -- ^ Client Secret
:: YesodAuth m
=> Text
-- ^ Client Id
-> Text
-- ^ Client Secret
-> AuthPlugin m
oauth2WordPressDotCom clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(WpUser userId, userResponse) <- authGetProfile
(WpUser userId, userResponse) <-
authGetProfile
pluginName
manager
token
"https://public-api.wordpress.com/rest/v1/me/"
pure Creds
pure
Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
oauth2 =
OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =

7
test/URI/ByteString/ExtensionSpec.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module URI.ByteString.ExtensionSpec
( spec
) where
@ -61,8 +62,7 @@ spec = do
uriWithQuery `shouldBe` [uri|http://example.com?foo=bar|]
it "handles a URI with an existing query" $ do
let
uriWithQuery =
let uriWithQuery =
[uri|http://example.com?foo=bar|] `withQuery` [("baz", "bat")]
uriWithQuery `shouldBe` [uri|http://example.com?foo=bar&baz=bat|]
@ -71,8 +71,7 @@ spec = do
-- it's worthwhile to show that you don't (and can't) pre-sanitize when
-- using this function.
it "handles santization of the query" $ do
let
uriWithQuery =
let uriWithQuery =
[uri|http://example.com|] `withQuery` [("foo", "bar baz")]
toText uriWithQuery `shouldBe` "http://example.com?foo=bar%20baz"