{-# 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 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