yesod-auth-oauth2 0.3.1 → 0.4.0.0
raw patch · 18 files changed
+854/−1167 lines, 18 filesdep +aeson-prettydep +errorsdep +safe-exceptionsdep −authenticatedep −lifted-basedep −network-uridep ~aesondep ~basedep ~bytestring
Dependencies added: aeson-pretty, errors, safe-exceptions
Dependencies removed: authenticate, lifted-base, network-uri, vector, yesod-form
Dependency ranges changed: aeson, base, bytestring
Files
- LICENSE +15/−22
- example/Main.hs +155/−0
- example/main.hs +0/−119
- src/Yesod/Auth/OAuth2.hs +47/−132
- src/Yesod/Auth/OAuth2/BattleNet.hs +69/−83
- src/Yesod/Auth/OAuth2/Bitbucket.hs +27/−109
- src/Yesod/Auth/OAuth2/Dispatch.hs +130/−0
- src/Yesod/Auth/OAuth2/EveOnline.hs +32/−74
- src/Yesod/Auth/OAuth2/Github.hs +21/−83
- src/Yesod/Auth/OAuth2/Google.hs +43/−111
- src/Yesod/Auth/OAuth2/Nylas.hs +41/−63
- src/Yesod/Auth/OAuth2/Prelude.hs +126/−0
- src/Yesod/Auth/OAuth2/Salesforce.hs +48/−128
- src/Yesod/Auth/OAuth2/Slack.hs +40/−90
- src/Yesod/Auth/OAuth2/Spotify.hs +20/−86
- src/Yesod/Auth/OAuth2/Upcase.hs +20/−47
- test/URI/ByteString/ExtensionSpec.hs +1/−5
- yesod-auth-oauth2.cabal +19/−15
LICENSE view
@@ -1,25 +1,18 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2008, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright 2018 Patrick Brisbin -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ example/Main.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+--+-- This single-file Yesod app uses all plugins defined within this site, as a+-- means of manual verification that they work. When adding a new plugin, add+-- usage of it here and verify locally that it works.+--+-- To do so, see @.env.example@, then:+--+-- > stack build --flag yesod-auth-oauth2:example+-- > stack exec yesod-auth-oauth2-example+-- >+-- > $BROWSER http://localhost:3000+--+module Main where++import Data.Aeson+import Data.Aeson.Encode.Pretty+import Data.ByteString.Lazy (fromStrict, toStrict)+import qualified Data.Map as M+import Data.Maybe (fromJust)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import LoadEnv+import Network.HTTP.Conduit+import Network.Wai.Handler.Warp (runEnv)+import System.Environment (getEnv)+import Yesod+import Yesod.Auth+import Yesod.Auth.OAuth2.BattleNet+import Yesod.Auth.OAuth2.Bitbucket+import Yesod.Auth.OAuth2.EveOnline+import Yesod.Auth.OAuth2.Github+import Yesod.Auth.OAuth2.Google+import Yesod.Auth.OAuth2.Nylas+import Yesod.Auth.OAuth2.Salesforce+import Yesod.Auth.OAuth2.Slack+import Yesod.Auth.OAuth2.Spotify+import Yesod.Auth.OAuth2.Upcase++data App = App+ { appHttpManager :: Manager+ , appAuthPlugins :: [AuthPlugin App]+ }++mkYesod "App" [parseRoutes|+ / RootR GET+ /auth AuthR Auth getAuth+|]++instance Yesod App where+ -- see https://github.com/thoughtbot/yesod-auth-oauth2/issues/87+ approot = ApprootStatic "http://localhost:3000"++instance YesodAuth App where+ type AuthId App = Text+ loginDest _ = RootR+ logoutDest _ = RootR++ -- Disable any attempt to read persisted authenticated state+ maybeAuthId = return Nothing++ -- Copy the Creds response into the session for viewing after+ authenticate c = do+ mapM_ (uncurry setSession) $+ [ ("credsIdent", credsIdent c)+ , ("credsPlugin", credsPlugin c)+ ] ++ credsExtra c++ return $ Authenticated "1"++ authHttpManager = appHttpManager+ authPlugins = appAuthPlugins++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++getRootR :: Handler Html+getRootR = do+ sess <- getSession++ let+ prettify+ = decodeUtf8+ . toStrict+ . encodePretty+ . fromJust+ . decode @Value+ . fromStrict++ mCredsIdent = decodeUtf8 <$> M.lookup "credsIdent" sess+ mCredsPlugin = decodeUtf8 <$> M.lookup "credsPlugin" sess+ mAccessToken = decodeUtf8 <$> M.lookup "accessToken" sess+ mUserResponse = prettify <$> M.lookup "userResponse" sess++ defaultLayout [whamlet|+ <h1>Yesod Auth OAuth2 Example+ <h2>+ <a href=@{AuthR LoginR}>Log in++ <h2>Credentials++ <h3>Plugin / Ident+ <p>#{show mCredsPlugin} / #{show mCredsIdent}++ <h3>Access Token+ <p>#{show mAccessToken}++ <h3>User Response+ <pre>+ $maybe userResponse <- mUserResponse+ #{userResponse}+ |]++mkFoundation :: IO App+mkFoundation = do+ loadEnv++ appHttpManager <- newManager tlsManagerSettings+ appAuthPlugins <- sequence+ -- When Providers are added, add them here and update .env.example.+ -- Nothing else should need changing.+ --+ -- FIXME: oauth2BattleNet is quite annoying!+ --+ [ loadPlugin (oauth2BattleNet [whamlet|TODO|] "en") "BATTLE_NET"+ , loadPlugin oauth2Bitbucket "BITBUCKET"+ , loadPlugin (oauth2Eve Plain) "EVE_ONLINE"+ , loadPlugin oauth2Github "GITHUB"+ , loadPlugin oauth2Google "GOOGLE"+ , loadPlugin oauth2Nylas "NYLAS"+ , loadPlugin oauth2Salesforce "SALES_FORCE"+ , loadPlugin oauth2Slack "SLACK"+ , loadPlugin (oauth2Spotify []) "SPOTIFY"+ , loadPlugin oauth2Upcase "UPCASE"+ ]++ return App{..}+ where+ loadPlugin f prefix = do+ clientId <- getEnv $ prefix <> "_CLIENT_ID"+ clientSecret <- getEnv $ prefix <> "_CLIENT_SECRET"+ pure $ f (T.pack clientId) (T.pack clientSecret)++main :: IO ()+main = runEnv 3000 =<< toWaiApp =<< mkFoundation
− example/main.hs
@@ -1,119 +0,0 @@--- |------ This is a single-file example of using yesod-auth-oauth2.------ It can be run with:------ > stack build --flag yesod-auth-oauth2:example--- > stack exec yesod-auth-oauth2-example--- > $BROWSER http://localhost:3000----{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module Main where--import Data.Monoid ((<>))-import Data.Text (Text)-import LoadEnv-import Network.HTTP.Conduit-import Network.Wai.Handler.Warp (runEnv)-import System.Environment (getEnv)-import Yesod-import Yesod.Auth-import Yesod.Auth.OAuth2.Github--import qualified Data.Text as T--data OAuthKeys = OAuthKeys- { oauthKeysClientId :: Text- , oauthKeysClientSecret :: Text- }--loadOAuthKeysEnv :: String -> IO OAuthKeys-loadOAuthKeysEnv prefix = OAuthKeys- <$> (getEnvT $ prefix <> "_CLIENT_ID")- <*> (getEnvT $ prefix <> "_CLIENT_SECRET")-- where- getEnvT = fmap T.pack . getEnv--data App = App- { appHttpManager :: Manager- , appGithubKeys :: OAuthKeys- -- , appGoogleKeys :: OAuthKeys- -- , etc...- }--mkYesod "App" [parseRoutes|- / RootR GET- /auth AuthR Auth getAuth-|]--instance Yesod App where- -- redirect_uri must be absolute to avoid callback mismatch error- approot = ApprootStatic "http://localhost:3000"--instance YesodAuth App where- type AuthId App = Text- loginDest _ = RootR- logoutDest _ = RootR-- -- Disable any attempt to read persisted authenticated state- maybeAuthId = return Nothing-- -- Copy the Creds response into the session for viewing after- authenticate c = do- mapM_ (uncurry setSession) $- [ ("credsIdent", credsIdent c)- , ("credsPlugin", credsPlugin c)- ] ++ credsExtra c-- return $ Authenticated "1"-- authHttpManager = appHttpManager-- authPlugins m =- [ oauth2Github- (oauthKeysClientId $ appGithubKeys m)- (oauthKeysClientSecret $ appGithubKeys m)- -- , oauth2Google- -- (oauthKeysClientId $ appGoogleKeys m)- -- (oauthKeysClientSecret $ appGoogleKeys m)- -- , etc...- ]--instance RenderMessage App FormMessage where- renderMessage _ _ = defaultFormMessage--getRootR :: Handler Html-getRootR = do- sess <- getSession-- defaultLayout [whamlet|- <h1>Yesod Auth OAuth2 Example- <h2>- <a href=@{AuthR LoginR}>Log in- <h2>Session Information- <pre style="word-wrap: break-word;">- #{show sess}- |]--mkFoundation :: IO App-mkFoundation = do- loadEnv-- appHttpManager <- newManager tlsManagerSettings- appGithubKeys <- loadOAuthKeysEnv "GITHUB"- -- appGoogleKeys <- loadOAuthKeysEnv "GOOGLE"- -- etc...-- return App{..}--main :: IO ()-main = runEnv 3000 =<< toWaiApp =<< mkFoundation
src/Yesod/Auth/OAuth2.hs view
@@ -1,85 +1,48 @@-{-# 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.+-- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage. -- module Yesod.Auth.OAuth2- ( authOAuth2- , authOAuth2Widget+ ( OAuth2(..)+ , FetchCreds+ , Manager+ , OAuth2Token(..)+ , Creds(..) , oauth2Url- , fromProfileURL- , YesodOAuth2Exception(..)- , invalidProfileResponse- , scopeParam- , maybeExtra- , module Network.OAuth.OAuth2- , module URI.ByteString- , module URI.ByteString.Extension- ) where+ , authOAuth2+ , authOAuth2Widget -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif+ -- * Reading our @'credsExtra'@ keys+ , getAccessToken+ , getUserResponse+ , getUserResponseJSON+ ) where -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 Control.Error.Util (note)+import Control.Monad ((<=<))+import Data.Aeson (FromJSON, eitherDecode)+import Data.ByteString.Lazy (ByteString, fromStrict)+import Data.Text (Text) 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 Network.OAuth.OAuth2 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+import Yesod.Auth.OAuth2.Dispatch+import Yesod.Core.Widget oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] -- | Create an @'AuthPlugin'@ for the given OAuth2 provider ----- Presents a generic @"Login via name"@ link+-- 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 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name -- | Create an @'AuthPlugin'@ for the given OAuth2 provider@@ -87,81 +50,33 @@ -- 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-+authOAuth2Widget+ :: YesodAuth m+ => WidgetT m IO ()+ -> Text+ -> OAuth2+ -> FetchCreds m+ -> AuthPlugin m+authOAuth2Widget widget name oauth getCreds =+ AuthPlugin name (dispatchAuthRequest name oauth getCreds) 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+ login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|] - tokenSessionKey :: Text- tokenSessionKey = "_yesod_oauth2_" <> name+-- | Read from the values set via @'setExtra'@+getAccessToken :: Creds m -> Maybe AccessToken+getAccessToken =+ (AccessToken <$>) . lookup "accessToken" . credsExtra - login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]+-- | Read from the values set via @'setExtra'@+getUserResponse :: Creds m -> Maybe ByteString+getUserResponse =+ (fromStrict . encodeUtf8 <$>) . lookup "userResponse" . credsExtra --- | Handle the common case of fetching Profile information from a JSON endpoint+-- | Read from the values set via @'setExtra'@, decode as JSON ----- Throws @'InvalidProfileResponse'@ if JSON parsing fails+-- This is unsafe if the key is missing, but safe with respect to parsing+-- errors. ---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 = []+getUserResponseJSON :: FromJSON a => Creds m -> Either String a+getUserResponseJSON =+ eitherDecode <=< note "userResponse key not present" . getUserResponse
src/Yesod/Auth/OAuth2/BattleNet.hs view
@@ -1,83 +1,69 @@-{-# 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" +{-# 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+ , oAuth2BattleNet+ ) where++import Yesod.Auth.OAuth2.Prelude++import qualified Data.Text as T (pack, toLower)+import Yesod.Core.Widget++newtype User = User Int++instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User+ <$> o .: "id"++pluginName :: Text+pluginName = "battle.net"++oauth2BattleNet+ :: YesodAuth m+ => WidgetT m IO () -- ^ Login widget+ -> Text -- ^ User region (e.g. "eu", "cn", "us")+ -> Text -- ^ Client ID+ -> Text -- ^ Client Secret+ -> AuthPlugin m+oauth2BattleNet widget region clientId clientSecret =+ authOAuth2Widget widget pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token+ $ fromRelative "https" (apiHost $ T.toLower region) "/account/user"++ pure Creds+ { credsPlugin = pluginName+ , credsIdent = T.pack $ show userId+ , credsExtra = setExtra token userResponse+ }+ where+ host = wwwHost $ T.toLower region+ oauth2 = OAuth2+ { oauthClientId = clientId+ , oauthClientSecret = clientSecret+ , oauthOAuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"+ , oauthAccessTokenEndpoint = fromRelative "https" host "/oauth/token"+ , oauthCallback = Nothing+ }+++apiHost :: Text -> Host+apiHost "cn" = "api.battlenet.com.cn"+apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"++wwwHost :: Text -> Host+wwwHost "cn" = "www.battlenet.com.cn"+wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"++oAuth2BattleNet :: YesodAuth m => Text -> Text -> Text -> WidgetT m IO () -> AuthPlugin m+oAuth2BattleNet i s r w = oauth2BattleNet w r i s+{-# DEPRECATED oAuth2BattleNet "Use oauth2BattleNet" #-}
src/Yesod/Auth/OAuth2/Bitbucket.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | --@@ -6,104 +5,50 @@ -- -- * 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 Yesod.Auth.OAuth2.Prelude import qualified Data.Text as T -data BitbucketUser = BitbucketUser- { bitbucketUserId :: Text- , bitbucketUserName :: Maybe Text- , bitbucketUserLogin :: Text- , bitbucketUserLocation :: Maybe Text- , bitbucketUserLinks :: BitbucketUserLinks- }+newtype User = User Text -instance FromJSON BitbucketUser where- parseJSON (Object o) = BitbucketUser+instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User <$> 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- }+pluginName :: Text+pluginName = "bitbucket" -instance FromJSON BitbucketUserEmail where- parseJSON (Object o) = BitbucketUserEmail- <$> o .: "email"- <*> o .: "is_primary"+defaultScopes :: [Text]+defaultScopes = ["account"] - parseJSON _ = mzero+oauth2Bitbucket :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Bitbucket = oauth2BitbucketScoped defaultScopes -oauth2Bitbucket :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> AuthPlugin m-oauth2Bitbucket clientId clientSecret = oauth2BitbucketScoped clientId clientSecret ["account"]+oauth2BitbucketScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m+oauth2BitbucketScoped scopes clientId clientSecret =+ authOAuth2 pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token "https://api.bitbucket.com/2.0/user" -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+ pure Creds+ { credsPlugin = pluginName+ -- FIXME: Preserved bug. This should just be userId (it's already+ -- a Text), but because this code was shipped, folks likely have+ -- Idents in their database like @"\"...\""@, and if we fixed this+ -- they would need migrating. We're keeping it for now as it's a+ -- minor wart. Breaking typed APIs is one thing, causing data to go+ -- invalid is another.+ , credsIdent = T.pack $ show userId+ , credsExtra = setExtra token userResponse+ } where- oauth = OAuth2+ oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://bitbucket.com/site/oauth2/authorize" `withQuery`@@ -112,30 +57,3 @@ , 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/Dispatch.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Auth.OAuth2.Dispatch+ ( FetchCreds+ , dispatchAuthRequest+ ) where++import Control.Exception.Safe (throwString, tryIO)+import Control.Monad (unless)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Conduit (Manager)+import Network.OAuth.OAuth2+import System.Random (newStdGen, randomRs)+import URI.ByteString.Extension+import Yesod.Auth+import Yesod.Core++-- | How to take an @'OAuth2Token'@ and retrieve user credentials+type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)++-- | Dispatch the various OAuth2 handshake routes+dispatchAuthRequest+ :: Text -- ^ Name+ -> OAuth2 -- ^ Service details+ -> FetchCreds m -- ^ How to get credentials+ -> Text -- ^ Method+ -> [Text] -- ^ Path pieces+ -> AuthHandler m TypedContent+dispatchAuthRequest name oauth2 _ "GET" ["forward"] = dispatchForward name oauth2+dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = dispatchCallback name oauth2 getCreds+dispatchAuthRequest _ _ _ _ _ = notFound++-- | Handle @GET \/forward@+--+-- 1. Set a random CSRF token in our session+-- 2. Redirect to the Provider's authorization URL+--+dispatchForward :: Text -> OAuth2 -> AuthHandler m TypedContent+dispatchForward name oauth2 = do+ csrf <- setSessionCSRF $ tokenSessionKey name+ oauth2' <- withCallbackAndState name oauth2 csrf+ 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 :: Text -> OAuth2 -> FetchCreds m -> AuthHandler m TypedContent+dispatchCallback name oauth2 getCreds = do+ csrf <- verifySessionCSRF $ tokenSessionKey name+ code <- requireGetParam "code"+ manager <- lift $ getsYesod authHttpManager+ oauth2' <- withCallbackAndState name oauth2 csrf+ token <- denyLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code+ creds <- denyLeft $ tryIO $ getCreds 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++withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2+withCallbackAndState name oauth2 csrf = do+ let url = PluginR name ["callback"]+ render <- getParentUrlRender+ let callbackText = render url++ callback <- maybe+ (throwString+ $ "Invalid callback URI: "+ <> T.unpack callbackText+ <> ". Not using an absolute Approot?"+ ) pure $ fromText callbackText++ pure oauth2+ { oauthCallback = Just callback+ , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2+ `withQuery` [("state", encodeUtf8 csrf)]+ }++getParentUrlRender :: HandlerT child (HandlerT parent IO) (Route child -> Text)+getParentUrlRender = (.)+ <$> lift getUrlRender+ <*> getRouteToParent++-- | 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 :: Text -> Text+tokenSessionKey name = "_yesod_oauth2_" <> name
src/Yesod/Auth/OAuth2/EveOnline.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -- |@@ -7,30 +6,24 @@ -- -- * 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 Yesod.Auth.OAuth2.Prelude -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 import Yesod.Core.Widget -import qualified Data.Text as T+newtype User = User Text +instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User+ <$> o .: "CharacterOwnerHash"+ data WidgetType m = Plain -- ^ Simple "Login via eveonline" text | BigWhite@@ -39,51 +32,37 @@ | 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"+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 - parseJSON _ = mzero+pluginName :: Text+pluginName = "eveonline" -oauth2Eve :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> WidgetType m- -> AuthPlugin m-oauth2Eve clientId clientSecret = oauth2EveScoped clientId clientSecret ["publicData"] . asWidget+defaultScopes :: [Text]+defaultScopes = ["publicData"] - 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+oauth2Eve :: YesodAuth m => WidgetType m -> Text -> Text -> AuthPlugin m+oauth2Eve = oauth2EveScoped defaultScopes -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+oauth2EveScoped :: YesodAuth m => [Text] -> WidgetType m -> Text -> Text -> AuthPlugin m+oauth2EveScoped scopes widgetType clientId clientSecret =+ authOAuth2Widget (asWidget widgetType) pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token "https://login.eveonline.com/oauth/verify" + pure Creds+ { credsPlugin = "eveonline"+ -- FIXME: Preserved bug. See similar comment in Bitbucket provider.+ , credsIdent = T.pack $ show userId+ , credsExtra = setExtra token userResponse+ } where- oauth = OAuth2+ oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://login.eveonline.com/oauth/authorize" `withQuery`@@ -93,24 +72,3 @@ , 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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | --@@ -6,76 +5,44 @@ -- -- * 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 Yesod.Auth.OAuth2.Prelude import qualified Data.Text as T -data GithubUser = GithubUser- { githubUserId :: Int- , githubUserName :: Maybe Text- , githubUserLogin :: Text- , githubUserAvatarUrl :: Text- , githubUserLocation :: Maybe Text- , githubUserPublicEmail :: Maybe Text- }+newtype User = User Int -instance FromJSON GithubUser where- parseJSON (Object o) = GithubUser+instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User <$> o .: "id"- <*> o .:? "name"- <*> o .: "login"- <*> o .: "avatar_url"- <*> o .:? "location"- <*> o .:? "email" - parseJSON _ = mzero--data GithubUserEmail = GithubUserEmail- { githubUserEmailAddress :: Text- , githubUserEmailPrimary :: Bool- }+pluginName :: Text+pluginName = "github" -instance FromJSON GithubUserEmail where- parseJSON (Object o) = GithubUserEmail- <$> o .: "email"- <*> o .: "primary"+defaultScopes :: [Text]+defaultScopes = ["user:email"] - parseJSON _ = mzero+oauth2Github :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Github = oauth2GithubScoped defaultScopes -oauth2Github :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> AuthPlugin m-oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]+oauth2GithubScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m+oauth2GithubScoped scopes clientId clientSecret =+ authOAuth2 pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token "https://api.github.com/user" -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+ pure Creds+ { credsPlugin = pluginName+ , credsIdent = T.pack $ show userId+ , credsExtra = setExtra token userResponse+ } where- oauth = OAuth2+ oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize" `withQuery`@@ -84,32 +51,3 @@ , 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
@@ -1,137 +1,69 @@-{-# 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+-- * Uses Google user id as credentials identifier ----- Note: This may eventually replace Yesod.Auth.GoogleEmail2. Currently it--- provides the same functionality except that GoogleEmail2 returns more profile--- information.+-- If you were previously relying on email as the creds identifier, you can+-- still do that (and more) by overriding it in the creds returned by the plugin+-- with any value read out of the new @userResponse@ key in @'credsExtra'@. --+-- For example:+--+-- > data User = User { userEmail :: Text }+-- >+-- > instance FromJSON User where -- you know...+-- >+-- > authenticate creds = do+-- > -- 'getUserResponseJSON' provided by "Yesod.Auth.OAuth" module+-- > let Right email = userEmail <$> getUserResponseJSON creds+-- > updatedCreds = creds { credsIdent = email }+-- >+-- > -- continue normally with updatedCreds+-- module Yesod.Auth.OAuth2.Google ( oauth2Google , oauth2GoogleScoped- , oauth2GoogleScopedWithCustomId- , googleUid- , emailUid- , module Yesod.Auth.OAuth2 ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), (<*>))-#endif+import Yesod.Auth.OAuth2.Prelude -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+newtype User = User Text --- | 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"]+instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User+ -- Required for data backwards-compatibility+ <$> (("google-uid:" <>) <$> o .: "sub") --- | 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+pluginName :: Text+pluginName = "google" --- | 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+defaultScopes :: [Text]+defaultScopes = ["openid", "email"] +oauth2Google :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Google = oauth2GoogleScoped defaultScopes++oauth2GoogleScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m+oauth2GoogleScoped scopes clientId clientSecret =+ authOAuth2 pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token "https://www.googleapis.com/oauth2/v3/userinfo"++ pure Creds+ { credsPlugin = pluginName+ , credsIdent = userId+ , credsExtra = setExtra token userResponse+ } where- oauth = OAuth2+ oauth2 = 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" , 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
@@ -1,86 +1,64 @@-{-# 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 Yesod.Auth.OAuth2.Prelude +import Control.Monad (unless)+import qualified Data.ByteString.Lazy.Char8 as BL8+import Network.HTTP.Client import qualified Network.HTTP.Types as HT -data NylasAccount = NylasAccount- { nylasAccountId :: Text- , nylasAccountEmailAddress :: Text- , nylasAccountName :: Text- , nylasAccountProvider :: Text- , nylasAccountOrganizationUnit :: Text- }+newtype User = User Text -instance FromJSON NylasAccount where- parseJSON (Object o) = NylasAccount+instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User <$> 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+pluginName :: Text+pluginName = "nylas"++defaultScopes :: [Text]+defaultScopes = ["email"]++oauth2Nylas :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Nylas clientId clientSecret =+ authOAuth2 pluginName oauth $ \manager token -> do+ req <- applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""+ <$> parseRequest "https://api.nylas.com/account"+ resp <- httpLbs req manager+ let userResponse = responseBody resp++ -- FIXME: was this working? I'm 95% sure that the client will throw its+ -- own exception on unsuccessful status codes.+ unless (HT.statusIsSuccessful $ responseStatus resp)+ $ throwIO $ InvalidProfileResponse pluginName+ $ "Unsuccessful HTTP response: " <> userResponse+++ either+ (throwIO . InvalidProfileResponse pluginName . BL8.pack)+ (\(User userId) -> pure Creds+ { credsPlugin = pluginName+ , credsIdent = userId+ , credsExtra = setExtra token userResponse+ }+ )+ $ eitherDecode userResponse where oauth = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize" `withQuery` [ ("response_type", "code")- , ("scope", "email") , ("client_id", encodeUtf8 clientId)+ -- N.B. The scopes delimeter is unknown/untested. Verify that before+ -- extracting this to an argument and offering a Scoped function. In+ -- its current state, it doesn't matter because it's only one scope.+ , scopeParam "," defaultScopes ] , 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/Prelude.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+-- |+--+-- Modules and support functions required by most or all provider+-- implementations. May also be useful for writing local providers.+--+module Yesod.Auth.OAuth2.Prelude+ ( YesodOAuth2Exception(..)++ -- * Provider helpers+ , authGetProfile+ , scopeParam+ , setExtra++ -- * Text+ , Text+ , decodeUtf8+ , encodeUtf8++ -- * JSON+ , (.:)+ , (.:?)+ , (.=)+ , (<>)+ , FromJSON(..)+ , ToJSON(..)+ , eitherDecode+ , withObject++ -- * Exceptions+ , throwIO++ -- * OAuth2+ , OAuth2(..)+ , OAuth2Token(..)+ , AccessToken(..)+ , RefreshToken(..)++ -- * HTTP+ , Manager++ -- * Yesod+ , YesodAuth(..)+ , AuthPlugin(..)+ , Creds(..)++ -- * Bytestring URI types+ , URI+ , Host(..)++ -- * Bytestring URI extensions+ , module URI.ByteString.Extension++ -- * Temporary, until I finish re-structuring modules+ , authOAuth2+ , authOAuth2Widget+ ) where++import Control.Exception.Safe+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import Data.Semigroup ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import Network.HTTP.Conduit+import Network.OAuth.OAuth2+import URI.ByteString+import URI.ByteString.Extension+import Yesod.Auth+import Yesod.Auth.OAuth2++-- | Provider name and error+--+-- The error is a lazy bytestring because it's most often encoded JSON.+--+-- Deprecated. Eventually, we'll return @Either@s all the way up.+--+data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString+ deriving (Show, Typeable)+instance Exception YesodOAuth2Exception++-- | Retrieve a user's profile as JSON+--+-- The response should be parsed only far enough to read the required+-- @'credsIdent'@. Additional information should either be re-parsed by or+-- fetched via additional requests by consumers.+--+authGetProfile :: FromJSON a => Text -> Manager -> OAuth2Token -> URI -> IO (a, BL.ByteString)+authGetProfile name manager token url = do+ resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url+ decoded <- fromAuthJSON name resp+ pure (decoded, resp)++-- | Throws a @Left@ result as an @'InvalidProfileResponse'@+fromAuthGet :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString+fromAuthGet _ (Right bs) = pure bs -- nice+fromAuthGet name (Left err) = throwIO $ InvalidProfileResponse name $ encode err++-- | Throws a decoding error as an @'InvalidProfileResponse'@+fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a+fromAuthJSON name =+ -- FIXME: unique exception constructors+ either (throwIO . InvalidProfileResponse name . BL8.pack) pure . eitherDecode++-- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter+scopeParam :: Text -> [Text] -> (ByteString, ByteString)+scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d++-- | Construct part of @'credsExtra'@+--+-- Sets the following keys:+--+-- - @accessToken@: to support follow-up requests+-- - @userResponse@: to support getting additional information+--+setExtra :: OAuth2Token -> BL.ByteString -> [(Text, Text)]+setExtra token userResponse =+ [ ("accessToken", atoken $ accessToken token)+ , ("userResponse", decodeUtf8 $ BL.toStrict userResponse)+ ]
src/Yesod/Auth/OAuth2/Salesforce.hs view
@@ -1,154 +1,74 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} -- | -- -- OAuth2 plugin for http://login.salesforce.com ----- * Authenticates against Salesforce+-- * Authenticates against Salesforce (or sandbox) -- * 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 Yesod.Auth.OAuth2.Prelude -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+newtype User = User Text -import qualified Data.Text as T+instance FromJSON User where+ parseJSON = withObject "User" $ \o -> User+ <$> o .: "user_id" -oauth2Salesforce :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> AuthPlugin m-oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"]+pluginName :: Text+pluginName = "salesforce" -svcName :: Text-svcName = "salesforce"+defaultScopes :: [Text]+defaultScopes = ["openid", "email", "api"] -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- }+oauth2Salesforce :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Salesforce = oauth2SalesforceScoped defaultScopes -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+oauth2SalesforceScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m+oauth2SalesforceScoped = salesforceHelper pluginName+ "https://login.salesforce.com/services/oauth2/userinfo"+ "https://login.salesforce.com/services/oauth2/authorize"+ "https://login.salesforce.com/services/oauth2/token" -svcNameSb :: Text-svcNameSb = "salesforce-sandbox"+oauth2SalesforceSandbox :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped defaultScopes -oauth2SalesforceSandbox :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> AuthPlugin m-oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped ["openid", "email"]+oauth2SalesforceSandboxScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m+oauth2SalesforceSandboxScoped = salesforceHelper (pluginName <> "-sandbox")+ "https://test.salesforce.com/services/oauth2/userinfo"+ "https://test.salesforce.com/services/oauth2/authorize"+ "https://test.salesforce.com/services/oauth2/token" +salesforceHelper+ :: YesodAuth m+ => Text+ -> URI -- ^ User profile+ -> URI -- ^ Authorize+ -> URI -- ^ Token+ -> [Text]+ -> Text+ -> Text+ -> AuthPlugin m+salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSecret =+ authOAuth2 name oauth2 $ \manager token -> do+ (User userId, userResponse) <- authGetProfile name manager token profileUri -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+ pure Creds+ { credsPlugin = pluginName+ , credsIdent = userId+ , credsExtra = setExtra token userResponse+ } 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+ oauth2 = OAuth2+ { oauthClientId = clientId+ , oauthClientSecret = clientSecret+ , oauthOAuthorizeEndpoint = authorizeUri `withQuery` [scopeParam " " scopes]+ , oauthAccessTokenEndpoint = tokenUri+ , 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
@@ -4,7 +4,6 @@ -- -- * 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(..)@@ -12,112 +11,63 @@ , 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 Yesod.Auth.OAuth2.Prelude -import qualified Network.HTTP.Conduit as HTTP+import Network.HTTP.Client+ (httpLbs, parseUrlThrow, responseBody, setQueryString) data SlackScope- = SlackEmailScope+ = SlackBasicScope+ | SlackEmailScope | SlackTeamScope | SlackAvatarScope -data SlackUser = SlackUser- { slackUserId :: Text- , slackUserName :: Text- , slackUserEmail :: Maybe Text- , slackUserAvatarUrl :: Maybe Text- , slackUserTeam :: Maybe SlackTeam- }+scopeText :: SlackScope -> Text+scopeText SlackBasicScope = "identity.basic"+scopeText SlackEmailScope = "identity.email"+scopeText SlackTeamScope = "identity.team"+scopeText SlackAvatarScope = "identity.avatar" -data SlackTeam = SlackTeam- { slackTeamId :: Text- , slackTeamName :: Text- }+newtype User = User Text -instance FromJSON SlackUser where- parseJSON = withObject "root" $ \root -> do- user <- root .: "user"+instance FromJSON User where+ parseJSON = withObject "User" $ \root -> do+ o <- root .: "user"+ User <$> o .: "id" - SlackUser- <$> user .: "id"- <*> user .: "name"- <*> user .:? "email"- <*> user .:? "image_512"- <*> root .:? "team"+pluginName :: Text+pluginName = "slack" -instance FromJSON SlackTeam where- parseJSON = withObject "team" $ \team ->- SlackTeam- <$> team .: "id"- <*> team .: "name"+defaultScopes :: [SlackScope]+defaultScopes = [SlackBasicScope] --- | 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 []+oauth2Slack :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Slack = oauth2SlackScoped defaultScopes --- | 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+oauth2SlackScoped :: YesodAuth m => [SlackScope] -> Text -> Text -> AuthPlugin m+oauth2SlackScoped scopes clientId clientSecret =+ authOAuth2 pluginName oauth2 $ \manager token -> do+ let param = encodeUtf8 $ atoken $ accessToken token+ req <- setQueryString [("token", Just param)]+ <$> parseUrlThrow "https://slack.com/api/users.identity"+ userResponse <- responseBody <$> httpLbs req manager++ either+ (const $ throwIO $ InvalidProfileResponse pluginName userResponse)+ (\(User userId) -> pure Creds+ { credsPlugin = pluginName+ , credsIdent = userId+ , credsExtra = setExtra token userResponse+ }+ )+ $ eitherDecode userResponse where- oauth = OAuth2+ oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize" `withQuery`- [ scopeParam "," $ "identity.basic" : map scopeText scopes+ [ scopeParam "," $ 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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | --@@ -6,102 +5,37 @@ -- 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"+import Yesod.Auth.OAuth2.Prelude - parseJSON _ = mzero+newtype User = User Text -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 User where+ parseJSON = withObject "User" $ \o -> User+ <$> o .: "id" -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"+pluginName :: Text+pluginName = "spotify" - parseJSON _ = mzero+oauth2Spotify :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m+oauth2Spotify scopes clientId clientSecret =+ authOAuth2 pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token "https://api.spotify.com/v1/me" -oauth2Spotify :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> [Text] -- ^ Scopes- -> AuthPlugin m-oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify"- OAuth2+ pure Creds+ { credsPlugin = pluginName+ , credsIdent = userId+ , credsExtra = setExtra token userResponse+ }+ where+ oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://accounts.spotify.com/authorize" `withQuery`- [ ("scope", encodeUtf8 $ T.intercalate " " scope)+ [ scopeParam " " scopes ] , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token" , oauthCallback = Nothing }- $ fromProfileURL "spotify" "https://api.spotify.com/v1/me" toCreds--toCreds :: SpotifyUser -> Creds m-toCreds user = Creds- { credsPlugin = "spotify"- , credsIdent = spotifyUserId user- , credsExtra = mapMaybe getExtra extrasTemplate- }-- 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
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | --@@ -6,67 +5,41 @@ -- -- * Authenticates against upcase -- * Uses upcase user id as credentials identifier--- * Returns first_name, last_name, and email as extras -- module Yesod.Auth.OAuth2.Upcase ( oauth2Upcase- , module Yesod.Auth.OAuth2 ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), (<*>))-#endif+import Yesod.Auth.OAuth2.Prelude -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 User = User Int -newtype UpcaseResponse = UpcaseResponse UpcaseUser+instance FromJSON User where+ parseJSON = withObject "User" $ \root -> do+ o <- root .: "user"+ User <$> o .: "id" -instance FromJSON UpcaseResponse where- parseJSON (Object o) = UpcaseResponse- <$> o .: "user"+pluginName :: Text+pluginName = "upcase" - parseJSON _ = mzero+oauth2Upcase :: YesodAuth m => Text -> Text -> AuthPlugin m+oauth2Upcase clientId clientSecret =+ authOAuth2 pluginName oauth2 $ \manager token -> do+ (User userId, userResponse) <-+ authGetProfile pluginName manager token "http://upcase.com/api/v1/me.json" -oauth2Upcase :: YesodAuth m- => Text -- ^ Client ID- -> Text -- ^ Client Secret- -> AuthPlugin m-oauth2Upcase clientId clientSecret = authOAuth2 "upcase"- OAuth2+ pure Creds+ { credsPlugin = pluginName+ , credsIdent = T.pack $ show userId+ , credsExtra = setExtra token userResponse+ }+ where+ oauth2 = 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
@@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module URI.ByteString.ExtensionSpec- ( main- , spec+ ( spec ) where import Test.Hspec@@ -12,9 +11,6 @@ import URI.ByteString import URI.ByteString.Extension import URI.ByteString.QQ--main :: IO ()-main = hspec spec spec :: Spec spec = do
yesod-auth-oauth2.cabal view
@@ -2,18 +2,18 @@ -- -- see: https://github.com/sol/hpack ----- hash: 86087f5e361d8686832a02a805ac3132bb640ed555912b2f45d98e978edd6677+-- hash: adce3f04c3cdf1be9321b5402956fabab0b850d7b2033fbb2e9921b1d6756b3e name: yesod-auth-oauth2-version: 0.3.1+version: 0.4.0.0 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+maintainer: Pat Brisbin <pbrisbin@gmail.com>+license: MIT license-file: LICENSE build-type: Simple cabal-version: >= 1.10@@ -30,35 +30,35 @@ library hs-source-dirs: src+ ghc-options: -Wall build-depends:- aeson >=0.6 && <1.3- , authenticate >=1.3.2.7 && <1.4- , base >=4.5 && <5+ aeson >=0.6 && <1.4+ , base >=4.9.0.0 && <5 , bytestring >=0.9.1.4+ , errors , 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+ , safe-exceptions , 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.Dispatch Yesod.Auth.OAuth2.EveOnline Yesod.Auth.OAuth2.Github Yesod.Auth.OAuth2.Google Yesod.Auth.OAuth2.Nylas+ Yesod.Auth.OAuth2.Prelude Yesod.Auth.OAuth2.Salesforce Yesod.Auth.OAuth2.Slack Yesod.Auth.OAuth2.Spotify@@ -68,12 +68,15 @@ default-language: Haskell2010 executable yesod-auth-oauth2-example- main-is: main.hs+ main-is: Main.hs hs-source-dirs: example- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.5 && <5+ aeson+ , aeson-pretty+ , base >=4.9.0.0 && <5+ , bytestring , containers , http-conduit , load-env@@ -93,8 +96,9 @@ main-is: Spec.hs hs-source-dirs: test+ ghc-options: -Wall build-depends:- base >=4.5 && <5+ base >=4.9.0.0 && <5 , hspec , uri-bytestring , yesod-auth-oauth2