mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-09-10 19:34:56 +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
|
homepage: http://github.com/thoughtbot/yesod-auth-oauth2
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
- base >=4.5 && <5
|
- base >=4.8.0.0 && <5
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
@ -21,8 +21,6 @@ library:
|
|||||||
- hoauth2 >=1.3.0 && <1.6
|
- hoauth2 >=1.3.0 && <1.6
|
||||||
- http-client >=0.4.0 && <0.6
|
- http-client >=0.4.0 && <0.6
|
||||||
- http-conduit >=2.0 && <3.0
|
- http-conduit >=2.0 && <3.0
|
||||||
- http-types >=0.8 && <0.10
|
|
||||||
- lifted-base >=0.2 && <0.4
|
|
||||||
- microlens
|
- microlens
|
||||||
- random
|
- random
|
||||||
- text >=0.7 && <2.0
|
- text >=0.7 && <2.0
|
||||||
|
|||||||
@ -7,11 +7,10 @@ import Data.String (IsString(..))
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
import Lens.Micro
|
import Lens.Micro
|
||||||
|
import URI.ByteString
|
||||||
|
|
||||||
import qualified Data.ByteString.Char8 as C8
|
import qualified Data.ByteString.Char8 as C8
|
||||||
|
|
||||||
import URI.ByteString
|
|
||||||
|
|
||||||
instance IsString Scheme where
|
instance IsString Scheme where
|
||||||
fromString = Scheme . fromString
|
fromString = Scheme . fromString
|
||||||
|
|
||||||
|
|||||||
@ -1,167 +1,69 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
-- |
|
|
||||||
--
|
|
||||||
-- Generic OAuth2 plugin for Yesod
|
|
||||||
--
|
|
||||||
-- * See Yesod.Auth.OAuth2.GitHub for example usage.
|
|
||||||
--
|
|
||||||
module Yesod.Auth.OAuth2
|
module Yesod.Auth.OAuth2
|
||||||
( authOAuth2
|
( oauth2Url
|
||||||
, authOAuth2Widget
|
, authOAuth2
|
||||||
, oauth2Url
|
|
||||||
, fromProfileURL
|
|
||||||
, YesodOAuth2Exception(..)
|
|
||||||
, invalidProfileResponse
|
|
||||||
, scopeParam
|
|
||||||
, maybeExtra
|
|
||||||
, module Network.OAuth.OAuth2
|
|
||||||
, module URI.ByteString
|
|
||||||
, module URI.ByteString.Extension
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
import Data.Aeson (FromJSON)
|
||||||
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 Yesod.Auth
|
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
|
-- | Login route for a provider by name
|
||||||
import qualified Data.Text as T
|
oauth2Url :: ProviderName -> AuthRoute
|
||||||
|
oauth2Url (ProviderName name) = PluginR name ["forward"]
|
||||||
|
|
||||||
-- | Provider name and Aeson parse error
|
-- | Yesod Auth Plugin for a given Provider
|
||||||
data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
|
|
||||||
deriving (Show, Typeable)
|
|
||||||
|
|
||||||
instance Exception YesodOAuth2Exception
|
|
||||||
|
|
||||||
-- | Construct an @'InvalidProfileResponse'@ exception from an @'OAuth2Error'@
|
|
||||||
--
|
--
|
||||||
-- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which
|
-- Example:
|
||||||
-- is then re-encoded for the exception message.
|
|
||||||
--
|
--
|
||||||
invalidProfileResponse :: Text -> OAuth2Error Value -> YesodOAuth2Exception
|
-- > import Yesod.Auth.OAuth2
|
||||||
invalidProfileResponse name = InvalidProfileResponse name . encode
|
-- > import Yesod.Auth.OAuth2.Github
|
||||||
|
-- >
|
||||||
oauth2Url :: Text -> AuthRoute
|
-- > authOAuth2 (oauth2Github defaultScopes) "CLIENT_ID" "CLIENT_SECRET"
|
||||||
oauth2Url name = PluginR name ["forward"]
|
|
||||||
|
|
||||||
-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
|
|
||||||
--
|
--
|
||||||
-- 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
|
-- > import Yesod.Auth.OAuth2
|
||||||
=> Text -- ^ Service name
|
-- > import Yesod.Auth.OAuth2.Github
|
||||||
-> OAuth2 -- ^ Service details
|
-- >
|
||||||
-> (Manager -> OAuth2Token -> IO (Creds m))
|
-- > authOAuth2Widget
|
||||||
-- ^ This function defines how to take an @'OAuth2Token'@ and
|
-- > (\name toParent ->
|
||||||
-- retrieve additional information about the user, to be set in the
|
-- > [whamlet|
|
||||||
-- session as @'Creds'@. Usually this means a second authorized
|
-- > <a href=@{toParent $ oauth2Url name}>
|
||||||
-- request to @api/me.json@.
|
-- > Login via #{providerName name}
|
||||||
--
|
-- > |]
|
||||||
-- See @'fromProfileURL'@ for an example.
|
-- > )
|
||||||
-> AuthPlugin m
|
-- > $ (oauth2Github defaultScopes) -- ...
|
||||||
authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
|
|
||||||
|
|
||||||
-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
|
|
||||||
--
|
--
|
||||||
-- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an
|
authOAuth2Widget
|
||||||
-- example.
|
:: ( FromJSON a
|
||||||
--
|
, ToIdent a
|
||||||
authOAuth2Widget :: YesodAuth m
|
, YesodAuth m
|
||||||
=> WidgetT m IO ()
|
)
|
||||||
-> Text
|
=> (ProviderName -> (Route Auth -> Route m) -> WidgetT m IO ())
|
||||||
-> OAuth2
|
-> Provider m a
|
||||||
-> (Manager -> OAuth2Token -> IO (Creds m))
|
-> ClientId
|
||||||
-> AuthPlugin m
|
-> ClientSecret
|
||||||
authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
|
-> AuthPlugin m
|
||||||
|
authOAuth2Widget widget p@Provider{..} cid cs =
|
||||||
where
|
AuthPlugin (providerName pName) (dispatchAuthRequest p cid cs) $ widget pName
|
||||||
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 = []
|
|
||||||
|
|||||||
@ -1,85 +1,33 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
module Yesod.Auth.OAuth2.BattleNet
|
||||||
|
( oauth2BattleNet
|
||||||
-- |
|
) where
|
||||||
--
|
|
||||||
-- OAuth2 plugin for Battle.Net
|
import Data.Monoid ((<>))
|
||||||
--
|
import Data.Text (Text)
|
||||||
-- * Authenticates against battle.net.
|
import Data.Text.Encoding (encodeUtf8)
|
||||||
-- * Uses user's id as credentials identifier.
|
import URI.ByteString (Host(..))
|
||||||
-- * Returns user's battletag in extras.
|
import URI.ByteString.Extension (fromRelative)
|
||||||
--
|
import Yesod.Auth.OAuth2.Provider
|
||||||
module Yesod.Auth.OAuth2.BattleNet
|
import Yesod.Auth.OAuth2.UserId
|
||||||
( oAuth2BattleNet
|
|
||||||
) where
|
oauth2BattleNet
|
||||||
|
:: Text -- ^ Lower-case region (cn, us, etc)
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
-> Provider m UserId
|
||||||
import Control.Applicative ((<$>), (<*>))
|
oauth2BattleNet region = Provider
|
||||||
#endif
|
{ pName = "battle.net"
|
||||||
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint $ wwwPath "/oauth/authorize"
|
||||||
import Control.Exception (throwIO)
|
, pAccessTokenEndpoint = AccessTokenEndpoint $ wwwPath "/oauth/token"
|
||||||
import Control.Monad (mzero)
|
, pFetchUserProfile = authGetProfile $ apiPath "/account/user"
|
||||||
import Data.Aeson
|
}
|
||||||
import Data.Monoid ((<>))
|
where
|
||||||
import Data.Text (Text)
|
apiPath = fromRelative "https" (apiHost region)
|
||||||
import qualified Data.Text as T (pack, toLower)
|
wwwPath = fromRelative "https" (wwwHost region)
|
||||||
import qualified Data.Text.Encoding as E (encodeUtf8)
|
|
||||||
import Network.HTTP.Conduit (Manager)
|
apiHost :: Text -> Host
|
||||||
import Prelude
|
apiHost "cn" = "api.battlenet.com.cn"
|
||||||
import Yesod.Auth
|
apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"
|
||||||
import Yesod.Auth.OAuth2
|
|
||||||
import Yesod.Core.Widget
|
wwwHost :: Text -> Host
|
||||||
|
wwwHost "cn" = "www.battlenet.com.cn"
|
||||||
data BattleNetUser = BattleNetUser
|
wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"
|
||||||
{ 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"
|
|
||||||
|
|||||||
@ -1,141 +1,26 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# 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
|
module Yesod.Auth.OAuth2.Bitbucket
|
||||||
( oauth2Bitbucket
|
( oauth2Bitbucket
|
||||||
, oauth2BitbucketScoped
|
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
import Data.Aeson
|
||||||
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.Text (Text)
|
import Data.Text (Text)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
|
|
||||||
import Yesod.Auth.OAuth2
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
newtype UserId = UserId Text
|
||||||
|
deriving ToIdent
|
||||||
|
|
||||||
data BitbucketUser = BitbucketUser
|
instance FromJSON UserId where
|
||||||
{ bitbucketUserId :: Text
|
parseJSON = withObject "User" $ \o -> UserId <$> o .: "uuid"
|
||||||
, bitbucketUserName :: Maybe Text
|
|
||||||
, bitbucketUserLogin :: Text
|
|
||||||
, bitbucketUserLocation :: Maybe Text
|
|
||||||
, bitbucketUserLinks :: BitbucketUserLinks
|
|
||||||
}
|
|
||||||
|
|
||||||
instance FromJSON BitbucketUser where
|
oauth2Bitbucket :: [Scope] -> Provider m UserId
|
||||||
parseJSON (Object o) = BitbucketUser
|
oauth2Bitbucket scopes = Provider
|
||||||
<$> o .: "uuid"
|
{ pName = "bitbucket"
|
||||||
<*> o .:? "display_name"
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
<*> o .: "username"
|
$ "https://bitbucket.com/site/oauth2/authorize" `withQuery`
|
||||||
<*> 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`
|
|
||||||
[ scopeParam "," scopes
|
[ scopeParam "," scopes
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
|
, pAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://api.bitbucket.com/2.0/user"
|
||||||
}
|
|
||||||
|
|
||||||
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)
|
|
||||||
}
|
}
|
||||||
|
|
||||||
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 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
|
module Yesod.Auth.OAuth2.EveOnline
|
||||||
( oauth2Eve
|
( oauth2EveOnline
|
||||||
, oauth2EveScoped
|
|
||||||
, WidgetType(..)
|
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
|
||||||
import Control.Applicative ((<$>), (<*>))
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import Control.Exception.Lifted
|
|
||||||
import Control.Monad (mzero)
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Text (Text)
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Network.HTTP.Conduit (Manager)
|
|
||||||
import Yesod.Auth
|
|
||||||
import Yesod.Auth.OAuth2
|
|
||||||
import Yesod.Core.Widget
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
newtype CharId = CharId Int
|
||||||
|
deriving ToIdent
|
||||||
|
|
||||||
data WidgetType m
|
instance FromJSON CharId where
|
||||||
= Plain -- ^ Simple "Login via eveonline" text
|
parseJSON = withObject "Character" $ \o -> CharId <$> o .: "CharacterId"
|
||||||
| BigWhite
|
|
||||||
| SmallWhite
|
|
||||||
| BigBlack
|
|
||||||
| SmallBlack
|
|
||||||
| Custom (WidgetT m IO ())
|
|
||||||
|
|
||||||
data EveUser = EveUser
|
oauth2EveOnline :: [Scope] -> Provider m CharId
|
||||||
{ eveUserName :: Text
|
oauth2EveOnline scopes = Provider
|
||||||
, eveUserExpire :: Text
|
{ pName = "eveonline"
|
||||||
, eveTokenType :: Text
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
, eveCharOwnerHash :: Text
|
$ "https://login.eveonline.com/oauth/authorize" `withQuery`
|
||||||
, 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`
|
|
||||||
[ ("response_type", "code")
|
[ ("response_type", "code")
|
||||||
, scopeParam " " scopes
|
, scopeParam " " scopes
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://login.eveonline.com/oauth/token"
|
, pAccessTokenEndpoint = "https://login.eveonline.com/oauth/token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://login.eveonline.com/oauth/verify"
|
||||||
}
|
|
||||||
|
|
||||||
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)
|
|
||||||
]
|
|
||||||
}
|
}
|
||||||
|
|||||||
@ -1,115 +1,22 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# 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
|
module Yesod.Auth.OAuth2.Github
|
||||||
( oauth2Github
|
( oauth2Github
|
||||||
, oauth2GithubScoped
|
, defaultScopes
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Control.Applicative ((<$>), (<*>))
|
import Yesod.Auth.OAuth2.UserId
|
||||||
#endif
|
|
||||||
|
|
||||||
import Control.Exception.Lifted
|
oauth2Github :: [Scope] -> Provider m UserId
|
||||||
import Control.Monad (mzero)
|
oauth2Github scopes = Provider
|
||||||
import Data.Aeson
|
{ pName = "github"
|
||||||
import Data.List (find)
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
import Data.Maybe (fromMaybe)
|
$ "http://github.com/login/oauth/authorize" `withQuery`
|
||||||
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`
|
|
||||||
[ scopeParam "," scopes
|
[ scopeParam "," scopes
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
|
, pAccessTokenEndpoint = "http://github.com/login/oauth/access_token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://api.github.com/user"
|
||||||
}
|
|
||||||
|
|
||||||
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)
|
|
||||||
}
|
}
|
||||||
|
|
||||||
where
|
defaultScopes :: [Scope]
|
||||||
email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
|
defaultScopes = ["user:email"]
|
||||||
|
|||||||
@ -1,137 +1,30 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# 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
|
module Yesod.Auth.OAuth2.Google
|
||||||
( oauth2Google
|
( oauth2Google
|
||||||
, oauth2GoogleScoped
|
, defaultScopes
|
||||||
, oauth2GoogleScopedWithCustomId
|
|
||||||
, googleUid
|
|
||||||
, emailUid
|
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
|
||||||
import Control.Applicative ((<$>), (<*>))
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import Control.Exception.Lifted
|
|
||||||
import Control.Monad (mzero)
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Yesod.Auth
|
|
||||||
import Yesod.Auth.OAuth2
|
|
||||||
|
|
||||||
-- | Auth with Google
|
newtype UserId = UserId Text
|
||||||
--
|
deriving ToIdent
|
||||||
-- 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"]
|
|
||||||
|
|
||||||
-- | Auth with Google
|
instance FromJSON UserId where
|
||||||
--
|
parseJSON = withObject "User" $ \o -> UserId <$> o .: "sub"
|
||||||
-- 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
|
|
||||||
|
|
||||||
-- | Auth with Google
|
oauth2Google :: [Scope] -> Provider m UserId
|
||||||
--
|
oauth2Google scopes = Provider
|
||||||
-- Requests custom scopes and uses the given function to create credentials
|
{ pName = "google"
|
||||||
-- which allows for using any attribute as the identifier.
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
--
|
$ "https://accounts.google.com/o/oauth2/auth" `withQuery`
|
||||||
-- 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`
|
|
||||||
[ scopeParam "+" scopes
|
[ scopeParam "+" scopes
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
|
, pAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://www.googleapis.com/oauth2/v3/userinfo"
|
||||||
}
|
|
||||||
|
|
||||||
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
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON GoogleUser where
|
defaultScopes :: [Scope]
|
||||||
parseJSON (Object o) = GoogleUser
|
defaultScopes = ["openid", "email"]
|
||||||
<$> 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)
|
|
||||||
}
|
|
||||||
|
|||||||
@ -1,86 +1,28 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Yesod.Auth.OAuth2.Nylas
|
module Yesod.Auth.OAuth2.Nylas
|
||||||
( oauth2Nylas
|
( oauth2Nylas
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) 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 Data.Text.Encoding (encodeUtf8)
|
||||||
import Network.HTTP.Client
|
import Network.HTTP.Client
|
||||||
(applyBasicAuth, httpLbs, parseRequest, responseBody, responseStatus)
|
(applyBasicAuth, httpLbs, parseUrlThrow, responseBody)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Network.OAuth.OAuth2 (AccessToken(..))
|
||||||
import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
|
import URI.ByteString.Extension (withQuery)
|
||||||
import Yesod.Auth.OAuth2
|
import Yesod.Auth.OAuth2.Provider
|
||||||
|
import Yesod.Auth.OAuth2.UserId
|
||||||
|
|
||||||
import qualified Network.HTTP.Types as HT
|
oauth2Nylas :: Provider m UserIdText
|
||||||
|
oauth2Nylas = Provider
|
||||||
data NylasAccount = NylasAccount
|
{ pName = "nylas"
|
||||||
{ nylasAccountId :: Text
|
, pAuthorizeEndpoint = \cid -> AuthorizeEndpoint $
|
||||||
, nylasAccountEmailAddress :: Text
|
"https://api.nylas.com/oauth/authorize" `withQuery`
|
||||||
, nylasAccountName :: Text
|
[ ("client_id", encodeUtf8 $ clientId cid)
|
||||||
, nylasAccountProvider :: Text
|
, ("response_type", "code")
|
||||||
, 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")
|
|
||||||
, ("scope", "email")
|
, ("scope", "email")
|
||||||
, ("client_id", encodeUtf8 clientId)
|
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://api.nylas.com/oauth/token"
|
, pAccessTokenEndpoint = "https://api.nylas.com/oauth/token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = \manager token -> do
|
||||||
}
|
req <- applyBasicAuth (encodeUtf8 $ atoken token) ""
|
||||||
|
<$> parseUrlThrow "https://api.nylas.com/account"
|
||||||
fetchCreds :: Manager -> OAuth2Token -> IO (Creds a)
|
Right . responseBody <$> httpLbs req manager
|
||||||
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)
|
|
||||||
]
|
|
||||||
}
|
}
|
||||||
|
|||||||
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 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
|
module Yesod.Auth.OAuth2.Salesforce
|
||||||
( oauth2Salesforce
|
( oauth2Salesforce
|
||||||
, oauth2SalesforceScoped
|
|
||||||
, oauth2SalesforceSandbox
|
, oauth2SalesforceSandbox
|
||||||
, oauth2SalesforceSandboxScoped
|
, defaultScopes
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
|
||||||
import Control.Applicative ((<$>), (<*>))
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import Control.Exception.Lifted
|
|
||||||
import Control.Monad (mzero)
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Network.HTTP.Conduit (Manager)
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Yesod.Auth
|
|
||||||
import Yesod.Auth.OAuth2
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
newtype UserId = UserId Text
|
||||||
|
deriving ToIdent
|
||||||
|
|
||||||
oauth2Salesforce :: YesodAuth m
|
instance FromJSON UserId where
|
||||||
=> Text -- ^ Client ID
|
parseJSON = withObject "User" $ \o -> UserId <$> o .: "user_id"
|
||||||
-> Text -- ^ Client Secret
|
|
||||||
-> AuthPlugin m
|
|
||||||
oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"]
|
|
||||||
|
|
||||||
svcName :: Text
|
oauth2Salesforce :: [Scope] -> Provider m UserId
|
||||||
svcName = "salesforce"
|
oauth2Salesforce scopes = Provider
|
||||||
|
{ pName = "salesforce"
|
||||||
oauth2SalesforceScoped :: YesodAuth m
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
=> [Text] -- ^ List of scopes to request
|
$ "https://login.salesforce.com/services/oauth2/authorize" `withQuery`
|
||||||
-> 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`
|
|
||||||
[ scopeParam " " scopes
|
[ scopeParam " " scopes
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"
|
, pAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://login.salesforce.com/services/oauth2/userinfo"
|
||||||
}
|
}
|
||||||
|
|
||||||
fetchSalesforceUser :: Manager -> OAuth2Token -> IO (Creds m)
|
oauth2SalesforceSandbox :: [Scope] -> Provider m UserId
|
||||||
fetchSalesforceUser manager token = do
|
oauth2SalesforceSandbox scopes = Provider
|
||||||
result <- authGetJSON manager (accessToken token) "https://login.salesforce.com/services/oauth2/userinfo"
|
{ pName = "salesforce-sandbox"
|
||||||
case result of
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
Right user -> return $ toCreds svcName user token
|
$ "https://test.salesforce.com/services/oauth2/authorize" `withQuery`
|
||||||
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`
|
|
||||||
[ scopeParam " " scopes
|
[ scopeParam " " scopes
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token"
|
, pAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://test.salesforce.com/services/oauth2/userinfo"
|
||||||
}
|
|
||||||
|
|
||||||
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
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON User where
|
defaultScopes :: [Scope]
|
||||||
parseJSON (Object o) = do
|
defaultScopes = ["openid", "email", "api"]
|
||||||
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)
|
|
||||||
}
|
|
||||||
|
|||||||
@ -1,123 +1,29 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# 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
|
module Yesod.Auth.OAuth2.Slack
|
||||||
( SlackScope(..)
|
( oauth2Slack
|
||||||
, oauth2Slack
|
, defaultScopes
|
||||||
, oauth2SlackScoped
|
|
||||||
) where
|
) 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 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
|
oauth2Slack :: [Scope] -> Provider m UserIdText
|
||||||
|
oauth2Slack scopes = Provider
|
||||||
data SlackScope
|
{ pName = "slack"
|
||||||
= SlackEmailScope
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
| SlackTeamScope
|
$ "https://slack.com/oauth/authorize" `withQuery`
|
||||||
| SlackAvatarScope
|
[ scopeParam "," scopes
|
||||||
|
|
||||||
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
|
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://slack.com/api/oauth.access"
|
, pAccessTokenEndpoint = "https://slack.com/api/oauth.access"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = \manager token -> do
|
||||||
}
|
request <- setQueryString [("token", Just $ encodeUtf8 $ atoken token)]
|
||||||
|
<$> parseUrlThrow "https://slack.com/api/users.identity"
|
||||||
scopeText :: SlackScope -> Text
|
Right . responseBody <$> httpLbs request manager
|
||||||
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)
|
|
||||||
]
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
defaultScopes :: [Scope]
|
||||||
|
defaultScopes = ["identity.basic"]
|
||||||
|
|||||||
@ -1,107 +1,18 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
-- |
|
|
||||||
--
|
|
||||||
-- OAuth2 plugin for http://spotify.com
|
|
||||||
--
|
|
||||||
module Yesod.Auth.OAuth2.Spotify
|
module Yesod.Auth.OAuth2.Spotify
|
||||||
( oauth2Spotify
|
( oauth2Spotify
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Control.Applicative (pure, (<$>), (<*>))
|
import Yesod.Auth.OAuth2.UserId
|
||||||
#endif
|
|
||||||
|
|
||||||
import Control.Monad (mzero)
|
oauth2Spotify :: [Scope] -> Provider m UserIdText
|
||||||
import Data.Aeson
|
oauth2Spotify scopes = Provider
|
||||||
import Data.Maybe
|
{ pName = "spotify"
|
||||||
import Data.Text (Text)
|
, pAuthorizeEndpoint = const $ AuthorizeEndpoint
|
||||||
import Data.Text.Encoding (encodeUtf8)
|
$ "https://accounts.spotify.com/authorize" `withQuery`
|
||||||
import Yesod.Auth
|
[ scopeParam " " scopes
|
||||||
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)
|
|
||||||
]
|
]
|
||||||
, oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
|
, pAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
|
||||||
, oauthCallback = Nothing
|
, pFetchUserProfile = authGetProfile "https://api.spotify.com/v1/me"
|
||||||
}
|
|
||||||
$ 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
|
|
||||||
}
|
}
|
||||||
|
|
||||||
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 #-}
|
{-# 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
|
module Yesod.Auth.OAuth2.Upcase
|
||||||
( oauth2Upcase
|
( oauth2Upcase
|
||||||
, module Yesod.Auth.OAuth2
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ < 710
|
import Yesod.Auth.OAuth2.Provider
|
||||||
import Control.Applicative ((<$>), (<*>))
|
import Yesod.Auth.OAuth2.UserId
|
||||||
#endif
|
|
||||||
|
|
||||||
import Control.Monad (mzero)
|
oauth2Upcase :: Provider m UserId
|
||||||
import Data.Aeson
|
oauth2Upcase = Provider
|
||||||
import Data.Text (Text)
|
{ pName = "upcase"
|
||||||
import qualified Data.Text as T
|
, pAuthorizeEndpoint = const "http://upcase.com/oauth/authorize"
|
||||||
import Yesod.Auth
|
, pAccessTokenEndpoint = "http://upcase.com/oauth/token"
|
||||||
import Yesod.Auth.OAuth2
|
, pFetchUserProfile = authGetProfile "http://upcase.com/api/v1/me.json"
|
||||||
|
|
||||||
data UpcaseUser = UpcaseUser
|
|
||||||
{ upcaseUserId :: Int
|
|
||||||
, upcaseUserFirstName :: Text
|
|
||||||
, upcaseUserLastName :: Text
|
|
||||||
, upcaseUserEmail :: Text
|
|
||||||
}
|
}
|
||||||
|
|
||||||
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:
|
packages:
|
||||||
- .
|
- .
|
||||||
extra-deps:
|
|
||||||
- load-env-0.1.1
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user