From acbcaaafe344b5dd077d8b20674c97ebe11c04f5 Mon Sep 17 00:00:00 2001 From: "Michael \"Gilli\" Gilliland" Date: Mon, 30 Jan 2023 14:10:39 -0500 Subject: [PATCH] Use CPP to get 2.7.0 to compile Resolves #164 --- CHANGELOG.md | 2 +- src/Network/OAuth/OAuth2/Compat.hs | 30 ++++++++++-- src/Yesod/Auth/OAuth2/Dispatch.hs | 5 +- src/Yesod/Auth/OAuth2/DispatchError.hs | 63 +++++++++++++------------- 4 files changed, 59 insertions(+), 41 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ff19422..b236fad 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,7 @@ ## [v0.7.0.3](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.7.0.2...v0.7.0.3) -WIP, fill this in +- Support `hoauth-2.7` ## [v0.7.0.2](https://github.com/thoughtbot/yesod-auth-oauth2/compare/v0.7.0.1...v0.7.0.2) diff --git a/src/Network/OAuth/OAuth2/Compat.hs b/src/Network/OAuth/OAuth2/Compat.hs index 05af0da..79ac434 100644 --- a/src/Network/OAuth/OAuth2/Compat.hs +++ b/src/Network/OAuth/OAuth2/Compat.hs @@ -3,6 +3,7 @@ module Network.OAuth.OAuth2.Compat ( OAuth2(..) , OAuth2Result + , Error , authorizationUrl , fetchAccessToken , fetchAccessToken2 @@ -15,6 +16,14 @@ module Network.OAuth.OAuth2.Compat import Data.ByteString.Lazy (ByteString) import Data.Text (Text) 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 ( AccessToken(..) , ExchangeToken(..) @@ -22,8 +31,13 @@ import Network.OAuth.OAuth2 , OAuth2Token(..) , RefreshToken(..) ) +#endif 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) +#endif import URI.ByteString #if MIN_VERSION_hoauth2(2,2,0) @@ -39,7 +53,13 @@ data OAuth2 = OAuth2 , oauth2RedirectUri :: Maybe (URIRef Absolute) } -type OAuth2Result err a = Either (OAuth2Error err) a +#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.authorizationUrl . getOAuth2 @@ -48,14 +68,14 @@ fetchAccessToken :: Manager -> OAuth2 -> ExchangeToken - -> IO (OAuth2Result Errors OAuth2Token) + -> IO (OAuth2Result OAuth2Token) fetchAccessToken = fetchAccessTokenBasic fetchAccessToken2 :: Manager -> OAuth2 -> ExchangeToken - -> IO (OAuth2Result Errors OAuth2Token) + -> IO (OAuth2Result OAuth2Token) fetchAccessToken2 = fetchAccessTokenPost authGetBS :: Manager -> AccessToken -> URI -> IO (Either ByteString ByteString) @@ -131,7 +151,7 @@ fetchAccessTokenBasic :: Manager -> OAuth2 -> ExchangeToken - -> IO (OAuth2Result Errors OAuth2Token) + -> IO (OAuth2Result OAuth2Token) fetchAccessTokenBasic m o e = runOAuth2 $ f m (getOAuth2 o) e where #if MIN_VERSION_hoauth2(2,6,0) @@ -146,7 +166,7 @@ fetchAccessTokenPost :: Manager -> OAuth2 -> ExchangeToken - -> IO (OAuth2Result Errors OAuth2Token) + -> IO (OAuth2Result OAuth2Token) fetchAccessTokenPost m o e = runOAuth2 $ f m (getOAuth2 o) e where #if MIN_VERSION_hoauth2(2, 6, 0) diff --git a/src/Yesod/Auth/OAuth2/Dispatch.hs b/src/Yesod/Auth/OAuth2/Dispatch.hs index dfeb598..a98f41d 100644 --- a/src/Yesod/Auth/OAuth2/Dispatch.hs +++ b/src/Yesod/Auth/OAuth2/Dispatch.hs @@ -18,9 +18,8 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Conduit (Manager) import Network.OAuth.OAuth2.Compat -import Network.OAuth.OAuth2.TokenRequest (Errors) -import URI.ByteString.Extension import UnliftIO.Exception +import URI.ByteString.Extension import Yesod.Auth hiding (ServerError) import Yesod.Auth.OAuth2.DispatchError import Yesod.Auth.OAuth2.ErrorResponse @@ -32,7 +31,7 @@ import Yesod.Core hiding (ErrorResponse) -- This will be 'fetchAccessToken' or 'fetchAccessToken2' -- type FetchToken - = Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token) + = Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result OAuth2Token) -- | How to take an @'OAuth2Token'@ and retrieve user credentials type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m) diff --git a/src/Yesod/Auth/OAuth2/DispatchError.hs b/src/Yesod/Auth/OAuth2/DispatchError.hs index bdfc483..41930fc 100644 --- a/src/Yesod/Auth/OAuth2/DispatchError.hs +++ b/src/Yesod/Auth/OAuth2/DispatchError.hs @@ -9,15 +9,14 @@ {-# LANGUAGE TypeFamilies #-} module Yesod.Auth.OAuth2.DispatchError - ( DispatchError(..) - , handleDispatchError - , onDispatchError - ) where + ( DispatchError(..) + , handleDispatchError + , onDispatchError + ) where import Control.Monad.Except import Data.Text (Text, pack) -import Network.OAuth.OAuth2 -import Network.OAuth.OAuth2.TokenRequest (Errors) +import Network.OAuth.OAuth2.Compat (Error) import UnliftIO.Except () import UnliftIO.Exception import Yesod.Auth hiding (ServerError) @@ -31,7 +30,7 @@ data DispatchError | InvalidStateToken (Maybe Text) Text | InvalidCallbackUri Text | OAuth2HandshakeError ErrorResponse - | OAuth2ResultError (OAuth2Error Errors) + | OAuth2ResultError Error | FetchCredsIOException IOException | FetchCredsYesodOAuth2Exception YesodOAuth2Exception | OtherDispatchError Text @@ -45,37 +44,37 @@ data DispatchError -- dispatchErrorMessage :: DispatchError -> Text dispatchErrorMessage = \case - MissingParameter name -> - "Parameter '" <> name <> "' is required, but not present in the URL" - InvalidStateToken{} -> "State token is invalid, please try again" - InvalidCallbackUri{} - -> "Callback URI was not valid, this server may be misconfigured (no approot)" - OAuth2HandshakeError er -> "OAuth2 handshake failure: " <> erUserMessage er - OAuth2ResultError{} -> "Login failed, please try again" - FetchCredsIOException{} -> "Login failed, please try again" - FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again" - OtherDispatchError{} -> "Login failed, please try again" + MissingParameter name -> + "Parameter '" <> name <> "' is required, but not present in the URL" + InvalidStateToken{} -> "State token is invalid, please try again" + InvalidCallbackUri{} -> + "Callback URI was not valid, this server may be misconfigured (no approot)" + OAuth2HandshakeError er -> "OAuth2 handshake failure: " <> erUserMessage er + OAuth2ResultError{} -> "Login failed, please try again" + FetchCredsIOException{} -> "Login failed, please try again" + FetchCredsYesodOAuth2Exception{} -> "Login failed, please try again" + OtherDispatchError{} -> "Login failed, please try again" handleDispatchError - :: MonadAuthHandler site m - => ExceptT DispatchError m TypedContent - -> m TypedContent + :: MonadAuthHandler site m + => ExceptT DispatchError m TypedContent + -> m TypedContent handleDispatchError f = do - result <- runExceptT f - either onDispatchError pure result + result <- runExceptT f + either onDispatchError pure result onDispatchError :: MonadAuthHandler site m => DispatchError -> m TypedContent onDispatchError err = do - errorId <- liftIO $ randomText 16 - let suffix = " [errorId=" <> errorId <> "]" - $(logError) $ pack (displayException err) <> suffix + errorId <- liftIO $ randomText 16 + let suffix = " [errorId=" <> errorId <> "]" + $(logError) $ pack (displayException err) <> suffix - let message = dispatchErrorMessage err <> suffix - messageValue = - object ["error" .= object ["id" .= errorId, "message" .= message]] + let message = dispatchErrorMessage err <> suffix + messageValue = + object ["error" .= object ["id" .= errorId, "message" .= message]] - loginR <- ($ LoginR) <$> getRouteToParent + loginR <- ($ LoginR) <$> getRouteToParent - selectRep $ do - provideRep @_ @Html $ onErrorHtml loginR message - provideRep @_ @Value $ pure messageValue + selectRep $ do + provideRep @_ @Html $ onErrorHtml loginR message + provideRep @_ @Value $ pure messageValue