haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-04-20 18:04:14 +02: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. -- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage.
-- --
module Yesod.Auth.OAuth2 module Yesod.Auth.OAuth2
( OAuth2(..) ( OAuth2(..)
, FetchCreds , FetchCreds
, Manager , Manager
, OAuth2Token(..) , OAuth2Token(..)
, Creds(..) , Creds(..)
, oauth2Url , oauth2Url
, authOAuth2 , authOAuth2
, authOAuth2Widget , authOAuth2Widget
-- * Alternatives that use 'fetchAccessToken2' -- * Alternatives that use 'fetchAccessToken2'
, authOAuth2' , authOAuth2'
, authOAuth2Widget' , authOAuth2Widget'
-- * Reading our @'credsExtra'@ keys -- * Reading our @'credsExtra'@ keys
, getAccessToken , getAccessToken
, getRefreshToken , getRefreshToken
, getUserResponse , getUserResponse
, getUserResponseJSON , getUserResponseJSON
) where ) where
import Control.Error.Util (note) import Control.Error.Util (note)
import Control.Monad ((<=<)) import Control.Monad ((<=<))
@ -63,12 +63,12 @@ authOAuth2' name = authOAuth2Widget' [whamlet|Login via #{name}|] name
-- example. -- example.
-- --
authOAuth2Widget authOAuth2Widget
:: YesodAuth m :: YesodAuth m
=> WidgetFor m () => WidgetFor m ()
-> Text -> Text
-> OAuth2 -> OAuth2
-> FetchCreds m -> FetchCreds m
-> AuthPlugin m -> AuthPlugin m
authOAuth2Widget = buildPlugin fetchAccessToken authOAuth2Widget = buildPlugin fetchAccessToken
-- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2' -- | A version of 'authOAuth2Widget' that uses 'fetchAccessToken2'
@ -76,27 +76,27 @@ authOAuth2Widget = buildPlugin fetchAccessToken
-- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129> -- See <https://github.com/thoughtbot/yesod-auth-oauth2/pull/129>
-- --
authOAuth2Widget' authOAuth2Widget'
:: YesodAuth m :: YesodAuth m
=> WidgetFor m () => WidgetFor m ()
-> Text -> Text
-> OAuth2 -> OAuth2
-> FetchCreds m -> FetchCreds m
-> AuthPlugin m -> AuthPlugin m
authOAuth2Widget' = buildPlugin fetchAccessToken2 authOAuth2Widget' = buildPlugin fetchAccessToken2
buildPlugin buildPlugin
:: YesodAuth m :: YesodAuth m
=> FetchToken => FetchToken
-> WidgetFor m () -> WidgetFor m ()
-> Text -> Text
-> OAuth2 -> OAuth2
-> FetchCreds m -> FetchCreds m
-> AuthPlugin m -> AuthPlugin m
buildPlugin getToken widget name oauth getCreds = AuthPlugin buildPlugin getToken widget name oauth getCreds = AuthPlugin
name name
(dispatchAuthRequest name oauth getToken getCreds) (dispatchAuthRequest name oauth getToken getCreds)
login 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'@ -- | Read the @'AccessToken'@ from the values set via @'setExtra'@
getAccessToken :: Creds m -> Maybe AccessToken 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'@ -- | Read the original profile response from the values set via @'setExtra'@
getUserResponse :: Creds m -> Maybe ByteString getUserResponse :: Creds m -> Maybe ByteString
getUserResponse = getUserResponse =
(fromStrict . encodeUtf8 <$>) . lookup "userResponse" . credsExtra (fromStrict . encodeUtf8 <$>) . lookup "userResponse" . credsExtra
-- | @'getUserResponse'@, and decode as JSON -- | @'getUserResponse'@, and decode as JSON
getUserResponseJSON :: FromJSON a => Creds m -> Either String a getUserResponseJSON :: FromJSON a => Creds m -> Either String a
getUserResponseJSON = 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 -- * Uses email as credentials identifier
-- --
module Yesod.Auth.OAuth2.AzureAD module Yesod.Auth.OAuth2.AzureAD
( oauth2AzureAD ( oauth2AzureAD
, oauth2AzureADScoped , oauth2AzureADScoped
) ) where
where
import Prelude import Prelude
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -18,7 +17,7 @@ import Yesod.Auth.OAuth2.Prelude
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "mail" parseJSON = withObject "User" $ \o -> User <$> o .: "mail"
pluginName :: Text pluginName :: Text
pluginName = "azuread" pluginName = "azuread"
@ -31,28 +30,26 @@ oauth2AzureAD = oauth2AzureADScoped defaultScopes
oauth2AzureADScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m oauth2AzureADScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2AzureADScoped scopes clientId clientSecret = oauth2AzureADScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile
pluginName pluginName
manager manager
token token
"https://graph.microsoft.com/v1.0/me" "https://graph.microsoft.com/v1.0/me"
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = userId
, credsIdent = userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint =
, oauth2AuthorizeEndpoint = "https://login.windows.net/common/oauth2/authorize"
"https://login.windows.net/common/oauth2/authorize" `withQuery` [ scopeParam "," scopes
`withQuery` [ scopeParam "," scopes , ("resource", "https://graph.microsoft.com")
, ("resource", "https://graph.microsoft.com") ]
] , oauth2TokenEndpoint = "https://login.windows.net/common/oauth2/token"
, oauth2TokenEndpoint = , oauth2RedirectUri = Nothing
"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. -- * Returns user's battletag in extras.
-- --
module Yesod.Auth.OAuth2.BattleNet module Yesod.Auth.OAuth2.BattleNet
( oauth2BattleNet ( oauth2BattleNet
, oAuth2BattleNet , oAuth2BattleNet
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -22,52 +21,48 @@ import Yesod.Core.Widget
newtype User = User Int newtype User = User Int
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id" parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text pluginName :: Text
pluginName = "battle.net" pluginName = "battle.net"
oauth2BattleNet oauth2BattleNet
:: YesodAuth m :: YesodAuth m
=> WidgetFor m () -- ^ Login widget => WidgetFor m () -- ^ Login widget
-> Text -- ^ User region (e.g. "eu", "cn", "us") -> Text -- ^ User region (e.g. "eu", "cn", "us")
-> Text -- ^ Client ID -> Text -- ^ Client ID
-> Text -- ^ Client Secret -> Text -- ^ Client Secret
-> AuthPlugin m -> AuthPlugin m
oauth2BattleNet widget region clientId clientSecret = oauth2BattleNet widget region clientId clientSecret =
authOAuth2Widget widget pluginName oauth2 $ \manager token -> do authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- (User userId, userResponse) <-
authGetProfile pluginName manager token authGetProfile pluginName manager token
$ fromRelative $ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
"https"
(apiHost $ T.toLower region)
"/account/user"
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = T.pack $ show userId
, credsIdent = T.pack $ show userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where host = wwwHost $ T.toLower region
host = wwwHost $ T.toLower region oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
, oauth2AuthorizeEndpoint = fromRelative "https" host "/oauth/authorize" , oauth2TokenEndpoint = fromRelative "https" host "/oauth/token"
, oauth2TokenEndpoint = fromRelative "https" host "/oauth/token" , oauth2RedirectUri = Nothing
, oauth2RedirectUri = Nothing }
}
apiHost :: Text -> Host apiHost :: Text -> Host
apiHost "cn" = "api.battlenet.com.cn" apiHost "cn" = "api.battlenet.com.cn"
apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net" apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"
wwwHost :: Text -> Host wwwHost :: Text -> Host
wwwHost "cn" = "www.battlenet.com.cn" wwwHost "cn" = "www.battlenet.com.cn"
wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net" wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"
oAuth2BattleNet 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 oAuth2BattleNet i s r w = oauth2BattleNet w r i s
{-# DEPRECATED oAuth2BattleNet "Use oauth2BattleNet" #-} {-# DEPRECATED oAuth2BattleNet "Use oauth2BattleNet" #-}

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

@ -7,10 +7,9 @@
-- * Uses bitbucket uuid as credentials identifier -- * Uses bitbucket uuid as credentials identifier
-- --
module Yesod.Auth.OAuth2.Bitbucket module Yesod.Auth.OAuth2.Bitbucket
( oauth2Bitbucket ( oauth2Bitbucket
, oauth2BitbucketScoped , oauth2BitbucketScoped
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -19,7 +18,7 @@ import qualified Data.Text as T
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "uuid" parseJSON = withObject "User" $ \o -> User <$> o .: "uuid"
pluginName :: Text pluginName :: Text
pluginName = "bitbucket" pluginName = "bitbucket"
@ -32,32 +31,29 @@ oauth2Bitbucket = oauth2BitbucketScoped defaultScopes
oauth2BitbucketScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m oauth2BitbucketScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2BitbucketScoped scopes clientId clientSecret = oauth2BitbucketScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile
pluginName pluginName
manager manager
token token
"https://api.bitbucket.com/2.0/user" "https://api.bitbucket.com/2.0/user"
pure Creds pure Creds { credsPlugin = pluginName
{ 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
-- a Text), but because this code was shipped, folks likely have -- Idents in their database like @"\"...\""@, and if we fixed this
-- Idents in their database like @"\"...\""@, and if we fixed this -- they would need migrating. We're keeping it for now as it's a
-- 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
-- minor wart. Breaking typed APIs is one thing, causing data to go -- invalid is another.
-- invalid is another. , credsIdent = T.pack $ show userId
, credsIdent = T.pack $ show userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://bitbucket.com/site/oauth2/authorize"
, oauth2AuthorizeEndpoint = `withQuery` [scopeParam "," scopes]
"https://bitbucket.com/site/oauth2/authorize" , oauth2TokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
`withQuery` [scopeParam "," scopes] , oauth2RedirectUri = Nothing
, 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 #-} {-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.ClassLink module Yesod.Auth.OAuth2.ClassLink
( oauth2ClassLink ( oauth2ClassLink
, oauth2ClassLinkScoped , oauth2ClassLinkScoped
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -13,7 +12,7 @@ import qualified Data.Text as T
newtype User = User Int newtype User = User Int
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "UserId" parseJSON = withObject "User" $ \o -> User <$> o .: "UserId"
pluginName :: Text pluginName :: Text
pluginName = "classlink" pluginName = "classlink"
@ -26,26 +25,23 @@ oauth2ClassLink = oauth2ClassLinkScoped defaultScopes
oauth2ClassLinkScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m oauth2ClassLinkScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2ClassLinkScoped scopes clientId clientSecret = oauth2ClassLinkScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile
pluginName pluginName
manager manager
token token
"https://nodeapi.classlink.com/v2/my/info" "https://nodeapi.classlink.com/v2/my/info"
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = T.pack $ show userId
, credsIdent = T.pack $ show userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://launchpad.classlink.com/oauth2/v2/auth"
, oauth2AuthorizeEndpoint = `withQuery` [scopeParam "," scopes]
"https://launchpad.classlink.com/oauth2/v2/auth" , oauth2TokenEndpoint = "https://launchpad.classlink.com/oauth2/v2/token"
`withQuery` [scopeParam "," scopes] , oauth2RedirectUri = Nothing
, 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 #-} {-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.OAuth2.Dispatch module Yesod.Auth.OAuth2.Dispatch
( FetchToken ( FetchToken
, fetchAccessToken , fetchAccessToken
, fetchAccessToken2 , fetchAccessToken2
, FetchCreds , FetchCreds
, dispatchAuthRequest , dispatchAuthRequest
) where ) where
import Control.Monad.Except import Control.Monad.Except
import Data.Text (Text) import Data.Text (Text)
@ -32,24 +32,24 @@ import Yesod.Core hiding (ErrorResponse)
-- This will be 'fetchAccessToken' or 'fetchAccessToken2' -- This will be 'fetchAccessToken' or 'fetchAccessToken2'
-- --
type FetchToken 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 -- | How to take an @'OAuth2Token'@ and retrieve user credentials
type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m) type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)
-- | Dispatch the various OAuth2 handshake routes -- | Dispatch the various OAuth2 handshake routes
dispatchAuthRequest dispatchAuthRequest
:: Text -- ^ Name :: Text -- ^ Name
-> OAuth2 -- ^ Service details -> OAuth2 -- ^ Service details
-> FetchToken -- ^ How to get a token -> FetchToken -- ^ How to get a token
-> FetchCreds m -- ^ How to get credentials -> FetchCreds m -- ^ How to get credentials
-> Text -- ^ Method -> Text -- ^ Method
-> [Text] -- ^ Path pieces -> [Text] -- ^ Path pieces
-> AuthHandler m TypedContent -> AuthHandler m TypedContent
dispatchAuthRequest name oauth2 _ _ "GET" ["forward"] = dispatchAuthRequest name oauth2 _ _ "GET" ["forward"] =
handleDispatchError $ dispatchForward name oauth2 handleDispatchError $ dispatchForward name oauth2
dispatchAuthRequest name oauth2 getToken getCreds "GET" ["callback"] = dispatchAuthRequest name oauth2 getToken getCreds "GET" ["callback"] =
handleDispatchError $ dispatchCallback name oauth2 getToken getCreds handleDispatchError $ dispatchCallback name oauth2 getToken getCreds
dispatchAuthRequest _ _ _ _ _ _ = notFound dispatchAuthRequest _ _ _ _ _ _ = notFound
-- | Handle @GET \/forward@ -- | Handle @GET \/forward@
@ -58,14 +58,14 @@ dispatchAuthRequest _ _ _ _ _ _ = notFound
-- 2. Redirect to the Provider's authorization URL -- 2. Redirect to the Provider's authorization URL
-- --
dispatchForward dispatchForward
:: (MonadError DispatchError m, MonadAuthHandler site m) :: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text => Text
-> OAuth2 -> OAuth2
-> m TypedContent -> m TypedContent
dispatchForward name oauth2 = do dispatchForward name oauth2 = do
csrf <- setSessionCSRF $ tokenSessionKey name csrf <- setSessionCSRF $ tokenSessionKey name
oauth2' <- withCallbackAndState name oauth2 csrf oauth2' <- withCallbackAndState name oauth2 csrf
redirect $ toText $ authorizationUrl oauth2' redirect $ toText $ authorizationUrl oauth2'
-- | Handle @GET \/callback@ -- | Handle @GET \/callback@
-- --
@ -74,41 +74,40 @@ dispatchForward name oauth2 = do
-- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider -- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider
-- --
dispatchCallback dispatchCallback
:: (MonadError DispatchError m, MonadAuthHandler site m) :: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text => Text
-> OAuth2 -> OAuth2
-> FetchToken -> FetchToken
-> FetchCreds site -> FetchCreds site
-> m TypedContent -> m TypedContent
dispatchCallback name oauth2 getToken getCreds = do dispatchCallback name oauth2 getToken getCreds = do
onErrorResponse $ throwError . OAuth2HandshakeError onErrorResponse $ throwError . OAuth2HandshakeError
csrf <- verifySessionCSRF $ tokenSessionKey name csrf <- verifySessionCSRF $ tokenSessionKey name
code <- requireGetParam "code" code <- requireGetParam "code"
manager <- authHttpManager manager <- authHttpManager
oauth2' <- withCallbackAndState name oauth2 csrf oauth2' <- withCallbackAndState name oauth2 csrf
token <- either (throwError . OAuth2ResultError) pure token <- either (throwError . OAuth2ResultError) pure
=<< liftIO (getToken manager oauth2' $ ExchangeToken code) =<< liftIO (getToken manager oauth2' $ ExchangeToken code)
creds <- creds <-
liftIO (getCreds manager token) liftIO (getCreds manager token)
`catch` (throwError . FetchCredsIOException) `catch` (throwError . FetchCredsIOException)
`catch` (throwError . FetchCredsYesodOAuth2Exception) `catch` (throwError . FetchCredsYesodOAuth2Exception)
setCredsRedirect creds setCredsRedirect creds
withCallbackAndState withCallbackAndState
:: (MonadError DispatchError m, MonadAuthHandler site m) :: (MonadError DispatchError m, MonadAuthHandler site m)
=> Text => Text
-> OAuth2 -> OAuth2
-> Text -> Text
-> m OAuth2 -> m OAuth2
withCallbackAndState name oauth2 csrf = do withCallbackAndState name oauth2 csrf = do
uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender uri <- ($ PluginR name ["callback"]) <$> getParentUrlRender
callback <- maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri callback <- maybe (throwError $ InvalidCallbackUri uri) pure $ fromText uri
pure oauth2 pure oauth2
{ oauth2RedirectUri = Just callback { oauth2RedirectUri = Just callback
, oauth2AuthorizeEndpoint = , oauth2AuthorizeEndpoint = oauth2AuthorizeEndpoint oauth2
oauth2AuthorizeEndpoint oauth2 `withQuery` [("state", encodeUtf8 csrf)]
`withQuery` [("state", encodeUtf8 csrf)] }
}
getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text) getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)
getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
@ -124,25 +123,24 @@ getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
-- --
setSessionCSRF :: MonadHandler m => Text -> m Text setSessionCSRF :: MonadHandler m => Text -> m Text
setSessionCSRF sessionKey = do setSessionCSRF sessionKey = do
csrfToken <- liftIO randomToken csrfToken <- liftIO randomToken
csrfToken <$ setSession sessionKey csrfToken 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 -- | Verify the callback provided the same CSRF token as in our session
verifySessionCSRF verifySessionCSRF
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text :: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
verifySessionCSRF sessionKey = do verifySessionCSRF sessionKey = do
token <- requireGetParam "state" token <- requireGetParam "state"
sessionToken <- lookupSession sessionKey sessionToken <- lookupSession sessionKey
deleteSession sessionKey deleteSession sessionKey
token <$ unless token <$ unless (sessionToken == Just token)
(sessionToken == Just token) (throwError $ InvalidStateToken sessionToken token)
(throwError $ InvalidStateToken sessionToken token)
requireGetParam requireGetParam
:: (MonadError DispatchError m, MonadHandler m) => Text -> m Text :: (MonadError DispatchError m, MonadHandler m) => Text -> m Text
requireGetParam key = requireGetParam key =
maybe (throwError $ MissingParameter key) pure =<< lookupGetParam key maybe (throwError $ MissingParameter key) pure =<< lookupGetParam key
tokenSessionKey :: Text -> Text tokenSessionKey :: Text -> Text
tokenSessionKey name = "_yesod_oauth2_" <> name 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 -- * Uses EVEs unique account-user-char-hash as credentials identifier
-- --
module Yesod.Auth.OAuth2.EveOnline module Yesod.Auth.OAuth2.EveOnline
( oauth2Eve ( oauth2Eve
, oauth2EveScoped , oauth2EveScoped
, WidgetType(..) , WidgetType(..)
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -22,7 +21,7 @@ import Yesod.Core.Widget
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "CharacterOwnerHash" parseJSON = withObject "User" $ \o -> User <$> o .: "CharacterOwnerHash"
data WidgetType m data WidgetType m
= Plain -- ^ Simple "Login via eveonline" text = Plain -- ^ Simple "Login via eveonline" text
@ -35,13 +34,13 @@ data WidgetType m
asWidget :: YesodAuth m => WidgetType m -> WidgetFor m () asWidget :: YesodAuth m => WidgetType m -> WidgetFor m ()
asWidget Plain = [whamlet|Login via eveonline|] asWidget Plain = [whamlet|Login via eveonline|]
asWidget BigWhite = 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 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 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 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 asWidget (Custom a) = a
pluginName :: Text pluginName :: Text
@ -54,29 +53,29 @@ oauth2Eve :: YesodAuth m => WidgetType m -> Text -> Text -> AuthPlugin m
oauth2Eve = oauth2EveScoped defaultScopes oauth2Eve = oauth2EveScoped defaultScopes
oauth2EveScoped oauth2EveScoped
:: YesodAuth m => [Text] -> WidgetType m -> Text -> Text -> AuthPlugin m :: YesodAuth m => [Text] -> WidgetType m -> Text -> Text -> AuthPlugin m
oauth2EveScoped scopes widgetType clientId clientSecret = oauth2EveScoped scopes widgetType clientId clientSecret =
authOAuth2Widget (asWidget widgetType) pluginName oauth2 authOAuth2Widget (asWidget widgetType) pluginName oauth2 $ \manager token ->
$ \manager token -> do do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile
pluginName pluginName
manager manager
token token
"https://login.eveonline.com/oauth/verify" "https://login.eveonline.com/oauth/verify"
pure Creds pure Creds { credsPlugin = "eveonline"
{ credsPlugin = "eveonline" -- FIXME: Preserved bug. See similar comment in Bitbucket provider.
-- FIXME: Preserved bug. See similar comment in Bitbucket provider. , credsIdent = T.pack $ show userId
, credsIdent = T.pack $ show userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://login.eveonline.com/oauth/authorize"
, oauth2AuthorizeEndpoint = `withQuery` [ ("response_type", "code")
"https://login.eveonline.com/oauth/authorize" , scopeParam " " scopes
`withQuery` [("response_type", "code"), scopeParam " " scopes] ]
, oauth2TokenEndpoint = "https://login.eveonline.com/oauth/token" , oauth2TokenEndpoint = "https://login.eveonline.com/oauth/token"
, oauth2RedirectUri = Nothing , oauth2RedirectUri = Nothing
} }

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

@ -7,10 +7,9 @@
-- * Uses github user id as credentials identifier -- * Uses github user id as credentials identifier
-- --
module Yesod.Auth.OAuth2.GitHub module Yesod.Auth.OAuth2.GitHub
( oauth2GitHub ( oauth2GitHub
, oauth2GitHubScoped , oauth2GitHubScoped
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -19,7 +18,7 @@ import qualified Data.Text as T
newtype User = User Int newtype User = User Int
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id" parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text pluginName :: Text
pluginName = "github" pluginName = "github"
@ -32,26 +31,23 @@ oauth2GitHub = oauth2GitHubScoped defaultScopes
oauth2GitHubScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m oauth2GitHubScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2GitHubScoped scopes clientId clientSecret = oauth2GitHubScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile
pluginName pluginName
manager manager
token token
"https://api.github.com/user" "https://api.github.com/user"
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = T.pack $ show userId
, credsIdent = T.pack $ show userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://github.com/login/oauth/authorize"
, oauth2AuthorizeEndpoint = `withQuery` [scopeParam "," scopes]
"https://github.com/login/oauth/authorize" , oauth2TokenEndpoint = "https://github.com/login/oauth/access_token"
`withQuery` [scopeParam "," scopes] , oauth2RedirectUri = Nothing
, 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 #-} {-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.GitLab module Yesod.Auth.OAuth2.GitLab
( oauth2GitLab ( oauth2GitLab
, oauth2GitLabHostScopes , oauth2GitLabHostScopes
, defaultHost , defaultHost
, defaultScopes , defaultScopes
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -14,7 +13,7 @@ import qualified Data.Text as T
newtype User = User Int newtype User = User Int
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id" parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text pluginName :: Text
pluginName = "gitlab" pluginName = "gitlab"
@ -38,27 +37,23 @@ oauth2GitLab :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2GitLab = oauth2GitLabHostScopes defaultHost defaultScopes oauth2GitLab = oauth2GitLabHostScopes defaultHost defaultScopes
oauth2GitLabHostScopes oauth2GitLabHostScopes
:: YesodAuth m => URI -> [Text] -> Text -> Text -> AuthPlugin m :: YesodAuth m => URI -> [Text] -> Text -> Text -> AuthPlugin m
oauth2GitLabHostScopes host scopes clientId clientSecret = oauth2GitLabHostScopes host scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do authOAuth2 pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- (User userId, userResponse) <-
authGetProfile pluginName manager token authGetProfile pluginName manager token $ host `withPath` "/api/v4/user"
$ host
`withPath` "/api/v4/user"
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = T.pack $ show userId
, credsIdent = T.pack $ show userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = host
, oauth2AuthorizeEndpoint = `withPath` "/oauth/authorize"
host `withQuery` [scopeParam " " scopes]
`withPath` "/oauth/authorize" , oauth2TokenEndpoint = host `withPath` "/oauth/token"
`withQuery` [scopeParam " " scopes] , oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = host `withPath` "/oauth/token" }
, oauth2RedirectUri = Nothing
}

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

@ -25,12 +25,11 @@
-- > -- continue normally with updatedCreds -- > -- continue normally with updatedCreds
-- --
module Yesod.Auth.OAuth2.Google module Yesod.Auth.OAuth2.Google
( oauth2Google ( oauth2Google
, oauth2GoogleWidget , oauth2GoogleWidget
, oauth2GoogleScoped , oauth2GoogleScoped
, oauth2GoogleScopedWidget , oauth2GoogleScopedWidget
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
import Yesod.Core (WidgetFor, whamlet) import Yesod.Core (WidgetFor, whamlet)
@ -38,10 +37,10 @@ import Yesod.Core (WidgetFor, whamlet)
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = parseJSON =
withObject "User" $ \o -> User withObject "User" $ \o -> User
-- Required for data backwards-compatibility -- Required for data backwards-compatibility
<$> (("google-uid:" <>) <$> o .: "sub") <$> (("google-uid:" <>) <$> o .: "sub")
pluginName :: Text pluginName :: Text
pluginName = "google" pluginName = "google"
@ -52,34 +51,34 @@ defaultScopes = ["openid", "email"]
oauth2Google :: YesodAuth m => Text -> Text -> AuthPlugin m oauth2Google :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Google = oauth2GoogleScoped defaultScopes 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 oauth2GoogleWidget widget = oauth2GoogleScopedWidget widget defaultScopes
oauth2GoogleScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m 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 = oauth2GoogleScopedWidget widget scopes clientId clientSecret =
authOAuth2Widget widget pluginName oauth2 $ \manager token -> do authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile
pluginName pluginName
manager manager
token token
"https://www.googleapis.com/oauth2/v3/userinfo" "https://www.googleapis.com/oauth2/v3/userinfo"
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = userId
, credsIdent = userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"
, oauth2AuthorizeEndpoint = `withQuery` [scopeParam " " scopes]
"https://accounts.google.com/o/oauth2/auth" , oauth2TokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
`withQuery` [scopeParam " " scopes] , oauth2RedirectUri = Nothing
, 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 #-} {-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OAuth2.Nylas module Yesod.Auth.OAuth2.Nylas
( oauth2Nylas ( oauth2Nylas
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -16,7 +15,7 @@ import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "id" parseJSON = withObject "User" $ \o -> User <$> o .: "id"
pluginName :: Text pluginName :: Text
pluginName = "nylas" pluginName = "nylas"
@ -26,44 +25,42 @@ defaultScopes = ["email"]
oauth2Nylas :: YesodAuth m => Text -> Text -> AuthPlugin m oauth2Nylas :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Nylas clientId clientSecret = oauth2Nylas clientId clientSecret =
authOAuth2 pluginName oauth $ \manager token -> do authOAuth2 pluginName oauth $ \manager token -> do
req <- applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) "" req <- applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
<$> parseRequest "https://api.nylas.com/account" <$> parseRequest "https://api.nylas.com/account"
resp <- httpLbs req manager resp <- httpLbs req manager
let userResponse = responseBody resp let userResponse = responseBody resp
-- FIXME: was this working? I'm 95% sure that the client will throw its -- FIXME: was this working? I'm 95% sure that the client will throw its
-- own exception on unsuccessful status codes. -- own exception on unsuccessful status codes.
unless (HT.statusIsSuccessful $ responseStatus resp) unless (HT.statusIsSuccessful $ responseStatus resp)
$ throwIO $ throwIO
$ YesodOAuth2Exception.GenericError pluginName $ YesodOAuth2Exception.GenericError pluginName
$ "Unsuccessful HTTP response: " $ "Unsuccessful HTTP response: "
<> BL8.unpack userResponse <> BL8.unpack userResponse
either either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName) (throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(User userId) -> pure Creds (\(User userId) -> pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = userId
, credsIdent = userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} )
) $ eitherDecode userResponse
$ eitherDecode userResponse where
where oauth = OAuth2
oauth = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://api.nylas.com/oauth/authorize"
, oauth2AuthorizeEndpoint = `withQuery` [ ("response_type", "code")
"https://api.nylas.com/oauth/authorize" , ( "client_id"
`withQuery` [ ("response_type", "code") , encodeUtf8 clientId
, ( "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
-- N.B. The scopes delimeter is unknown/untested. Verify that before -- its current state, it doesn't matter because it's only one scope.
-- extracting this to an argument and offering a Scoped function. In , scopeParam "," defaultScopes
-- its current state, it doesn't matter because it's only one scope. ]
, scopeParam "," defaultScopes , oauth2TokenEndpoint = "https://api.nylas.com/oauth/token"
] , oauth2RedirectUri = Nothing
, 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. -- implementations. May also be useful for writing local providers.
-- --
module Yesod.Auth.OAuth2.Prelude module Yesod.Auth.OAuth2.Prelude
( (
-- * Provider helpers -- * Provider helpers
authGetProfile authGetProfile
, scopeParam , scopeParam
, setExtra , setExtra
-- * Text -- * Text
, Text , Text
, decodeUtf8 , decodeUtf8
, encodeUtf8 , encodeUtf8
-- * JSON -- * JSON
, (.:) , (.:)
, (.:?) , (.:?)
, (.=) , (.=)
, (<>) , (<>)
, FromJSON(..) , FromJSON(..)
, ToJSON(..) , ToJSON(..)
, eitherDecode , eitherDecode
, withObject , withObject
-- * Exceptions -- * Exceptions
, throwIO , throwIO
-- * OAuth2 -- * OAuth2
, OAuth2(..) , OAuth2(..)
, OAuth2Token(..) , OAuth2Token(..)
, AccessToken(..) , AccessToken(..)
, RefreshToken(..) , RefreshToken(..)
-- * HTTP -- * HTTP
, Manager , Manager
-- * Yesod -- * Yesod
, YesodAuth(..) , YesodAuth(..)
, AuthPlugin(..) , AuthPlugin(..)
, Creds(..) , Creds(..)
-- * Bytestring URI types -- * Bytestring URI types
, URI , URI
, Host(..) , Host(..)
-- * Bytestring URI extensions -- * Bytestring URI extensions
, module URI.ByteString.Extension , module URI.ByteString.Extension
-- * Temporary, until I finish re-structuring modules -- * Temporary, until I finish re-structuring modules
, authOAuth2 , authOAuth2
, authOAuth2Widget , authOAuth2Widget
) where ) where
import Control.Exception.Safe import Control.Exception.Safe
import Data.Aeson import Data.Aeson
@ -78,28 +78,28 @@ import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
-- fetched via additional requests by consumers. -- fetched via additional requests by consumers.
-- --
authGetProfile authGetProfile
:: FromJSON a :: FromJSON a
=> Text => Text
-> Manager -> Manager
-> OAuth2Token -> OAuth2Token
-> URI -> URI
-> IO (a, BL.ByteString) -> IO (a, BL.ByteString)
authGetProfile name manager token url = do 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 decoded <- fromAuthJSON name resp
pure (decoded, resp) pure (decoded, resp)
-- | Throws a @Left@ result as an @'YesodOAuth2Exception'@ -- | Throws a @Left@ result as an @'YesodOAuth2Exception'@
fromAuthGet :: Text -> Either BL.ByteString BL.ByteString -> IO BL.ByteString fromAuthGet :: Text -> Either BL.ByteString BL.ByteString -> IO BL.ByteString
fromAuthGet _ (Right bs) = pure bs -- nice fromAuthGet _ (Right bs) = pure bs -- nice
fromAuthGet name (Left err) = fromAuthGet name (Left err) =
throwIO $ YesodOAuth2Exception.OAuth2Error name err throwIO $ YesodOAuth2Exception.OAuth2Error name err
-- | Throws a decoding error as an @'YesodOAuth2Exception'@ -- | Throws a decoding error as an @'YesodOAuth2Exception'@
fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a
fromAuthJSON name = fromAuthJSON name =
either (throwIO . YesodOAuth2Exception.JSONDecodingError name) pure either (throwIO . YesodOAuth2Exception.JSONDecodingError name) pure
. eitherDecode . eitherDecode
-- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter -- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter
scopeParam :: Text -> [Text] -> (ByteString, ByteString) 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 -- * Uses Salesforce user id as credentials identifier
-- --
module Yesod.Auth.OAuth2.Salesforce module Yesod.Auth.OAuth2.Salesforce
( oauth2Salesforce ( oauth2Salesforce
, oauth2SalesforceScoped , oauth2SalesforceScoped
, oauth2SalesforceSandbox , oauth2SalesforceSandbox
, oauth2SalesforceSandboxScoped , oauth2SalesforceSandboxScoped
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \o -> User <$> o .: "user_id" parseJSON = withObject "User" $ \o -> User <$> o .: "user_id"
pluginName :: Text pluginName :: Text
pluginName = "salesforce" pluginName = "salesforce"
@ -32,51 +31,45 @@ oauth2Salesforce = oauth2SalesforceScoped defaultScopes
oauth2SalesforceScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m oauth2SalesforceScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2SalesforceScoped = salesforceHelper oauth2SalesforceScoped = salesforceHelper
pluginName pluginName
"https://login.salesforce.com/services/oauth2/userinfo" "https://login.salesforce.com/services/oauth2/userinfo"
"https://login.salesforce.com/services/oauth2/authorize" "https://login.salesforce.com/services/oauth2/authorize"
"https://login.salesforce.com/services/oauth2/token" "https://login.salesforce.com/services/oauth2/token"
oauth2SalesforceSandbox :: YesodAuth m => Text -> Text -> AuthPlugin m oauth2SalesforceSandbox :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped defaultScopes oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped defaultScopes
oauth2SalesforceSandboxScoped oauth2SalesforceSandboxScoped
:: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
oauth2SalesforceSandboxScoped = salesforceHelper oauth2SalesforceSandboxScoped = salesforceHelper
(pluginName <> "-sandbox") (pluginName <> "-sandbox")
"https://test.salesforce.com/services/oauth2/userinfo" "https://test.salesforce.com/services/oauth2/userinfo"
"https://test.salesforce.com/services/oauth2/authorize" "https://test.salesforce.com/services/oauth2/authorize"
"https://test.salesforce.com/services/oauth2/token" "https://test.salesforce.com/services/oauth2/token"
salesforceHelper salesforceHelper
:: YesodAuth m :: YesodAuth m
=> Text => Text
-> URI -- ^ User profile -> URI -- ^ User profile
-> URI -- ^ Authorize -> URI -- ^ Authorize
-> URI -- ^ Token -> URI -- ^ Token
-> [Text] -> [Text]
-> Text -> Text
-> Text -> Text
-> AuthPlugin m -> AuthPlugin m
salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSecret salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSecret
= authOAuth2 name oauth2 $ \manager token -> do = authOAuth2 name oauth2 $ \manager token -> do
(User userId, userResponse) <- authGetProfile (User userId, userResponse) <- authGetProfile name manager token profileUri
name
manager
token
profileUri
pure Creds pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = userId
, credsIdent = userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = authorizeUri `withQuery` [scopeParam " " scopes]
, oauth2AuthorizeEndpoint = , oauth2TokenEndpoint = tokenUri
authorizeUri `withQuery` [scopeParam " " scopes] , oauth2RedirectUri = Nothing
, oauth2TokenEndpoint = tokenUri }
, oauth2RedirectUri = Nothing
}

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

@ -6,11 +6,10 @@
-- * Uses slack user id as credentials identifier -- * Uses slack user id as credentials identifier
-- --
module Yesod.Auth.OAuth2.Slack module Yesod.Auth.OAuth2.Slack
( SlackScope(..) ( SlackScope(..)
, oauth2Slack , oauth2Slack
, oauth2SlackScoped , oauth2SlackScoped
) ) where
where
import Yesod.Auth.OAuth2.Prelude import Yesod.Auth.OAuth2.Prelude
@ -25,17 +24,17 @@ data SlackScope
| SlackAvatarScope | SlackAvatarScope
scopeText :: SlackScope -> Text scopeText :: SlackScope -> Text
scopeText SlackBasicScope = "identity.basic" scopeText SlackBasicScope = "identity.basic"
scopeText SlackEmailScope = "identity.email" scopeText SlackEmailScope = "identity.email"
scopeText SlackTeamScope = "identity.team" scopeText SlackTeamScope = "identity.team"
scopeText SlackAvatarScope = "identity.avatar" scopeText SlackAvatarScope = "identity.avatar"
newtype User = User Text newtype User = User Text
instance FromJSON User where instance FromJSON User where
parseJSON = withObject "User" $ \root -> do parseJSON = withObject "User" $ \root -> do
o <- root .: "user" o <- root .: "user"
User <$> o .: "id" User <$> o .: "id"
pluginName :: Text pluginName :: Text
pluginName = "slack" pluginName = "slack"
@ -46,30 +45,31 @@ defaultScopes = [SlackBasicScope]
oauth2Slack :: YesodAuth m => Text -> Text -> AuthPlugin m oauth2Slack :: YesodAuth m => Text -> Text -> AuthPlugin m
oauth2Slack = oauth2SlackScoped defaultScopes oauth2Slack = oauth2SlackScoped defaultScopes
oauth2SlackScoped :: YesodAuth m => [SlackScope] -> Text -> Text -> AuthPlugin m oauth2SlackScoped
:: YesodAuth m => [SlackScope] -> Text -> Text -> AuthPlugin m
oauth2SlackScoped scopes clientId clientSecret = oauth2SlackScoped scopes clientId clientSecret =
authOAuth2 pluginName oauth2 $ \manager token -> do authOAuth2 pluginName oauth2 $ \manager token -> do
let param = encodeUtf8 $ atoken $ accessToken token let param = encodeUtf8 $ atoken $ accessToken token
req <- setQueryString [("token", Just param)] req <- setQueryString [("token", Just param)]
<$> parseUrlThrow "https://slack.com/api/users.identity" <$> parseUrlThrow "https://slack.com/api/users.identity"
userResponse <- responseBody <$> httpLbs req manager userResponse <- responseBody <$> httpLbs req manager
either either
(throwIO . YesodOAuth2Exception.JSONDecodingError pluginName) (throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)
(\(User userId) -> pure Creds (\(User userId) -> pure Creds { credsPlugin = pluginName
{ credsPlugin = pluginName , credsIdent = userId
, credsIdent = userId , credsExtra = setExtra token userResponse
, credsExtra = setExtra token userResponse }
} )
) $ eitherDecode userResponse
$ eitherDecode userResponse where
where oauth2 = OAuth2
oauth2 = OAuth2 { oauth2ClientId = clientId
{ oauth2ClientId = clientId , oauth2ClientSecret = Just clientSecret
, oauth2ClientSecret = Just clientSecret , oauth2AuthorizeEndpoint = "https://slack.com/oauth/authorize"
, oauth2AuthorizeEndpoint = `withQuery` [ scopeParam ","
"https://slack.com/oauth/authorize" $ map scopeText scopes
`withQuery` [scopeParam "," $ map scopeText scopes] ]
, oauth2TokenEndpoint = "https://slack.com/api/oauth.access" , oauth2TokenEndpoint = "https://slack.com/api/oauth.access"
, oauth2RedirectUri = Nothing , oauth2RedirectUri = Nothing
} }

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

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

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

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