mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-21 16:41:55 +01:00
Re-structure modules
- Extract ...OAuth2.Dispatch - Extract ...OAuth2.Prelude - Reduce ...OAuth2 interface - Re-export ...OAuth2 from Prelude Incidental improvements: - Moves a lot of FromJSON interfaces to withObject which will provide better de-serialization errors - Updates Dispatch code to prepare for fetch-creds functions returning either instead of maybe, so we can eventually remove exceptions entirely - Replaces (the potentially information-leaking) 500 on OAuth2-related errors with a 403 and logged error
This commit is contained in:
patrick brisbin
parent
82585f9b32
commit
49542cbca1
@ -24,9 +24,9 @@ library:
|
||||
- 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
|
||||
- random
|
||||
- safe-exceptions
|
||||
- text >=0.7 && <2.0
|
||||
- transformers >=0.2.2 && <0.6
|
||||
- uri-bytestring
|
||||
|
||||
@ -1,61 +1,29 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
-- |
|
||||
--
|
||||
-- Generic OAuth2 plugin for Yesod
|
||||
--
|
||||
-- * See Yesod.Auth.OAuth2.GitHub for example usage.
|
||||
-- See "Yesod.Auth.OAuth2.GitHub" for example usage.
|
||||
--
|
||||
module Yesod.Auth.OAuth2
|
||||
( authOAuth2
|
||||
, authOAuth2Widget
|
||||
( OAuth2(..)
|
||||
, FetchCreds
|
||||
, Manager
|
||||
, OAuth2Token(..)
|
||||
, Creds(..)
|
||||
, oauth2Url
|
||||
, fromProfileURL
|
||||
, YesodOAuth2Exception(..)
|
||||
, invalidProfileResponse
|
||||
, scopeParam
|
||||
, maybeExtra
|
||||
, module Network.OAuth.OAuth2
|
||||
, module URI.ByteString
|
||||
, module URI.ByteString.Extension
|
||||
, authOAuth2
|
||||
, authOAuth2Widget
|
||||
) where
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson (Value(..), encode)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Typeable
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Network.OAuth.OAuth2 hiding (error)
|
||||
import System.Random
|
||||
import URI.ByteString
|
||||
import URI.ByteString.Extension
|
||||
import Network.OAuth.OAuth2
|
||||
import Yesod.Auth
|
||||
import Yesod.Core
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | Provider name and Aeson parse error
|
||||
data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Exception YesodOAuth2Exception
|
||||
|
||||
-- | Construct an @'InvalidProfileResponse'@ exception from an @'OAuth2Error'@
|
||||
--
|
||||
-- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which
|
||||
-- is then re-encoded for the exception message.
|
||||
--
|
||||
invalidProfileResponse :: Text -> OAuth2Error Value -> YesodOAuth2Exception
|
||||
invalidProfileResponse name = InvalidProfileResponse name . encode
|
||||
import Yesod.Auth.OAuth2.Dispatch
|
||||
import Yesod.Core.Widget
|
||||
|
||||
oauth2Url :: Text -> AuthRoute
|
||||
oauth2Url name = PluginR name ["forward"]
|
||||
@ -64,17 +32,7 @@ oauth2Url name = PluginR name ["forward"]
|
||||
--
|
||||
-- Presents a generic @"Login via name"@ link
|
||||
--
|
||||
authOAuth2 :: YesodAuth m
|
||||
=> Text -- ^ Service name
|
||||
-> OAuth2 -- ^ Service details
|
||||
-> (Manager -> OAuth2Token -> IO (Creds m))
|
||||
-- ^ This function defines how to take an @'OAuth2Token'@ and
|
||||
-- retrieve additional information about the user, to be set in the
|
||||
-- session as @'Creds'@. Usually this means a second authorized
|
||||
-- request to @api/me.json@.
|
||||
--
|
||||
-- See @'fromProfileURL'@ for an example.
|
||||
-> AuthPlugin m
|
||||
authOAuth2 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
|
||||
authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
|
||||
|
||||
-- | Create an @'AuthPlugin'@ for the given OAuth2 provider
|
||||
@ -82,81 +40,14 @@ authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
|
||||
-- Allows passing a custom widget for the login link. See @'oauth2Eve'@ for an
|
||||
-- example.
|
||||
--
|
||||
authOAuth2Widget :: YesodAuth m
|
||||
=> WidgetT m IO ()
|
||||
-> Text
|
||||
-> OAuth2
|
||||
-> (Manager -> OAuth2Token -> IO (Creds m))
|
||||
-> AuthPlugin m
|
||||
authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
|
||||
|
||||
authOAuth2Widget
|
||||
:: YesodAuth m
|
||||
=> WidgetT m IO ()
|
||||
-> Text
|
||||
-> OAuth2
|
||||
-> FetchCreds m
|
||||
-> AuthPlugin m
|
||||
authOAuth2Widget widget name oauth getCreds =
|
||||
AuthPlugin name (dispatchAuthRequest name oauth getCreds) login
|
||||
where
|
||||
url = PluginR name ["callback"]
|
||||
|
||||
withCallback csrfToken = do
|
||||
tm <- getRouteToParent
|
||||
render <- lift getUrlRender
|
||||
return oauth
|
||||
{ oauthCallback = Just $ unsafeFromText $ render $ tm url
|
||||
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
|
||||
`withQuery` [("state", encodeUtf8 csrfToken)]
|
||||
}
|
||||
|
||||
dispatch "GET" ["forward"] = do
|
||||
csrfToken <- liftIO generateToken
|
||||
setSession tokenSessionKey csrfToken
|
||||
authUrl <- toText . authorizationUrl <$> withCallback csrfToken
|
||||
lift $ redirect authUrl
|
||||
|
||||
dispatch "GET" ["callback"] = do
|
||||
csrfToken <- requireGetParam "state"
|
||||
oldToken <- lookupSession tokenSessionKey
|
||||
deleteSession tokenSessionKey
|
||||
unless (oldToken == Just csrfToken) $ permissionDenied "Invalid OAuth2 state token"
|
||||
code <- requireGetParam "code"
|
||||
oauth' <- withCallback csrfToken
|
||||
master <- lift getYesod
|
||||
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (ExchangeToken code)
|
||||
case result of
|
||||
Left _ -> permissionDenied "Unable to retrieve OAuth2 token"
|
||||
Right token -> do
|
||||
creds <- liftIO $ getCreds (authHttpManager master) token
|
||||
lift $ setCredsRedirect creds
|
||||
where
|
||||
requireGetParam key = do
|
||||
m <- lookupGetParam key
|
||||
maybe (permissionDenied $ "'" <> key <> "' parameter not provided") return m
|
||||
|
||||
dispatch _ _ = notFound
|
||||
|
||||
generateToken = pack . take 30 . randomRs ('a', 'z') <$> newStdGen
|
||||
|
||||
tokenSessionKey :: Text
|
||||
tokenSessionKey = "_yesod_oauth2_" <> name
|
||||
|
||||
login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
|
||||
|
||||
-- | Handle the common case of fetching Profile information from a JSON endpoint
|
||||
--
|
||||
-- Throws @'InvalidProfileResponse'@ if JSON parsing fails
|
||||
--
|
||||
fromProfileURL :: FromJSON a
|
||||
=> Text -- ^ Plugin name
|
||||
-> URI -- ^ Profile URI
|
||||
-> (a -> Creds m) -- ^ Conversion to Creds
|
||||
-> Manager -> OAuth2Token -> IO (Creds m)
|
||||
fromProfileURL name url toCreds manager token = do
|
||||
result <- authGetJSON manager (accessToken token) url
|
||||
|
||||
case result of
|
||||
Right profile -> return $ toCreds profile
|
||||
Left err -> throwIO $ invalidProfileResponse name err
|
||||
|
||||
-- | A tuple of @scope@ and the given scopes separated by a delimiter
|
||||
scopeParam :: Text -> [Text] -> (ByteString, ByteString)
|
||||
scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
|
||||
|
||||
-- | A helper for providing an optional value to credsExtra
|
||||
maybeExtra :: Text -> Maybe Text -> [(Text, Text)]
|
||||
maybeExtra k (Just v) = [(k, v)]
|
||||
maybeExtra _ Nothing = []
|
||||
|
||||
@ -12,17 +12,9 @@ module Yesod.Auth.OAuth2.BattleNet
|
||||
( oAuth2BattleNet
|
||||
) where
|
||||
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import qualified Data.Text as T (pack, toLower)
|
||||
import qualified Data.Text.Encoding as E (encodeUtf8)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Prelude
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Core.Widget
|
||||
|
||||
data BattleNetUser = BattleNetUser
|
||||
@ -31,10 +23,9 @@ data BattleNetUser = BattleNetUser
|
||||
}
|
||||
|
||||
instance FromJSON BattleNetUser where
|
||||
parseJSON (Object o) = BattleNetUser
|
||||
parseJSON = withObject "BattleNetUser" $ \o -> BattleNetUser
|
||||
<$> o .: "id"
|
||||
<*> o .: "battletag"
|
||||
parseJSON _ = mzero
|
||||
|
||||
oAuth2BattleNet
|
||||
:: YesodAuth m
|
||||
@ -73,8 +64,8 @@ makeCredentials region manager token = do
|
||||
|
||||
apiHost :: Text -> Host
|
||||
apiHost "cn" = "api.battlenet.com.cn"
|
||||
apiHost region = Host $ E.encodeUtf8 $ region <> ".api.battle.net"
|
||||
apiHost region = Host $ encodeUtf8 $ region <> ".api.battle.net"
|
||||
|
||||
wwwHost :: Text -> Host
|
||||
wwwHost "cn" = "www.battlenet.com.cn"
|
||||
wwwHost region = Host $ E.encodeUtf8 $ region <> ".battle.net"
|
||||
wwwHost region = Host $ encodeUtf8 $ region <> ".battle.net"
|
||||
|
||||
@ -10,19 +10,12 @@
|
||||
module Yesod.Auth.OAuth2.Bitbucket
|
||||
( oauth2Bitbucket
|
||||
, oauth2BitbucketScoped
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
import Control.Exception.Lifted (throwIO)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?))
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
data BitbucketUser = BitbucketUser
|
||||
@ -34,57 +27,47 @@ data BitbucketUser = BitbucketUser
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketUser where
|
||||
parseJSON (Object o) = BitbucketUser
|
||||
parseJSON = withObject "BitbucketUser" $ \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
|
||||
parseJSON = withObject "BitbucketUserLinks" $ \o -> BitbucketUserLinks
|
||||
<$> o .: "avatar"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
newtype BitbucketLink = BitbucketLink
|
||||
{ bitbucketLinkHref :: Text
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketLink where
|
||||
parseJSON (Object o) = BitbucketLink
|
||||
parseJSON = withObject "BitbucketLink" $ \o -> BitbucketLink
|
||||
<$> o .: "href"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
newtype BitbucketEmailSearchResults = BitbucketEmailSearchResults
|
||||
{ bitbucketEmails :: [BitbucketUserEmail]
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketEmailSearchResults where
|
||||
parseJSON (Object o) = BitbucketEmailSearchResults
|
||||
parseJSON = withObject "BitbucketEmailSearchResults" $ \o -> BitbucketEmailSearchResults
|
||||
<$> o .: "values"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
data BitbucketUserEmail = BitbucketUserEmail
|
||||
{ bitbucketUserEmailAddress :: Text
|
||||
, bitbucketUserEmailPrimary :: Bool
|
||||
}
|
||||
|
||||
instance FromJSON BitbucketUserEmail where
|
||||
parseJSON (Object o) = BitbucketUserEmail
|
||||
parseJSON = withObject "BitbucketUserEmail" $ \o -> BitbucketUserEmail
|
||||
<$> o .: "email"
|
||||
<*> o .: "is_primary"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Bitbucket :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
|
||||
126
src/Yesod/Auth/OAuth2/Dispatch.hs
Normal file
126
src/Yesod/Auth/OAuth2/Dispatch.hs
Normal file
@ -0,0 +1,126 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Auth.OAuth2.Dispatch
|
||||
( FetchCreds
|
||||
, dispatchAuthRequest
|
||||
) where
|
||||
|
||||
import Control.Exception.Safe (tryIO)
|
||||
import Control.Monad (unless)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Network.OAuth.OAuth2
|
||||
import System.Random (newStdGen, randomRs)
|
||||
import URI.ByteString.Extension
|
||||
import Yesod.Auth
|
||||
import Yesod.Core
|
||||
|
||||
-- | How to take an @'OAuth2Token'@ and retrieve user credentials
|
||||
--
|
||||
-- Usually this means a second authorized request to @api/me.json@. See
|
||||
-- @'fromProfileURL'@ for an example.
|
||||
--
|
||||
type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)
|
||||
|
||||
-- | Dispatch the various OAuth2 handshake routes
|
||||
dispatchAuthRequest
|
||||
:: Text -- ^ Name
|
||||
-> OAuth2 -- ^ Service details
|
||||
-> FetchCreds m -- ^ How to get credentials
|
||||
-> Text -- ^ Method
|
||||
-> [Text] -- ^ Path pieces
|
||||
-> AuthHandler m TypedContent
|
||||
dispatchAuthRequest name oauth2 _ "GET" ["forward"] = dispatchForward name oauth2
|
||||
dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = dispatchCallback name oauth2 getCreds
|
||||
dispatchAuthRequest _ _ _ _ _ = notFound
|
||||
|
||||
-- | Handle @GET \/forward@
|
||||
--
|
||||
-- 1. Set a random CSRF token in our session
|
||||
-- 2. Redirect to the Provider's authorization URL
|
||||
--
|
||||
dispatchForward :: Text -> OAuth2 -> AuthHandler m TypedContent
|
||||
dispatchForward name oauth2 = do
|
||||
csrf <- setSessionCSRF $ tokenSessionKey name
|
||||
oauth2' <- withCallbackAndState name oauth2 csrf
|
||||
lift $ redirect $ toText $ authorizationUrl oauth2'
|
||||
|
||||
-- | Handle @GET \/callback@
|
||||
--
|
||||
-- 1. Verify the URL's CSRF token matches our session
|
||||
-- 2. Use the code parameter to fetch an AccessToken for the Provider
|
||||
-- 3. Use the AccessToken to construct a @'Creds'@ value for the Provider
|
||||
--
|
||||
dispatchCallback :: Text -> OAuth2 -> FetchCreds m -> AuthHandler m TypedContent
|
||||
dispatchCallback name oauth2 getCreds = do
|
||||
csrf <- verifySessionCSRF $ tokenSessionKey name
|
||||
code <- requireGetParam "code"
|
||||
manager <- lift $ getsYesod authHttpManager
|
||||
oauth2' <- withCallbackAndState name oauth2 csrf
|
||||
token <- denyLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code
|
||||
creds <- denyLeft $ tryIO $ getCreds manager token
|
||||
lift $ setCredsRedirect creds
|
||||
where
|
||||
-- On a Left result, log it and return an opaque permission-denied
|
||||
denyLeft :: (MonadHandler m, MonadLogger m, Show e) => IO (Either e a) -> m a
|
||||
denyLeft act = do
|
||||
result <- liftIO act
|
||||
either
|
||||
(\err -> do
|
||||
$(logError) $ T.pack $ "OAuth2 error: " <> show err
|
||||
permissionDenied "Invalid OAuth2 authentication attempt"
|
||||
)
|
||||
return
|
||||
result
|
||||
|
||||
withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2
|
||||
withCallbackAndState name oauth2 csrf = do
|
||||
let url = PluginR name ["callback"]
|
||||
render <- getParentUrlRender
|
||||
return oauth2
|
||||
-- FIXME: an invalid AppRoot can blow this up
|
||||
{ oauthCallback = Just $ unsafeFromText $ render url
|
||||
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2
|
||||
`withQuery` [("state", encodeUtf8 csrf)]
|
||||
}
|
||||
|
||||
getParentUrlRender :: HandlerT child (HandlerT parent IO) (Route child -> Text)
|
||||
getParentUrlRender = (.)
|
||||
<$> lift getUrlRender
|
||||
<*> getRouteToParent
|
||||
|
||||
-- | Set a random, 30-character value in the session
|
||||
setSessionCSRF :: MonadHandler m => Text -> m Text
|
||||
setSessionCSRF sessionKey = do
|
||||
csrfToken <- liftIO randomToken
|
||||
csrfToken <$ setSession sessionKey csrfToken
|
||||
where
|
||||
randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen
|
||||
|
||||
-- | Verify the callback provided the same CSRF token as in our session
|
||||
verifySessionCSRF :: MonadHandler m => Text -> m Text
|
||||
verifySessionCSRF sessionKey = do
|
||||
token <- requireGetParam "state"
|
||||
sessionToken <- lookupSession sessionKey
|
||||
deleteSession sessionKey
|
||||
|
||||
unless (sessionToken == Just token)
|
||||
$ permissionDenied "Invalid OAuth2 state token"
|
||||
|
||||
return token
|
||||
|
||||
requireGetParam :: MonadHandler m => Text -> m Text
|
||||
requireGetParam key = do
|
||||
m <- lookupGetParam key
|
||||
maybe errInvalidArgs return m
|
||||
where
|
||||
errInvalidArgs = invalidArgs ["The '" <> key <> "' parameter is required"]
|
||||
|
||||
tokenSessionKey :: Text -> Text
|
||||
tokenSessionKey name = "_yesod_oauth2_" <> name
|
||||
@ -12,19 +12,12 @@ module Yesod.Auth.OAuth2.EveOnline
|
||||
( oauth2Eve
|
||||
, oauth2EveScoped
|
||||
, WidgetType(..)
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
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 Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Yesod.Core.Widget
|
||||
|
||||
data WidgetType m
|
||||
= Plain -- ^ Simple "Login via eveonline" text
|
||||
@ -43,15 +36,13 @@ data EveUser = EveUser
|
||||
}
|
||||
|
||||
instance FromJSON EveUser where
|
||||
parseJSON (Object o) = EveUser
|
||||
parseJSON = withObject "EveUser" $ \o -> EveUser
|
||||
<$> o .: "CharacterName"
|
||||
<*> o .: "ExpiresOn"
|
||||
<*> o .: "TokenType"
|
||||
<*> o .: "CharacterOwnerHash"
|
||||
<*> o .: "CharacterID"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Eve :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
|
||||
@ -10,19 +10,12 @@
|
||||
module Yesod.Auth.OAuth2.Github
|
||||
( oauth2Github
|
||||
, oauth2GithubScoped
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
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
|
||||
@ -35,7 +28,7 @@ data GithubUser = GithubUser
|
||||
}
|
||||
|
||||
instance FromJSON GithubUser where
|
||||
parseJSON (Object o) = GithubUser
|
||||
parseJSON = withObject "GithubUser" $ \o -> GithubUser
|
||||
<$> o .: "id"
|
||||
<*> o .:? "name"
|
||||
<*> o .: "login"
|
||||
@ -43,20 +36,16 @@ instance FromJSON GithubUser where
|
||||
<*> o .:? "location"
|
||||
<*> o .:? "email"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
data GithubUserEmail = GithubUserEmail
|
||||
{ githubUserEmailAddress :: Text
|
||||
, githubUserEmailPrimary :: Bool
|
||||
}
|
||||
|
||||
instance FromJSON GithubUserEmail where
|
||||
parseJSON (Object o) = GithubUserEmail
|
||||
parseJSON = withObject "GithubUserEmail" $ \o -> GithubUserEmail
|
||||
<$> o .: "email"
|
||||
<*> o .: "primary"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Github :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
|
||||
@ -17,17 +17,9 @@ module Yesod.Auth.OAuth2.Google
|
||||
, oauth2GoogleScopedWithCustomId
|
||||
, googleUid
|
||||
, emailUid
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
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
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
-- | Auth with Google
|
||||
--
|
||||
@ -97,7 +89,7 @@ data GoogleUser = GoogleUser
|
||||
}
|
||||
|
||||
instance FromJSON GoogleUser where
|
||||
parseJSON (Object o) = GoogleUser
|
||||
parseJSON = withObject "GoogleUser" $ \o -> GoogleUser
|
||||
<$> o .: "sub"
|
||||
<*> o .: "name"
|
||||
<*> o .: "email"
|
||||
@ -106,8 +98,6 @@ instance FromJSON GoogleUser where
|
||||
<*> 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
|
||||
|
||||
@ -2,20 +2,14 @@
|
||||
|
||||
module Yesod.Auth.OAuth2.Nylas
|
||||
( oauth2Nylas
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
import Control.Exception.Lifted (throwIO)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson (FromJSON, Value(..), decode, parseJSON, (.:))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSL8
|
||||
import Network.HTTP.Client
|
||||
(applyBasicAuth, httpLbs, parseRequest, responseBody, responseStatus)
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import Yesod.Auth (AuthPlugin, Creds(..), YesodAuth)
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
data NylasAccount = NylasAccount
|
||||
{ nylasAccountId :: Text
|
||||
@ -26,13 +20,12 @@ data NylasAccount = NylasAccount
|
||||
}
|
||||
|
||||
instance FromJSON NylasAccount where
|
||||
parseJSON (Object o) = NylasAccount
|
||||
parseJSON = withObject "NylasAccount" $ \o -> NylasAccount
|
||||
<$> o .: "id"
|
||||
<*> o .: "email_address"
|
||||
<*> o .: "name"
|
||||
<*> o .: "provider"
|
||||
<*> o .: "organization_unit"
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Nylas :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
@ -57,13 +50,13 @@ 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
|
||||
then case eitherDecode (responseBody resp) of
|
||||
Right ns -> return $ toCreds ns token
|
||||
Left err -> throwIO $ parseFailure err
|
||||
else throwIO requestFailure
|
||||
where
|
||||
authorize = applyBasicAuth (encodeUtf8 $ atoken $ accessToken token) ""
|
||||
parseFailure = InvalidProfileResponse "nylas" "failed to parse account"
|
||||
parseFailure = InvalidProfileResponse "nylas" . BSL8.pack
|
||||
requestFailure = InvalidProfileResponse "nylas" "failed to get account"
|
||||
|
||||
toCreds :: NylasAccount -> OAuth2Token -> Creds a
|
||||
|
||||
111
src/Yesod/Auth/OAuth2/Prelude.hs
Normal file
111
src/Yesod/Auth/OAuth2/Prelude.hs
Normal file
@ -0,0 +1,111 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
-- |
|
||||
--
|
||||
-- Modules and support functions required by most or all provider
|
||||
-- implementations. May also be useful for writing local providers.
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Prelude
|
||||
( YesodOAuth2Exception(..)
|
||||
, invalidProfileResponse
|
||||
|
||||
-- * Helpers
|
||||
, fromProfileURL
|
||||
, scopeParam
|
||||
, maybeExtra
|
||||
|
||||
-- * Text
|
||||
, Text
|
||||
, decodeUtf8
|
||||
, encodeUtf8
|
||||
|
||||
-- * JSON
|
||||
, (.:)
|
||||
, (.:?)
|
||||
, (.=)
|
||||
, (<>)
|
||||
, FromJSON(..)
|
||||
, ToJSON(..)
|
||||
, eitherDecode
|
||||
, withObject
|
||||
|
||||
-- * Exceptions
|
||||
, throwIO
|
||||
, tryIO
|
||||
|
||||
-- * OAuth2
|
||||
, OAuth2(..)
|
||||
, OAuth2Token(..)
|
||||
, AccessToken(..)
|
||||
, RefreshToken(..)
|
||||
|
||||
-- * HTTP
|
||||
, Manager
|
||||
, authGetJSON
|
||||
|
||||
-- * Yesod
|
||||
, YesodAuth(..)
|
||||
, AuthPlugin(..)
|
||||
, Creds(..)
|
||||
|
||||
-- * Bytestring URI types
|
||||
, Host(..)
|
||||
|
||||
-- * Bytestring URI extensions
|
||||
, module URI.ByteString.Extension
|
||||
|
||||
-- * Temporary, until I finish re-structuring modules
|
||||
, authOAuth2
|
||||
, authOAuth2Widget
|
||||
) where
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Data.Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding
|
||||
import Network.HTTP.Conduit
|
||||
import Network.OAuth.OAuth2
|
||||
import URI.ByteString
|
||||
import URI.ByteString.Extension
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
-- | Provider name and error
|
||||
--
|
||||
-- The error is a lazy bytestring because it's most often encoded JSON.
|
||||
--
|
||||
data YesodOAuth2Exception = InvalidProfileResponse Text BSL.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
|
||||
|
||||
-- | Handle the common case of fetching Profile information from a JSON endpoint
|
||||
--
|
||||
-- Throws @'InvalidProfileResponse'@ if JSON parsing fails
|
||||
--
|
||||
fromProfileURL :: FromJSON a => Text -> URI -> (a -> Creds m) -> FetchCreds m
|
||||
fromProfileURL name url toCreds manager token = do
|
||||
result <- authGetJSON manager (accessToken token) url
|
||||
either (throwIO . invalidProfileResponse name) (return . toCreds) result
|
||||
|
||||
-- | 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 = []
|
||||
@ -13,17 +13,11 @@ module Yesod.Auth.OAuth2.Salesforce
|
||||
, oauth2SalesforceScoped
|
||||
, oauth2SalesforceSandbox
|
||||
, oauth2SalesforceSandboxScoped
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Conduit (Manager)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
oauth2Salesforce :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
@ -109,7 +103,7 @@ data User = User
|
||||
}
|
||||
|
||||
instance FromJSON User where
|
||||
parseJSON (Object o) = do
|
||||
parseJSON = withObject "User" $ \o -> do
|
||||
userId <- o .: "user_id"
|
||||
userOrg <- o .: "organization_id"
|
||||
userNickname <- o .: "nickname"
|
||||
@ -124,8 +118,6 @@ instance FromJSON User where
|
||||
userRestUrl <- urls .: "rest"
|
||||
return User{..}
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
toCreds :: Text -> User -> OAuth2Token -> Creds m
|
||||
toCreds name user token = Creds
|
||||
{ credsPlugin = name
|
||||
|
||||
@ -12,16 +12,9 @@ module Yesod.Auth.OAuth2.Slack
|
||||
, oauth2SlackScoped
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
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
|
||||
|
||||
@ -5,17 +5,12 @@
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Spotify
|
||||
( oauth2Spotify
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
data SpotifyUserImage = SpotifyUserImage
|
||||
{ spotifyUserImageHeight :: Maybe Int
|
||||
@ -24,13 +19,11 @@ data SpotifyUserImage = SpotifyUserImage
|
||||
}
|
||||
|
||||
instance FromJSON SpotifyUserImage where
|
||||
parseJSON (Object v) = SpotifyUserImage
|
||||
parseJSON = withObject "SpotifyUserImage" $ \v -> SpotifyUserImage
|
||||
<$> v .:? "height"
|
||||
<*> v .:? "width"
|
||||
<*> v .: "url"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
data SpotifyUser = SpotifyUser
|
||||
{ spotifyUserId :: Text
|
||||
, spotifyUserHref :: Text
|
||||
@ -43,7 +36,7 @@ data SpotifyUser = SpotifyUser
|
||||
}
|
||||
|
||||
instance FromJSON SpotifyUser where
|
||||
parseJSON (Object v) = SpotifyUser
|
||||
parseJSON = withObject "SpotifyUser" $ \v -> SpotifyUser
|
||||
<$> v .: "id"
|
||||
<*> v .: "href"
|
||||
<*> v .: "uri"
|
||||
@ -53,8 +46,6 @@ instance FromJSON SpotifyUser where
|
||||
<*> v .:? "email"
|
||||
<*> v .:? "images"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Spotify :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
|
||||
@ -9,15 +9,11 @@
|
||||
--
|
||||
module Yesod.Auth.OAuth2.Upcase
|
||||
( oauth2Upcase
|
||||
, module Yesod.Auth.OAuth2
|
||||
) where
|
||||
|
||||
import Control.Monad (mzero)
|
||||
import Data.Aeson
|
||||
import Data.Text (Text)
|
||||
import Yesod.Auth.OAuth2.Prelude
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OAuth2
|
||||
|
||||
data UpcaseUser = UpcaseUser
|
||||
{ upcaseUserId :: Int
|
||||
@ -27,22 +23,18 @@ data UpcaseUser = UpcaseUser
|
||||
}
|
||||
|
||||
instance FromJSON UpcaseUser where
|
||||
parseJSON (Object o) = UpcaseUser
|
||||
parseJSON = withObject "UpcaseUser" $ \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
|
||||
parseJSON = withObject "UpcaseResponse" $ \o -> UpcaseResponse
|
||||
<$> o .: "user"
|
||||
|
||||
parseJSON _ = mzero
|
||||
|
||||
oauth2Upcase :: YesodAuth m
|
||||
=> Text -- ^ Client ID
|
||||
-> Text -- ^ Client Secret
|
||||
|
||||
Loading…
Reference in New Issue
Block a user