{-# 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
(Int -> DispatchError -> ShowS)
-> (DispatchError -> String)
-> ([DispatchError] -> ShowS)
-> Show DispatchError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DispatchError -> ShowS
showsPrec :: Int -> DispatchError -> ShowS
$cshow :: DispatchError -> String
show :: DispatchError -> String
$cshowList :: [DispatchError] -> ShowS
showList :: [DispatchError] -> ShowS
Show)
  deriving anyclass (Show DispatchError
Typeable DispatchError
(Typeable DispatchError, Show DispatchError) =>
(DispatchError -> SomeException)
-> (SomeException -> Maybe DispatchError)
-> (DispatchError -> String)
-> Exception DispatchError
SomeException -> Maybe DispatchError
DispatchError -> String
DispatchError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: DispatchError -> SomeException
toException :: DispatchError -> SomeException
$cfromException :: SomeException -> Maybe DispatchError
fromException :: SomeException -> Maybe DispatchError
$cdisplayException :: DispatchError -> String
displayException :: DispatchError -> String
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 '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
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: " Text -> Text -> Text
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 <- ExceptT DispatchError m TypedContent
-> m (Either DispatchError TypedContent)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT DispatchError m TypedContent
f
  (DispatchError -> m TypedContent)
-> (TypedContent -> m TypedContent)
-> Either DispatchError TypedContent
-> m TypedContent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either DispatchError -> m TypedContent
forall site (m :: * -> *).
MonadAuthHandler site m =>
DispatchError -> m TypedContent
onDispatchError TypedContent -> m TypedContent
forall a. a -> m a
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 <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ Int -> IO Text
forall (m :: * -> *). MonadRandom m => Int -> m Text
randomText Int
16
  let suffix :: Text
suffix = Text
" [errorId=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errorId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
  $(logError) (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (DispatchError -> String
forall e. Exception e => e -> String
displayException DispatchError
err) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix

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

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

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