haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-03-25 13:27:03 +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 FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
-- | -- |
-- --
-- Generic OAuth2 plugin for Yesod -- Generic OAuth2 plugin for Yesod
@ -15,8 +16,12 @@ module Yesod.Auth.OAuth2
, oauth2Url , oauth2Url
, fromProfileURL , fromProfileURL
, YesodOAuth2Exception(..) , YesodOAuth2Exception(..)
, invalidProfileResponse
, scopeParam
, maybeExtra , maybeExtra
, module Network.OAuth.OAuth2 , module Network.OAuth.OAuth2
, module URI.ByteString
, module URI.ByteString.Extension
) where ) where
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
@ -26,20 +31,22 @@ import Control.Applicative ((<$>))
import Control.Exception.Lifted import Control.Exception.Lifted
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad (unless) import Control.Monad (unless)
import Data.ByteString (ByteString) import Data.Aeson (Value(..), encode)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.ByteString (ByteString)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable import Data.Typeable
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2 import Network.OAuth.OAuth2 hiding (error)
import System.Random import System.Random
import URI.ByteString
import URI.ByteString.Extension
import Yesod.Auth import Yesod.Auth
import Yesod.Core import Yesod.Core
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as C8
-- | Provider name and Aeson parse error -- | Provider name and Aeson parse error
data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
@ -47,6 +54,14 @@ data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
instance Exception YesodOAuth2Exception 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 :: Text -> AuthRoute
oauth2Url name = PluginR name ["forward"] oauth2Url name = PluginR name ["forward"]
@ -57,11 +72,11 @@ oauth2Url name = PluginR name ["forward"]
authOAuth2 :: YesodAuth m authOAuth2 :: YesodAuth m
=> Text -- ^ Service name => Text -- ^ Service name
-> OAuth2 -- ^ Service details -> OAuth2 -- ^ Service details
-> (Manager -> AccessToken -> IO (Creds m)) -> (Manager -> OAuth2Token -> IO (Creds m))
-- ^ This function defines how to take an @'AccessToken'@ and -- ^ This function defines how to take an @'OAuth2Token'@ and
-- retrieve additional information about the user, to be -- retrieve additional information about the user, to be set in the
-- set in the session as @'Creds'@. Usually this means a -- session as @'Creds'@. Usually this means a second authorized
-- second authorized request to @api/me.json@. -- request to @api/me.json@.
-- --
-- See @'fromProfileURL'@ for an example. -- See @'fromProfileURL'@ for an example.
-> AuthPlugin m -> AuthPlugin m
@ -76,7 +91,7 @@ authOAuth2Widget :: YesodAuth m
=> WidgetT m IO () => WidgetT m IO ()
-> Text -> Text
-> OAuth2 -> OAuth2
-> (Manager -> AccessToken -> IO (Creds m)) -> (Manager -> OAuth2Token -> IO (Creds m))
-> AuthPlugin m -> AuthPlugin m
authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
@ -87,15 +102,15 @@ authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
tm <- getRouteToParent tm <- getRouteToParent
render <- lift getUrlRender render <- lift getUrlRender
return oauth return oauth
{ oauthCallback = Just $ encodeUtf8 $ render $ tm url { oauthCallback = Just $ unsafeFromText $ render $ tm url
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
`appendQuery` "state=" <> encodeUtf8 csrfToken `withQuery` [("state", encodeUtf8 csrfToken)]
} }
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
csrfToken <- liftIO generateToken csrfToken <- liftIO generateToken
setSession tokenSessionKey csrfToken setSession tokenSessionKey csrfToken
authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken authUrl <- toText . authorizationUrl <$> withCallback csrfToken
lift $ redirect authUrl lift $ redirect authUrl
dispatch "GET" ["callback"] = do dispatch "GET" ["callback"] = do
@ -106,7 +121,7 @@ authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
code <- requireGetParam "code" code <- requireGetParam "code"
oauth' <- withCallback csrfToken oauth' <- withCallback csrfToken
master <- lift getYesod master <- lift getYesod
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code) result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (ExchangeToken code)
case result of case result of
Left _ -> permissionDenied "Unable to retrieve OAuth2 token" Left _ -> permissionDenied "Unable to retrieve OAuth2 token"
Right token -> do Right token -> do
@ -134,25 +149,19 @@ fromProfileURL :: FromJSON a
=> Text -- ^ Plugin name => Text -- ^ Plugin name
-> URI -- ^ Profile URI -> URI -- ^ Profile URI
-> (a -> Creds m) -- ^ Conversion to Creds -> (a -> Creds m) -- ^ Conversion to Creds
-> Manager -> AccessToken -> IO (Creds m) -> Manager -> OAuth2Token -> IO (Creds m)
fromProfileURL name url toCreds manager token = do fromProfileURL name url toCreds manager token = do
result <- authGetJSON manager token url result <- authGetJSON manager (accessToken token) url
case result of case result of
Right profile -> return $ toCreds profile Right profile -> return $ toCreds profile
Left err -> throwIO $ InvalidProfileResponse name err Left err -> throwIO $ invalidProfileResponse name err
bsToText :: ByteString -> Text -- | A tuple of @scope@ and the given scopes separated by a delimiter
bsToText = decodeUtf8With lenientDecode scopeParam :: Text -> [Text] -> (ByteString, ByteString)
scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
appendQuery :: ByteString -> ByteString -> ByteString
appendQuery url query =
if '?' `C8.elem` url
then url <> "&" <> query
else url <> "?" <> query
-- | A helper for providing an optional value to credsExtra -- | A helper for providing an optional value to credsExtra
--
maybeExtra :: Text -> Maybe Text -> [(Text, Text)] maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
maybeExtra k (Just v) = [(k, v)] maybeExtra k (Just v) = [(k, v)]
maybeExtra _ Nothing = [] 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") -> Text -- ^ User region (e.g. "eu", "cn", "us")
-> WidgetT m IO () -- ^ Login widget -> WidgetT m IO () -- ^ Login widget
-> AuthPlugin m -> AuthPlugin m
oAuth2BattleNet clientId clientSecret region widget = authOAuth2Widget widget "battle.net" oAuthData (makeCredentials region) oAuth2BattleNet clientId clientSecret region widget = authOAuth2Widget widget "battle.net" oAuthData $ makeCredentials region
where oAuthData = OAuth2 { oauthClientId = E.encodeUtf8 clientId where oAuthData = OAuth2 { oauthClientId = clientId
, oauthClientSecret = E.encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = E.encodeUtf8 ("https://" <> host <> "/oauth/authorize") , oauthOAuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
, oauthAccessTokenEndpoint = E.encodeUtf8 ("https://" <> host <> "/oauth/token") , oauthAccessTokenEndpoint = fromRelative "https" host "/oauth/token"
, oauthCallback = Nothing , 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 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 case userResult of
Left err -> throwIO $ InvalidProfileResponse "battle.net" err Left err -> throwIO $ invalidProfileResponse "battle.net" err
Right user -> return Creds Right user -> return Creds
{ credsPlugin = "battle.net" { credsPlugin = "battle.net"
, credsIdent = T.pack $ show $ userId user , credsIdent = T.pack $ show $ userId user
, credsExtra = [("battletag", battleTag user)] , credsExtra = [("battletag", battleTag user)]
} }
where host :: URI
host = let r = T.toLower region in apiHost :: Text -> Host
case r of apiHost "cn" = "api.battlenet.com.cn"
"cn" -> "api.battlenet.com.cn" apiHost region = Host $ E.encodeUtf8 $ region <> ".api.battle.net"
_ -> E.encodeUtf8 r <> ".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.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?))
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List (find) import Data.List (find)
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Yesod.Auth (YesodAuth, Creds(..), AuthPlugin) 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 import qualified Data.Text as T
@ -106,24 +104,26 @@ oauth2BitbucketScoped :: YesodAuth m
oauth2BitbucketScoped clientId clientSecret scopes = authOAuth2 "bitbucket" oauth fetchBitbucketProfile oauth2BitbucketScoped clientId clientSecret scopes = authOAuth2 "bitbucket" oauth fetchBitbucketProfile
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://bitbucket.com/site/oauth2/authorize?scope=" <> T.intercalate "," scopes , oauthOAuthorizeEndpoint = "https://bitbucket.com/site/oauth2/authorize" `withQuery`
[ scopeParam "," scopes
]
, oauthAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token" , oauthAccessTokenEndpoint = "https://bitbucket.com/site/oauth2/access_token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchBitbucketProfile :: Manager -> AccessToken -> IO (Creds m) fetchBitbucketProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchBitbucketProfile manager token = do fetchBitbucketProfile manager token = do
userResult <- authGetJSON manager token "https://api.bitbucket.com/2.0/user" userResult <- authGetJSON manager (accessToken token) "https://api.bitbucket.com/2.0/user"
mailResult <- authGetJSON manager token "https://api.bitbucket.com/2.0/user/emails" mailResult <- authGetJSON manager (accessToken token) "https://api.bitbucket.com/2.0/user/emails"
case (userResult, mailResult) of case (userResult, mailResult) of
(Right user, Right mails) -> return $ toCreds user (bitbucketEmails mails) token (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 toCreds user userMails token = Creds
{ credsPlugin = "bitbucket" { credsPlugin = "bitbucket"
, credsIdent = T.pack $ show $ bitbucketUserId user , credsIdent = T.pack $ show $ bitbucketUserId user
@ -131,7 +131,7 @@ toCreds user userMails token = Creds
[ ("email", bitbucketUserEmailAddress email) [ ("email", bitbucketUserEmailAddress email)
, ("login", bitbucketUserLogin user) , ("login", bitbucketUserLogin user)
, ("avatar_url", bitbucketLinkHref (bitbucketAvatarLink (bitbucketUserLinks user))) , ("avatar_url", bitbucketLinkHref (bitbucketAvatarLink (bitbucketUserLinks user)))
, ("access_token", decodeUtf8 $ accessToken token) , ("access_token", atoken $ accessToken token)
] ]
++ maybeExtra "name" (bitbucketUserName user) ++ maybeExtra "name" (bitbucketUserName user)
++ maybeExtra "location" (bitbucketUserLocation 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.Exception.Lifted
import Control.Monad (mzero) import Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
@ -86,22 +84,25 @@ oauth2EveScoped clientId clientSecret scopes widget =
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://login.eveonline.com/oauth/authorize?response_type=code&scope=" <> T.intercalate " " scopes , oauthOAuthorizeEndpoint = "https://login.eveonline.com/oauth/authorize" `withQuery`
[ ("response_type", "code")
, scopeParam " " scopes
]
, oauthAccessTokenEndpoint = "https://login.eveonline.com/oauth/token" , oauthAccessTokenEndpoint = "https://login.eveonline.com/oauth/token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchEveProfile :: Manager -> AccessToken -> IO (Creds m) fetchEveProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchEveProfile manager token = do 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 case userResult of
Right user -> return $ toCreds user token 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 toCreds user token = Creds
{ credsPlugin = "eveonline" { credsPlugin = "eveonline"
, credsIdent = T.pack $ show $ eveCharOwnerHash user , credsIdent = T.pack $ show $ eveCharOwnerHash user
@ -110,6 +111,6 @@ toCreds user token = Creds
, ("charId", T.pack . show . eveCharId $ user) , ("charId", T.pack . show . eveCharId $ user)
, ("tokenType", eveTokenType user) , ("tokenType", eveTokenType user)
, ("expires", eveUserExpire 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.Aeson
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List (find) import Data.List (find)
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
@ -78,25 +76,27 @@ oauth2GithubScoped :: YesodAuth m
oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize" `withQuery`
[ scopeParam "," scopes
]
, oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) fetchGithubProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchGithubProfile manager token = do fetchGithubProfile manager token = do
userResult <- authGetJSON manager token "https://api.github.com/user" userResult <- authGetJSON manager (accessToken token) "https://api.github.com/user"
mailResult <- authGetJSON manager token "https://api.github.com/user/emails" mailResult <- authGetJSON manager (accessToken token) "https://api.github.com/user/emails"
case (userResult, mailResult) of case (userResult, mailResult) of
(Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user" (Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
(Right user, Right mails) -> return $ toCreds user mails token (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 toCreds user userMails token = Creds
{ credsPlugin = "github" { credsPlugin = "github"
, credsIdent = T.pack $ show $ githubUserId user , credsIdent = T.pack $ show $ githubUserId user
@ -104,7 +104,7 @@ toCreds user userMails token = Creds
[ ("email", githubUserEmailAddress email) [ ("email", githubUserEmailAddress email)
, ("login", githubUserLogin user) , ("login", githubUserLogin user)
, ("avatar_url", githubUserAvatarUrl user) , ("avatar_url", githubUserAvatarUrl user)
, ("access_token", decodeUtf8 $ accessToken token) , ("access_token", atoken $ accessToken token)
] ]
++ maybeExtra "name" (githubUserName user) ++ maybeExtra "name" (githubUserName user)
++ maybeExtra "public_email" (githubUserPublicEmail 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.Aeson
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
import qualified Data.Text as T
-- | Auth with Google -- | Auth with Google
-- --
-- Requests @openid@ and @email@ scopes and uses email as the @'Creds'@ -- Requests @openid@ and @email@ scopes and uses email as the @'Creds'@
@ -67,7 +64,7 @@ oauth2GoogleScoped = oauth2GoogleScopedWithCustomId emailUid
-- See @'emailUid'@ and @'googleUid'@. -- See @'emailUid'@ and @'googleUid'@.
-- --
oauth2GoogleScopedWithCustomId :: YesodAuth m oauth2GoogleScopedWithCustomId :: YesodAuth m
=> (GoogleUser -> AccessToken -> Creds m) => (GoogleUser -> OAuth2Token -> Creds m)
-- ^ A function to generate the credentials -- ^ A function to generate the credentials
-> [Text] -- ^ List of scopes to request -> [Text] -- ^ List of scopes to request
-> Text -- ^ Client ID -> Text -- ^ Client ID
@ -78,20 +75,21 @@ oauth2GoogleScopedWithCustomId toCreds scopes clientId clientSecret =
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" `withQuery`
$ "https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes [ scopeParam "+" scopes
]
, oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token" , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
, oauthCallback = Nothing , 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 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 case userInfo of
Right user -> return $ toCreds user token Right user -> return $ toCreds user token
Left err -> throwIO $ InvalidProfileResponse "google" err Left err -> throwIO $ invalidProfileResponse "google" err
data GoogleUser = GoogleUser data GoogleUser = GoogleUser
{ googleUserId :: Text { googleUserId :: Text
@ -116,14 +114,14 @@ instance FromJSON GoogleUser where
parseJSON _ = mzero parseJSON _ = mzero
-- | Build a @'Creds'@ using the user's google-uid as the identifier -- | 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 googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId
-- | Build a @'Creds'@ using the user's email as the identifier -- | Build a @'Creds'@ using the user's email as the identifier
emailUid :: GoogleUser -> AccessToken -> Creds m emailUid :: GoogleUser -> OAuth2Token -> Creds m
emailUid = uidBuilder googleUserEmail emailUid = uidBuilder googleUserEmail
uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> AccessToken -> Creds m uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> OAuth2Token -> Creds m
uidBuilder f user token = Creds uidBuilder f user token = Creds
{ credsPlugin = "google" { credsPlugin = "google"
, credsIdent = f user , credsIdent = f user
@ -133,7 +131,7 @@ uidBuilder f user token = Creds
, ("given_name", googleUserGivenName user) , ("given_name", googleUserGivenName user)
, ("family_name", googleUserFamilyName user) , ("family_name", googleUserFamilyName user)
, ("avatar_url", googleUserPicture user) , ("avatar_url", googleUserPicture user)
, ("access_token", decodeUtf8 $ accessToken token) , ("access_token", atoken $ accessToken token)
] ]
++ maybeExtra "hosted_domain" (googleUserHostedDomain user) ++ 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.Monad (mzero)
import Control.Exception.Lifted (throwIO) import Control.Exception.Lifted (throwIO)
import Data.Aeson (FromJSON, Value(..), parseJSON, decode, (.:)) import Data.Aeson (FromJSON, Value(..), parseJSON, decode, (.:))
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Client (applyBasicAuth, httpLbs, parseRequest, responseBody, import Network.HTTP.Client (applyBasicAuth, httpLbs, parseRequest, responseBody,
responseStatus) responseStatus)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Yesod.Auth (Creds(..), YesodAuth, AuthPlugin) import Yesod.Auth (Creds(..), YesodAuth, AuthPlugin)
import Yesod.Auth.OAuth2 (OAuth2(..), AccessToken(..), import Yesod.Auth.OAuth2
YesodOAuth2Exception(InvalidProfileResponse),
authOAuth2)
import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types as HT
data NylasAccount = NylasAccount data NylasAccount = NylasAccount
@ -48,18 +46,19 @@ oauth2Nylas :: YesodAuth m
-> AuthPlugin m -> AuthPlugin m
oauth2Nylas clientId clientSecret = authOAuth2 "nylas" oauth fetchCreds oauth2Nylas clientId clientSecret = authOAuth2 "nylas" oauth fetchCreds
where where
authorizeUrl = encodeUtf8 $ "https://api.nylas.com/oauth/authorize" <>
"?response_type=code&scope=email&client_id=" <> clientId
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = authorizeUrl , oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize" `withQuery`
[ ("response_type", "code")
, ("scope", "email")
, ("client_id", encodeUtf8 clientId)
]
, oauthAccessTokenEndpoint = "https://api.nylas.com/oauth/token" , oauthAccessTokenEndpoint = "https://api.nylas.com/oauth/token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchCreds :: Manager -> AccessToken -> IO (Creds a) fetchCreds :: Manager -> OAuth2Token -> IO (Creds a)
fetchCreds manager token = do fetchCreds manager token = do
req <- authorize <$> parseRequest "https://api.nylas.com/account" req <- authorize <$> parseRequest "https://api.nylas.com/account"
resp <- httpLbs req manager resp <- httpLbs req manager
@ -69,11 +68,11 @@ fetchCreds manager token = do
Nothing -> throwIO parseFailure Nothing -> throwIO parseFailure
else throwIO requestFailure else throwIO requestFailure
where where
authorize = applyBasicAuth (accessToken token) "" authorize = applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
parseFailure = InvalidProfileResponse "nylas" "failed to parse account" parseFailure = InvalidProfileResponse "nylas" "failed to parse account"
requestFailure = InvalidProfileResponse "nylas" "failed to get account" requestFailure = InvalidProfileResponse "nylas" "failed to get account"
toCreds :: NylasAccount -> AccessToken -> Creds a toCreds :: NylasAccount -> OAuth2Token -> Creds a
toCreds ns token = Creds toCreds ns token = Creds
{ credsPlugin = "nylas" { credsPlugin = "nylas"
, credsIdent = nylasAccountId ns , credsIdent = nylasAccountId ns
@ -82,6 +81,6 @@ toCreds ns token = Creds
, ("name", nylasAccountName ns) , ("name", nylasAccountName ns)
, ("provider", nylasAccountProvider ns) , ("provider", nylasAccountProvider ns)
, ("organization_unit", nylasAccountOrganizationUnit 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.Exception.Lifted
import Control.Monad (mzero) import Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
@ -51,19 +49,21 @@ oauth2SalesforceScoped scopes clientId clientSecret =
authOAuth2 svcName oauth fetchSalesforceUser authOAuth2 svcName oauth fetchSalesforceUser
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://login.salesforce.com/services/oauth2/authorize?scope=" <> T.intercalate " " scopes , oauthOAuthorizeEndpoint = "https://login.salesforce.com/services/oauth2/authorize" `withQuery`
[ scopeParam " " scopes
]
, oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token" , oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchSalesforceUser :: Manager -> AccessToken -> IO (Creds m) fetchSalesforceUser :: Manager -> OAuth2Token -> IO (Creds m)
fetchSalesforceUser manager token = do 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 case result of
Right user -> return $ toCreds svcName user token Right user -> return $ toCreds svcName user token
Left err -> throwIO $ InvalidProfileResponse svcName err Left err -> throwIO $ invalidProfileResponse svcName err
svcNameSb :: Text svcNameSb :: Text
svcNameSb = "salesforce-sandbox" svcNameSb = "salesforce-sandbox"
@ -84,19 +84,21 @@ oauth2SalesforceSandboxScoped scopes clientId clientSecret =
authOAuth2 svcNameSb oauth fetchSalesforceSandboxUser authOAuth2 svcNameSb oauth fetchSalesforceSandboxUser
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://test.salesforce.com/services/oauth2/authorize?scope=" <> T.intercalate " " scopes , oauthOAuthorizeEndpoint = "https://test.salesforce.com/services/oauth2/authorize" `withQuery`
[ scopeParam " " scopes
]
, oauthAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token" , oauthAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchSalesforceSandboxUser :: Manager -> AccessToken -> IO (Creds m) fetchSalesforceSandboxUser :: Manager -> OAuth2Token -> IO (Creds m)
fetchSalesforceSandboxUser manager token = do 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 case result of
Right user -> return $ toCreds svcNameSb user token Right user -> return $ toCreds svcNameSb user token
Left err -> throwIO $ InvalidProfileResponse svcNameSb err Left err -> throwIO $ invalidProfileResponse svcNameSb err
data User = User data User = User
{ userId :: Text { userId :: Text
@ -130,7 +132,7 @@ instance FromJSON User where
parseJSON _ = mzero parseJSON _ = mzero
toCreds :: Text -> User -> AccessToken -> Creds m toCreds :: Text -> User -> OAuth2Token -> Creds m
toCreds name user token = Creds toCreds name user token = Creds
{ credsPlugin = name { credsPlugin = name
, credsIdent = userId user , credsIdent = userId user
@ -144,9 +146,9 @@ toCreds name user token = Creds
, ("time_zone", userTimeZone user) , ("time_zone", userTimeZone user)
, ("avatar_url", userPicture user) , ("avatar_url", userPicture user)
, ("rest_url", userRestUrl 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 "expires_in" ((T.pack . show) <$> expiresIn token)
++ maybeExtra "phone_number" (userPhone user) ++ 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 Control.Exception.Lifted (throwIO)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import qualified Data.Text as Text
import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Conduit as HTTP
data SlackScope data SlackScope
@ -86,39 +84,37 @@ oauth2SlackScoped clientId clientSecret scopes =
authOAuth2 "slack" oauth fetchSlackProfile authOAuth2 "slack" oauth fetchSlackProfile
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = , oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize" `withQuery`
encodeUtf8 [ scopeParam "," $ "identity.basic" : map scopeText scopes
$ "https://slack.com/oauth/authorize?scope=" ]
<> Text.intercalate "," scopeTexts
, oauthAccessTokenEndpoint = "https://slack.com/api/oauth.access" , oauthAccessTokenEndpoint = "https://slack.com/api/oauth.access"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
scopeTexts = "identity.basic":map scopeText scopes
scopeText :: SlackScope -> Text scopeText :: SlackScope -> Text
scopeText SlackEmailScope = "identity.email" scopeText SlackEmailScope = "identity.email"
scopeText SlackTeamScope = "identity.team" scopeText SlackTeamScope = "identity.team"
scopeText SlackAvatarScope = "identity.avatar" scopeText SlackAvatarScope = "identity.avatar"
fetchSlackProfile :: Manager -> AccessToken -> IO (Creds m) fetchSlackProfile :: Manager -> OAuth2Token -> IO (Creds m)
fetchSlackProfile manager token = do fetchSlackProfile manager token = do
request request
<- HTTP.setQueryString [("token", Just $ accessToken token)] <- HTTP.setQueryString [("token", Just $ encodeUtf8 $ atoken $ accessToken token)]
<$> HTTP.parseUrl "https://slack.com/api/users.identity" <$> HTTP.parseUrlThrow "https://slack.com/api/users.identity"
body <- HTTP.responseBody <$> HTTP.httpLbs request manager body <- HTTP.responseBody <$> HTTP.httpLbs request manager
case eitherDecode body of case eitherDecode body of
Left _ -> throwIO $ InvalidProfileResponse "slack" body Left _ -> throwIO $ InvalidProfileResponse "slack" body
Right u -> return $ toCreds u token Right u -> return $ toCreds u token
toCreds :: SlackUser -> AccessToken -> Creds m toCreds :: SlackUser -> OAuth2Token -> Creds m
toCreds user token = Creds toCreds user token = Creds
{ credsPlugin = "slack" { credsPlugin = "slack"
, credsIdent = slackUserId user , credsIdent = slackUserId user
, credsExtra = catMaybes , credsExtra = catMaybes
[ Just ("name", slackUserName user) [ Just ("name", slackUserName user)
, Just ("access_token", decodeUtf8 $ accessToken token) , Just ("access_token", atoken $ accessToken token)
, (,) <$> pure "email" <*> slackUserEmail user , (,) <$> pure "email" <*> slackUserEmail user
, (,) <$> pure "avatar" <*> slackUserAvatarUrl user , (,) <$> pure "avatar" <*> slackUserAvatarUrl user
, (,) <$> pure "team_name" <*> (slackTeamName <$> slackUserTeam 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 Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.ByteString (ByteString)
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
import qualified Data.ByteString as B
import qualified Data.Text as T import qualified Data.Text as T
data SpotifyUserImage = SpotifyUserImage data SpotifyUserImage = SpotifyUserImage
@ -66,13 +64,15 @@ instance FromJSON SpotifyUser where
oauth2Spotify :: YesodAuth m oauth2Spotify :: YesodAuth m
=> Text -- ^ Client ID => Text -- ^ Client ID
-> Text -- ^ Client Secret -> Text -- ^ Client Secret
-> [ByteString] -- ^ Scopes -> [Text] -- ^ Scopes
-> AuthPlugin m -> AuthPlugin m
oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify" oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify"
OAuth2 OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = clientSecret
, oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope) , oauthOAuthorizeEndpoint = "https://accounts.spotify.com/authorize" `withQuery`
[ ("scope", encodeUtf8 $ T.intercalate " " scope)
]
, oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token" , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }

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

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

4
stack.yaml
View File

@ -1,8 +1,8 @@
resolver: lts-9.5
flags: flags:
yesod-auth-oauth2: yesod-auth-oauth2:
network-uri: true network-uri: true
packages: packages:
- '.' - .
resolver: lts-8.23
extra-deps: extra-deps:
- load-env-0.1.1 - 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-client >= 0.4.0 && < 0.6
, http-conduit >= 2.0 && < 3.0 , http-conduit >= 2.0 && < 3.0
, http-types >= 0.8 && < 0.10 , http-types >= 0.8 && < 0.10
, aeson >= 0.6 && < 1.1 , aeson >= 0.6 && < 1.2
, yesod-core >= 1.2 && < 1.5 , yesod-core >= 1.2 && < 1.5
, authenticate >= 1.3.2.7 && < 1.4 , authenticate >= 1.3.2.7 && < 1.4
, random , random
@ -39,9 +39,11 @@ library
, text >= 0.7 && < 2.0 , text >= 0.7 && < 2.0
, yesod-form >= 1.3 && < 1.5 , yesod-form >= 1.3 && < 1.5
, transformers >= 0.2.2 && < 0.6 , transformers >= 0.2.2 && < 0.6
, hoauth2 >= 0.4.7 && < 0.6 , hoauth2 >= 1.3.0 && < 1.4
, lifted-base >= 0.2 && < 0.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 exposed-modules: Yesod.Auth.OAuth2
Yesod.Auth.OAuth2.Github Yesod.Auth.OAuth2.Github
@ -54,6 +56,8 @@ library
Yesod.Auth.OAuth2.Salesforce Yesod.Auth.OAuth2.Salesforce
Yesod.Auth.OAuth2.Bitbucket Yesod.Auth.OAuth2.Bitbucket
Yesod.Auth.OAuth2.BattleNet Yesod.Auth.OAuth2.BattleNet
URI.ByteString.Extension
-- ^ exposed for testing
ghc-options: -Wall ghc-options: -Wall
@ -84,6 +88,7 @@ test-suite test
build-depends: base build-depends: base
, yesod-auth-oauth2 , yesod-auth-oauth2
, hspec , hspec
, uri-bytestring
source-repository head source-repository head
type: git type: git