{-# 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
import Network.OAuth.OAuth2.TokenRequest (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 (OAuth2Error 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
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
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
displayException :: DispatchError -> String
$cdisplayException :: DispatchError -> String
fromException :: SomeException -> Maybe DispatchError
$cfromException :: SomeException -> Maybe DispatchError
toException :: DispatchError -> SomeException
$ctoException :: DispatchError -> SomeException
$cp2Exception :: Show DispatchError
$cp1Exception :: Typeable DispatchError
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure Either DispatchError TypedContent
result

onDispatchError :: MonadAuthHandler site m => DispatchError -> m TypedContent
onDispatchError :: DispatchError -> m TypedContent
onDispatchError DispatchError
err = do
    Text
errorId <- IO Text -> m Text
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
"]"
    $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> 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 [Text
"error" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object [Text
"id" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
errorId, Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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)
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
        (Monad m, HasContentType Html) =>
m Html -> Writer (Endo [ProvidedRep m]) ()
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
onErrorHtml Route site
loginR Text
message
        (Monad m, HasContentType Value) =>
m Value -> Writer (Endo [ProvidedRep m]) ()
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 (f :: * -> *) a. Applicative f => a -> f a
pure Value
messageValue