haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-01-12 04:08:30 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Reformat everything with Brittany

Browse Source
This commit is contained in:
patrick brisbin 2023-04-05 17:50:51 -04:00
parent 8475daa665
commit 6314843076
No known key found for this signature in database
GPG Key ID: 07BF97A312D7F34C
26 changed files with 333 additions and 317 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
example/Main.hs
View File

@ -78,7 +78,7 @@ 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)]
$ [("credsIdent", credsIdent c), ("credsPlugin", credsPlugin c)]
++ credsExtra c
return $ Authenticated "1"
@ -131,7 +131,7 @@ mkFoundation :: IO App
mkFoundation = do
loadEnv
auth0Host <- getEnv "AUTH0_HOST"
auth0Host <- getEnv "AUTH0_HOST"
appHttpManager <- newManager tlsManagerSettings
appAuthPlugins <- sequence
@ -140,28 +140,28 @@ mkFoundation = do
--
-- FIXME: oauth2BattleNet is quite annoying!
--
[ loadPlugin oauth2AzureAD "AZURE_AD"
[ loadPlugin oauth2AzureAD "AZURE_AD"
, loadPlugin (oauth2Auth0Host $ fromString auth0Host) "AUTH0"
, loadPlugin (oauth2BattleNet [whamlet|TODO|] "en") "BATTLE_NET"
, loadPlugin oauth2Bitbucket "BITBUCKET"
, loadPlugin oauth2ClassLink "CLASSLINK"
, loadPlugin (oauth2Eve Plain) "EVE_ONLINE"
, loadPlugin oauth2GitHub "GITHUB"
, loadPlugin oauth2GitLab "GITLAB"
, loadPlugin oauth2Google "GOOGLE"
, loadPlugin oauth2Nylas "NYLAS"
, loadPlugin oauth2Salesforce "SALES_FORCE"
, loadPlugin oauth2Slack "SLACK"
, loadPlugin (oauth2Spotify []) "SPOTIFY"
, loadPlugin oauth2Twitch "TWITCH"
, loadPlugin oauth2WordPressDotCom "WORDPRESS_DOT_COM"
, loadPlugin oauth2Upcase "UPCASE"
, loadPlugin (oauth2BattleNet [whamlet|TODO|] "en") "BATTLE_NET"
, loadPlugin oauth2Bitbucket "BITBUCKET"
, loadPlugin oauth2ClassLink "CLASSLINK"
, loadPlugin (oauth2Eve Plain) "EVE_ONLINE"
, loadPlugin oauth2GitHub "GITHUB"
, loadPlugin oauth2GitLab "GITLAB"
, loadPlugin oauth2Google "GOOGLE"
, loadPlugin oauth2Nylas "NYLAS"
, loadPlugin oauth2Salesforce "SALES_FORCE"
, loadPlugin oauth2Slack "SLACK"
, loadPlugin (oauth2Spotify []) "SPOTIFY"
, loadPlugin oauth2Twitch "TWITCH"
, loadPlugin oauth2WordPressDotCom "WORDPRESS_DOT_COM"
, loadPlugin oauth2Upcase "UPCASE"
]
return App { .. }
where
loadPlugin f prefix = do
clientId <- getEnv $ prefix <> "_CLIENT_ID"
clientId <- getEnv $ prefix <> "_CLIENT_ID"
clientSecret <- getEnv $ prefix <> "_CLIENT_SECRET"
pure $ f (T.pack clientId) (T.pack clientSecret)

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

@ -13,30 +13,26 @@ import qualified Data.ByteString.Char8 as C8
import URI.ByteString
instance IsString Scheme where
fromString = Scheme . fromString
fromString = Scheme . fromString
instance IsString Host where
fromString = Host . fromString
fromString = Host . fromString
instance IsString (URIRef Absolute) where
fromString = either (error . show) id
. parseURI strictURIParserOptions
. C8.pack
fromString =
either (error . show) id . parseURI strictURIParserOptions . C8.pack
instance IsString (URIRef Relative) where
fromString = either (error . show) id
. parseRelativeRef strictURIParserOptions
. C8.pack
fromString =
either (error . show) id . parseRelativeRef strictURIParserOptions . C8.pack
fromText :: Text -> Maybe URI
fromText = either (const Nothing) Just
. parseURI strictURIParserOptions
. encodeUtf8
fromText =
either (const Nothing) Just . parseURI strictURIParserOptions . encodeUtf8
unsafeFromText :: Text -> URI
unsafeFromText = either (error . show) id
. parseURI strictURIParserOptions
. encodeUtf8
unsafeFromText =
either (error . show) id . parseURI strictURIParserOptions . encodeUtf8
toText :: URI -> Text
toText = decodeUtf8 . serializeURIRef'
@ -46,8 +42,8 @@ fromRelative s h = flip withHost h . toAbsolute s
withHost :: URIRef a -> Host -> URIRef a
withHost u h = u & authorityL %~ maybe
(Just $ Authority Nothing h Nothing)
(\a -> Just $ a & authorityHostL .~ h)
(Just $ Authority Nothing h Nothing)
(\a -> Just $ a & authorityHostL .~ h)
withPath :: URIRef a -> ByteString -> URIRef a
withPath u p = u & pathL .~ p

8
src/UnliftIO/Except.hs
View File

@ -1,12 +1,12 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module UnliftIO.Except
() where
() where
import Control.Monad.Except
import UnliftIO
instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where
withRunInIO exceptToIO = ExceptT $ try $ do
withRunInIO $ \runInIO ->
exceptToIO (runInIO . (either throwIO pure <=< runExceptT))
withRunInIO exceptToIO = ExceptT $ try $ do
withRunInIO $ \runInIO ->
exceptToIO (runInIO . (either throwIO pure <=< runExceptT))

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

@ -36,21 +36,22 @@ oauth2Auth0HostScopes
:: YesodAuth m => URI -> [Text] -> Text -> Text -> AuthPlugin m
oauth2Auth0HostScopes host scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User uid, userResponse) <- authGetProfile pluginName
manager
token
(host `withPath` "/userinfo")
pure Creds { credsPlugin = pluginName
, credsIdent = uid
, credsExtra = setExtra token userResponse
}
(User uid, userResponse) <- authGetProfile
pluginName
manager
token
(host `withPath` "/userinfo")
pure Creds
{ credsPlugin = pluginName
, credsIdent = uid
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = host
`withPath` "/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = host `withPath` "/oauth/token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
host `withPath` "/authorize" `withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = host `withPath` "/oauth/token"
, oauth2RedirectUri = Nothing
}

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

@ -37,19 +37,20 @@ oauth2AzureADScoped scopes clientId clientSecret =
token
"https://graph.microsoft.com/v1.0/me"
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://login.windows.net/common/oauth2/authorize"
`withQuery` [ scopeParam "," scopes
, ("resource", "https://graph.microsoft.com")
]
, oauth2TokenEndpoint = "https://login.windows.net/common/oauth2/token"
, oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = "https://login.windows.net/common/oauth2/token"
, oauth2RedirectUri = Nothing
}

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

@ -39,27 +39,28 @@ oauth2BattleNet widget region clientId clientSecret =
authGetProfile pluginName manager token
$ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
host = wwwHost $ T.toLower region
host = wwwHost $ T.toLower region
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
, oauth2TokenEndpoint = fromRelative "https" host "/oauth/token"
, oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = fromRelative "https" host "/oauth/token"
, oauth2RedirectUri = Nothing
}
apiHost :: Text -> Host
apiHost "cn" = "api.battlenet.com.cn"
apiHost "cn" = "api.battlenet.com.cn"
apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"
wwwHost :: Text -> Host
wwwHost "cn" = "www.battlenet.com.cn"
wwwHost "cn" = "www.battlenet.com.cn"
wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"
oAuth2BattleNet

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

@ -38,22 +38,24 @@ oauth2BitbucketScoped scopes clientId clientSecret =
token
"https://api.bitbucket.com/2.0/user"
pure Creds { credsPlugin = pluginName
pure Creds
{ credsPlugin = pluginName
-- 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
, credsExtra = setExtra token userResponse
}
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://bitbucket.com/site/oauth2/authorize"
`withQuery` [scopeParam "," scopes]
, oauth2TokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://bitbucket.com/site/oauth2/authorize"
`withQuery` [scopeParam "," scopes]
, oauth2TokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
, oauth2RedirectUri = Nothing
}

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

@ -32,16 +32,18 @@ oauth2ClassLinkScoped scopes clientId clientSecret =
token
"https://nodeapi.classlink.com/v2/my/info"
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://launchpad.classlink.com/oauth2/v2/auth"
`withQuery` [scopeParam "," scopes]
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://launchpad.classlink.com/oauth2/v2/auth"
`withQuery` [scopeParam "," scopes]
, oauth2TokenEndpoint = "https://launchpad.classlink.com/oauth2/v2/token"
, oauth2RedirectUri = Nothing
, oauth2RedirectUri = Nothing
}

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

@ -62,7 +62,7 @@ dispatchForward
-> OAuth2
-> m TypedContent
dispatchForward name oauth2 = do
csrf <- setSessionCSRF $ tokenSessionKey name
csrf <- setSessionCSRF $ tokenSessionKey name
oauth2' <- withCallbackAndState name oauth2 csrf
redirect $ toText $ authorizationUrl oauth2'
@ -81,11 +81,11 @@ dispatchCallback
-> m TypedContent
dispatchCallback name oauth2 getToken getCreds = do
onErrorResponse $ throwError . OAuth2HandshakeError
csrf <- verifySessionCSRF $ tokenSessionKey name
code <- requireGetParam "code"
csrf <- verifySessionCSRF $ tokenSessionKey name
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)
@ -100,12 +100,12 @@ withCallbackAndState
-> Text
-> m OAuth2
withCallbackAndState name oauth2 csrf = do
uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender
uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender
callback <- maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri
pure oauth2
{ oauth2RedirectUri = Just callback
, oauth2AuthorizeEndpoint = oauth2AuthorizeEndpoint oauth2
`withQuery` [("state", encodeUtf8 csrf)]
{ oauth2RedirectUri = Just callback
, oauth2AuthorizeEndpoint =
oauth2AuthorizeEndpoint oauth2 `withQuery` [("state", encodeUtf8 csrf)]
}
getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)
@ -130,11 +130,12 @@ setSessionCSRF sessionKey = do
verifySessionCSRF
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
verifySessionCSRF sessionKey = do
token <- requireGetParam "state"
token <- requireGetParam "state"
sessionToken <- lookupSession sessionKey
deleteSession sessionKey
token <$ unless (sessionToken == Just token)
(throwError $ InvalidStateToken sessionToken token)
token <$ unless
(sessionToken == Just token)
(throwError $ InvalidStateToken sessionToken token)
requireGetParam
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text

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

@ -50,10 +50,10 @@ dispatchErrorMessage = \case
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"
OAuth2ResultError{} -> "Login failed, please try again"
FetchCredsIOException{} -> "Login failed, please try again"
FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again"
OtherDispatchError{} -> "Login failed, please try again"
OtherDispatchError{} -> "Login failed, please try again"
handleDispatchError
:: MonadAuthHandler site m
@ -69,9 +69,10 @@ onDispatchError err = do
let suffix = " [errorId=" <> errorId <> "]"
$(logError) $ pack (displayException err) <> suffix
let message = dispatchErrorMessage err <> suffix
messageValue =
object ["error" .= object ["id" .= errorId, "message" .= message]]
let
message = dispatchErrorMessage err <> suffix
messageValue =
object ["error" .= object ["id" .= errorId, "message" .= message]]
loginR <- ($ LoginR) <$> getRouteToParent

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

@ -4,13 +4,12 @@
-- <https://tools.ietf.org/html/rfc6749#section-4.1.2.1>
--
module Yesod.Auth.OAuth2.ErrorResponse
( ErrorResponse(..)
, erUserMessage
, ErrorName(..)
, onErrorResponse
, unknownError
)
where
( ErrorResponse(..)
, erUserMessage
, ErrorName(..)
, onErrorResponse
, unknownError
) where
import Data.Foldable (traverse_)
import Data.Text (Text)
@ -29,30 +28,27 @@ data ErrorName
deriving Show
data ErrorResponse = ErrorResponse
{ erName :: ErrorName
, erDescription :: Maybe Text
, erURI :: Maybe Text
}
deriving Show
{ erName :: ErrorName
, erDescription :: Maybe Text
, erURI :: Maybe Text
}
deriving Show
-- | Textual value suitable for display to a User
erUserMessage :: ErrorResponse -> Text
erUserMessage err = case erName err of
InvalidRequest -> "Invalid request"
UnauthorizedClient -> "Unauthorized client"
AccessDenied -> "Access denied"
UnsupportedResponseType -> "Unsupported response type"
InvalidScope -> "Invalid scope"
ServerError -> "Server error"
TemporarilyUnavailable -> "Temporarily unavailable"
Unknown _ -> "Unknown error"
InvalidRequest -> "Invalid request"
UnauthorizedClient -> "Unauthorized client"
AccessDenied -> "Access denied"
UnsupportedResponseType -> "Unsupported response type"
InvalidScope -> "Invalid scope"
ServerError -> "Server error"
TemporarilyUnavailable -> "Temporarily unavailable"
Unknown _ -> "Unknown error"
unknownError :: Text -> ErrorResponse
unknownError x = ErrorResponse
{ erName = Unknown x
, erDescription = Nothing
, erURI = Nothing
}
unknownError x =
ErrorResponse { erName = Unknown x, erDescription = Nothing, erURI = Nothing }
-- | Check query parameters for an error, if found run the given action
--
@ -64,12 +60,12 @@ onErrorResponse f = traverse_ f =<< checkErrorResponse
checkErrorResponse :: MonadHandler m => m (Maybe ErrorResponse)
checkErrorResponse = do
merror <- lookupGetParam "error"
merror <- lookupGetParam "error"
for merror $ \err ->
ErrorResponse (readErrorName err)
<$> lookupGetParam "error_description"
<*> lookupGetParam "error_uri"
for merror $ \err ->
ErrorResponse (readErrorName err)
<$> lookupGetParam "error_description"
<*> lookupGetParam "error_uri"
readErrorName :: Text -> ErrorName
readErrorName "invalid_request" = InvalidRequest

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

@ -63,19 +63,19 @@ oauth2EveScoped scopes widgetType clientId clientSecret =
token
"https://login.eveonline.com/oauth/verify"
pure Creds { credsPlugin = "eveonline"
pure Creds
{ credsPlugin = "eveonline"
-- FIXME: Preserved bug. See similar comment in Bitbucket provider.
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://login.eveonline.com/oauth/authorize"
`withQuery` [ ("response_type", "code")
, scopeParam " " scopes
]
, oauth2TokenEndpoint = "https://login.eveonline.com/oauth/token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://login.eveonline.com/oauth/authorize"
`withQuery` [("response_type", "code"), scopeParam " " scopes]
, oauth2TokenEndpoint = "https://login.eveonline.com/oauth/token"
, oauth2RedirectUri = Nothing
}

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

@ -1,8 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Yesod.Auth.OAuth2.Exception
( YesodOAuth2Exception(..)
) where
( YesodOAuth2Exception(..)
) where
import Control.Exception.Safe
import Data.ByteString.Lazy (ByteString)

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

@ -38,16 +38,18 @@ oauth2GitHubScoped scopes clientId clientSecret =
token
"https://api.github.com/user"
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://github.com/login/oauth/authorize"
`withQuery` [scopeParam "," scopes]
, oauth2TokenEndpoint = "https://github.com/login/oauth/access_token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://github.com/login/oauth/authorize"
`withQuery` [scopeParam "," scopes]
, oauth2TokenEndpoint = "https://github.com/login/oauth/access_token"
, oauth2RedirectUri = Nothing
}

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

@ -43,17 +43,17 @@ oauth2GitLabHostScopes host scopes clientId clientSecret =
(User userId, userResponse) <-
authGetProfile pluginName manager token $ host `withPath` "/api/v4/user"
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = host
`withPath` "/oauth/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = host `withPath` "/oauth/token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
host `withPath` "/oauth/authorize" `withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = host `withPath` "/oauth/token"
, oauth2RedirectUri = Nothing
}

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

@ -69,16 +69,18 @@ oauth2GoogleScopedWidget widget scopes clientId clientSecret =
token
"https://www.googleapis.com/oauth2/v3/userinfo"
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://accounts.google.com/o/oauth2/auth"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
, oauth2RedirectUri = Nothing
}

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

@ -34,33 +34,33 @@ oauth2Nylas clientId clientSecret =
-- 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: "
$ throwIO
$ YesodOAuth2Exception.GenericError pluginName
$ "Unsuccessful HTTP response: "
<> BL8.unpack userResponse
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(User userId) -> pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
(\(User userId) -> pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
)
$ eitherDecode userResponse
where
oauth = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://api.nylas.com/oauth/authorize"
`withQuery` [ ("response_type", "code")
, ( "client_id"
, encodeUtf8 clientId
)
{ 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
-- 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
]
, oauth2TokenEndpoint = "https://api.nylas.com/oauth/token"
, oauth2RedirectUri = Nothing
, scopeParam "," defaultScopes
]
, oauth2TokenEndpoint = "https://api.nylas.com/oauth/token"
, oauth2RedirectUri = Nothing
}

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

@ -85,7 +85,7 @@ authGetProfile
-> URI
-> IO (a, BL.ByteString)
authGetProfile name manager token url = do
resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url
resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url
decoded <- fromAuthJSON name resp
pure (decoded, resp)

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

@ -1,8 +1,8 @@
{-# LANGUAGE TypeApplications #-}
module Yesod.Auth.OAuth2.Random
( randomText
) where
( randomText
) where
import Crypto.Random (MonadRandom, getRandomBytes)
import Data.ByteArray.Encoding (Base(Base64), convertToBase)
@ -11,9 +11,9 @@ import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
randomText
:: MonadRandom m
=> Int
:: MonadRandom m
=> Int
-- ^ Size in Bytes (note necessarily characters)
-> m Text
-> m Text
randomText size =
decodeUtf8 . convertToBase @ByteString Base64 <$> getRandomBytes size
decodeUtf8 . convertToBase @ByteString Base64 <$> getRandomBytes size

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

@ -61,15 +61,16 @@ salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSec
= authOAuth2 name oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile name manager token profileUri
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = authorizeUri `withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = tokenUri
, oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = tokenUri
, oauth2RedirectUri = Nothing
}

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

@ -14,7 +14,7 @@ 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
@ -24,9 +24,9 @@ data SlackScope
| SlackAvatarScope
scopeText :: SlackScope -> Text
scopeText SlackBasicScope = "identity.basic"
scopeText SlackEmailScope = "identity.email"
scopeText SlackTeamScope = "identity.team"
scopeText SlackBasicScope = "identity.basic"
scopeText SlackEmailScope = "identity.email"
scopeText SlackTeamScope = "identity.team"
scopeText SlackAvatarScope = "identity.avatar"
newtype User = User Text
@ -56,20 +56,20 @@ oauth2SlackScoped scopes clientId clientSecret =
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(User userId) -> pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
(\(User userId) -> pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
)
$ eitherDecode userResponse
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://slack.com/oauth/authorize"
`withQuery` [ scopeParam ","
$ map scopeText scopes
]
, oauth2TokenEndpoint = "https://slack.com/api/oauth.access"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://slack.com/oauth/authorize"
`withQuery` [scopeParam "," $ map scopeText scopes]
, oauth2TokenEndpoint = "https://slack.com/api/oauth.access"
, oauth2RedirectUri = Nothing
}

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

@ -26,16 +26,18 @@ oauth2Spotify scopes clientId clientSecret =
token
"https://api.spotify.com/v1/me"
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://accounts.spotify.com/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = "https://accounts.spotify.com/api/token"
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://accounts.spotify.com/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = "https://accounts.spotify.com/api/token"
, oauth2RedirectUri = Nothing
}

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

@ -38,19 +38,22 @@ oauth2TwitchScoped scopes clientId clientSecret =
token
"https://id.twitch.tv/oauth2/validate"
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "https://id.twitch.tv/oauth2/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = "https://id.twitch.tv/oauth2/token"
`withQuery` [ ("client_id", T.encodeUtf8 clientId)
, ("client_secret", T.encodeUtf8 clientSecret)
]
, oauth2RedirectUri = Nothing
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://id.twitch.tv/oauth2/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint =
"https://id.twitch.tv/oauth2/token"
`withQuery` [ ("client_id", T.encodeUtf8 clientId)
, ("client_secret", T.encodeUtf8 clientSecret)
]
, oauth2RedirectUri = Nothing
}

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

@ -33,15 +33,16 @@ oauth2Upcase clientId clientSecret =
token
"http://upcase.com/api/v1/me.json"
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "http://upcase.com/oauth/authorize"
, oauth2TokenEndpoint = "http://upcase.com/oauth/token"
, oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = "http://upcase.com/oauth/token"
, oauth2RedirectUri = Nothing
}

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

@ -28,18 +28,19 @@ oauth2WordPressDotCom clientId clientSecret =
token
"https://public-api.wordpress.com/rest/v1/me/"
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
"https://public-api.wordpress.com/oauth2/authorize"
`withQuery` [scopeParam "," ["auth"]]
, oauth2TokenEndpoint = "https://public-api.wordpress.com/oauth2/token"
, oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = "https://public-api.wordpress.com/oauth2/token"
, oauth2RedirectUri = Nothing
}

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

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module URI.ByteString.ExtensionSpec
( spec
) where
( spec
) where
import Test.Hspec
@ -14,65 +14,68 @@ import URI.ByteString.QQ
spec :: Spec
spec = do
describe "IsString Scheme" $ it "works" $ do
"https" `shouldBe` Scheme "https"
describe "IsString Scheme" $ it "works" $ do
"https" `shouldBe` Scheme "https"
describe "IsString Host" $ it "works" $ do
"example.com" `shouldBe` Host "example.com"
describe "IsString Host" $ it "works" $ do
"example.com" `shouldBe` Host "example.com"
describe "IsString URIRef Relative" $ it "works" $ do
"example.com/foo?bar=baz"
`shouldBe` [relativeRef|example.com/foo?bar=baz|]
describe "IsString URIRef Relative" $ it "works" $ do
"example.com/foo?bar=baz" `shouldBe` [relativeRef|example.com/foo?bar=baz|]
describe "IsString URIRef Absolute" $ it "works" $ do
"https://example.com/foo?bar=baz"
`shouldBe` [uri|https://example.com/foo?bar=baz|]
describe "IsString URIRef Absolute" $ it "works" $ do
"https://example.com/foo?bar=baz"
`shouldBe` [uri|https://example.com/foo?bar=baz|]
describe "fromText" $ do
it "returns Just a URI for valid values, as the quasi-quoter would" $ do
fromText "http://example.com/foo?bar=baz"
`shouldBe` Just [uri|http://example.com/foo?bar=baz|]
describe "fromText" $ do
it "returns Just a URI for valid values, as the quasi-quoter would" $ do
fromText "http://example.com/foo?bar=baz"
`shouldBe` Just [uri|http://example.com/foo?bar=baz|]
it "returns Nothing for invalid values" $ do
fromText "Oh my, what did I do?" `shouldBe` Nothing
it "returns Nothing for invalid values" $ do
fromText "Oh my, what did I do?" `shouldBe` Nothing
describe "unsafeFromText" $ do
it "returns a URI for valid values, as the quasi-quoter would" $ do
unsafeFromText "http://example.com/foo?bar=baz"
`shouldBe` [uri|http://example.com/foo?bar=baz|]
describe "unsafeFromText" $ do
it "returns a URI for valid values, as the quasi-quoter would" $ do
unsafeFromText "http://example.com/foo?bar=baz"
`shouldBe` [uri|http://example.com/foo?bar=baz|]
it "raises for invalid values" $ do
evaluate (unsafeFromText "Oh my, what did I do?")
`shouldThrow` errorContaining "MissingColon"
it "raises for invalid values" $ do
evaluate (unsafeFromText "Oh my, what did I do?")
`shouldThrow` errorContaining "MissingColon"
describe "toText" $ do
it "serializes the URI to text" $ do
toText [uri|https://example.com/foo?bar=baz|]
`shouldBe` "https://example.com/foo?bar=baz"
describe "toText" $ do
it "serializes the URI to text" $ do
toText [uri|https://example.com/foo?bar=baz|]
`shouldBe` "https://example.com/foo?bar=baz"
describe "fromRelative" $ do
it "makes a URI absolute with a given host" $ do
fromRelative "ftp" "foo.com" [relativeRef|/bar?baz=bat|]
`shouldBe` [uri|ftp://foo.com/bar?baz=bat|]
describe "fromRelative" $ do
it "makes a URI absolute with a given host" $ do
fromRelative "ftp" "foo.com" [relativeRef|/bar?baz=bat|]
`shouldBe` [uri|ftp://foo.com/bar?baz=bat|]
describe "withQuery" $ do
it "appends a query to a URI" $ do
let uriWithQuery = [uri|http://example.com|] `withQuery` [("foo", "bar")]
describe "withQuery" $ do
it "appends a query to a URI" $ do
let uriWithQuery = [uri|http://example.com|] `withQuery` [("foo", "bar")]
uriWithQuery `shouldBe` [uri|http://example.com?foo=bar|]
uriWithQuery `shouldBe` [uri|http://example.com?foo=bar|]
it "handles a URI with an existing query" $ do
let uriWithQuery = [uri|http://example.com?foo=bar|] `withQuery` [("baz", "bat")]
it "handles a URI with an existing query" $ do
let
uriWithQuery =
[uri|http://example.com?foo=bar|] `withQuery` [("baz", "bat")]
uriWithQuery `shouldBe` [uri|http://example.com?foo=bar&baz=bat|]
uriWithQuery `shouldBe` [uri|http://example.com?foo=bar&baz=bat|]
-- This is arguably testing the internals of another package, but IMO
-- 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 = [uri|http://example.com|] `withQuery` [("foo", "bar baz")]
-- This is arguably testing the internals of another package, but IMO
-- 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 =
[uri|http://example.com|] `withQuery` [("foo", "bar baz")]
toText uriWithQuery `shouldBe` "http://example.com?foo=bar%20baz"
toText uriWithQuery `shouldBe` "http://example.com?foo=bar%20baz"
errorContaining :: String -> Selector ErrorCall
errorContaining msg = (msg `isInfixOf`) . show