mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-09-10 11:34:55 +02:00
Merge d6b682b330 into 8efe95773b
This commit is contained in:
patrick brisbin
GitHub
commit
b40a20f8b1
@ -11,7 +11,7 @@ github: thoughtbot/yesod-auth-oauth2.git
|
||||
homepage: http://github.com/thoughtbot/yesod-auth-oauth2
|
||||
|
||||
dependencies:
|
||||
- base >=4.5 && <5
|
||||
- base >=4.8.0.0 && <5
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
@ -21,8 +21,6 @@ library:
|
||||
- hoauth2 >=1.3.0 && <1.6
|
||||
- http-client >=0.4.0 && <0.6
|
||||
- http-conduit >=2.0 && <3.0
|
||||
- http-types >=0.8 && <0.10
|
||||
- lifted-base >=0.2 && <0.4
|
||||
- microlens
|
||||
- random
|
||||
- text >=0.7 && <2.0
|
||||
|
||||
@ -7,11 +7,10 @@ import Data.String (IsString(..))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Lens.Micro
|
||||
import URI.ByteString
|
||||
|
||||
import qualified Data.ByteString.Char8 as C8
|
||||
|
||||
import URI.ByteString
|
||||
|
||||
instance IsString Scheme where
|
||||
fromString = Scheme . fromString
|
||||
|
||||
|
||||
@ -1,167 +1,69 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
-- |
|
||||
--
|
||||
-- Generic OAuth2 plugin for Yesod
|
||||
--
|
||||
-- * See Yesod.Auth.OAuth2.GitHub for example usage.
|
||||
--
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Yesod.Auth.OAuth2
|
||||
( authOAuth2
|
||||
, authOAuth2Widget
|
||||
, oauth2Url
|
||||
, fromProfileURL
|
||||
, YesodOAuth2Exception(..)
|
||||
, invalidProfileResponse
|
||||
, scopeParam
|
||||
, maybeExtra
|
||||
, module Network.OAuth.OAuth2
|
||||
, module URI.ByteString
|
||||
, module URI.ByteString.Extension
|
||||
( oauth2Url
|
||||
, authOAuth2
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson (Value(..), encode)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Network.OAuth.OAuth2 hiding (error)
|
||||
import System.Random
|
||||
import URI.ByteString
|
||||
import URI.ByteString.Extension
|
||||
import Data.Aeson (FromJSON)
|
||||
import Yesod.Auth
|
||||
import Yesod.Core
|
||||
import Yesod.Auth.OAuth2.Dispatch
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Core (WidgetT, whamlet)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Text as T
|
||||
-- | Login route for a provider by name
|
||||
oauth2Url :: ProviderName -> AuthRoute
|
||||
oauth2Url (ProviderName name) = PluginR name ["forward"]
|
||||
|
||||
-- | Provider name and Aeson parse error
|
||||
data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception YesodOAuth2Exception
|
||||
|
||||
-- | Construct an @'InvalidProfileResponse'@ exception from an @'OAuth2Error'@
|
||||
-- | Yesod Auth Plugin for a given Provider
|
||||
--
|
||||
-- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which
|
||||
-- is then re-encoded for the exception message.
|
||||
-- Example:
|
||||
--
|
||||
invalidProfileResponse :: Text -> OAuth2Error Value -> YesodOAuth2Exception
|
||||
invalidProfileResponse name = InvalidProfileResponse name . encode
|
||||
|
||||
oauth2Url :: Text -> AuthRoute
|
||||
oauth2Url name = PluginR name ["forward"]
|
||||
|
||||
-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
|
||||
-- > import Yesod.Auth.OAuth2
|
||||
-- > import Yesod.Auth.OAuth2.Github
|
||||
-- >
|
||||
-- > authOAuth2 (oauth2Github defaultScopes) "CLIENT_ID" "CLIENT_SECRET"
|
||||
--
|
||||
-- Presents a generic @"Login via name"@ link
|
||||
authOAuth2
|
||||
:: ( FromJSON a
|
||||
, ToIdent a
|
||||
, YesodAuth m
|
||||
)
|
||||
=> Provider m a
|
||||
-> ClientId
|
||||
-> ClientSecret
|
||||
-> AuthPlugin m
|
||||
authOAuth2 = authOAuth2Widget $ \name toParent ->
|
||||
[whamlet|
|
||||
<a href=@{toParent $ oauth2Url name}>
|
||||
Login via #{providerName name}
|
||||
|]
|
||||
|
||||
-- | Same, but with custom login Widget
|
||||
--
|
||||
authOAuth2 :: YesodAuth m
|
||||
=> Text -- ^ Service name
|
||||
-> OAuth2 -- ^ Service details
|
||||
-> (Manager -> OAuth2Token -> IO (Creds m))
|
||||
-- ^ This function defines how to take an @'OAuth2Token'@ and
|
||||
-- retrieve additional information about the user, to be set in the
|
||||
-- session as @'Creds'@. Usually this means a second authorized
|
||||
-- request to @api/me.json@.
|
||||
--
|
||||
-- See @'fromProfileURL'@ for an example.
|
||||
-> AuthPlugin m
|
||||
authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
|
||||
|
||||
-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
|
||||
-- > import Yesod.Auth.OAuth2
|
||||
-- > import Yesod.Auth.OAuth2.Github
|
||||
-- >
|
||||
-- > authOAuth2Widget
|
||||
-- > (\name toParent ->
|
||||
-- > [whamlet|
|
||||
-- > <a href=@{toParent $ oauth2Url name}>
|
||||
-- > Login via #{providerName name}
|
||||
-- > |]
|
||||
-- > )
|
||||
-- > $ (oauth2Github defaultScopes) -- ...
|
||||
--
|
||||
-- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an
|
||||
-- example.
|
||||
--
|
||||
authOAuth2Widget :: YesodAuth m
|
||||
=> WidgetT m IO ()
|
||||
-> Text
|
||||
-> OAuth2
|
||||
-> (Manager -> OAuth2Token -> IO (Creds m))
|
||||
-> AuthPlugin m
|
||||
authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
|
||||
|
||||
where
|
||||
url = PluginR name ["callback"]
|
||||
|
||||
withCallback csrfToken = do
|
||||
tm <- getRouteToParent
|
||||
render <- lift getUrlRender
|
||||
return oauth
|
||||
{ oauthCallback = Just $ unsafeFromText $ render $ tm url
|
||||
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
|
||||
`withQuery` [("state", encodeUtf8 csrfToken)]
|
||||
}
|
||||
|
||||
dispatch "GET" ["forward"] = do
|
||||
csrfToken <- liftIO generateToken
|
||||
setSession tokenSessionKey csrfToken
|
||||
authUrl <- toText . authorizationUrl <$> withCallback csrfToken
|
||||
lift $ redirect authUrl
|
||||
|
||||
dispatch "GET" ["callback"] = do
|
||||
csrfToken <- requireGetParam "state"
|
||||
oldToken <- lookupSession tokenSessionKey
|
||||
deleteSession tokenSessionKey
|
||||
unless (oldToken == Just csrfToken) $ permissionDenied "Invalid OAuth2 state token"
|
||||
code <- requireGetParam "code"
|
||||
oauth' <- withCallback csrfToken
|
||||
master <- lift getYesod
|
||||
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (ExchangeToken code)
|
||||
case result of
|
||||
Left _ -> permissionDenied "Unable to retrieve OAuth2 token"
|
||||
Right token -> do
|
||||
creds <- liftIO $ getCreds (authHttpManager master) token
|
||||
lift $ setCredsRedirect creds
|
||||
where
|
||||
requireGetParam key = do
|
||||
m <- lookupGetParam key
|
||||
maybe (permissionDenied $ "'" <> key <> "' parameter not provided") return m
|
||||
|
||||
dispatch _ _ = notFound
|
||||
|
||||
generateToken = pack . take 30 . randomRs ('a', 'z') <$> newStdGen
|
||||
|
||||
tokenSessionKey :: Text
|
||||
tokenSessionKey = "_yesod_oauth2_" <> name
|
||||
|
||||
login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
|
||||
|
||||
-- | Handle the common case of fetching Profile information from a JSON endpoint
|
||||
--
|
||||
-- Throws @'InvalidProfileResponse'@ if JSON parsing fails
|
||||
--
|
||||
fromProfileURL :: FromJSON a
|
||||
=> Text -- ^ Plugin name
|
||||
-> URI -- ^ Profile URI
|
||||
-> (a -> Creds m) -- ^ Conversion to Creds
|
||||
-> Manager -> OAuth2Token -> IO (Creds m)
|
||||
fromProfileURL name url toCreds manager token = do
|
||||
result <- authGetJSON manager (accessToken token) url
|
||||
|
||||
case result of
|
||||
Right profile -> return $ toCreds profile
|
||||
Left err -> throwIO $ invalidProfileResponse name err
|
||||
|
||||
-- | A tuple of @scope@ and the given scopes separated by a delimiter
|
||||
scopeParam :: Text -> [Text] -> (ByteString, ByteString)
|
||||
scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
|
||||
|
||||
-- | A helper for providing an optional value to credsExtra
|
||||
maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
|
||||
maybeExtra k (Just v) = [(k, v)]
|
||||
maybeExtra _ Nothing = []
|
||||
authOAuth2Widget
|
||||
:: ( FromJSON a
|
||||
, ToIdent a
|
||||
, YesodAuth m
|
||||
)
|
||||
=> (ProviderName -> (Route Auth -> Route m) -> WidgetT m IO ())
|
||||
-> Provider m a
|
||||
-> ClientId
|
||||
-> ClientSecret
|
||||
-> AuthPlugin m
|
||||
authOAuth2Widget widget p@Provider{..} cid cs =
|
||||
AuthPlugin (providerName pName) (dispatchAuthRequest p cid cs) $ widget pName
|
||||
|
||||
@ -1,85 +1,33 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for Battle.Net
|
||||
--
|
||||
-- * Authenticates against battle.net.
|
||||
-- * Uses user's id as credentials identifier.
|
||||
-- * Returns user's battletag in extras.
|
||||
--
|
||||
module Yesod.Auth.OAuth2.BattleNet
|
||||
( oAuth2BattleNet
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T (pack, toLower)
|
||||
import qualified Data.Text.Encoding as E (encodeUtf8)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Prelude
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Core.Widget
|
||||
|
||||
data BattleNetUser = BattleNetUser
|
||||
{ userId :: Int
|
||||
, battleTag :: Text
|
||||
}
|
||||
|
||||
instance FromJSON BattleNetUser where
|
||||
parseJSON (Object o) = BattleNetUser
|
||||
<$> o .: "id"
|
||||
<*> o .: "battletag"
|
||||
parseJSON _ = mzero
|
||||
|
||||
oAuth2BattleNet
|
||||
:: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> Text -- ^ User region (e.g. "eu", "cn", "us")
|
||||
-> WidgetT m IO () -- ^ Login widget
|
||||
-> AuthPlugin m
|
||||
oAuth2BattleNet clientId clientSecret region widget =
|
||||
authOAuth2Widget widget "battle.net" oAuthData $ makeCredentials region
|
||||
where
|
||||
oAuthData = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
|
||||
, oauthAccessTokenEndpoint = fromRelative "https" host "/oauth/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
host = wwwHost $ T.toLower region
|
||||
|
||||
makeCredentials :: Text -> Manager -> OAuth2Token -> IO (Creds m)
|
||||
makeCredentials region manager token = do
|
||||
userResult <- authGetJSON manager (accessToken token)
|
||||
$ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
|
||||
|
||||
either
|
||||
(throwIO . invalidProfileResponse "battle.net")
|
||||
(\user ->
|
||||
return Creds
|
||||
{ credsPlugin = "battle.net"
|
||||
, credsIdent = T.pack $ show $ userId user
|
||||
, credsExtra = [("battletag", battleTag user)]
|
||||
}
|
||||
) userResult
|
||||
|
||||
apiHost :: Text -> Host
|
||||
apiHost "cn" = "api.battlenet.com.cn"
|
||||
apiHost region = Host $ E.encodeUtf8 $ region <> ".api.battle.net"
|
||||
|
||||
wwwHost :: Text -> Host
|
||||
wwwHost "cn" = "www.battlenet.com.cn"
|
||||
wwwHost region = Host $ E.encodeUtf8 $ region <> ".battle.net"
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Auth.OAuth2.BattleNet
|
||||
( oauth2BattleNet
|
||||
) where
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import URI.ByteString (Host(..))
|
||||
import URI.ByteString.Extension (fromRelative)
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Auth.OAuth2.UserId
|
||||
|
||||
oauth2BattleNet
|
||||
:: Text -- ^ Lower-case region (cn, us, etc)
|
||||
-> Provider m UserId
|
||||
oauth2BattleNet region = Provider
|
||||
{ pName = "battle.net"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint $ wwwPath "/oauth/authorize"
|
||||
, pAccessTokenEndpoint = AccessTokenEndpoint $ wwwPath "/oauth/token"
|
||||
, pFetchUserProfile = authGetProfile $ apiPath "/account/user"
|
||||
}
|
||||
where
|
||||
apiPath = fromRelative "https" (apiHost region)
|
||||
wwwPath = fromRelative "https" (wwwHost region)
|
||||
|
||||
apiHost :: Text -> Host
|
||||
apiHost "cn" = "api.battlenet.com.cn"
|
||||
apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"
|
||||
|
||||
wwwHost :: Text -> Host
|
||||
wwwHost "cn" = "www.battlenet.com.cn"
|
||||
wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"
|
||||
|
||||
@ -1,141 +1,26 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://bitbucket.com
|
||||
--
|
||||
-- * Authenticates against bitbucket
|
||||
-- * Uses bitbucket uuid as credentials identifier
|
||||
-- * Returns email, username, full name, location and avatar as extras
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Bitbucket
|
||||
( oauth2Bitbucket
|
||||
, oauth2BitbucketScoped
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Control.Exception.Lifted (throwIO)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?))
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
|
||||
import qualified Data.Text as T
|
||||
newtype UserId = UserId Text
|
||||
deriving ToIdent
|
||||
|
||||
data BitbucketUser = BitbucketUser
|
||||
{ bitbucketUserId :: Text
|
||||
, bitbucketUserName :: Maybe Text
|
||||
, bitbucketUserLogin :: Text
|
||||
, bitbucketUserLocation :: Maybe Text
|
||||
, bitbucketUserLinks :: BitbucketUserLinks
|
||||
}
|
||||
instance FromJSON UserId where
|
||||
parseJSON = withObject "User" $ \o -> UserId <$> o .: "uuid"
|
||||
|
||||
instance FromJSON BitbucketUser where
|
||||
parseJSON (Object o) = BitbucketUser
|
||||
<$> o .: "uuid"
|
||||
<*> o .:? "display_name"
|
||||
<*> o .: "username"
|
||||
<*> o .:? "location"
|
||||
<*> o .: "links"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
newtype BitbucketUserLinks = BitbucketUserLinks
|
||||
{ bitbucketAvatarLink :: BitbucketLink
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketUserLinks where
|
||||
parseJSON (Object o) = BitbucketUserLinks
|
||||
<$> o .: "avatar"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
newtype BitbucketLink = BitbucketLink
|
||||
{ bitbucketLinkHref :: Text
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketLink where
|
||||
parseJSON (Object o) = BitbucketLink
|
||||
<$> o .: "href"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
newtype BitbucketEmailSearchResults = BitbucketEmailSearchResults
|
||||
{ bitbucketEmails :: [BitbucketUserEmail]
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketEmailSearchResults where
|
||||
parseJSON (Object o) = BitbucketEmailSearchResults
|
||||
<$> o .: "values"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
data BitbucketUserEmail = BitbucketUserEmail
|
||||
{ bitbucketUserEmailAddress :: Text
|
||||
, bitbucketUserEmailPrimary :: Bool
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketUserEmail where
|
||||
parseJSON (Object o) = BitbucketUserEmail
|
||||
<$> o .: "email"
|
||||
<*> o .: "is_primary"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Bitbucket :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Bitbucket clientId clientSecret = oauth2BitbucketScoped clientId clientSecret ["account"]
|
||||
|
||||
oauth2BitbucketScoped :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> [Text] -- ^ List of scopes to request
|
||||
-> AuthPlugin m
|
||||
oauth2BitbucketScoped clientId clientSecret scopes = authOAuth2 "bitbucket" oauth fetchBitbucketProfile
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://bitbucket.com/site/oauth2/authorize" `withQuery`
|
||||
oauth2Bitbucket :: [Scope] -> Provider m UserId
|
||||
oauth2Bitbucket scopes = Provider
|
||||
{ pName = "bitbucket"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://bitbucket.com/site/oauth2/authorize" `withQuery`
|
||||
[ scopeParam "," scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
fetchBitbucketProfile :: Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchBitbucketProfile manager token = do
|
||||
userResult <- authGetJSON manager (accessToken token) "https://api.bitbucket.com/2.0/user"
|
||||
mailResult <- authGetJSON manager (accessToken token) "https://api.bitbucket.com/2.0/user/emails"
|
||||
|
||||
case (userResult, mailResult) of
|
||||
(Right user, Right mails) -> return $ toCreds user (bitbucketEmails mails) token
|
||||
(Left err, _) -> throwIO $ invalidProfileResponse "bitbucket" err
|
||||
(_, Left err) -> throwIO $ invalidProfileResponse "bitbucket" err
|
||||
|
||||
toCreds :: BitbucketUser -> [BitbucketUserEmail] -> OAuth2Token -> Creds m
|
||||
toCreds user userMails token = Creds
|
||||
{ credsPlugin = "bitbucket"
|
||||
, credsIdent = T.pack $ show $ bitbucketUserId user
|
||||
, credsExtra =
|
||||
[ ("email", bitbucketUserEmailAddress email)
|
||||
, ("login", bitbucketUserLogin user)
|
||||
, ("avatar_url", bitbucketLinkHref (bitbucketAvatarLink (bitbucketUserLinks user)))
|
||||
, ("access_token", atoken $ accessToken token)
|
||||
]
|
||||
++ maybeExtra "name" (bitbucketUserName user)
|
||||
++ maybeExtra "location" (bitbucketUserLocation user)
|
||||
, pAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
|
||||
, pFetchUserProfile = authGetProfile "https://api.bitbucket.com/2.0/user"
|
||||
}
|
||||
|
||||
where
|
||||
email = fromMaybe (head userMails) $ find bitbucketUserEmailPrimary userMails
|
||||
|
||||
116
src/Yesod/Auth/OAuth2/Dispatch.hs
Normal file
116
src/Yesod/Auth/OAuth2/Dispatch.hs
Normal file
@ -0,0 +1,116 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Auth.OAuth2.Dispatch
|
||||
( dispatchAuthRequest
|
||||
) where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.OAuth.OAuth2
|
||||
import System.Random (newStdGen, randomRs)
|
||||
import URI.ByteString.Extension
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Core
|
||||
|
||||
-- | Dispatch the various OAuth2 handshake routes
|
||||
dispatchAuthRequest :: (FromJSON a, ToIdent a) => Provider app a -> ClientId -> ClientSecret -> Text -> [Text] -> AuthHandler app TypedContent
|
||||
dispatchAuthRequest p cid cs "GET" ["forward"] = dispatchForward p cid cs
|
||||
dispatchAuthRequest p cid cs "GET" ["callback"] = dispatchCallback p cid cs
|
||||
dispatchAuthRequest _ _ _ _ _ = notFound
|
||||
|
||||
-- | Handle @GET \/forward@
|
||||
--
|
||||
-- 1. Set a random CSRF token in our session
|
||||
-- 2. Redirect to the Provider's authorization URL
|
||||
--
|
||||
dispatchForward :: Provider app a -> ClientId -> ClientSecret -> AuthHandler app TypedContent
|
||||
dispatchForward p cid cs = do
|
||||
csrf <- setSessionCSRF $ tokenSessionKey p
|
||||
oauth2 <- providerToOAuth2 p csrf cid cs
|
||||
lift $ redirect $ toText $ authorizationUrl oauth2
|
||||
|
||||
-- | Handle @GET \/callback@
|
||||
--
|
||||
-- 1. Verify the URL's CSRF token matches our session
|
||||
-- 2. Use the code parameter to fetch an AccessToken for the Provider
|
||||
-- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider
|
||||
--
|
||||
dispatchCallback :: (FromJSON a, ToIdent a) => Provider app a -> ClientId -> ClientSecret -> AuthHandler app TypedContent
|
||||
dispatchCallback p cid cs = do
|
||||
csrf <- verifySessionCSRF $ tokenSessionKey p
|
||||
code <- requireGetParam "code"
|
||||
oauth2 <- providerToOAuth2 p csrf cid cs
|
||||
manager <- lift $ getsYesod authHttpManager
|
||||
token <- denyLeft $ fetchAccessToken manager oauth2 $ ExchangeToken code
|
||||
creds <- denyLeft $ providerCreds p manager token
|
||||
lift $ setCredsRedirect creds
|
||||
where
|
||||
-- On a Left result, log it and return an opaque permission-denied
|
||||
denyLeft :: (MonadHandler m, MonadLogger m, Show e) => IO (Either e a) -> m a
|
||||
denyLeft act = do
|
||||
result <- liftIO act
|
||||
either
|
||||
(\err -> do
|
||||
$(logError) $ T.pack $ "OAuth2 error: " <> show err
|
||||
permissionDenied "Invalid OAuth2 authentication attempt"
|
||||
)
|
||||
return
|
||||
result
|
||||
|
||||
-- | Convert our @'Provider'@ to an @'OAuth2'@ value
|
||||
--
|
||||
-- Append the CSRF token to the authorization URL as a state parameter.
|
||||
--
|
||||
providerToOAuth2 :: Provider app a -> Text -> ClientId -> ClientSecret -> AuthHandler app OAuth2
|
||||
providerToOAuth2 Provider{..} csrfToken cid cs = do
|
||||
toParent <- getRouteToParent
|
||||
urlRender <- lift getUrlRender
|
||||
|
||||
return OAuth2
|
||||
{ oauthClientId = clientId cid
|
||||
, oauthClientSecret = clientSecret cs
|
||||
, oauthAccessTokenEndpoint = accessTokenEndpoint pAccessTokenEndpoint
|
||||
, oauthOAuthorizeEndpoint = authorizeEndpoint (pAuthorizeEndpoint cid)
|
||||
`withQuery` [("state", encodeUtf8 csrfToken)]
|
||||
, oauthCallback = Just
|
||||
-- FIXME: clarify the error here when appRoot is non-absolute
|
||||
$ unsafeFromText $ urlRender $ toParent
|
||||
$ PluginR (providerName pName) ["callback"]
|
||||
}
|
||||
|
||||
-- | Set a random, 30-character value in the session
|
||||
setSessionCSRF :: MonadHandler m => Text -> m Text
|
||||
setSessionCSRF sessionKey = do
|
||||
csrfToken <- liftIO randomToken
|
||||
csrfToken <$ setSession sessionKey csrfToken
|
||||
where
|
||||
randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen
|
||||
|
||||
-- | Verify the callback provided the same CSRF token as in our session
|
||||
verifySessionCSRF :: MonadHandler m => Text -> m Text
|
||||
verifySessionCSRF sessionKey = do
|
||||
token <- requireGetParam "state"
|
||||
sessionToken <- lookupSession sessionKey
|
||||
deleteSession sessionKey
|
||||
|
||||
unless (sessionToken == Just token)
|
||||
$ permissionDenied "Invalid OAuth2 state token"
|
||||
|
||||
return token
|
||||
|
||||
requireGetParam :: MonadHandler m => Text -> m Text
|
||||
requireGetParam key = do
|
||||
m <- lookupGetParam key
|
||||
maybe errInvalidArgs return m
|
||||
where
|
||||
errInvalidArgs = invalidArgs ["The '" <> key <> "' parameter is required"]
|
||||
|
||||
tokenSessionKey :: Provider m a -> Text
|
||||
tokenSessionKey Provider{..} = "_yesod_oauth2_" <> providerName pName
|
||||
@ -1,116 +1,26 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://eveonline.com
|
||||
--
|
||||
-- * Authenticates against eveonline
|
||||
-- * Uses EVEs unique account-user-char-hash as credentials identifier
|
||||
-- * Returns charName, charId, tokenType, accessToken and expires as extras
|
||||
--
|
||||
module Yesod.Auth.OAuth2.EveOnline
|
||||
( oauth2Eve
|
||||
, oauth2EveScoped
|
||||
, WidgetType(..)
|
||||
, module Yesod.Auth.OAuth2
|
||||
( oauth2EveOnline
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Core.Widget
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
|
||||
import qualified Data.Text as T
|
||||
newtype CharId = CharId Int
|
||||
deriving ToIdent
|
||||
|
||||
data WidgetType m
|
||||
= Plain -- ^ Simple "Login via eveonline" text
|
||||
| BigWhite
|
||||
| SmallWhite
|
||||
| BigBlack
|
||||
| SmallBlack
|
||||
| Custom (WidgetT m IO ())
|
||||
instance FromJSON CharId where
|
||||
parseJSON = withObject "Character" $ \o -> CharId <$> o .: "CharacterId"
|
||||
|
||||
data EveUser = EveUser
|
||||
{ eveUserName :: Text
|
||||
, eveUserExpire :: Text
|
||||
, eveTokenType :: Text
|
||||
, eveCharOwnerHash :: Text
|
||||
, eveCharId :: Integer
|
||||
}
|
||||
|
||||
instance FromJSON EveUser where
|
||||
parseJSON (Object o) = EveUser
|
||||
<$> o .: "CharacterName"
|
||||
<*> o .: "ExpiresOn"
|
||||
<*> o .: "TokenType"
|
||||
<*> o .: "CharacterOwnerHash"
|
||||
<*> o .: "CharacterID"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Eve :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> WidgetType m
|
||||
-> AuthPlugin m
|
||||
oauth2Eve clientId clientSecret = oauth2EveScoped clientId clientSecret ["publicData"] . asWidget
|
||||
|
||||
where
|
||||
asWidget :: YesodAuth m => WidgetType m -> WidgetT m IO ()
|
||||
asWidget Plain = [whamlet|Login via eveonline|]
|
||||
asWidget BigWhite = [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/4PTzeiAshqiM8osU2giO0Y/5cc4cb60bac52422da2e45db87b6819c/EVE_SSO_Login_Buttons_Large_White.png?w=270&h=45">|]
|
||||
asWidget BigBlack = [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/4fSjj56uD6CYwYyus4KmES/4f6385c91e6de56274d99496e6adebab/EVE_SSO_Login_Buttons_Large_Black.png?w=270&h=45">|]
|
||||
asWidget SmallWhite = [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/18BxKSXCymyqY4QKo8KwKe/c2bdded6118472dd587c8107f24104d7/EVE_SSO_Login_Buttons_Small_White.png?w=195&h=30">|]
|
||||
asWidget SmallBlack = [whamlet|<img src="https://images.contentful.com/idjq7aai9ylm/12vrPsIMBQi28QwCGOAqGk/33234da7672c6b0cdca394fc8e0b1c2b/EVE_SSO_Login_Buttons_Small_Black.png?w=195&h=30">|]
|
||||
asWidget (Custom a) = a
|
||||
|
||||
oauth2EveScoped :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> [Text] -- ^ List of scopes to request
|
||||
-> WidgetT m IO () -- ^ Login widget
|
||||
-> AuthPlugin m
|
||||
oauth2EveScoped clientId clientSecret scopes widget =
|
||||
authOAuth2Widget widget "eveonline" oauth fetchEveProfile
|
||||
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://login.eveonline.com/oauth/authorize" `withQuery`
|
||||
oauth2EveOnline :: [Scope] -> Provider m CharId
|
||||
oauth2EveOnline scopes = Provider
|
||||
{ pName = "eveonline"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://login.eveonline.com/oauth/authorize" `withQuery`
|
||||
[ ("response_type", "code")
|
||||
, scopeParam " " scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://login.eveonline.com/oauth/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
fetchEveProfile :: Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchEveProfile manager token = do
|
||||
userResult <- authGetJSON manager (accessToken token) "https://login.eveonline.com/oauth/verify"
|
||||
|
||||
case userResult of
|
||||
Right user -> return $ toCreds user token
|
||||
Left err-> throwIO $ invalidProfileResponse "eveonline" err
|
||||
|
||||
toCreds :: EveUser -> OAuth2Token -> Creds m
|
||||
toCreds user token = Creds
|
||||
{ credsPlugin = "eveonline"
|
||||
, credsIdent = T.pack $ show $ eveCharOwnerHash user
|
||||
, credsExtra =
|
||||
[ ("charName", eveUserName user)
|
||||
, ("charId", T.pack . show . eveCharId $ user)
|
||||
, ("tokenType", eveTokenType user)
|
||||
, ("expires", eveUserExpire user)
|
||||
, ("accessToken", atoken $ accessToken token)
|
||||
]
|
||||
, pAccessTokenEndpoint = "https://login.eveonline.com/oauth/token"
|
||||
, pFetchUserProfile = authGetProfile "https://login.eveonline.com/oauth/verify"
|
||||
}
|
||||
|
||||
@ -1,115 +1,22 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://github.com
|
||||
--
|
||||
-- * Authenticates against github
|
||||
-- * Uses github user id as credentials identifier
|
||||
-- * Returns first_name, last_name, and email as extras
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Github
|
||||
( oauth2Github
|
||||
, oauth2GithubScoped
|
||||
, module Yesod.Auth.OAuth2
|
||||
, defaultScopes
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Auth.OAuth2.UserId
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
data GithubUser = GithubUser
|
||||
{ githubUserId :: Int
|
||||
, githubUserName :: Maybe Text
|
||||
, githubUserLogin :: Text
|
||||
, githubUserAvatarUrl :: Text
|
||||
, githubUserLocation :: Maybe Text
|
||||
, githubUserPublicEmail :: Maybe Text
|
||||
}
|
||||
|
||||
instance FromJSON GithubUser where
|
||||
parseJSON (Object o) = GithubUser
|
||||
<$> o .: "id"
|
||||
<*> o .:? "name"
|
||||
<*> o .: "login"
|
||||
<*> o .: "avatar_url"
|
||||
<*> o .:? "location"
|
||||
<*> o .:? "email"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
data GithubUserEmail = GithubUserEmail
|
||||
{ githubUserEmailAddress :: Text
|
||||
, githubUserEmailPrimary :: Bool
|
||||
}
|
||||
|
||||
instance FromJSON GithubUserEmail where
|
||||
parseJSON (Object o) = GithubUserEmail
|
||||
<$> o .: "email"
|
||||
<*> o .: "primary"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Github :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]
|
||||
|
||||
oauth2GithubScoped :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> [Text] -- ^ List of scopes to request
|
||||
-> AuthPlugin m
|
||||
oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize" `withQuery`
|
||||
oauth2Github :: [Scope] -> Provider m UserId
|
||||
oauth2Github scopes = Provider
|
||||
{ pName = "github"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "http://github.com/login/oauth/authorize" `withQuery`
|
||||
[ scopeParam "," scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
fetchGithubProfile :: Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchGithubProfile manager token = do
|
||||
userResult <- authGetJSON manager (accessToken token) "https://api.github.com/user"
|
||||
mailResult <- authGetJSON manager (accessToken token) "https://api.github.com/user/emails"
|
||||
|
||||
case (userResult, mailResult) of
|
||||
(Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
|
||||
(Right user, Right mails) -> return $ toCreds user mails token
|
||||
(Left err, _) -> throwIO $ invalidProfileResponse "github" err
|
||||
(_, Left err) -> throwIO $ invalidProfileResponse "github" err
|
||||
|
||||
toCreds :: GithubUser -> [GithubUserEmail] -> OAuth2Token -> Creds m
|
||||
toCreds user userMails token = Creds
|
||||
{ credsPlugin = "github"
|
||||
, credsIdent = T.pack $ show $ githubUserId user
|
||||
, credsExtra =
|
||||
[ ("email", githubUserEmailAddress email)
|
||||
, ("login", githubUserLogin user)
|
||||
, ("avatar_url", githubUserAvatarUrl user)
|
||||
, ("access_token", atoken $ accessToken token)
|
||||
]
|
||||
++ maybeExtra "name" (githubUserName user)
|
||||
++ maybeExtra "public_email" (githubUserPublicEmail user)
|
||||
++ maybeExtra "location" (githubUserLocation user)
|
||||
, pAccessTokenEndpoint = "http://github.com/login/oauth/access_token"
|
||||
, pFetchUserProfile = authGetProfile "https://api.github.com/user"
|
||||
}
|
||||
|
||||
where
|
||||
email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
|
||||
defaultScopes :: [Scope]
|
||||
defaultScopes = ["user:email"]
|
||||
|
||||
@ -1,137 +1,30 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://www.google.com
|
||||
--
|
||||
-- * Authenticates against Google
|
||||
-- * Uses Google user id or email as credentials identifier
|
||||
-- * Returns given_name, family_name, email, and avatar_url as extras
|
||||
--
|
||||
-- Note: This may eventually replace Yesod.Auth.GoogleEmail2. Currently it
|
||||
-- provides the same functionality except that GoogleEmail2 returns more profile
|
||||
-- information.
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Google
|
||||
( oauth2Google
|
||||
, oauth2GoogleScoped
|
||||
, oauth2GoogleScopedWithCustomId
|
||||
, googleUid
|
||||
, emailUid
|
||||
, module Yesod.Auth.OAuth2
|
||||
, defaultScopes
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
|
||||
-- | Auth with Google
|
||||
--
|
||||
-- Requests @openid@ and @email@ scopes and uses email as the @'Creds'@
|
||||
-- identifier.
|
||||
--
|
||||
oauth2Google :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Google = oauth2GoogleScoped ["openid", "email"]
|
||||
newtype UserId = UserId Text
|
||||
deriving ToIdent
|
||||
|
||||
-- | Auth with Google
|
||||
--
|
||||
-- Requests custom scopes and uses email as the @'Creds'@ identifier.
|
||||
--
|
||||
oauth2GoogleScoped :: YesodAuth m
|
||||
=> [Text] -- ^ List of scopes to request
|
||||
-> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2GoogleScoped = oauth2GoogleScopedWithCustomId emailUid
|
||||
instance FromJSON UserId where
|
||||
parseJSON = withObject "User" $ \o -> UserId <$> o .: "sub"
|
||||
|
||||
-- | Auth with Google
|
||||
--
|
||||
-- Requests custom scopes and uses the given function to create credentials
|
||||
-- which allows for using any attribute as the identifier.
|
||||
--
|
||||
-- See @'emailUid'@ and @'googleUid'@.
|
||||
--
|
||||
oauth2GoogleScopedWithCustomId :: YesodAuth m
|
||||
=> (GoogleUser -> OAuth2Token -> Creds m)
|
||||
-- ^ A function to generate the credentials
|
||||
-> [Text] -- ^ List of scopes to request
|
||||
-> Text -- ^ Client ID
|
||||
-> Text -- ^ Client secret
|
||||
-> AuthPlugin m
|
||||
oauth2GoogleScopedWithCustomId toCreds scopes clientId clientSecret =
|
||||
authOAuth2 "google" oauth $ fetchGoogleProfile toCreds
|
||||
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" `withQuery`
|
||||
oauth2Google :: [Scope] -> Provider m UserId
|
||||
oauth2Google scopes = Provider
|
||||
{ pName = "google"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://accounts.google.com/o/oauth2/auth" `withQuery`
|
||||
[ scopeParam "+" scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
fetchGoogleProfile :: (GoogleUser -> OAuth2Token -> Creds m) -> Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchGoogleProfile toCreds manager token = do
|
||||
userInfo <- authGetJSON manager (accessToken token) "https://www.googleapis.com/oauth2/v3/userinfo"
|
||||
case userInfo of
|
||||
Right user -> return $ toCreds user token
|
||||
Left err -> throwIO $ invalidProfileResponse "google" err
|
||||
|
||||
data GoogleUser = GoogleUser
|
||||
{ googleUserId :: Text
|
||||
, googleUserName :: Text
|
||||
, googleUserEmail :: Text
|
||||
, googleUserPicture :: Text
|
||||
, googleUserGivenName :: Text
|
||||
, googleUserFamilyName :: Text
|
||||
, googleUserHostedDomain :: Maybe Text
|
||||
, pAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
|
||||
, pFetchUserProfile = authGetProfile "https://www.googleapis.com/oauth2/v3/userinfo"
|
||||
}
|
||||
|
||||
instance FromJSON GoogleUser where
|
||||
parseJSON (Object o) = GoogleUser
|
||||
<$> o .: "sub"
|
||||
<*> o .: "name"
|
||||
<*> o .: "email"
|
||||
<*> o .: "picture"
|
||||
<*> o .: "given_name"
|
||||
<*> o .: "family_name"
|
||||
<*> o .:? "hd"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
-- | Build a @'Creds'@ using the user's google-uid as the identifier
|
||||
googleUid :: GoogleUser -> OAuth2Token -> Creds m
|
||||
googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId
|
||||
|
||||
-- | Build a @'Creds'@ using the user's email as the identifier
|
||||
emailUid :: GoogleUser -> OAuth2Token -> Creds m
|
||||
emailUid = uidBuilder googleUserEmail
|
||||
|
||||
uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> OAuth2Token -> Creds m
|
||||
uidBuilder f user token = Creds
|
||||
{ credsPlugin = "google"
|
||||
, credsIdent = f user
|
||||
, credsExtra =
|
||||
[ ("email", googleUserEmail user)
|
||||
, ("name", googleUserName user)
|
||||
, ("given_name", googleUserGivenName user)
|
||||
, ("family_name", googleUserFamilyName user)
|
||||
, ("avatar_url", googleUserPicture user)
|
||||
, ("access_token", atoken $ accessToken token)
|
||||
]
|
||||
++ maybeExtra "hosted_domain" (googleUserHostedDomain user)
|
||||
}
|
||||
defaultScopes :: [Scope]
|
||||
defaultScopes = ["openid", "email"]
|
||||
|
||||
@ -1,86 +1,28 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Yesod.Auth.OAuth2.Nylas
|
||||
( oauth2Nylas
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Control.Exception.Lifted (throwIO)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson (FromJSON, Value(..), decode, parseJSON, (.:))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.HTTP.Client
|
||||
(applyBasicAuth, httpLbs, parseRequest, responseBody, responseStatus)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
|
||||
import Yesod.Auth.OAuth2
|
||||
(applyBasicAuth, httpLbs, parseUrlThrow, responseBody)
|
||||
import Network.OAuth.OAuth2 (AccessToken(..))
|
||||
import URI.ByteString.Extension (withQuery)
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Auth.OAuth2.UserId
|
||||
|
||||
import qualified Network.HTTP.Types as HT
|
||||
|
||||
data NylasAccount = NylasAccount
|
||||
{ nylasAccountId :: Text
|
||||
, nylasAccountEmailAddress :: Text
|
||||
, nylasAccountName :: Text
|
||||
, nylasAccountProvider :: Text
|
||||
, nylasAccountOrganizationUnit :: Text
|
||||
}
|
||||
|
||||
instance FromJSON NylasAccount where
|
||||
parseJSON (Object o) = NylasAccount
|
||||
<$> o .: "id"
|
||||
<*> o .: "email_address"
|
||||
<*> o .: "name"
|
||||
<*> o .: "provider"
|
||||
<*> o .: "organization_unit"
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Nylas :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Nylas clientId clientSecret = authOAuth2 "nylas" oauth fetchCreds
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize" `withQuery`
|
||||
[ ("response_type", "code")
|
||||
oauth2Nylas :: Provider m UserIdText
|
||||
oauth2Nylas = Provider
|
||||
{ pName = "nylas"
|
||||
, pAuthorizeEndpoint = \cid -> AuthorizeEndpoint $
|
||||
"https://api.nylas.com/oauth/authorize" `withQuery`
|
||||
[ ("client_id", encodeUtf8 $ clientId cid)
|
||||
, ("response_type", "code")
|
||||
, ("scope", "email")
|
||||
, ("client_id", encodeUtf8 clientId)
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://api.nylas.com/oauth/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
fetchCreds :: Manager -> OAuth2Token -> IO (Creds a)
|
||||
fetchCreds manager token = do
|
||||
req <- authorize <$> parseRequest "https://api.nylas.com/account"
|
||||
resp <- httpLbs req manager
|
||||
if HT.statusIsSuccessful (responseStatus resp)
|
||||
then case decode (responseBody resp) of
|
||||
Just ns -> return $ toCreds ns token
|
||||
Nothing -> throwIO parseFailure
|
||||
else throwIO requestFailure
|
||||
where
|
||||
authorize = applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
|
||||
parseFailure = InvalidProfileResponse "nylas" "failed to parse account"
|
||||
requestFailure = InvalidProfileResponse "nylas" "failed to get account"
|
||||
|
||||
toCreds :: NylasAccount -> OAuth2Token -> Creds a
|
||||
toCreds ns token = Creds
|
||||
{ credsPlugin = "nylas"
|
||||
, credsIdent = nylasAccountId ns
|
||||
, credsExtra =
|
||||
[ ("email_address", nylasAccountEmailAddress ns)
|
||||
, ("name", nylasAccountName ns)
|
||||
, ("provider", nylasAccountProvider ns)
|
||||
, ("organization_unit", nylasAccountOrganizationUnit ns)
|
||||
, ("access_token", atoken $ accessToken token)
|
||||
]
|
||||
, pAccessTokenEndpoint = "https://api.nylas.com/oauth/token"
|
||||
, pFetchUserProfile = \manager token -> do
|
||||
req <- applyBasicAuth (encodeUtf8 $ atoken token) ""
|
||||
<$> parseUrlThrow "https://api.nylas.com/account"
|
||||
Right . responseBody <$> httpLbs req manager
|
||||
}
|
||||
|
||||
99
src/Yesod/Auth/OAuth2/Provider.hs
Normal file
99
src/Yesod/Auth/OAuth2/Provider.hs
Normal file
@ -0,0 +1,99 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module Yesod.Auth.OAuth2.Provider
|
||||
( ClientId(..)
|
||||
, ClientSecret(..)
|
||||
, AuthorizeEndpoint(..)
|
||||
, AccessTokenEndpoint(..)
|
||||
, ProviderName(..)
|
||||
, Provider(..)
|
||||
, authGetProfile
|
||||
, providerCreds
|
||||
, Scope(..)
|
||||
, scopeParam
|
||||
, withQuery
|
||||
, ToIdent(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Aeson (FromJSON, eitherDecode)
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Lazy (ByteString, toStrict)
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Network.OAuth.OAuth2
|
||||
(AccessToken(..), OAuth2Error(..), OAuth2Token(..), authGetBS)
|
||||
import URI.ByteString (URI)
|
||||
import URI.ByteString.Extension (withQuery)
|
||||
import Yesod.Auth (Creds(..))
|
||||
|
||||
newtype ClientId = ClientId { clientId :: Text }
|
||||
newtype ClientSecret = ClientSecret { clientSecret :: Text }
|
||||
|
||||
newtype AuthorizeEndpoint = AuthorizeEndpoint { authorizeEndpoint :: URI }
|
||||
deriving (IsString)
|
||||
|
||||
newtype AccessTokenEndpoint = AccessTokenEndpoint { accessTokenEndpoint :: URI }
|
||||
deriving (IsString)
|
||||
|
||||
newtype Scope = Scope { scope :: Text }
|
||||
deriving (IsString)
|
||||
|
||||
newtype ProviderName = ProviderName { providerName :: Text }
|
||||
deriving (IsString)
|
||||
|
||||
data Provider m a = Provider
|
||||
{ pName :: ProviderName
|
||||
, pAuthorizeEndpoint :: ClientId -> AuthorizeEndpoint
|
||||
-- ^ Authorization endpoint
|
||||
--
|
||||
-- Some providers need to include the client-id in the request, so it's
|
||||
-- provided here. Most providers can ignore it
|
||||
--
|
||||
-- > pAuthorizeEndpoint = const "http://example.com/oauth2/authorize"
|
||||
--
|
||||
, pAccessTokenEndpoint :: AccessTokenEndpoint
|
||||
, pFetchUserProfile :: Manager -> AccessToken -> IO (Either Text ByteString)
|
||||
}
|
||||
|
||||
pParseUserProfile :: FromJSON a => Provider m a -> ByteString -> Either String a
|
||||
pParseUserProfile _ = eitherDecode
|
||||
|
||||
authGetProfile :: URI -> Manager -> AccessToken -> IO (Either Text ByteString)
|
||||
authGetProfile uri manager token =
|
||||
first prettyOAuth2Error <$> authGetBS manager token uri
|
||||
where
|
||||
prettyOAuth2Error :: OAuth2Error Text -> Text
|
||||
prettyOAuth2Error = T.pack . show -- FIXME
|
||||
|
||||
class ToIdent a where
|
||||
toIdent :: a -> Text
|
||||
|
||||
instance ToIdent Int where
|
||||
toIdent = T.pack . show
|
||||
|
||||
instance ToIdent Text where
|
||||
toIdent = id
|
||||
|
||||
providerCreds :: (FromJSON a, ToIdent a) => Provider m a -> Manager -> OAuth2Token -> IO (Either Text (Creds m))
|
||||
providerCreds p@Provider{..} manager token = runExceptT $ do
|
||||
lbs <- ExceptT $ pFetchUserProfile manager $ accessToken token
|
||||
user <- withExceptT T.pack $ ExceptT $ return $ pParseUserProfile p lbs
|
||||
|
||||
return Creds
|
||||
{ credsPlugin = providerName pName
|
||||
, credsIdent = toIdent user
|
||||
, credsExtra =
|
||||
[ ("accessToken", atoken $ accessToken token)
|
||||
, ("userResponseBody", decodeUtf8 $ toStrict lbs)
|
||||
]
|
||||
}
|
||||
|
||||
scopeParam :: Text -> [Scope] -> (BS.ByteString, BS.ByteString)
|
||||
scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d . map scope
|
||||
@ -1,154 +1,42 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://login.salesforce.com
|
||||
--
|
||||
-- * Authenticates against Salesforce
|
||||
-- * Uses Salesforce user id as credentials identifier
|
||||
-- * Returns given_name, family_name, email and avatar_url as extras
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Salesforce
|
||||
( oauth2Salesforce
|
||||
, oauth2SalesforceScoped
|
||||
, oauth2SalesforceSandbox
|
||||
, oauth2SalesforceSandboxScoped
|
||||
, module Yesod.Auth.OAuth2
|
||||
, defaultScopes
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
|
||||
import qualified Data.Text as T
|
||||
newtype UserId = UserId Text
|
||||
deriving ToIdent
|
||||
|
||||
oauth2Salesforce :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"]
|
||||
instance FromJSON UserId where
|
||||
parseJSON = withObject "User" $ \o -> UserId <$> o .: "user_id"
|
||||
|
||||
svcName :: Text
|
||||
svcName = "salesforce"
|
||||
|
||||
oauth2SalesforceScoped :: YesodAuth m
|
||||
=> [Text] -- ^ List of scopes to request
|
||||
-> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2SalesforceScoped scopes clientId clientSecret =
|
||||
authOAuth2 svcName oauth fetchSalesforceUser
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://login.salesforce.com/services/oauth2/authorize" `withQuery`
|
||||
oauth2Salesforce :: [Scope] -> Provider m UserId
|
||||
oauth2Salesforce scopes = Provider
|
||||
{ pName = "salesforce"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://login.salesforce.com/services/oauth2/authorize" `withQuery`
|
||||
[ scopeParam " " scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
, pAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"
|
||||
, pFetchUserProfile = authGetProfile "https://login.salesforce.com/services/oauth2/userinfo"
|
||||
}
|
||||
|
||||
fetchSalesforceUser :: Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchSalesforceUser manager token = do
|
||||
result <- authGetJSON manager (accessToken token) "https://login.salesforce.com/services/oauth2/userinfo"
|
||||
case result of
|
||||
Right user -> return $ toCreds svcName user token
|
||||
Left err -> throwIO $ invalidProfileResponse svcName err
|
||||
|
||||
svcNameSb :: Text
|
||||
svcNameSb = "salesforce-sandbox"
|
||||
|
||||
oauth2SalesforceSandbox :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped ["openid", "email"]
|
||||
|
||||
|
||||
oauth2SalesforceSandboxScoped :: YesodAuth m
|
||||
=> [Text] -- ^ List of scopes to request
|
||||
-> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2SalesforceSandboxScoped scopes clientId clientSecret =
|
||||
authOAuth2 svcNameSb oauth fetchSalesforceSandboxUser
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://test.salesforce.com/services/oauth2/authorize" `withQuery`
|
||||
oauth2SalesforceSandbox :: [Scope] -> Provider m UserId
|
||||
oauth2SalesforceSandbox scopes = Provider
|
||||
{ pName = "salesforce-sandbox"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://test.salesforce.com/services/oauth2/authorize" `withQuery`
|
||||
[ scopeParam " " scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
fetchSalesforceSandboxUser :: Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchSalesforceSandboxUser manager token = do
|
||||
result <- authGetJSON manager (accessToken token) "https://test.salesforce.com/services/oauth2/userinfo"
|
||||
case result of
|
||||
Right user -> return $ toCreds svcNameSb user token
|
||||
Left err -> throwIO $ invalidProfileResponse svcNameSb err
|
||||
|
||||
data User = User
|
||||
{ userId :: Text
|
||||
, userOrg :: Text
|
||||
, userNickname :: Text
|
||||
, userName :: Text
|
||||
, userGivenName :: Text
|
||||
, userFamilyName :: Text
|
||||
, userTimeZone :: Text
|
||||
, userEmail :: Text
|
||||
, userPicture :: Text
|
||||
, userPhone :: Maybe Text
|
||||
, userRestUrl :: Text
|
||||
, pAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token"
|
||||
, pFetchUserProfile = authGetProfile "https://test.salesforce.com/services/oauth2/userinfo"
|
||||
}
|
||||
|
||||
instance FromJSON User where
|
||||
parseJSON (Object o) = do
|
||||
userId <- o .: "user_id"
|
||||
userOrg <- o .: "organization_id"
|
||||
userNickname <- o .: "nickname"
|
||||
userName <- o .: "name"
|
||||
userGivenName <- o .: "given_name"
|
||||
userFamilyName <- o .: "family_name"
|
||||
userTimeZone <- o .: "zoneinfo"
|
||||
userEmail <- o .: "email"
|
||||
userPicture <- o .: "picture"
|
||||
userPhone <- o .:? "phone_number"
|
||||
urls <- o .: "urls"
|
||||
userRestUrl <- urls .: "rest"
|
||||
return User{..}
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
toCreds :: Text -> User -> OAuth2Token -> Creds m
|
||||
toCreds name user token = Creds
|
||||
{ credsPlugin = name
|
||||
, credsIdent = userId user
|
||||
, credsExtra =
|
||||
[ ("email", userEmail user)
|
||||
, ("org", userOrg user)
|
||||
, ("nickname", userName user)
|
||||
, ("name", userName user)
|
||||
, ("given_name", userGivenName user)
|
||||
, ("family_name", userFamilyName user)
|
||||
, ("time_zone", userTimeZone user)
|
||||
, ("avatar_url", userPicture user)
|
||||
, ("rest_url", userRestUrl user)
|
||||
, ("access_token", atoken $ accessToken token)
|
||||
]
|
||||
++ maybeExtra "refresh_token" (rtoken <$> refreshToken token)
|
||||
++ maybeExtra "expires_in" ((T.pack . show) <$> expiresIn token)
|
||||
++ maybeExtra "phone_number" (userPhone user)
|
||||
}
|
||||
defaultScopes :: [Scope]
|
||||
defaultScopes = ["openid", "email", "api"]
|
||||
|
||||
@ -1,123 +1,29 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
-- OAuth2 plugin for https://slack.com/
|
||||
--
|
||||
-- * Authenticates against slack
|
||||
-- * Uses slack user id as credentials identifier
|
||||
-- * Returns name, access_token, email, avatar, team_id, and team_name as extras
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Slack
|
||||
( SlackScope(..)
|
||||
, oauth2Slack
|
||||
, oauth2SlackScoped
|
||||
( oauth2Slack
|
||||
, defaultScopes
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
import Control.Exception.Lifted (throwIO)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Network.HTTP.Client
|
||||
(httpLbs, parseUrlThrow, responseBody, setQueryString)
|
||||
import Network.OAuth.OAuth2 (AccessToken(..))
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Auth.OAuth2.UserId
|
||||
|
||||
import qualified Network.HTTP.Conduit as HTTP
|
||||
|
||||
data SlackScope
|
||||
= SlackEmailScope
|
||||
| SlackTeamScope
|
||||
| SlackAvatarScope
|
||||
|
||||
data SlackUser = SlackUser
|
||||
{ slackUserId :: Text
|
||||
, slackUserName :: Text
|
||||
, slackUserEmail :: Maybe Text
|
||||
, slackUserAvatarUrl :: Maybe Text
|
||||
, slackUserTeam :: Maybe SlackTeam
|
||||
}
|
||||
|
||||
data SlackTeam = SlackTeam
|
||||
{ slackTeamId :: Text
|
||||
, slackTeamName :: Text
|
||||
}
|
||||
|
||||
instance FromJSON SlackUser where
|
||||
parseJSON = withObject "root" $ \root -> do
|
||||
user <- root .: "user"
|
||||
|
||||
SlackUser
|
||||
<$> user .: "id"
|
||||
<*> user .: "name"
|
||||
<*> user .:? "email"
|
||||
<*> user .:? "image_512"
|
||||
<*> root .:? "team"
|
||||
|
||||
instance FromJSON SlackTeam where
|
||||
parseJSON = withObject "team" $ \team ->
|
||||
SlackTeam
|
||||
<$> team .: "id"
|
||||
<*> team .: "name"
|
||||
|
||||
-- | Auth with Slack
|
||||
--
|
||||
-- Requests @identity.basic@ scopes and uses the user's Slack ID as the @'Creds'@
|
||||
-- identifier.
|
||||
--
|
||||
oauth2Slack :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Slack clientId clientSecret = oauth2SlackScoped clientId clientSecret []
|
||||
|
||||
-- | Auth with Slack
|
||||
--
|
||||
-- Requests custom scopes and uses the user's Slack ID as the @'Creds'@
|
||||
-- identifier.
|
||||
--
|
||||
oauth2SlackScoped :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> [SlackScope]
|
||||
-> AuthPlugin m
|
||||
oauth2SlackScoped clientId clientSecret scopes =
|
||||
authOAuth2 "slack" oauth fetchSlackProfile
|
||||
where
|
||||
oauth = OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize" `withQuery`
|
||||
[ scopeParam "," $ "identity.basic" : map scopeText scopes
|
||||
oauth2Slack :: [Scope] -> Provider m UserIdText
|
||||
oauth2Slack scopes = Provider
|
||||
{ pName = "slack"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://slack.com/oauth/authorize" `withQuery`
|
||||
[ scopeParam "," scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://slack.com/api/oauth.access"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
|
||||
scopeText :: SlackScope -> Text
|
||||
scopeText SlackEmailScope = "identity.email"
|
||||
scopeText SlackTeamScope = "identity.team"
|
||||
scopeText SlackAvatarScope = "identity.avatar"
|
||||
|
||||
fetchSlackProfile :: Manager -> OAuth2Token -> IO (Creds m)
|
||||
fetchSlackProfile manager token = do
|
||||
request
|
||||
<- HTTP.setQueryString [("token", Just $ encodeUtf8 $ atoken $ accessToken token)]
|
||||
<$> HTTP.parseUrlThrow "https://slack.com/api/users.identity"
|
||||
body <- HTTP.responseBody <$> HTTP.httpLbs request manager
|
||||
case eitherDecode body of
|
||||
Left _ -> throwIO $ InvalidProfileResponse "slack" body
|
||||
Right u -> return $ toCreds u token
|
||||
|
||||
toCreds :: SlackUser -> OAuth2Token -> Creds m
|
||||
toCreds user token = Creds
|
||||
{ credsPlugin = "slack"
|
||||
, credsIdent = slackUserId user
|
||||
, credsExtra = catMaybes
|
||||
[ Just ("name", slackUserName user)
|
||||
, Just ("access_token", atoken $ accessToken token)
|
||||
, (,) <$> pure "email" <*> slackUserEmail user
|
||||
, (,) <$> pure "avatar" <*> slackUserAvatarUrl user
|
||||
, (,) <$> pure "team_name" <*> (slackTeamName <$> slackUserTeam user)
|
||||
, (,) <$> pure "team_id" <*> (slackTeamId <$> slackUserTeam user)
|
||||
]
|
||||
, pAccessTokenEndpoint = "https://slack.com/api/oauth.access"
|
||||
, pFetchUserProfile = \manager token -> do
|
||||
request <- setQueryString [("token", Just $ encodeUtf8 $ atoken token)]
|
||||
<$> parseUrlThrow "https://slack.com/api/users.identity"
|
||||
Right . responseBody <$> httpLbs request manager
|
||||
}
|
||||
|
||||
defaultScopes :: [Scope]
|
||||
defaultScopes = ["identity.basic"]
|
||||
|
||||
@ -1,107 +1,18 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://spotify.com
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Spotify
|
||||
( oauth2Spotify
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative (pure, (<$>), (<*>))
|
||||
#endif
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Auth.OAuth2.UserId
|
||||
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
data SpotifyUserImage = SpotifyUserImage
|
||||
{ spotifyUserImageHeight :: Maybe Int
|
||||
, spotifyUserImageWidth :: Maybe Int
|
||||
, spotifyUserImageUrl :: Text
|
||||
}
|
||||
|
||||
instance FromJSON SpotifyUserImage where
|
||||
parseJSON (Object v) = SpotifyUserImage
|
||||
<$> v .:? "height"
|
||||
<*> v .:? "width"
|
||||
<*> v .: "url"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
data SpotifyUser = SpotifyUser
|
||||
{ spotifyUserId :: Text
|
||||
, spotifyUserHref :: Text
|
||||
, spotifyUserUri :: Text
|
||||
, spotifyUserDisplayName :: Maybe Text
|
||||
, spotifyUserProduct :: Maybe Text
|
||||
, spotifyUserCountry :: Maybe Text
|
||||
, spotifyUserEmail :: Maybe Text
|
||||
, spotifyUserImages :: Maybe [SpotifyUserImage]
|
||||
}
|
||||
|
||||
instance FromJSON SpotifyUser where
|
||||
parseJSON (Object v) = SpotifyUser
|
||||
<$> v .: "id"
|
||||
<*> v .: "href"
|
||||
<*> v .: "uri"
|
||||
<*> v .:? "display_name"
|
||||
<*> v .:? "product"
|
||||
<*> v .:? "country"
|
||||
<*> v .:? "email"
|
||||
<*> v .:? "images"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Spotify :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> [Text] -- ^ Scopes
|
||||
-> AuthPlugin m
|
||||
oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify"
|
||||
OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "https://accounts.spotify.com/authorize" `withQuery`
|
||||
[ ("scope", encodeUtf8 $ T.intercalate " " scope)
|
||||
oauth2Spotify :: [Scope] -> Provider m UserIdText
|
||||
oauth2Spotify scopes = Provider
|
||||
{ pName = "spotify"
|
||||
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||
$ "https://accounts.spotify.com/authorize" `withQuery`
|
||||
[ scopeParam " " scopes
|
||||
]
|
||||
, oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
$ fromProfileURL "spotify" "https://api.spotify.com/v1/me" toCreds
|
||||
|
||||
toCreds :: SpotifyUser -> Creds m
|
||||
toCreds user = Creds
|
||||
{ credsPlugin = "spotify"
|
||||
, credsIdent = spotifyUserId user
|
||||
, credsExtra = mapMaybe getExtra extrasTemplate
|
||||
, pAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
|
||||
, pFetchUserProfile = authGetProfile "https://api.spotify.com/v1/me"
|
||||
}
|
||||
|
||||
where
|
||||
userImage :: Maybe SpotifyUserImage
|
||||
userImage = spotifyUserImages user >>= listToMaybe
|
||||
|
||||
userImagePart :: (SpotifyUserImage -> Maybe a) -> Maybe a
|
||||
userImagePart getter = userImage >>= getter
|
||||
|
||||
extrasTemplate = [ ("href", Just $ spotifyUserHref user)
|
||||
, ("uri", Just $ spotifyUserUri user)
|
||||
, ("display_name", spotifyUserDisplayName user)
|
||||
, ("product", spotifyUserProduct user)
|
||||
, ("country", spotifyUserCountry user)
|
||||
, ("email", spotifyUserEmail user)
|
||||
, ("image_url", spotifyUserImageUrl <$> userImage)
|
||||
, ("image_height", T.pack . show <$> userImagePart spotifyUserImageHeight)
|
||||
, ("image_width", T.pack . show <$> userImagePart spotifyUserImageWidth)
|
||||
]
|
||||
|
||||
getExtra :: (Text, Maybe Text) -> Maybe (Text, Text)
|
||||
getExtra (key, val) = fmap ((,) key) val
|
||||
|
||||
@ -1,72 +1,15 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- |
|
||||
--
|
||||
-- OAuth2 plugin for http://upcase.com
|
||||
--
|
||||
-- * Authenticates against upcase
|
||||
-- * Uses upcase user id as credentials identifier
|
||||
-- * Returns first_name, last_name, and email as extras
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Upcase
|
||||
( oauth2Upcase
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
#endif
|
||||
import Yesod.Auth.OAuth2.Provider
|
||||
import Yesod.Auth.OAuth2.UserId
|
||||
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
data UpcaseUser = UpcaseUser
|
||||
{ upcaseUserId :: Int
|
||||
, upcaseUserFirstName :: Text
|
||||
, upcaseUserLastName :: Text
|
||||
, upcaseUserEmail :: Text
|
||||
oauth2Upcase :: Provider m UserId
|
||||
oauth2Upcase = Provider
|
||||
{ pName = "upcase"
|
||||
, pAuthorizeEndpoint = const "http://upcase.com/oauth/authorize"
|
||||
, pAccessTokenEndpoint = "http://upcase.com/oauth/token"
|
||||
, pFetchUserProfile = authGetProfile "http://upcase.com/api/v1/me.json"
|
||||
}
|
||||
|
||||
instance FromJSON UpcaseUser where
|
||||
parseJSON (Object o) = UpcaseUser
|
||||
<$> o .: "id"
|
||||
<*> o .: "first_name"
|
||||
<*> o .: "last_name"
|
||||
<*> o .: "email"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
newtype UpcaseResponse = UpcaseResponse UpcaseUser
|
||||
|
||||
instance FromJSON UpcaseResponse where
|
||||
parseJSON (Object o) = UpcaseResponse
|
||||
<$> o .: "user"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Upcase :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
-> AuthPlugin m
|
||||
oauth2Upcase clientId clientSecret = authOAuth2 "upcase"
|
||||
OAuth2
|
||||
{ oauthClientId = clientId
|
||||
, oauthClientSecret = clientSecret
|
||||
, oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize"
|
||||
, oauthAccessTokenEndpoint = "http://upcase.com/oauth/token"
|
||||
, oauthCallback = Nothing
|
||||
}
|
||||
$ fromProfileURL "upcase" "http://upcase.com/api/v1/me.json"
|
||||
$ \user -> Creds
|
||||
{ credsPlugin = "upcase"
|
||||
, credsIdent = T.pack $ show $ upcaseUserId user
|
||||
, credsExtra =
|
||||
[ ("first_name", upcaseUserFirstName user)
|
||||
, ("last_name", upcaseUserLastName user)
|
||||
, ("email", upcaseUserEmail user)
|
||||
]
|
||||
}
|
||||
|
||||
24
src/Yesod/Auth/OAuth2/UserId.hs
Normal file
24
src/Yesod/Auth/OAuth2/UserId.hs
Normal file
@ -0,0 +1,24 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Auth.OAuth2.UserId
|
||||
( UserId(..)
|
||||
, UserIdText(..)
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Yesod.Auth.OAuth2.Provider (ToIdent(..))
|
||||
|
||||
-- | Parse-able type to use for responses with an integer @id@ field
|
||||
newtype UserId = UserId Int
|
||||
deriving ToIdent
|
||||
|
||||
instance FromJSON UserId where
|
||||
parseJSON = withObject "User" $ \o -> UserId <$> o .: "id"
|
||||
|
||||
-- | Parse-able type to use for responses with a textual @id@ field
|
||||
newtype UserIdText = UserIdText Text
|
||||
deriving ToIdent
|
||||
|
||||
instance FromJSON UserIdText where
|
||||
parseJSON = withObject "User" $ \o -> UserIdText <$> o .: "id"
|
||||
@ -1,6 +1,4 @@
|
||||
---
|
||||
resolver: lts-9.18
|
||||
resolver: lts-10.1
|
||||
packages:
|
||||
- .
|
||||
extra-deps:
|
||||
- load-env-0.1.1
|
||||
|
||||
Loading…
Reference in New Issue
Block a user