diff --git a/URI/ByteString/Extension.hs b/URI/ByteString/Extension.hs deleted file mode 100644 --- a/URI/ByteString/Extension.hs +++ /dev/null @@ -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) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2.hs +++ /dev/null @@ -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|^{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 = [] diff --git a/Yesod/Auth/OAuth2/BattleNet.hs b/Yesod/Auth/OAuth2/BattleNet.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/BattleNet.hs +++ /dev/null @@ -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" diff --git a/Yesod/Auth/OAuth2/Bitbucket.hs b/Yesod/Auth/OAuth2/Bitbucket.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Bitbucket.hs +++ /dev/null @@ -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 diff --git a/Yesod/Auth/OAuth2/EveOnline.hs b/Yesod/Auth/OAuth2/EveOnline.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/EveOnline.hs +++ /dev/null @@ -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||] - asWidget BigBlack = [whamlet||] - asWidget SmallWhite = [whamlet||] - asWidget SmallBlack = [whamlet||] - 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) - ] - } diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ /dev/null @@ -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 diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Google.hs +++ /dev/null @@ -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) - } diff --git a/Yesod/Auth/OAuth2/Nylas.hs b/Yesod/Auth/OAuth2/Nylas.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Nylas.hs +++ /dev/null @@ -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) - ] - } diff --git a/Yesod/Auth/OAuth2/Salesforce.hs b/Yesod/Auth/OAuth2/Salesforce.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Salesforce.hs +++ /dev/null @@ -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) - } diff --git a/Yesod/Auth/OAuth2/Slack.hs b/Yesod/Auth/OAuth2/Slack.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Slack.hs +++ /dev/null @@ -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) - ] - } diff --git a/Yesod/Auth/OAuth2/Spotify.hs b/Yesod/Auth/OAuth2/Spotify.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Spotify.hs +++ /dev/null @@ -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 diff --git a/Yesod/Auth/OAuth2/Upcase.hs b/Yesod/Auth/OAuth2/Upcase.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Upcase.hs +++ /dev/null @@ -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) - ] - } diff --git a/src/URI/ByteString/Extension.hs b/src/URI/ByteString/Extension.hs new file mode 100644 --- /dev/null +++ b/src/URI/ByteString/Extension.hs @@ -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) diff --git a/src/Yesod/Auth/OAuth2.hs b/src/Yesod/Auth/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2.hs @@ -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|^{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 = [] diff --git a/src/Yesod/Auth/OAuth2/BattleNet.hs b/src/Yesod/Auth/OAuth2/BattleNet.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/BattleNet.hs @@ -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" diff --git a/src/Yesod/Auth/OAuth2/Bitbucket.hs b/src/Yesod/Auth/OAuth2/Bitbucket.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Bitbucket.hs @@ -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 diff --git a/src/Yesod/Auth/OAuth2/EveOnline.hs b/src/Yesod/Auth/OAuth2/EveOnline.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/EveOnline.hs @@ -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||] + asWidget BigBlack = [whamlet||] + asWidget SmallWhite = [whamlet||] + asWidget SmallBlack = [whamlet||] + 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) + ] + } diff --git a/src/Yesod/Auth/OAuth2/Github.hs b/src/Yesod/Auth/OAuth2/Github.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Github.hs @@ -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 diff --git a/src/Yesod/Auth/OAuth2/Google.hs b/src/Yesod/Auth/OAuth2/Google.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Google.hs @@ -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) + } diff --git a/src/Yesod/Auth/OAuth2/Nylas.hs b/src/Yesod/Auth/OAuth2/Nylas.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Nylas.hs @@ -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) + ] + } diff --git a/src/Yesod/Auth/OAuth2/Salesforce.hs b/src/Yesod/Auth/OAuth2/Salesforce.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Salesforce.hs @@ -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) + } diff --git a/src/Yesod/Auth/OAuth2/Slack.hs b/src/Yesod/Auth/OAuth2/Slack.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Slack.hs @@ -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) + ] + } diff --git a/src/Yesod/Auth/OAuth2/Spotify.hs b/src/Yesod/Auth/OAuth2/Spotify.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Spotify.hs @@ -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 diff --git a/src/Yesod/Auth/OAuth2/Upcase.hs b/src/Yesod/Auth/OAuth2/Upcase.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/OAuth2/Upcase.hs @@ -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) + ] + } diff --git a/test/URI/ByteString/ExtensionSpec.hs b/test/URI/ByteString/ExtensionSpec.hs new file mode 100644 --- /dev/null +++ b/test/URI/ByteString/ExtensionSpec.hs @@ -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 diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -1,95 +1,104 @@ -name: yesod-auth-oauth2 -version: 0.3.0 -license: BSD3 -license-file: LICENSE -author: Tom Streller -maintainer: Pat Brisbin -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 +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