DispatchError.hs

{-# 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 (TokenResponseError)
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 TokenResponseError
  | 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