Use CPP to get 2.7.0 to compile

This commit is contained in:
Michael "Gilli" Gilliland 2023-01-30 14:10:39 -05:00
parent 17c778a47f
commit cf43baac7a
3 changed files with 62 additions and 39 deletions

View File

@ -3,6 +3,8 @@
module Network.OAuth.OAuth2.Compat module Network.OAuth.OAuth2.Compat
( OAuth2(..) ( OAuth2(..)
, OAuth2Result , OAuth2Result
, Error
, Errors
, authorizationUrl , authorizationUrl
, fetchAccessToken , fetchAccessToken
, fetchAccessToken2 , fetchAccessToken2
@ -15,6 +17,14 @@ module Network.OAuth.OAuth2.Compat
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.Text (Text) import Data.Text (Text)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
#if MIN_VERSION_hoauth2(2,7,0)
import Network.OAuth.OAuth2
( AccessToken(..)
, ExchangeToken(..)
, OAuth2Token(..)
, RefreshToken(..)
)
#else
import Network.OAuth.OAuth2 import Network.OAuth.OAuth2
( AccessToken(..) ( AccessToken(..)
, ExchangeToken(..) , ExchangeToken(..)
@ -22,8 +32,13 @@ import Network.OAuth.OAuth2
, OAuth2Token(..) , OAuth2Token(..)
, RefreshToken(..) , RefreshToken(..)
) )
#endif
import qualified Network.OAuth.OAuth2 as OAuth2 import qualified Network.OAuth.OAuth2 as OAuth2
#if MIN_VERSION_hoauth2(2,7,0)
import Network.OAuth.OAuth2.TokenRequest (TokenRequestError)
#else
import Network.OAuth.OAuth2.TokenRequest (Errors) import Network.OAuth.OAuth2.TokenRequest (Errors)
#endif
import URI.ByteString import URI.ByteString
#if MIN_VERSION_hoauth2(2,2,0) #if MIN_VERSION_hoauth2(2,2,0)
@ -39,7 +54,17 @@ data OAuth2 = OAuth2
, oauth2RedirectUri :: Maybe (URIRef Absolute) , oauth2RedirectUri :: Maybe (URIRef Absolute)
} }
type OAuth2Result err a = Either (OAuth2Error err) a #if MIN_VERSION_hoauth2(2,7,0)
type Errors = TokenRequestError
#endif
#if MIN_VERSION_hoauth2(2,7,0)
type Error = TokenRequestError
#else
type Error = OAuth2Error Errors
#endif
type OAuth2Result a = Either Error a
authorizationUrl :: OAuth2 -> URI authorizationUrl :: OAuth2 -> URI
authorizationUrl = OAuth2.authorizationUrl . getOAuth2 authorizationUrl = OAuth2.authorizationUrl . getOAuth2
@ -48,14 +73,14 @@ fetchAccessToken
:: Manager :: Manager
-> OAuth2 -> OAuth2
-> ExchangeToken -> ExchangeToken
-> IO (OAuth2Result Errors OAuth2Token) -> IO (OAuth2Result OAuth2Token)
fetchAccessToken = fetchAccessTokenBasic fetchAccessToken = fetchAccessTokenBasic
fetchAccessToken2 fetchAccessToken2
:: Manager :: Manager
-> OAuth2 -> OAuth2
-> ExchangeToken -> ExchangeToken
-> IO (OAuth2Result Errors OAuth2Token) -> IO (OAuth2Result OAuth2Token)
fetchAccessToken2 = fetchAccessTokenPost fetchAccessToken2 = fetchAccessTokenPost
authGetBS :: Manager -> AccessToken -> URI -> IO (Either ByteString ByteString) authGetBS :: Manager -> AccessToken -> URI -> IO (Either ByteString ByteString)
@ -131,7 +156,7 @@ fetchAccessTokenBasic
:: Manager :: Manager
-> OAuth2 -> OAuth2
-> ExchangeToken -> ExchangeToken
-> IO (OAuth2Result Errors OAuth2Token) -> IO (OAuth2Result OAuth2Token)
fetchAccessTokenBasic m o e = runOAuth2 $ f m (getOAuth2 o) e fetchAccessTokenBasic m o e = runOAuth2 $ f m (getOAuth2 o) e
where where
#if MIN_VERSION_hoauth2(2,6,0) #if MIN_VERSION_hoauth2(2,6,0)
@ -146,7 +171,7 @@ fetchAccessTokenPost
:: Manager :: Manager
-> OAuth2 -> OAuth2
-> ExchangeToken -> ExchangeToken
-> IO (OAuth2Result Errors OAuth2Token) -> IO (OAuth2Result OAuth2Token)
fetchAccessTokenPost m o e = runOAuth2 $ f m (getOAuth2 o) e fetchAccessTokenPost m o e = runOAuth2 $ f m (getOAuth2 o) e
where where
#if MIN_VERSION_hoauth2(2, 6, 0) #if MIN_VERSION_hoauth2(2, 6, 0)

View File

@ -18,7 +18,6 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2.Compat import Network.OAuth.OAuth2.Compat
import Network.OAuth.OAuth2.TokenRequest (Errors)
import URI.ByteString.Extension import URI.ByteString.Extension
import UnliftIO.Exception import UnliftIO.Exception
import Yesod.Auth hiding (ServerError) import Yesod.Auth hiding (ServerError)
@ -32,7 +31,7 @@ import Yesod.Core hiding (ErrorResponse)
-- This will be 'fetchAccessToken' or 'fetchAccessToken2' -- This will be 'fetchAccessToken' or 'fetchAccessToken2'
-- --
type FetchToken type FetchToken
= Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token) = Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result OAuth2Token)
-- | How to take an @'OAuth2Token'@ and retrieve user credentials -- | How to take an @'OAuth2Token'@ and retrieve user credentials
type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m) type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)

View File

@ -9,15 +9,14 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.OAuth2.DispatchError module Yesod.Auth.OAuth2.DispatchError
( DispatchError(..) ( DispatchError(..)
, handleDispatchError , handleDispatchError
, onDispatchError , onDispatchError
) where ) where
import Control.Monad.Except import Control.Monad.Except
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Network.OAuth.OAuth2 import Network.OAuth.OAuth2.Compat (Error)
import Network.OAuth.OAuth2.TokenRequest (Errors)
import UnliftIO.Except () import UnliftIO.Except ()
import UnliftIO.Exception import UnliftIO.Exception
import Yesod.Auth hiding (ServerError) import Yesod.Auth hiding (ServerError)
@ -31,7 +30,7 @@ data DispatchError
| InvalidStateToken (Maybe Text) Text | InvalidStateToken (Maybe Text) Text
| InvalidCallbackUri Text | InvalidCallbackUri Text
| OAuth2HandshakeError ErrorResponse | OAuth2HandshakeError ErrorResponse
| OAuth2ResultError (OAuth2Error Errors) | OAuth2ResultError Error
| FetchCredsIOException IOException | FetchCredsIOException IOException
| FetchCredsYesodOAuth2Exception YesodOAuth2Exception | FetchCredsYesodOAuth2Exception YesodOAuth2Exception
| OtherDispatchError Text | OtherDispatchError Text
@ -45,37 +44,37 @@ data DispatchError
-- --
dispatchErrorMessage :: DispatchError -> Text dispatchErrorMessage :: DispatchError -> Text
dispatchErrorMessage = \case dispatchErrorMessage = \case
MissingParameter name -> MissingParameter name ->
"Parameter '" <> name <> "' is required, but not present in the URL" "Parameter '" <> name <> "' is required, but not present in the URL"
InvalidStateToken{} -> "State token is invalid, please try again" InvalidStateToken{} -> "State token is invalid, please try again"
InvalidCallbackUri{} InvalidCallbackUri{} ->
-> "Callback URI was not valid, this server may be misconfigured (no approot)" "Callback URI was not valid, this server may be misconfigured (no approot)"
OAuth2HandshakeError er -> "OAuth2 handshake failure: " <> erUserMessage er OAuth2HandshakeError er -> "OAuth2 handshake failure: " <> erUserMessage er
OAuth2ResultError{} -> "Login failed, please try again" OAuth2ResultError{} -> "Login failed, please try again"
FetchCredsIOException{} -> "Login failed, please try again" FetchCredsIOException{} -> "Login failed, please try again"
FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again" FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again"
OtherDispatchError{} -> "Login failed, please try again" OtherDispatchError{} -> "Login failed, please try again"
handleDispatchError handleDispatchError
:: MonadAuthHandler site m :: MonadAuthHandler site m
=> ExceptT DispatchError m TypedContent => ExceptT DispatchError m TypedContent
-> m TypedContent -> m TypedContent
handleDispatchError f = do handleDispatchError f = do
result <- runExceptT f result <- runExceptT f
either onDispatchError pure result either onDispatchError pure result
onDispatchError :: MonadAuthHandler site m => DispatchError -> m TypedContent onDispatchError :: MonadAuthHandler site m => DispatchError -> m TypedContent
onDispatchError err = do onDispatchError err = do
errorId <- liftIO $ randomText 16 errorId <- liftIO $ randomText 16
let suffix = " [errorId=" <> errorId <> "]" let suffix = " [errorId=" <> errorId <> "]"
$(logError) $ pack (displayException err) <> suffix $(logError) $ pack (displayException err) <> suffix
let message = dispatchErrorMessage err <> suffix let message = dispatchErrorMessage err <> suffix
messageValue = messageValue =
object ["error" .= object ["id" .= errorId, "message" .= message]] object ["error" .= object ["id" .= errorId, "message" .= message]]
loginR <- ($ LoginR) <$> getRouteToParent loginR <- ($ LoginR) <$> getRouteToParent
selectRep $ do selectRep $ do
provideRep @_ @Html $ onErrorHtml loginR message provideRep @_ @Html $ onErrorHtml loginR message
provideRep @_ @Value $ pure messageValue provideRep @_ @Value $ pure messageValue