haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-01-11 19:58:28 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Update to LTS-9.5 and hoauth2 1.3.0

Browse Source 
The largest changes were around the hoauth2 interface:

The OAuth2 type replaced all of its ByteString fields with either Text
or URI. This is a huge improvement. The fields that are now Text are the
type we had them in anyway. The fields that are now URI are type safe
and easier to manipulate. For example, we were doing very unsafe query
string manipulations looking for raw ? or & values, but now we can work
with tuples in a well-typed property.

Additionally the AccessToken type was upgraded to OAuth2Token with an
accessToken field, and the simple Either ByteString a results were
replaced by a real OAuth2Error type. This required changes to our
InvalidProfileResponse mechanism to support.

To make working with uri-bytestring more convenient, an Extension
library was added with some useful instances and helper functions. This
library may be upstreamed at some point.
This commit is contained in:
patrick brisbin 2017-09-19 21:24:25 -04:00
parent aeeddcf1c2
commit 937ad572a3
15 changed files with 302 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
URI/ByteString/Extension.hs Normal file
View File

@ -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)

63
Yesod/Auth/OAuth2.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
-- |
--
-- Generic OAuth2 plugin for Yesod
@ -15,8 +16,12 @@ module Yesod.Auth.OAuth2
, oauth2Url
, fromProfileURL
, YesodOAuth2Exception(..)
, invalidProfileResponse
, scopeParam
, maybeExtra
, module Network.OAuth.OAuth2
, module URI.ByteString
, module URI.ByteString.Extension
) where
#if __GLASGOW_HASKELL__ < 710
@ -26,20 +31,22 @@ import Control.Applicative ((<$>))
import Control.Exception.Lifted
import Control.Monad.IO.Class
import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.Aeson (Value(..), encode)
import Data.Monoid ((<>))
import Data.ByteString (ByteString)
import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2
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
import qualified Data.ByteString.Char8 as C8
-- | Provider name and Aeson parse error
data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
@ -47,6 +54,14 @@ data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
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"]
@ -57,11 +72,11 @@ oauth2Url name = PluginR name ["forward"]
authOAuth2 :: YesodAuth m
=> Text -- ^ Service name
-> OAuth2 -- ^ Service details
-> (Manager -> AccessToken -> IO (Creds m))
-- ^ This function defines how to take an @'AccessToken'@ 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@.
-> (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
@ -76,7 +91,7 @@ authOAuth2Widget :: YesodAuth m
=> WidgetT m IO ()
-> Text
-> OAuth2
-> (Manager -> AccessToken -> IO (Creds m))
-> (Manager -> OAuth2Token -> IO (Creds m))
-> AuthPlugin m
authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
@ -87,15 +102,15 @@ authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
tm <- getRouteToParent
render <- lift getUrlRender
return oauth
{ oauthCallback = Just $ encodeUtf8 $ render $ tm url
{ oauthCallback = Just $ unsafeFromText $ render $ tm url
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
`appendQuery` "state=" <> encodeUtf8 csrfToken
`withQuery` [("state", encodeUtf8 csrfToken)]
}
dispatch "GET" ["forward"] = do
csrfToken <- liftIO generateToken
setSession tokenSessionKey csrfToken
authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken
authUrl <- toText . authorizationUrl <$> withCallback csrfToken
lift $ redirect authUrl
dispatch "GET" ["callback"] = do
@ -106,7 +121,7 @@ authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
code <- requireGetParam "code"
oauth' <- withCallback csrfToken
master <- lift getYesod
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code)
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (ExchangeToken code)
case result of
Left _ -> permissionDenied "Unable to retrieve OAuth2 token"
Right token -> do
@ -134,25 +149,19 @@ fromProfileURL :: FromJSON a
=> Text -- ^ Plugin name
-> URI -- ^ Profile URI
-> (a -> Creds m) -- ^ Conversion to Creds
-> Manager -> AccessToken -> IO (Creds m)
-> Manager -> OAuth2Token -> IO (Creds m)
fromProfileURL name url toCreds manager token = do
result <- authGetJSON manager token url
result <- authGetJSON manager (accessToken token) url
case result of
Right profile -> return $ toCreds profile
Left err -> throwIO $ InvalidProfileResponse name err
Left err -> throwIO $ invalidProfileResponse name err
bsToText :: ByteString -> Text
bsToText = decodeUtf8With lenientDecode
appendQuery :: ByteString -> ByteString -> ByteString
appendQuery url query =
if '?' `C8.elem` url
then url <> "&" <> query
else url <> "?" <> query
-- | 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 = []

37
Yesod/Auth/OAuth2/BattleNet.hs
View File

@ -51,30 +51,33 @@ oAuth2BattleNet :: YesodAuth m
-> 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 = E.encodeUtf8 clientId
, oauthClientSecret = E.encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = E.encodeUtf8 ("https://" <> host <> "/oauth/authorize")
, oauthAccessTokenEndpoint = E.encodeUtf8 ("https://" <> host <> "/oauth/token")
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 = let r = T.toLower region in
case r of
"cn" -> "www.battlenet.com.cn"
_ -> r <> ".battle.net"
makeCredentials :: Text -> Manager -> AccessToken -> IO (Creds m)
host = wwwHost $ T.toLower region
makeCredentials :: Text -> Manager -> OAuth2Token -> IO (Creds m)
makeCredentials region manager token = do
userResult <- authGetJSON manager token ("https://" <> host <> "/account/user") :: IO (OAuth2Result BattleNetUser)
userResult <- authGetJSON manager (accessToken token)
$ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
case userResult of
Left err -> throwIO $ InvalidProfileResponse "battle.net" err
Left err -> throwIO $ invalidProfileResponse "battle.net" err
Right user -> return Creds
{ credsPlugin = "battle.net"
, credsIdent = T.pack $ show $ userId user
, credsExtra = [("battletag", battleTag user)]
}
where host :: URI
host = let r = T.toLower region in
case r of
"cn" -> "api.battlenet.com.cn"
_ -> E.encodeUtf8 r <> ".api.battle.net"
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"

26
Yesod/Auth/OAuth2/Bitbucket.hs
View File

@ -23,12 +23,10 @@ import Control.Monad (mzero)
import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?))
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager)
import Yesod.Auth (YesodAuth, Creds(..), AuthPlugin)
import Yesod.Auth.OAuth2 (AccessToken, YesodOAuth2Exception(InvalidProfileResponse), OAuth2(..), authOAuth2, maybeExtra, accessToken, authGetJSON)
import Yesod.Auth.OAuth2
import qualified Data.Text as T
@ -106,24 +104,26 @@ oauth2BitbucketScoped :: YesodAuth m
oauth2BitbucketScoped clientId clientSecret scopes = authOAuth2 "bitbucket" oauth fetchBitbucketProfile
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://bitbucket.com/site/oauth2/authorize?scope=" <> T.intercalate "," scopes
{ 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 -> AccessToken -> IO (Creds m)
fetchBitbucketProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchBitbucketProfile manager token = do
userResult <- authGetJSON manager token "https://api.bitbucket.com/2.0/user"
mailResult <- authGetJSON manager token "https://api.bitbucket.com/2.0/user/emails"
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
(Left err, _) -> throwIO $ invalidProfileResponse "bitbucket" err
(_, Left err) -> throwIO $ invalidProfileResponse "bitbucket" err
toCreds :: BitbucketUser -> [BitbucketUserEmail] -> AccessToken -> Creds m
toCreds :: BitbucketUser -> [BitbucketUserEmail] -> OAuth2Token -> Creds m
toCreds user userMails token = Creds
{ credsPlugin = "bitbucket"
, credsIdent = T.pack $ show $ bitbucketUserId user
@ -131,7 +131,7 @@ toCreds user userMails token = Creds
[ ("email", bitbucketUserEmailAddress email)
, ("login", bitbucketUserLogin user)
, ("avatar_url", bitbucketLinkHref (bitbucketAvatarLink (bitbucketUserLinks user)))
, ("access_token", decodeUtf8 $ accessToken token)
, ("access_token", atoken $ accessToken token)
]
++ maybeExtra "name" (bitbucketUserName user)
++ maybeExtra "location" (bitbucketUserLocation user)

21
Yesod/Auth/OAuth2/EveOnline.hs
View File

@ -23,9 +23,7 @@ import Control.Applicative ((<$>), (<*>))
import Control.Exception.Lifted
import Control.Monad (mzero)
import Data.Aeson
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager)
import Yesod.Auth
import Yesod.Auth.OAuth2
@ -86,22 +84,25 @@ oauth2EveScoped clientId clientSecret scopes widget =
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://login.eveonline.com/oauth/authorize?response_type=code&scope=" <> T.intercalate " " scopes
{ 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 -> AccessToken -> IO (Creds m)
fetchEveProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchEveProfile manager token = do
userResult <- authGetJSON manager token "https://login.eveonline.com/oauth/verify"
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
Left err-> throwIO $ invalidProfileResponse "eveonline" err
toCreds :: EveUser -> AccessToken -> Creds m
toCreds :: EveUser -> OAuth2Token -> Creds m
toCreds user token = Creds
{ credsPlugin = "eveonline"
, credsIdent = T.pack $ show $ eveCharOwnerHash user
@ -110,6 +111,6 @@ toCreds user token = Creds
, ("charId", T.pack . show . eveCharId $ user)
, ("tokenType", eveTokenType user)
, ("expires", eveUserExpire user)
, ("accessToken", decodeUtf8 . accessToken $ token)
, ("accessToken", atoken $ accessToken token)
]
}

24
Yesod/Auth/OAuth2/Github.hs
View File

@ -23,9 +23,7 @@ import Control.Monad (mzero)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager)
import Yesod.Auth
import Yesod.Auth.OAuth2
@ -78,25 +76,27 @@ oauth2GithubScoped :: YesodAuth m
oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes
{ 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 -> AccessToken -> IO (Creds m)
fetchGithubProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchGithubProfile manager token = do
userResult <- authGetJSON manager token "https://api.github.com/user"
mailResult <- authGetJSON manager token "https://api.github.com/user/emails"
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
(Left err, _) -> throwIO $ invalidProfileResponse "github" err
(_, Left err) -> throwIO $ invalidProfileResponse "github" err
toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
toCreds :: GithubUser -> [GithubUserEmail] -> OAuth2Token -> Creds m
toCreds user userMails token = Creds
{ credsPlugin = "github"
, credsIdent = T.pack $ show $ githubUserId user
@ -104,7 +104,7 @@ toCreds user userMails token = Creds
[ ("email", githubUserEmailAddress email)
, ("login", githubUserLogin user)
, ("avatar_url", githubUserAvatarUrl user)
, ("access_token", decodeUtf8 $ accessToken token)
, ("access_token", atoken $ accessToken token)
]
++ maybeExtra "name" (githubUserName user)
++ maybeExtra "public_email" (githubUserPublicEmail user)

28
Yesod/Auth/OAuth2/Google.hs
View File

@ -30,13 +30,10 @@ import Control.Monad (mzero)
import Data.Aeson
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager)
import Yesod.Auth
import Yesod.Auth.OAuth2
import qualified Data.Text as T
-- | Auth with Google
--
-- Requests @openid@ and @email@ scopes and uses email as the @'Creds'@
@ -67,7 +64,7 @@ oauth2GoogleScoped = oauth2GoogleScopedWithCustomId emailUid
-- See @'emailUid'@ and @'googleUid'@.
--
oauth2GoogleScopedWithCustomId :: YesodAuth m
=> (GoogleUser -> AccessToken -> Creds m)
=> (GoogleUser -> OAuth2Token -> Creds m)
-- ^ A function to generate the credentials
-> [Text] -- ^ List of scopes to request
-> Text -- ^ Client ID
@ -78,20 +75,21 @@ oauth2GoogleScopedWithCustomId toCreds scopes clientId clientSecret =
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8
$ "https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes
{ 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 -> AccessToken -> Creds m) -> Manager -> AccessToken -> IO (Creds m)
fetchGoogleProfile :: (GoogleUser -> OAuth2Token -> Creds m) -> Manager -> OAuth2Token -> IO (Creds m)
fetchGoogleProfile toCreds manager token = do
userInfo <- authGetJSON manager token "https://www.googleapis.com/oauth2/v3/userinfo"
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
Left err -> throwIO $ invalidProfileResponse "google" err
data GoogleUser = GoogleUser
{ googleUserId :: Text
@ -116,14 +114,14 @@ instance FromJSON GoogleUser where
parseJSON _ = mzero
-- | Build a @'Creds'@ using the user's google-uid as the identifier
googleUid :: GoogleUser -> AccessToken -> Creds m
googleUid :: GoogleUser -> OAuth2Token -> Creds m
googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId
-- | Build a @'Creds'@ using the user's email as the identifier
emailUid :: GoogleUser -> AccessToken -> Creds m
emailUid :: GoogleUser -> OAuth2Token -> Creds m
emailUid = uidBuilder googleUserEmail
uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> AccessToken -> Creds m
uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> OAuth2Token -> Creds m
uidBuilder f user token = Creds
{ credsPlugin = "google"
, credsIdent = f user
@ -133,7 +131,7 @@ uidBuilder f user token = Creds
, ("given_name", googleUserGivenName user)
, ("family_name", googleUserFamilyName user)
, ("avatar_url", googleUserPicture user)
, ("access_token", decodeUtf8 $ accessToken token)
, ("access_token", atoken $ accessToken token)
]
++ maybeExtra "hosted_domain" (googleUserHostedDomain user)
}

29
Yesod/Auth/OAuth2/Nylas.hs
View File

@ -13,16 +13,14 @@ import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Control.Exception.Lifted (throwIO)
import Data.Aeson (FromJSON, Value(..), parseJSON, decode, (.:))
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
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 (OAuth2(..), AccessToken(..),
YesodOAuth2Exception(InvalidProfileResponse),
authOAuth2)
import Yesod.Auth.OAuth2
import qualified Network.HTTP.Types as HT
data NylasAccount = NylasAccount
@ -48,18 +46,19 @@ oauth2Nylas :: YesodAuth m
-> AuthPlugin m
oauth2Nylas clientId clientSecret = authOAuth2 "nylas" oauth fetchCreds
where
authorizeUrl = encodeUtf8 $ "https://api.nylas.com/oauth/authorize" <>
"?response_type=code&scope=email&client_id=" <> clientId
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = authorizeUrl
{ 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 -> AccessToken -> IO (Creds a)
fetchCreds :: Manager -> OAuth2Token -> IO (Creds a)
fetchCreds manager token = do
req <- authorize <$> parseRequest "https://api.nylas.com/account"
resp <- httpLbs req manager
@ -69,11 +68,11 @@ fetchCreds manager token = do
Nothing -> throwIO parseFailure
else throwIO requestFailure
where
authorize = applyBasicAuth (accessToken token) ""
authorize = applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
parseFailure = InvalidProfileResponse "nylas" "failed to parse account"
requestFailure = InvalidProfileResponse "nylas" "failed to get account"
toCreds :: NylasAccount -> AccessToken -> Creds a
toCreds :: NylasAccount -> OAuth2Token -> Creds a
toCreds ns token = Creds
{ credsPlugin = "nylas"
, credsIdent = nylasAccountId ns
@ -82,6 +81,6 @@ toCreds ns token = Creds
, ("name", nylasAccountName ns)
, ("provider", nylasAccountProvider ns)
, ("organization_unit", nylasAccountOrganizationUnit ns)
, ("access_token", decodeUtf8 $ accessToken token)
, ("access_token", atoken $ accessToken token)
]
}

36
Yesod/Auth/OAuth2/Salesforce.hs
View File

@ -24,9 +24,7 @@ import Control.Applicative ((<$>), (<*>))
import Control.Exception.Lifted
import Control.Monad (mzero)
import Data.Aeson
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager)
import Yesod.Auth
import Yesod.Auth.OAuth2
@ -51,19 +49,21 @@ oauth2SalesforceScoped scopes clientId clientSecret =
authOAuth2 svcName oauth fetchSalesforceUser
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://login.salesforce.com/services/oauth2/authorize?scope=" <> T.intercalate " " scopes
{ 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 -> AccessToken -> IO (Creds m)
fetchSalesforceUser :: Manager -> OAuth2Token -> IO (Creds m)
fetchSalesforceUser manager token = do
result <- authGetJSON manager token "https://login.salesforce.com/services/oauth2/userinfo"
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
Left err -> throwIO $ invalidProfileResponse svcName err
svcNameSb :: Text
svcNameSb = "salesforce-sandbox"
@ -84,19 +84,21 @@ oauth2SalesforceSandboxScoped scopes clientId clientSecret =
authOAuth2 svcNameSb oauth fetchSalesforceSandboxUser
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://test.salesforce.com/services/oauth2/authorize?scope=" <> T.intercalate " " scopes
{ 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 -> AccessToken -> IO (Creds m)
fetchSalesforceSandboxUser :: Manager -> OAuth2Token -> IO (Creds m)
fetchSalesforceSandboxUser manager token = do
result <- authGetJSON manager token "https://test.salesforce.com/services/oauth2/userinfo"
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
Left err -> throwIO $ invalidProfileResponse svcNameSb err
data User = User
{ userId :: Text
@ -130,7 +132,7 @@ instance FromJSON User where
parseJSON _ = mzero
toCreds :: Text -> User -> AccessToken -> Creds m
toCreds :: Text -> User -> OAuth2Token -> Creds m
toCreds name user token = Creds
{ credsPlugin = name
, credsIdent = userId user
@ -144,9 +146,9 @@ toCreds name user token = Creds
, ("time_zone", userTimeZone user)
, ("avatar_url", userPicture user)
, ("rest_url", userRestUrl user)
, ("access_token", decodeUtf8 $ accessToken token)
, ("access_token", atoken $ accessToken token)
]
++ maybeExtra "refresh_token" (decodeUtf8 <$> refreshToken token)
++ maybeExtra "refresh_token" (rtoken <$> refreshToken token)
++ maybeExtra "expires_in" ((T.pack . show) <$> expiresIn token)
++ maybeExtra "phone_number" (userPhone user)
}

26
Yesod/Auth/OAuth2/Slack.hs
View File

@ -18,12 +18,10 @@ import Yesod.Auth.OAuth2
import Control.Exception.Lifted (throwIO)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (Manager)
import qualified Data.Text as Text
import qualified Network.HTTP.Conduit as HTTP
data SlackScope
@ -86,39 +84,37 @@ oauth2SlackScoped clientId clientSecret scopes =
authOAuth2 "slack" oauth fetchSlackProfile
where
oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint =
encodeUtf8
$ "https://slack.com/oauth/authorize?scope="
<> Text.intercalate "," scopeTexts
{ 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
}
scopeTexts = "identity.basic":map scopeText scopes
scopeText :: SlackScope -> Text
scopeText SlackEmailScope = "identity.email"
scopeText SlackTeamScope = "identity.team"
scopeText SlackAvatarScope = "identity.avatar"
fetchSlackProfile :: Manager -> AccessToken -> IO (Creds m)
fetchSlackProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchSlackProfile manager token = do
request
<- HTTP.setQueryString [("token", Just $ accessToken token)]
<$> HTTP.parseUrl "https://slack.com/api/users.identity"
<- 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 -> AccessToken -> Creds m
toCreds :: SlackUser -> OAuth2Token -> Creds m
toCreds user token = Creds
{ credsPlugin = "slack"
, credsIdent = slackUserId user
, credsExtra = catMaybes
[ Just ("name", slackUserName user)
, Just ("access_token", decodeUtf8 $ accessToken token)
, Just ("access_token", atoken $ accessToken token)
, (,) <$> pure "email" <*> slackUserEmail user
, (,) <$> pure "avatar" <*> slackUserAvatarUrl user
, (,) <$> pure "team_name" <*> (slackTeamName <$> slackUserTeam user)

12
Yesod/Auth/OAuth2/Spotify.hs
View File

@ -15,14 +15,12 @@ import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (mzero)
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Yesod.Auth
import Yesod.Auth.OAuth2
import qualified Data.ByteString as B
import qualified Data.Text as T
data SpotifyUserImage = SpotifyUserImage
@ -66,13 +64,15 @@ instance FromJSON SpotifyUser where
oauth2Spotify :: YesodAuth m
=> Text -- ^ Client ID
-> Text -- ^ Client Secret
-> [ByteString] -- ^ Scopes
-> [Text] -- ^ Scopes
-> AuthPlugin m
oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify"
OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope)
{ 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
}

5
Yesod/Auth/OAuth2/Upcase.hs
View File

@ -20,7 +20,6 @@ import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Data.Aeson
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Yesod.Auth
import Yesod.Auth.OAuth2
import qualified Data.Text as T
@ -55,8 +54,8 @@ oauth2Upcase :: YesodAuth m
-> AuthPlugin m
oauth2Upcase clientId clientSecret = authOAuth2 "upcase"
OAuth2
{ oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret
{ oauthClientId = clientId
, oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize"
, oauthAccessTokenEndpoint = "http://upcase.com/oauth/token"
, oauthCallback = Nothing

4
stack.yaml
View File

@ -1,8 +1,8 @@
resolver: lts-9.5
flags:
yesod-auth-oauth2:
network-uri: true
packages:
- '.'
resolver: lts-8.23
- .
extra-deps:
- load-env-0.1.1

82
test/URI/ByteString/ExtensionSpec.hs Normal file
View File

@ -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

11
yesod-auth-oauth2.cabal
View File

@ -31,7 +31,7 @@ library
, http-client >= 0.4.0 && < 0.6
, http-conduit >= 2.0 && < 3.0
, http-types >= 0.8 && < 0.10
, aeson >= 0.6 && < 1.1
, aeson >= 0.6 && < 1.2
, yesod-core >= 1.2 && < 1.5
, authenticate >= 1.3.2.7 && < 1.4
, random
@ -39,9 +39,11 @@ library
, text >= 0.7 && < 2.0
, yesod-form >= 1.3 && < 1.5
, transformers >= 0.2.2 && < 0.6
, hoauth2 >= 0.4.7 && < 0.6
, hoauth2 >= 1.3.0 && < 1.4
, lifted-base >= 0.2 && < 0.4
, vector >= 0.10 && < 0.12
, vector >= 0.10 && < 0.13
, uri-bytestring
, microlens
exposed-modules: Yesod.Auth.OAuth2
Yesod.Auth.OAuth2.Github
@ -54,6 +56,8 @@ library
Yesod.Auth.OAuth2.Salesforce
Yesod.Auth.OAuth2.Bitbucket
Yesod.Auth.OAuth2.BattleNet
URI.ByteString.Extension
-- ^ exposed for testing
ghc-options: -Wall
@ -84,6 +88,7 @@ test-suite test
build-depends: base
, yesod-auth-oauth2
, hspec
, uri-bytestring
source-repository head
type: git