{-# 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 (Int -> DispatchError -> ShowS
[DispatchError] -> ShowS
DispatchError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DispatchError] -> ShowS
$cshowList :: [DispatchError] -> ShowS
show :: DispatchError -> String
$cshow :: DispatchError -> String
showsPrec :: Int -> DispatchError -> ShowS
$cshowsPrec :: Int -> DispatchError -> ShowS
Show)
  deriving anyclass (Show DispatchError
Typeable DispatchError
SomeException -> Maybe DispatchError
DispatchError -> String
DispatchError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: DispatchError -> String
$cdisplayException :: DispatchError -> String
fromException :: SomeException -> Maybe DispatchError
$cfromException :: SomeException -> Maybe DispatchError
toException :: DispatchError -> SomeException
$ctoException :: DispatchError -> SomeException
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 :: DispatchError -> Text
dispatchErrorMessage = \case
  MissingParameter Text
name ->
    Text
"Parameter '" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"' is required, but not present in the URL"
  InvalidStateToken {} -> Text
"State token is invalid, please try again"
  InvalidCallbackUri {} ->
    Text
"Callback URI was not valid, this server may be misconfigured (no approot)"
  OAuth2HandshakeError ErrorResponse
er -> Text
"OAuth2 handshake failure: " forall a. Semigroup a => a -> a -> a
<> ErrorResponse -> Text
erUserMessage ErrorResponse
er
  OAuth2ResultError {} -> Text
"Login failed, please try again"
  FetchCredsIOException {} -> Text
"Login failed, please try again"
  FetchCredsYesodOAuth2Exception {} -> Text
"Login failed, please try again"
  OtherDispatchError {} -> Text
"Login failed, please try again"

handleDispatchError
  :: MonadAuthHandler site m
  => ExceptT DispatchError m TypedContent
  -> m TypedContent
handleDispatchError :: forall site (m :: * -> *).
MonadAuthHandler site m =>
ExceptT DispatchError m TypedContent -> m TypedContent
handleDispatchError ExceptT DispatchError m TypedContent
f = do
  Either DispatchError TypedContent
result <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT DispatchError m TypedContent
f
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall site (m :: * -> *).
MonadAuthHandler site m =>
DispatchError -> m TypedContent
onDispatchError forall (f :: * -> *) a. Applicative f => a -> f a
pure Either DispatchError TypedContent
result

onDispatchError :: MonadAuthHandler site m => DispatchError -> m TypedContent
onDispatchError :: forall site (m :: * -> *).
MonadAuthHandler site m =>
DispatchError -> m TypedContent
onDispatchError DispatchError
err = do
  Text
errorId <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadRandom m => Int -> m Text
randomText Int
16
  let suffix :: Text
suffix = Text
" [errorId=" forall a. Semigroup a => a -> a -> a
<> Text
errorId forall a. Semigroup a => a -> a -> a
<> Text
"]"
  $(logError) forall a b. (a -> b) -> a -> b
$ String -> Text
pack (forall e. Exception e => e -> String
displayException DispatchError
err) forall a. Semigroup a => a -> a -> a
<> Text
suffix

  let
    message :: Text
message = DispatchError -> Text
dispatchErrorMessage DispatchError
err forall a. Semigroup a => a -> a -> a
<> Text
suffix
    messageValue :: Value
messageValue =
      [Pair] -> Value
object [Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
errorId, Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
message]]

  Route site
loginR <- (forall a b. (a -> b) -> a -> b
$ Route Auth
LoginR) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent

  forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep @_ @Html forall a b. (a -> b) -> a -> b
$ forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Route master -> Text -> m Html
onErrorHtml Route site
loginR Text
message
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep @_ @Value forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
messageValue