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

Restyle

Browse Source 
- Restyled by brittany
- Restyled by stylish-haskell
This commit is contained in:
Restyled.io 2022-01-31 17:58:01 +00:00 committed by patrick brisbin
parent 772223a2d1
commit fbf29fb526
No known key found for this signature in database
GPG Key ID: C6A68C15A00FB52B
17 changed files with 554 additions and 601 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,25 +8,25 @@
-- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage.
--
module Yesod.Auth.OAuth2
( OAuth2(..)
, FetchCreds
, Manager
, OAuth2Token(..)
, Creds(..)
, oauth2Url
, authOAuth2
, authOAuth2Widget
( OAuth2(..)
, FetchCreds
, Manager
, OAuth2Token(..)
, Creds(..)
, oauth2Url
, authOAuth2
, authOAuth2Widget
-- * Alternatives that use 'fetchAccessToken2'
, authOAuth2'
, authOAuth2Widget'
, authOAuth2'
, authOAuth2Widget'
-- * Reading our @'credsExtra'@ keys
, getAccessToken
, getRefreshToken
, getUserResponse
, getUserResponseJSON
) where
, getAccessToken
, getRefreshToken
, getUserResponse
, getUserResponseJSON
) where
import Control.Error.Util (note)
import Control.Monad ((<=<))
@ -63,12 +63,12 @@ authOAuth2' name = authOAuth2Widget' [whamlet|Login via #{name}|] name
-- example.
--
authOAuth2Widget
:: YesodAuth m
=> WidgetFor m ()
-> Text
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
:: YesodAuth m
=> WidgetFor m ()
-> Text
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
authOAuth2Widget = buildPlugin fetchAccessToken
-- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2'
@ -76,27 +76,27 @@ authOAuth2Widget = buildPlugin fetchAccessToken
-- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
--
authOAuth2Widget'
:: YesodAuth m
=> WidgetFor m ()
-> Text
-> OAuth2
-> FetchCreds m
-> AuthPlugin m
:: 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
:: 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}|]
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
@ -112,9 +112,9 @@ 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
(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
eitherDecode <=< note "userResponse key not present" . getUserResponse

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

@ -7,10 +7,9 @@
-- * Uses email as credentials identifier
--
module Yesod.Auth.OAuth2.AzureAD
( oauth2AzureAD
, oauth2AzureADScoped
)
where
( oauth2AzureAD
, oauth2AzureADScoped
) where
import Prelude
import Yesod.Auth.OAuth2.Prelude
@ -18,7 +17,7 @@ import Yesod.Auth.OAuth2.Prelude
newtype User = User Text
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "mail"
parseJSON = withObject "User" $ \o -> User <$> o .: "mail"
pluginName :: Text
pluginName = "azuread"
@ -31,28 +30,26 @@ 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
pluginName
manager
token
"https://graph.microsoft.com/v1.0/me"
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://graph.microsoft.com/v1.0/me"
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ 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
}
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ 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
}

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

@ -9,10 +9,9 @@
-- * Returns user's battletag in extras.
--
module Yesod.Auth.OAuth2.BattleNet
( oauth2BattleNet
, oAuth2BattleNet
)
where
( oauth2BattleNet
, oAuth2BattleNet
) where
import Yesod.Auth.OAuth2.Prelude
@ -22,52 +21,48 @@ import Yesod.Core.Widget
newtype User = User Int
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text
pluginName = "battle.net"
oauth2BattleNet
:: YesodAuth m
=> WidgetFor m () -- ^ Login widget
-> Text -- ^ User region (e.g. "eu", "cn", "us")
-> Text -- ^ Client ID
-> Text -- ^ Client Secret
-> AuthPlugin m
:: YesodAuth m
=> 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"
authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <-
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
}
where
host = wwwHost $ T.toLower region
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
, oauth2TokenEndpoint = fromRelative "https" host "/oauth/token"
, oauth2RedirectUri = Nothing
}
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
host = wwwHost $ T.toLower region
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
, 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
:: YesodAuth m => Text -> Text -> Text -> WidgetFor m () -> AuthPlugin m
:: YesodAuth m => Text -> Text -> Text -> WidgetFor m () -> AuthPlugin m
oAuth2BattleNet i s r w = oauth2BattleNet w r i s
{-# DEPRECATED oAuth2BattleNet "Use oauth2BattleNet" #-}

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

@ -7,10 +7,9 @@
-- * Uses bitbucket uuid as credentials identifier
--
module Yesod.Auth.OAuth2.Bitbucket
( oauth2Bitbucket
, oauth2BitbucketScoped
)
where
( oauth2Bitbucket
, oauth2BitbucketScoped
) where
import Yesod.Auth.OAuth2.Prelude
@ -19,7 +18,7 @@ import qualified Data.Text as T
newtype User = User Text
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "uuid"
parseJSON = withObject "User" $ \o -> User <$> o .: "uuid"
pluginName :: Text
pluginName = "bitbucket"
@ -32,32 +31,29 @@ 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
pluginName
manager
token
"https://api.bitbucket.com/2.0/user"
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://api.bitbucket.com/2.0/user"
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
}
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
}
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
}
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
}

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

@ -1,10 +1,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.ClassLink
( oauth2ClassLink
, oauth2ClassLinkScoped
)
where
( oauth2ClassLink
, oauth2ClassLinkScoped
) where
import Yesod.Auth.OAuth2.Prelude
@ -13,7 +12,7 @@ import qualified Data.Text as T
newtype User = User Int
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "UserId"
parseJSON = withObject "User" $ \o -> User <$> o .: "UserId"
pluginName :: Text
pluginName = "classlink"
@ -26,26 +25,23 @@ 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
pluginName
manager
token
"https://nodeapi.classlink.com/v2/my/info"
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://nodeapi.classlink.com/v2/my/info"
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]
, oauth2TokenEndpoint =
"https://launchpad.classlink.com/oauth2/v2/token"
, oauth2RedirectUri = Nothing
}
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]
, oauth2TokenEndpoint = "https://launchpad.classlink.com/oauth2/v2/token"
, oauth2RedirectUri = Nothing
}

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

@ -5,12 +5,12 @@
{-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.OAuth2.Dispatch
( FetchToken
, fetchAccessToken
, fetchAccessToken2
, FetchCreds
, dispatchAuthRequest
) where
( FetchToken
, fetchAccessToken
, fetchAccessToken2
, FetchCreds
, dispatchAuthRequest
) where
import Control.Monad.Except
import Data.Text (Text)
@ -32,24 +32,24 @@ import Yesod.Core hiding (ErrorResponse)
-- This will be 'fetchAccessToken' or 'fetchAccessToken2'
--
type FetchToken
= Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token)
= 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
-> AuthHandler m TypedContent
:: 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
handleDispatchError $ dispatchForward name oauth2
dispatchAuthRequest name oauth2 getToken getCreds "GET" ["callback"] =
handleDispatchError $ dispatchCallback name oauth2 getToken getCreds
handleDispatchError $ dispatchCallback name oauth2 getToken getCreds
dispatchAuthRequest _ _ _ _ _ _ = notFound
-- | Handle @GET \/forward@
@ -58,14 +58,14 @@ dispatchAuthRequest _ _ _ _ _ _ = notFound
-- 2. Redirect to the Provider's authorization URL
--
dispatchForward
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
-> OAuth2
-> m TypedContent
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
-> OAuth2
-> m TypedContent
dispatchForward name oauth2 = do
csrf <- setSessionCSRF $ tokenSessionKey name
oauth2' <- withCallbackAndState name oauth2 csrf
redirect $ toText $ authorizationUrl oauth2'
csrf <- setSessionCSRF $ tokenSessionKey name
oauth2' <- withCallbackAndState name oauth2 csrf
redirect $ toText $ authorizationUrl oauth2'
-- | Handle @GET \/callback@
--
@ -74,41 +74,40 @@ dispatchForward name oauth2 = do
-- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider
--
dispatchCallback
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
-> OAuth2
-> FetchToken
-> FetchCreds site
-> m TypedContent
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
-> OAuth2
-> FetchToken
-> FetchCreds site
-> m TypedContent
dispatchCallback name oauth2 getToken getCreds = do
onErrorResponse $ throwError . OAuth2HandshakeError
csrf <- verifySessionCSRF $ tokenSessionKey name
code <- requireGetParam "code"
manager <- authHttpManager
oauth2' <- withCallbackAndState name oauth2 csrf
token <- either (throwError . OAuth2ResultError) pure
=<< liftIO (getToken manager oauth2' $ ExchangeToken code)
creds <-
liftIO (getCreds manager token)
`catch` (throwError . FetchCredsIOException)
`catch` (throwError . FetchCredsYesodOAuth2Exception)
setCredsRedirect creds
onErrorResponse $ throwError . OAuth2HandshakeError
csrf <- verifySessionCSRF $ tokenSessionKey name
code <- requireGetParam "code"
manager <- authHttpManager
oauth2' <- withCallbackAndState name oauth2 csrf
token <- either (throwError . OAuth2ResultError) pure
=<< liftIO (getToken manager oauth2' $ ExchangeToken code)
creds <-
liftIO (getCreds manager token)
`catch` (throwError . FetchCredsIOException)
`catch` (throwError . FetchCredsYesodOAuth2Exception)
setCredsRedirect creds
withCallbackAndState
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
-> OAuth2
-> Text
-> m OAuth2
:: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text
-> OAuth2
-> Text
-> m OAuth2
withCallbackAndState name oauth2 csrf = do
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)]
}
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)]
}
getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)
getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
@ -124,25 +123,24 @@ getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
--
setSessionCSRF :: MonadHandler m => Text -> m Text
setSessionCSRF sessionKey = do
csrfToken <- liftIO randomToken
csrfToken <$ setSession sessionKey csrfToken
where randomToken = T.filter (/= '+') <$> randomText 64
csrfToken <- liftIO randomToken
csrfToken <$ setSession sessionKey csrfToken
where randomToken = T.filter (/= '+') <$> randomText 64
-- | Verify the callback provided the same CSRF token as in our session
verifySessionCSRF
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
verifySessionCSRF sessionKey = do
token <- requireGetParam "state"
sessionToken <- lookupSession sessionKey
deleteSession sessionKey
token <$ unless
(sessionToken == Just token)
(throwError $ InvalidStateToken sessionToken token)
token <- requireGetParam "state"
sessionToken <- lookupSession sessionKey
deleteSession sessionKey
token <$ unless (sessionToken == Just token)
(throwError $ InvalidStateToken sessionToken token)
requireGetParam
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
requireGetParam key =
maybe (throwError $ MissingParameter key) pure =<< lookupGetParam key
maybe (throwError $ MissingParameter key) pure =<< lookupGetParam key
tokenSessionKey :: Text -> Text
tokenSessionKey name = "_yesod_oauth2_" <> name

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

@ -8,11 +8,10 @@
-- * Uses EVEs unique account-user-char-hash as credentials identifier
--
module Yesod.Auth.OAuth2.EveOnline
( oauth2Eve
, oauth2EveScoped
, WidgetType(..)
)
where
( oauth2Eve
, oauth2EveScoped
, WidgetType(..)
) where
import Yesod.Auth.OAuth2.Prelude
@ -22,7 +21,7 @@ import Yesod.Core.Widget
newtype User = User Text
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "CharacterOwnerHash"
parseJSON = withObject "User" $ \o -> User <$> o .: "CharacterOwnerHash"
data WidgetType m
= Plain -- ^ Simple "Login via eveonline" text
@ -35,13 +34,13 @@ data WidgetType m
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">|]
[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">|]
= [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">|]
= [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">|]
= [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
@ -54,29 +53,29 @@ oauth2Eve :: YesodAuth m => WidgetType m -> Text -> Text -> AuthPlugin m
oauth2Eve = oauth2EveScoped defaultScopes
oauth2EveScoped
:: YesodAuth m => [Text] -> WidgetType m -> Text -> Text -> AuthPlugin m
:: YesodAuth m => [Text] -> WidgetType m -> Text -> Text -> AuthPlugin m
oauth2EveScoped scopes widgetType clientId clientSecret =
authOAuth2Widget (asWidget widgetType) pluginName oauth2
$ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://login.eveonline.com/oauth/verify"
authOAuth2Widget (asWidget widgetType) pluginName oauth2 $ \manager token ->
do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://login.eveonline.com/oauth/verify"
pure Creds
{ credsPlugin = "eveonline"
-- FIXME: Preserved bug. See similar comment in Bitbucket provider.
, 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
}
pure Creds { credsPlugin = "eveonline"
-- FIXME: Preserved bug. See similar comment in Bitbucket provider.
, 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
}

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

@ -7,10 +7,9 @@
-- * Uses github user id as credentials identifier
--
module Yesod.Auth.OAuth2.GitHub
( oauth2GitHub
, oauth2GitHubScoped
)
where
( oauth2GitHub
, oauth2GitHubScoped
) where
import Yesod.Auth.OAuth2.Prelude
@ -19,7 +18,7 @@ import qualified Data.Text as T
newtype User = User Int
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text
pluginName = "github"
@ -32,26 +31,23 @@ 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
pluginName
manager
token
"https://api.github.com/user"
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://api.github.com/user"
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
}
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
}

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

@ -1,11 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.GitLab
( oauth2GitLab
, oauth2GitLabHostScopes
, defaultHost
, defaultScopes
)
where
( oauth2GitLab
, oauth2GitLabHostScopes
, defaultHost
, defaultScopes
) where
import Yesod.Auth.OAuth2.Prelude
@ -14,7 +13,7 @@ import qualified Data.Text as T
newtype User = User Int
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text
pluginName = "gitlab"
@ -38,27 +37,23 @@ oauth2GitLab :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2GitLab = oauth2GitLabHostScopes defaultHost defaultScopes
oauth2GitLabHostScopes
:: YesodAuth m => URI -> [Text] -> Text -> Text -> AuthPlugin m
:: YesodAuth m => URI -> [Text] -> Text -> Text -> AuthPlugin m
oauth2GitLabHostScopes host scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <-
authGetProfile pluginName manager token
$ host
`withPath` "/api/v4/user"
authOAuth2 pluginName oauth2 $ \manager token -> do
(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
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
host
`withPath` "/oauth/authorize"
`withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = host `withPath` "/oauth/token"
, oauth2RedirectUri = Nothing
}
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
}

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

@ -25,12 +25,11 @@
-- > -- continue normally with updatedCreds
--
module Yesod.Auth.OAuth2.Google
( oauth2Google
, oauth2GoogleWidget
, oauth2GoogleScoped
, oauth2GoogleScopedWidget
)
where
( oauth2Google
, oauth2GoogleWidget
, oauth2GoogleScoped
, oauth2GoogleScopedWidget
) where
import Yesod.Auth.OAuth2.Prelude
import Yesod.Core (WidgetFor, whamlet)
@ -38,10 +37,10 @@ import Yesod.Core (WidgetFor, whamlet)
newtype User = User Text
instance FromJSON User where
parseJSON =
withObject "User" $ \o -> User
-- Required for data backwards-compatibility
<$> (("google-uid:" <>) <$> o .: "sub")
parseJSON =
withObject "User" $ \o -> User
-- Required for data backwards-compatibility
<$> (("google-uid:" <>) <$> o .: "sub")
pluginName :: Text
pluginName = "google"
@ -52,34 +51,34 @@ defaultScopes = ["openid", "email"]
oauth2Google :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Google = oauth2GoogleScoped defaultScopes
oauth2GoogleWidget :: YesodAuth m => WidgetFor m () -> Text -> Text -> AuthPlugin m
oauth2GoogleWidget
:: YesodAuth m => WidgetFor m () -> Text -> Text -> AuthPlugin m
oauth2GoogleWidget widget = oauth2GoogleScopedWidget widget defaultScopes
oauth2GoogleScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2GoogleScoped = oauth2GoogleScopedWidget [whamlet|Login via #{pluginName}|]
oauth2GoogleScoped =
oauth2GoogleScopedWidget [whamlet|Login via #{pluginName}|]
oauth2GoogleScopedWidget :: YesodAuth m => WidgetFor m () -> [Text] -> Text -> Text -> AuthPlugin m
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
pluginName
manager
token
"https://www.googleapis.com/oauth2/v3/userinfo"
authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://www.googleapis.com/oauth2/v3/userinfo"
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
}
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
}

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

@ -1,9 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.Nylas
( oauth2Nylas
)
where
( oauth2Nylas
) where
import Yesod.Auth.OAuth2.Prelude
@ -16,7 +15,7 @@ import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
newtype User = User Text
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text
pluginName = "nylas"
@ -26,44 +25,42 @@ defaultScopes = ["email"]
oauth2Nylas :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Nylas clientId clientSecret =
authOAuth2 pluginName oauth $ \manager token -> do
req <- applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
<$> parseRequest "https://api.nylas.com/account"
resp <- httpLbs req manager
let userResponse = responseBody resp
authOAuth2 pluginName oauth $ \manager token -> do
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: "
<> BL8.unpack userResponse
-- 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: "
<> BL8.unpack userResponse
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(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
)
-- 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
}
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(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
)
-- 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
}

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

@ -6,55 +6,55 @@
-- implementations. May also be useful for writing local providers.
--
module Yesod.Auth.OAuth2.Prelude
(
(
-- * Provider helpers
authGetProfile
, scopeParam
, setExtra
authGetProfile
, scopeParam
, setExtra
-- * Text
, Text
, decodeUtf8
, encodeUtf8
, Text
, decodeUtf8
, encodeUtf8
-- * JSON
, (.:)
, (.:?)
, (.=)
, (<>)
, FromJSON(..)
, ToJSON(..)
, eitherDecode
, withObject
, (.:)
, (.:?)
, (.=)
, (<>)
, FromJSON(..)
, ToJSON(..)
, eitherDecode
, withObject
-- * Exceptions
, throwIO
, throwIO
-- * OAuth2
, OAuth2(..)
, OAuth2Token(..)
, AccessToken(..)
, RefreshToken(..)
, OAuth2(..)
, OAuth2Token(..)
, AccessToken(..)
, RefreshToken(..)
-- * HTTP
, Manager
, Manager
-- * Yesod
, YesodAuth(..)
, AuthPlugin(..)
, Creds(..)
, YesodAuth(..)
, AuthPlugin(..)
, Creds(..)
-- * Bytestring URI types
, URI
, Host(..)
, URI
, Host(..)
-- * Bytestring URI extensions
, module URI.ByteString.Extension
, module URI.ByteString.Extension
-- * Temporary, until I finish re-structuring modules
, authOAuth2
, authOAuth2Widget
) where
, authOAuth2
, authOAuth2Widget
) where
import Control.Exception.Safe
import Data.Aeson
@ -78,28 +78,28 @@ import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
-- fetched via additional requests by consumers.
--
authGetProfile
:: FromJSON a
=> Text
-> Manager
-> OAuth2Token
-> URI
-> IO (a, BL.ByteString)
:: FromJSON a
=> Text
-> Manager
-> OAuth2Token
-> URI
-> IO (a, BL.ByteString)
authGetProfile name manager token url = do
resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url
decoded <- fromAuthJSON name resp
pure (decoded, resp)
resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url
decoded <- fromAuthJSON name resp
pure (decoded, resp)
-- | Throws a @Left@ result as an @'YesodOAuth2Exception'@
fromAuthGet :: Text -> Either BL.ByteString BL.ByteString -> IO BL.ByteString
fromAuthGet _ (Right bs) = pure bs -- nice
fromAuthGet name (Left err) =
throwIO $ YesodOAuth2Exception.OAuth2Error name err
throwIO $ YesodOAuth2Exception.OAuth2Error name err
-- | Throws a decoding error as an @'YesodOAuth2Exception'@
fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a
fromAuthJSON name =
either (throwIO . YesodOAuth2Exception.JSONDecodingError name) pure
. eitherDecode
either (throwIO . YesodOAuth2Exception.JSONDecodingError name) pure
. eitherDecode
-- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter
scopeParam :: Text -> [Text] -> (ByteString, ByteString)

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

@ -7,19 +7,18 @@
-- * Uses Salesforce user id as credentials identifier
--
module Yesod.Auth.OAuth2.Salesforce
( oauth2Salesforce
, oauth2SalesforceScoped
, oauth2SalesforceSandbox
, oauth2SalesforceSandboxScoped
)
where
( oauth2Salesforce
, oauth2SalesforceScoped
, oauth2SalesforceSandbox
, oauth2SalesforceSandboxScoped
) where
import Yesod.Auth.OAuth2.Prelude
newtype User = User Text
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "user_id"
parseJSON = withObject "User" $ \o -> User <$> o .: "user_id"
pluginName :: Text
pluginName = "salesforce"
@ -32,51 +31,45 @@ oauth2Salesforce = oauth2SalesforceScoped defaultScopes
oauth2SalesforceScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2SalesforceScoped = salesforceHelper
pluginName
"https://login.salesforce.com/services/oauth2/userinfo"
"https://login.salesforce.com/services/oauth2/authorize"
"https://login.salesforce.com/services/oauth2/token"
pluginName
"https://login.salesforce.com/services/oauth2/userinfo"
"https://login.salesforce.com/services/oauth2/authorize"
"https://login.salesforce.com/services/oauth2/token"
oauth2SalesforceSandbox :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped defaultScopes
oauth2SalesforceSandboxScoped
:: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
:: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2SalesforceSandboxScoped = salesforceHelper
(pluginName <> "-sandbox")
"https://test.salesforce.com/services/oauth2/userinfo"
"https://test.salesforce.com/services/oauth2/authorize"
"https://test.salesforce.com/services/oauth2/token"
(pluginName <> "-sandbox")
"https://test.salesforce.com/services/oauth2/userinfo"
"https://test.salesforce.com/services/oauth2/authorize"
"https://test.salesforce.com/services/oauth2/token"
salesforceHelper
:: YesodAuth m
=> Text
-> URI -- ^ User profile
-> URI -- ^ Authorize
-> URI -- ^ Token
-> [Text]
-> Text
-> Text
-> AuthPlugin m
:: YesodAuth m
=> Text
-> 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
(User userId, userResponse) <- authGetProfile
name
manager
token
profileUri
= authOAuth2 name oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile name manager token profileUri
pure Creds
{ credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint =
authorizeUri `withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = tokenUri
, oauth2RedirectUri = Nothing
}
pure Creds { credsPlugin = pluginName
, credsIdent = userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = authorizeUri `withQuery` [scopeParam " " scopes]
, oauth2TokenEndpoint = tokenUri
, oauth2RedirectUri = Nothing
}

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

@ -6,11 +6,10 @@
-- * Uses slack user id as credentials identifier
--
module Yesod.Auth.OAuth2.Slack
( SlackScope(..)
, oauth2Slack
, oauth2SlackScoped
)
where
( SlackScope(..)
, oauth2Slack
, oauth2SlackScoped
) where
import Yesod.Auth.OAuth2.Prelude
@ -25,17 +24,17 @@ 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
instance FromJSON User where
parseJSON = withObject "User" $ \root -> do
o <- root .: "user"
User <$> o .: "id"
parseJSON = withObject "User" $ \root -> do
o <- root .: "user"
User <$> o .: "id"
pluginName :: Text
pluginName = "slack"
@ -46,30 +45,31 @@ defaultScopes = [SlackBasicScope]
oauth2Slack :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Slack = oauth2SlackScoped defaultScopes
oauth2SlackScoped :: YesodAuth m => [SlackScope] -> Text -> Text -> AuthPlugin m
oauth2SlackScoped
:: YesodAuth m => [SlackScope] -> Text -> Text -> AuthPlugin m
oauth2SlackScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
let param = encodeUtf8 $ atoken $ accessToken token
req <- setQueryString [("token", Just param)]
<$> parseUrlThrow "https://slack.com/api/users.identity"
userResponse <- responseBody <$> httpLbs req manager
authOAuth2 pluginName oauth2 $ \manager token -> do
let param = encodeUtf8 $ atoken $ accessToken token
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
{ 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
}
either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(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
}

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

@ -4,41 +4,38 @@
-- OAuth2 plugin for http://spotify.com
--
module Yesod.Auth.OAuth2.Spotify
( oauth2Spotify
)
where
( oauth2Spotify
) where
import Yesod.Auth.OAuth2.Prelude
newtype User = User Text
instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text
pluginName = "spotify"
oauth2Spotify :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2Spotify scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://api.spotify.com/v1/me"
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://api.spotify.com/v1/me"
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
}
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
}

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

@ -7,9 +7,8 @@
-- * Uses upcase user id as credentials identifier
--
module Yesod.Auth.OAuth2.Upcase
( oauth2Upcase
)
where
( oauth2Upcase
) where
import Yesod.Auth.OAuth2.Prelude
@ -18,32 +17,31 @@ import qualified Data.Text as T
newtype User = User Int
instance FromJSON User where
parseJSON = withObject "User" $ \root -> do
o <- root .: "user"
User <$> o .: "id"
parseJSON = withObject "User" $ \root -> do
o <- root .: "user"
User <$> o .: "id"
pluginName :: Text
pluginName = "upcase"
oauth2Upcase :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Upcase clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"http://upcase.com/api/v1/me.json"
authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile
pluginName
manager
token
"http://upcase.com/api/v1/me.json"
pure Creds
{ credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "http://upcase.com/oauth/authorize"
, oauth2TokenEndpoint = "http://upcase.com/oauth/token"
, oauth2RedirectUri = Nothing
}
pure Creds { credsPlugin = pluginName
, credsIdent = T.pack $ show userId
, credsExtra = setExtra token userResponse
}
where
oauth2 = OAuth2
{ oauth2ClientId = clientId
, oauth2ClientSecret = Just clientSecret
, oauth2AuthorizeEndpoint = "http://upcase.com/oauth/authorize"
, oauth2TokenEndpoint = "http://upcase.com/oauth/token"
, oauth2RedirectUri = Nothing
}

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

@ -1,9 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.WordPressDotCom
( oauth2WordPressDotCom
)
where
( oauth2WordPressDotCom
) where
import qualified Data.Text as T
import Yesod.Auth.OAuth2.Prelude
@ -14,35 +13,33 @@ pluginName = "WordPress.com"
newtype WpUser = WpUser Int
instance FromJSON WpUser where
parseJSON = withObject "WpUser" $ \o -> WpUser <$> o .: "ID"
parseJSON = withObject "WpUser" $ \o -> WpUser <$> o .: "ID"
oauth2WordPressDotCom
:: (YesodAuth m)
=> Text -- ^ Client Id
-> Text -- ^ Client Secret
-> AuthPlugin m
:: (YesodAuth m)
=> Text -- ^ Client Id
-> Text -- ^ Client Secret
-> AuthPlugin m
oauth2WordPressDotCom clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do
(WpUser userId, userResponse) <- authGetProfile
pluginName
manager
token
"https://public-api.wordpress.com/rest/v1/me/"
authOAuth2 pluginName oauth2 $ \manager token -> do
(WpUser userId, userResponse) <- authGetProfile
pluginName
manager
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
, oauth2AuthorizeEndpoint =
"https://public-api.wordpress.com/oauth2/authorize"
`withQuery` [scopeParam "," ["auth"]]
, oauth2TokenEndpoint =
"https://public-api.wordpress.com/oauth2/token"
, oauth2RedirectUri = Nothing
}
where
oauth2 = OAuth2
{ 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
}