yesod-auth-oauth2 0.3.0 → 0.3.1
raw patch · 26 files changed
+1528/−1437 lines, 26 filesdep −networkdep ~aesondep ~basedep ~hoauth2
Dependencies removed: network
Dependency ranges changed: aeson, base, hoauth2
Files
- URI/ByteString/Extension.hs +0/−53
- Yesod/Auth/OAuth2.hs +0/−167
- Yesod/Auth/OAuth2/BattleNet.hs +0/−83
- Yesod/Auth/OAuth2/Bitbucket.hs +0/−141
- Yesod/Auth/OAuth2/EveOnline.hs +0/−116
- Yesod/Auth/OAuth2/Github.hs +0/−115
- Yesod/Auth/OAuth2/Google.hs +0/−137
- Yesod/Auth/OAuth2/Nylas.hs +0/−86
- Yesod/Auth/OAuth2/Salesforce.hs +0/−154
- Yesod/Auth/OAuth2/Slack.hs +0/−123
- Yesod/Auth/OAuth2/Spotify.hs +0/−107
- Yesod/Auth/OAuth2/Upcase.hs +0/−72
- src/URI/ByteString/Extension.hs +53/−0
- src/Yesod/Auth/OAuth2.hs +167/−0
- src/Yesod/Auth/OAuth2/BattleNet.hs +83/−0
- src/Yesod/Auth/OAuth2/Bitbucket.hs +141/−0
- src/Yesod/Auth/OAuth2/EveOnline.hs +116/−0
- src/Yesod/Auth/OAuth2/Github.hs +115/−0
- src/Yesod/Auth/OAuth2/Google.hs +137/−0
- src/Yesod/Auth/OAuth2/Nylas.hs +86/−0
- src/Yesod/Auth/OAuth2/Salesforce.hs +154/−0
- src/Yesod/Auth/OAuth2/Slack.hs +123/−0
- src/Yesod/Auth/OAuth2/Spotify.hs +107/−0
- src/Yesod/Auth/OAuth2/Upcase.hs +72/−0
- test/URI/ByteString/ExtensionSpec.hs +82/−0
- yesod-auth-oauth2.cabal +92/−83
− URI/ByteString/Extension.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module URI.ByteString.Extension where--import Data.ByteString (ByteString)-import Data.String (IsString(..))-import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Lens.Micro--import qualified Data.ByteString.Char8 as C8--import URI.ByteString--instance IsString Scheme where- fromString = Scheme . fromString--instance IsString Host where- fromString = Host . fromString--instance IsString (URIRef Absolute) where- fromString = either (error . show) id- . parseURI strictURIParserOptions- . C8.pack--instance IsString (URIRef Relative) where- fromString = either (error . show) id- . parseRelativeRef strictURIParserOptions- . C8.pack--fromText :: Text -> Maybe URI-fromText = either (const Nothing) Just- . parseURI strictURIParserOptions- . encodeUtf8--unsafeFromText :: Text -> URI-unsafeFromText = either (error . show) id- . parseURI strictURIParserOptions- . encodeUtf8--toText :: URI -> Text-toText = decodeUtf8 . serializeURIRef'--fromRelative :: Scheme -> Host -> RelativeRef -> URI-fromRelative s h = flip withHost h . toAbsolute s--withHost :: URIRef a -> Host -> URIRef a-withHost u h = u & authorityL %~ maybe- (Just $ Authority Nothing h Nothing)- (\a -> Just $ a & authorityHostL .~ h)--withQuery :: URIRef a -> [(ByteString, ByteString)] -> URIRef a-withQuery u q = u & (queryL . queryPairsL) %~ (++ q)
− Yesod/Auth/OAuth2.hs
@@ -1,167 +0,0 @@-{-# 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.----module Yesod.Auth.OAuth2- ( authOAuth2- , authOAuth2Widget- , oauth2Url- , fromProfileURL- , YesodOAuth2Exception(..)- , invalidProfileResponse- , scopeParam- , maybeExtra- , module Network.OAuth.OAuth2- , module URI.ByteString- , module URI.ByteString.Extension- ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif--import Control.Exception.Lifted-import Control.Monad.IO.Class-import Control.Monad (unless)-import Data.Aeson (Value(..), encode)-import Data.Monoid ((<>))-import Data.ByteString (ByteString)-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.Core--import qualified Data.Text as T-import qualified Data.ByteString.Lazy as BL---- | 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'@------ This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which--- is then re-encoded for the exception message.----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------ Presents a generic @"Login via name"@ link----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------ 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 = []
− Yesod/Auth/OAuth2/BattleNet.hs
@@ -1,83 +0,0 @@-{-# 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 Yesod.Auth -import Yesod.Auth.OAuth2 - -import Data.Monoid ((<>)) -import Network.HTTP.Conduit (Manager) - -import Data.Aeson -import Data.Text (Text) -import qualified Data.Text as T (pack, toLower) -import qualified Data.Text.Encoding as E (encodeUtf8) -import Prelude -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" - - case userResult of - Left err -> throwIO $ invalidProfileResponse "battle.net" err - Right user -> return Creds - { credsPlugin = "battle.net" - , credsIdent = T.pack $ show $ userId user - , credsExtra = [("battletag", battleTag user)] - } - -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"
− Yesod/Auth/OAuth2/Bitbucket.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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.Maybe (fromMaybe)-import Data.List (find)-import Data.Text (Text)-import Network.HTTP.Conduit (Manager)-import Yesod.Auth (YesodAuth, Creds(..), AuthPlugin)-import Yesod.Auth.OAuth2--import qualified Data.Text as T--data BitbucketUser = BitbucketUser- { bitbucketUserId :: Text- , bitbucketUserName :: Maybe Text- , bitbucketUserLogin :: Text- , bitbucketUserLocation :: Maybe Text- , bitbucketUserLinks :: BitbucketUserLinks- }--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`- [ 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)- }-- where- email = fromMaybe (head userMails) $ find bitbucketUserEmailPrimary userMails
− Yesod/Auth/OAuth2/EveOnline.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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- ) 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 qualified Data.Text as T--data WidgetType m- = Plain -- ^ Simple "Login via eveonline" text- | BigWhite- | SmallWhite- | BigBlack- | SmallBlack- | Custom (WidgetT m IO ())--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`- [ ("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)- ]- }
− Yesod/Auth/OAuth2/Github.hs
@@ -1,115 +0,0 @@-{-# 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- ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), (<*>))-#endif--import Control.Exception.Lifted-import Control.Monad (mzero)-import Data.Aeson-import Data.Maybe (fromMaybe)-import Data.List (find)-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- ]- , 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)- }-- where- email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
− Yesod/Auth/OAuth2/Google.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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- ) 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---- | 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"]---- | 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---- | 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`- [ 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- }--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)- }
− Yesod/Auth/OAuth2/Nylas.hs
@@ -1,86 +0,0 @@-{-# 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.Monad (mzero)-import Control.Exception.Lifted (throwIO)-import Data.Aeson (FromJSON, Value(..), parseJSON, decode, (.:))-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 (Creds(..), YesodAuth, AuthPlugin)-import Yesod.Auth.OAuth2--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")- , ("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)- ]- }
− Yesod/Auth/OAuth2/Salesforce.hs
@@ -1,154 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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- ) 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 qualified Data.Text as T--oauth2Salesforce :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> AuthPlugin m-oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"]--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`- [ scopeParam " " scopes- ]- , oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"- , oauthCallback = Nothing- }--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`- [ 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- }--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)- }
− Yesod/Auth/OAuth2/Slack.hs
@@ -1,123 +0,0 @@-{-# 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- ) 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 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- ]- , 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)- ]- }
− Yesod/Auth/OAuth2/Spotify.hs
@@ -1,107 +0,0 @@-{-# 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 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)- ]- , 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- }-- 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
− Yesod/Auth/OAuth2/Upcase.hs
@@ -1,72 +0,0 @@-{-# 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 Control.Monad (mzero)-import Data.Aeson-import Data.Text (Text)-import Yesod.Auth-import Yesod.Auth.OAuth2-import qualified Data.Text as T--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)- ]- }
+ src/URI/ByteString/Extension.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module URI.ByteString.Extension where++import Data.ByteString (ByteString)+import Data.String (IsString(..))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Lens.Micro++import qualified Data.ByteString.Char8 as C8++import URI.ByteString++instance IsString Scheme where+ fromString = Scheme . fromString++instance IsString Host where+ fromString = Host . fromString++instance IsString (URIRef Absolute) where+ fromString = either (error . show) id+ . parseURI strictURIParserOptions+ . C8.pack++instance IsString (URIRef Relative) where+ fromString = either (error . show) id+ . parseRelativeRef strictURIParserOptions+ . C8.pack++fromText :: Text -> Maybe URI+fromText = either (const Nothing) Just+ . parseURI strictURIParserOptions+ . encodeUtf8++unsafeFromText :: Text -> URI+unsafeFromText = either (error . show) id+ . parseURI strictURIParserOptions+ . encodeUtf8++toText :: URI -> Text+toText = decodeUtf8 . serializeURIRef'++fromRelative :: Scheme -> Host -> RelativeRef -> URI+fromRelative s h = flip withHost h . toAbsolute s++withHost :: URIRef a -> Host -> URIRef a+withHost u h = u & authorityL %~ maybe+ (Just $ Authority Nothing h Nothing)+ (\a -> Just $ a & authorityHostL .~ h)++withQuery :: URIRef a -> [(ByteString, ByteString)] -> URIRef a+withQuery u q = u & (queryL . queryPairsL) %~ (++ q)
+ src/Yesod/Auth/OAuth2.hs view
@@ -0,0 +1,167 @@+{-# 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.+--+module Yesod.Auth.OAuth2+ ( authOAuth2+ , authOAuth2Widget+ , oauth2Url+ , fromProfileURL+ , YesodOAuth2Exception(..)+ , invalidProfileResponse+ , scopeParam+ , maybeExtra+ , module Network.OAuth.OAuth2+ , module URI.ByteString+ , module URI.ByteString.Extension+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif++import Control.Exception.Lifted+import Control.Monad.IO.Class+import Control.Monad (unless)+import Data.Aeson (Value(..), encode)+import Data.Monoid ((<>))+import Data.ByteString (ByteString)+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.Core++import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL++-- | 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'@+--+-- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which+-- is then re-encoded for the exception message.+--+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+--+-- Presents a generic @"Login via name"@ link+--+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+--+-- 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 = []
+ src/Yesod/Auth/OAuth2/BattleNet.hs view
@@ -0,0 +1,83 @@+{-# 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 Yesod.Auth +import Yesod.Auth.OAuth2 + +import Data.Monoid ((<>)) +import Network.HTTP.Conduit (Manager) + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as T (pack, toLower) +import qualified Data.Text.Encoding as E (encodeUtf8) +import Prelude +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" + + case userResult of + Left err -> throwIO $ invalidProfileResponse "battle.net" err + Right user -> return Creds + { credsPlugin = "battle.net" + , credsIdent = T.pack $ show $ userId user + , credsExtra = [("battletag", battleTag user)] + } + +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"
+ src/Yesod/Auth/OAuth2/Bitbucket.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-# 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.Maybe (fromMaybe)+import Data.List (find)+import Data.Text (Text)+import Network.HTTP.Conduit (Manager)+import Yesod.Auth (YesodAuth, Creds(..), AuthPlugin)+import Yesod.Auth.OAuth2++import qualified Data.Text as T++data BitbucketUser = BitbucketUser+ { bitbucketUserId :: Text+ , bitbucketUserName :: Maybe Text+ , bitbucketUserLogin :: Text+ , bitbucketUserLocation :: Maybe Text+ , bitbucketUserLinks :: BitbucketUserLinks+ }++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`+ [ 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)+ }++ where+ email = fromMaybe (head userMails) $ find bitbucketUserEmailPrimary userMails
+ src/Yesod/Auth/OAuth2/EveOnline.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# 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+ ) 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 qualified Data.Text as T++data WidgetType m+ = Plain -- ^ Simple "Login via eveonline" text+ | BigWhite+ | SmallWhite+ | BigBlack+ | SmallBlack+ | Custom (WidgetT m IO ())++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`+ [ ("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)+ ]+ }
+ src/Yesod/Auth/OAuth2/Github.hs view
@@ -0,0 +1,115 @@+{-# 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+ ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>))+#endif++import Control.Exception.Lifted+import Control.Monad (mzero)+import Data.Aeson+import Data.Maybe (fromMaybe)+import Data.List (find)+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+ ]+ , 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)+ }++ where+ email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails
+ src/Yesod/Auth/OAuth2/Google.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP #-}+{-# 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+ ) 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++-- | 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"]++-- | 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++-- | 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`+ [ 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+ }++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)+ }
+ src/Yesod/Auth/OAuth2/Nylas.hs view
@@ -0,0 +1,86 @@+{-# 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.Monad (mzero)+import Control.Exception.Lifted (throwIO)+import Data.Aeson (FromJSON, Value(..), parseJSON, decode, (.:))+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 (Creds(..), YesodAuth, AuthPlugin)+import Yesod.Auth.OAuth2++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")+ , ("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)+ ]+ }
+ src/Yesod/Auth/OAuth2/Salesforce.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+{-# 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+ ) 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 qualified Data.Text as T++oauth2Salesforce :: YesodAuth m+ => Text -- ^ Client ID+ -> Text -- ^ Client Secret+ -> AuthPlugin m+oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"]++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`+ [ scopeParam " " scopes+ ]+ , oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"+ , oauthCallback = Nothing+ }++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`+ [ 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+ }++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)+ }
+ src/Yesod/Auth/OAuth2/Slack.hs view
@@ -0,0 +1,123 @@+{-# 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+ ) 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 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+ ]+ , 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)+ ]+ }
+ src/Yesod/Auth/OAuth2/Spotify.hs view
@@ -0,0 +1,107 @@+{-# 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 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)+ ]+ , 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+ }++ 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
+ src/Yesod/Auth/OAuth2/Upcase.hs view
@@ -0,0 +1,72 @@+{-# 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 Control.Monad (mzero)+import Data.Aeson+import Data.Text (Text)+import Yesod.Auth+import Yesod.Auth.OAuth2+import qualified Data.Text as T++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)+ ]+ }
+ test/URI/ByteString/ExtensionSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module URI.ByteString.ExtensionSpec+ ( main+ , spec+ ) where++import Test.Hspec++import Control.Exception (ErrorCall, evaluate)+import Data.List (isInfixOf)+import URI.ByteString+import URI.ByteString.Extension+import URI.ByteString.QQ++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "IsString Scheme" $ it "works" $ do+ "https" `shouldBe` Scheme "https"++ describe "IsString Host" $ it "works" $ do+ "example.com" `shouldBe` Host "example.com"++ describe "IsString URIRef Relative" $ it "works" $ do+ "example.com/foo?bar=baz"+ `shouldBe` [relativeRef|example.com/foo?bar=baz|]++ describe "IsString URIRef Absolute" $ it "works" $ do+ "https://example.com/foo?bar=baz"+ `shouldBe` [uri|https://example.com/foo?bar=baz|]++ describe "fromText" $ do+ it "returns Just a URI for valid values, as the quasi-quoter would" $ do+ fromText "http://example.com/foo?bar=baz"+ `shouldBe` Just [uri|http://example.com/foo?bar=baz|]++ it "returns Nothing for invalid values" $ do+ fromText "Oh my, what did I do?" `shouldBe` Nothing++ describe "unsafeFromText" $ do+ it "returns a URI for valid values, as the quasi-quoter would" $ do+ unsafeFromText "http://example.com/foo?bar=baz"+ `shouldBe` [uri|http://example.com/foo?bar=baz|]++ it "raises for invalid values" $ do+ evaluate (unsafeFromText "Oh my, what did I do?")+ `shouldThrow` errorContaining "MissingColon"++ describe "toText" $ do+ it "serializes the URI to text" $ do+ toText [uri|https://example.com/foo?bar=baz|]+ `shouldBe` "https://example.com/foo?bar=baz"++ describe "fromRelative" $ do+ it "makes a URI absolute with a given host" $ do+ fromRelative "ftp" "foo.com" [relativeRef|/bar?baz=bat|]+ `shouldBe` [uri|ftp://foo.com/bar?baz=bat|]++ describe "withQuery" $ do+ it "appends a query to a URI" $ do+ let uriWithQuery = [uri|http://example.com|] `withQuery` [("foo", "bar")]++ uriWithQuery `shouldBe` [uri|http://example.com?foo=bar|]++ it "handles a URI with an existing query" $ do+ let uriWithQuery = [uri|http://example.com?foo=bar|] `withQuery` [("baz", "bat")]++ uriWithQuery `shouldBe` [uri|http://example.com?foo=bar&baz=bat|]++ -- This is arguably testing the internals of another package, but IMO+ -- it's worthwhile to show that you don't (and can't) pre-sanitize when+ -- using this function.+ it "handles santization of the query" $ do+ let uriWithQuery = [uri|http://example.com|] `withQuery` [("foo", "bar baz")]++ toText uriWithQuery `shouldBe` "http://example.com?foo=bar%20baz"++errorContaining :: String -> Selector ErrorCall+errorContaining msg = (msg `isInfixOf`) . show
yesod-auth-oauth2.cabal view
@@ -1,95 +1,104 @@-name: yesod-auth-oauth2-version: 0.3.0-license: BSD3-license-file: LICENSE-author: Tom Streller-maintainer: Pat Brisbin <pat@thoughtbot.com>-synopsis: OAuth 2.0 authentication plugins-description: Library to authenticate with OAuth 2.0 for Yesod web applications.-category: Web-stability: Experimental-cabal-version: >= 1.8-build-type: Simple-homepage: http://github.com/thoughtbot/yesod-auth-oauth2+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 86087f5e361d8686832a02a805ac3132bb640ed555912b2f45d98e978edd6677 -flag network-uri- description: Get Network.URI from the network-uri package- default: True+name: yesod-auth-oauth2+version: 0.3.1+synopsis: OAuth 2.0 authentication plugins+description: Library to authenticate with OAuth 2.0 for Yesod web applications.+category: Web+homepage: http://github.com/thoughtbot/yesod-auth-oauth2+bug-reports: https://github.com/thoughtbot/yesod-auth-oauth2.git/issues+author: Tom Streller+maintainer: Pat Brisbin <pat@thoughtbot.com>+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 +source-repository head+ type: git+ location: https://github.com/thoughtbot/yesod-auth-oauth2.git+ flag example description: Build the example application+ manual: False default: False library- if flag(network-uri)- build-depends: network-uri >= 2.6- else- build-depends: network < 2.6-- build-depends: base >= 4.5 && < 5- , bytestring >= 0.9.1.4- , http-client >= 0.4.0 && < 0.6- , http-conduit >= 2.0 && < 3.0- , http-types >= 0.8 && < 0.10- , aeson >= 0.6 && < 1.2- , yesod-core >= 1.2 && < 1.5- , authenticate >= 1.3.2.7 && < 1.4- , random- , yesod-auth >= 1.3 && < 1.5- , text >= 0.7 && < 2.0- , yesod-form >= 1.3 && < 1.5- , transformers >= 0.2.2 && < 0.6- , hoauth2 >= 1.3.0 && < 1.4- , lifted-base >= 0.2 && < 0.4- , vector >= 0.10 && < 0.13- , uri-bytestring- , microlens-- exposed-modules: Yesod.Auth.OAuth2- Yesod.Auth.OAuth2.Github- Yesod.Auth.OAuth2.Google- Yesod.Auth.OAuth2.Spotify- Yesod.Auth.OAuth2.Upcase- Yesod.Auth.OAuth2.EveOnline- Yesod.Auth.OAuth2.Nylas- Yesod.Auth.OAuth2.Slack- Yesod.Auth.OAuth2.Salesforce- Yesod.Auth.OAuth2.Bitbucket- Yesod.Auth.OAuth2.BattleNet- URI.ByteString.Extension- -- ^ exposed for testing-- ghc-options: -Wall+ hs-source-dirs:+ src+ build-depends:+ aeson >=0.6 && <1.3+ , authenticate >=1.3.2.7 && <1.4+ , base >=4.5 && <5+ , bytestring >=0.9.1.4+ , 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+ , network-uri >=2.6+ , random+ , text >=0.7 && <2.0+ , transformers >=0.2.2 && <0.6+ , uri-bytestring+ , vector >=0.10 && <0.13+ , yesod-auth >=1.3 && <1.5+ , yesod-core >=1.2 && <1.5+ , yesod-form >=1.3 && <1.5+ exposed-modules:+ URI.ByteString.Extension+ Yesod.Auth.OAuth2+ Yesod.Auth.OAuth2.BattleNet+ Yesod.Auth.OAuth2.Bitbucket+ Yesod.Auth.OAuth2.EveOnline+ Yesod.Auth.OAuth2.Github+ Yesod.Auth.OAuth2.Google+ Yesod.Auth.OAuth2.Nylas+ Yesod.Auth.OAuth2.Salesforce+ Yesod.Auth.OAuth2.Slack+ Yesod.Auth.OAuth2.Spotify+ Yesod.Auth.OAuth2.Upcase+ other-modules:+ Paths_yesod_auth_oauth2+ default-language: Haskell2010 executable yesod-auth-oauth2-example- if flag(example)- buildable: True- else+ main-is: main.hs+ hs-source-dirs:+ example+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.5 && <5+ , containers+ , http-conduit+ , load-env+ , text+ , warp+ , yesod+ , yesod-auth+ , yesod-auth-oauth2+ if !(flag(example)) buildable: False-- hs-source-dirs: example- main-is: main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends: base- , containers- , http-conduit- , load-env- , text- , warp- , yesod- , yesod-auth- , yesod-auth-oauth2+ other-modules:+ Paths_yesod_auth_oauth2+ default-language: Haskell2010 test-suite test- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: test- ghc-options: -Wall- build-depends: base- , yesod-auth-oauth2- , hspec- , uri-bytestring--source-repository head- type: git- location: https://github.com/thoughtbot/yesod-auth-oauth2.git+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ build-depends:+ base >=4.5 && <5+ , hspec+ , uri-bytestring+ , yesod-auth-oauth2+ other-modules:+ URI.ByteString.ExtensionSpec+ Paths_yesod_auth_oauth2+ default-language: Haskell2010