mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-04-21 02:07:43 +02:00
Use CPP to get 2.7.0 to compile
This commit is contained in:
parent
17c778a47f
commit
cf43baac7a
@ -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)
|
||||||
|
|||||||
@ -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)
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user