mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-11 19:58:28 +01:00
81 lines
2.6 KiB
Haskell
81 lines
2.6 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Yesod.Auth.OAuth2.DispatchError
|
|
( DispatchError (..)
|
|
, handleDispatchError
|
|
, onDispatchError
|
|
) where
|
|
|
|
import Control.Monad.Except
|
|
import Data.Text (Text, pack)
|
|
import Network.OAuth.OAuth2.Compat (Errors)
|
|
import UnliftIO.Except ()
|
|
import UnliftIO.Exception
|
|
import Yesod.Auth hiding (ServerError)
|
|
import Yesod.Auth.OAuth2.ErrorResponse
|
|
import Yesod.Auth.OAuth2.Exception
|
|
import Yesod.Auth.OAuth2.Random
|
|
import Yesod.Core hiding (ErrorResponse)
|
|
|
|
data DispatchError
|
|
= MissingParameter Text
|
|
| InvalidStateToken (Maybe Text) Text
|
|
| InvalidCallbackUri Text
|
|
| OAuth2HandshakeError ErrorResponse
|
|
| OAuth2ResultError Errors
|
|
| FetchCredsIOException IOException
|
|
| FetchCredsYesodOAuth2Exception YesodOAuth2Exception
|
|
| OtherDispatchError Text
|
|
deriving stock (Show)
|
|
deriving anyclass (Exception)
|
|
|
|
-- | User-friendly message for any given 'DispatchError'
|
|
--
|
|
-- Most of these are opaque to the user. The exception details are present for
|
|
-- the server logs.
|
|
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"
|
|
|
|
handleDispatchError
|
|
:: MonadAuthHandler site m
|
|
=> ExceptT DispatchError m TypedContent
|
|
-> m TypedContent
|
|
handleDispatchError f = do
|
|
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
|
|
|
|
let
|
|
message = dispatchErrorMessage err <> suffix
|
|
messageValue =
|
|
object ["error" .= object ["id" .= errorId, "message" .= message]]
|
|
|
|
loginR <- ($ LoginR) <$> getRouteToParent
|
|
|
|
selectRep $ do
|
|
provideRep @_ @Html $ onErrorHtml loginR message
|
|
provideRep @_ @Value $ pure messageValue
|