{-|
Module: IHP.ErrorController
Description:  Provides web-based error screens for runtime errors in IHP
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.ErrorController
( displayException
, errorHandlerMiddleware
, RouterException(..)
, InitContextException(..)
) where

import Prelude
import Control.Exception.Safe (SomeException, fromException, catch)
import Control.Monad (when)
import Data.Maybe (mapMaybe, fromMaybe, listToMaybe)
import Data.String.Conversions (cs)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import IHP.HaskellSupport (isEmpty, forEach, (|>))
import qualified IHP.Controller.Param as Param
import qualified IHP.Router.Types as Router
import qualified Network.HTTP.Types.Method as Router
import qualified Control.Exception as Exception
import Data.Text (Text)
import Wai.Request.Params.Middleware (Respond)
import Network.HTTP.Types (Status, status404, status500, status400)
import Network.Wai (Request, Middleware, Response, ResponseReceived, responseBuilder, responseLBS, queryString, requestHeaders, vault)
import Network.HTTP.Types.Header
import qualified Network.HTTP.Media as Accept
import qualified Data.Aeson as Aeson
import Data.Aeson ((.=))

import IHP.HSX.Markup (Markup, MarkupM(..), ToHtml(..), getBuilder)
import qualified Database.PostgreSQL.Simple as PG
import qualified Hasql.Errors as HasqlErrors
import qualified Hasql.Pool as HasqlPool

import IHP.HSX.MarkupQQ (hsx)
import qualified IHP.ModelSupport as ModelSupport
import IHP.FrameworkConfig
import qualified IHP.Environment as Environment
import IHP.Controller.Context
import IHP.Controller.NotFound (handleNotFound, buildNotFoundResponse)
import qualified IHP.Log as Log
import IHP.Log (writeLog)
import IHP.Log.Types (LogLevel(..))
import IHP.ActionType (actionTypeVaultKey)
import qualified Data.Vault.Lazy as Vault

tshow :: Show a => a -> Text
tshow :: forall a. Show a => a -> Text
tshow = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Wrapper for exceptions that occur during routing.
-- This allows the error handler middleware to distinguish routing errors
-- from action errors and display appropriate error messages.
newtype RouterException = RouterException SomeException
    deriving (Int -> RouterException -> ShowS
[RouterException] -> ShowS
RouterException -> String
(Int -> RouterException -> ShowS)
-> (RouterException -> String)
-> ([RouterException] -> ShowS)
-> Show RouterException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RouterException -> ShowS
showsPrec :: Int -> RouterException -> ShowS
$cshow :: RouterException -> String
show :: RouterException -> String
$cshowList :: [RouterException] -> ShowS
showList :: [RouterException] -> ShowS
Show)

instance Exception.Exception RouterException

-- | Wrapper for exceptions that occur during 'initContext'.
-- This allows the error handler middleware to show "while calling initContext"
-- in the error message, helping developers locate the source of the problem.
newtype InitContextException = InitContextException SomeException
    deriving (Int -> InitContextException -> ShowS
[InitContextException] -> ShowS
InitContextException -> String
(Int -> InitContextException -> ShowS)
-> (InitContextException -> String)
-> ([InitContextException] -> ShowS)
-> Show InitContextException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitContextException -> ShowS
showsPrec :: Int -> InitContextException -> ShowS
$cshow :: InitContextException -> String
show :: InitContextException -> String
$cshowList :: [InitContextException] -> ShowS
showList :: [InitContextException] -> ShowS
Show)

instance Exception.Exception InitContextException

-- | Returns 'True' only when the request's Accept header explicitly prefers
-- @application/json@ over @text/html@. @Accept: */*@ or a missing header
-- stay on the HTML path (the browser-friendly default).
--
-- The server options are listed with @text/html@ first so that ties
-- (equal quality and specificity) resolve to HTML — this covers
-- @Accept: */*@ (curl's default, fetch() without custom headers) and
-- @Accept: text/html, application/json@ (typical browser ordering).
-- JSON wins only when the client excludes HTML or gives it a lower
-- q-value.
wantsJsonResponse :: Request -> Bool
wantsJsonResponse :: Request -> Bool
wantsJsonResponse Request
request =
    case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept (Request -> [(HeaderName, ByteString)]
requestHeaders Request
request) of
        Maybe ByteString
Nothing -> Bool
False
        Just ByteString
accept ->
            [(MediaType, Bool)] -> ByteString -> Maybe Bool
forall b. [(MediaType, b)] -> ByteString -> Maybe b
Accept.mapAcceptMedia
                [ (MediaType
"text/html", Bool
False)
                , (MediaType
"application/json", Bool
True)
                ] ByteString
accept Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True

-- | Render an error response, picking HTML or JSON based on the Accept header.
--
-- Callers provide both the HTML markup (title + body, rendered via 'renderError')
-- and a JSON payload. The JSON path uses 'responseLBS' with @application/json@;
-- the HTML path mirrors the existing 'responseBuilder'/'renderError' pipeline.
respondError
    :: Request
    -> Environment.Environment
    -> Status
    -> Markup
    -> Markup
    -> Aeson.Value
    -> IO Response
respondError :: Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status Markup
title Markup
body Value
json
  | Request -> Bool
wantsJsonResponse Request
request =
        Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status
            [(HeaderName
hContentType, ByteString
"application/json")]
            (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
json)
  | Bool
otherwise =
        Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status
            [(HeaderName
hContentType, ByteString
"text/html")]
            (Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder (Environment -> Markup -> Markup -> Markup
renderError Environment
environment Markup
title Markup
body))

displayException :: (Show action, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => SomeException -> action -> Text -> IO ResponseReceived
displayException :: forall action.
(Show action, ?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
SomeException -> action -> Text -> IO ResponseReceived
displayException SomeException
exception action
action Text
additionalInfo = do
    -- Dev handlers display helpful tips on how to resolve the problem
    let devHandlers :: [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
devHandlers =
            [ SomeException -> action -> Text -> Maybe (IO ResponseReceived)
forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
postgresHandler
            , SomeException -> action -> Text -> Maybe (IO ResponseReceived)
forall controller.
(Show controller, ?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
paramNotFoundExceptionHandler
            , SomeException -> action -> Text -> Maybe (IO ResponseReceived)
forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
patternMatchFailureHandler
            , SomeException -> action -> Text -> Maybe (IO ResponseReceived)
forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
recordNotFoundExceptionHandlerDev
            ]

    -- Prod handlers should not leak any information about the system
    let prodHandlers :: [SomeException
 -> controller -> Text -> Maybe (IO ResponseReceived)]
prodHandlers =
            [ SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
forall controller.
(?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
recordNotFoundExceptionHandlerProd
            ]

    let allHandlers :: [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
allHandlers = if ?context::ControllerContext
ControllerContext
?context.frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
            then [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
devHandlers
            else [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
forall {controller}.
[SomeException
 -> controller -> Text -> Maybe (IO ResponseReceived)]
prodHandlers

    let supportingHandlers :: [IO ResponseReceived]
supportingHandlers = [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
allHandlers [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
-> ([SomeException
     -> action -> Text -> Maybe (IO ResponseReceived)]
    -> [IO ResponseReceived])
-> [IO ResponseReceived]
forall a b. a -> (a -> b) -> b
|> ((SomeException -> action -> Text -> Maybe (IO ResponseReceived))
 -> Maybe (IO ResponseReceived))
-> [SomeException -> action -> Text -> Maybe (IO ResponseReceived)]
-> [IO ResponseReceived]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\SomeException -> action -> Text -> Maybe (IO ResponseReceived)
f -> SomeException -> action -> Text -> Maybe (IO ResponseReceived)
f SomeException
exception action
action Text
additionalInfo)

    let displayGenericError :: IO ResponseReceived
displayGenericError = SomeException -> action -> Text -> IO ResponseReceived
forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> IO ResponseReceived
genericHandler SomeException
exception action
action Text
additionalInfo


    -- Additionally to rendering the error message to the browser we also send it
    -- to the error tracking service (e.g. sentry). Usually this service also writes
    -- the error message to the stderr output
    --
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (?context::ControllerContext
ControllerContext
?context.frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Production) do
        let exceptionTracker :: Maybe Request -> SomeException -> IO ()
exceptionTracker = ?context::ControllerContext
ControllerContext
?context.frameworkConfig.exceptionTracker.onException
        Maybe Request -> SomeException -> IO ()
exceptionTracker (Request -> Maybe Request
forall a. a -> Maybe a
Just ?request::Request
Request
?request) SomeException
exception

    [IO ResponseReceived]
supportingHandlers
        [IO ResponseReceived]
-> ([IO ResponseReceived] -> Maybe (IO ResponseReceived))
-> Maybe (IO ResponseReceived)
forall a b. a -> (a -> b) -> b
|> [IO ResponseReceived] -> Maybe (IO ResponseReceived)
forall a. [a] -> Maybe a
listToMaybe
        Maybe (IO ResponseReceived)
-> (Maybe (IO ResponseReceived) -> IO ResponseReceived)
-> IO ResponseReceived
forall a b. a -> (a -> b) -> b
|> IO ResponseReceived
-> Maybe (IO ResponseReceived) -> IO ResponseReceived
forall a. a -> Maybe a -> a
fromMaybe IO ResponseReceived
displayGenericError

-- | Responds to all exceptions with a generic error message.
--
-- In dev mode the action and exception is added to the output.
-- In production mode nothing is specific is communicated about the exception
genericHandler :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => Exception.SomeException -> controller -> Text -> IO ResponseReceived
genericHandler :: forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> IO ResponseReceived
genericHandler SomeException
exception controller
controller Text
additionalInfo = do
    let errorMessageText :: Text
errorMessageText = Text
"An exception was raised while running the action " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> controller -> Text
forall a. Show a => a -> Text
tshow controller
controller Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
additionalInfo
    let errorMessageTitle :: String
errorMessageTitle = SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception

    let devErrorMessage :: Markup
devErrorMessage = [hsx|{errorMessageText}|]
    let devTitle :: Markup
devTitle = [hsx|{errorMessageTitle}|]

    Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.error (Text
errorMessageText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
errorMessageTitle)

    let prodErrorMessage :: Markup
prodErrorMessage = [hsx|An exception was raised while running the action|]
    let prodTitle :: Markup
prodTitle = [hsx|An error happened|]

    let (Markup
errorMessage, Markup
errorTitle) = if ?context::ControllerContext
ControllerContext
?context.frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
            then (Markup
devErrorMessage, Markup
devTitle)
            else (Markup
prodErrorMessage, Markup
prodTitle)

    ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError ?context::ControllerContext
ControllerContext
?context.frameworkConfig.environment Markup
errorTitle Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)

postgresHandler :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
postgresHandler :: forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
postgresHandler SomeException
exception controller
controller Text
additionalInfo = do
    let
        handlePostgresOutdatedError :: Text -> Markup -> IO ResponseReceived
        handlePostgresOutdatedError :: Text -> Markup -> IO ResponseReceived
handlePostgresOutdatedError Text
errorDetail Markup
errorText = do
            let ihpIdeBaseUrl :: Text
ihpIdeBaseUrl = ?context::ControllerContext
ControllerContext
?context.frameworkConfig.ideBaseUrl
            let title :: Markup
title = [hsx|Database looks outdated. {errorText}|]
            let errorMessage :: Markup
errorMessage = [hsx|
                        <h2>Possible Solutions</h2>
                        <div style="margin-bottom: 2rem; font-weight: 400;">
                            Have you clicked on
                            <form method="POST" action={ihpIdeBaseUrl <> "/NewMigration"} target="_blank" style="display: inline">
                                <button type="submit">Migrate DB</button>
                            </form>
                            after updating the Schema?
                        </div>

                        <h2>Details</h2>
                        <p style="font-size: 16px">The exception was raised while running the action: {tshow controller}{additionalInfo}</p>
                        <p style="font-family: monospace; font-size: 16px">{errorDetail}</p>
                    |]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)

        handleServerError :: Text -> [Text] -> HasqlErrors.ServerError -> IO ResponseReceived
        handleServerError :: Text -> [Text] -> ServerError -> IO ResponseReceived
handleServerError Text
sql [Text]
params (HasqlErrors.ServerError Text
code Text
msg Maybe Text
detail Maybe Text
hint Maybe Int
_position) = do
            let title :: Markup
title = [hsx|{msg}|]
            let detailSection :: Markup
detailSection = case Maybe Text
detail of
                    Just Text
d  -> [hsx|<p style="font-size: 16px"><strong>Detail:</strong> {d}</p>|]
                    Maybe Text
Nothing -> Markup
forall a. Monoid a => a
mempty
            let hintSection :: Markup
hintSection = case Maybe Text
hint of
                    Just Text
h  -> [hsx|<p style="font-size: 16px"><strong>Hint:</strong> {h}</p>|]
                    Maybe Text
Nothing -> Markup
forall a. Monoid a => a
mempty
            let paramsText :: Text
paramsText = Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
params
            let errorMessage :: Markup
errorMessage = [hsx|
                        <h2>While running the following query:</h2>
                        <div style="margin-bottom: 2rem; font-weight: 400;">
                            <pre class="ihp-error-code">{sql}</pre>
                        </div>

                        <h2>With parameters:</h2>
                        <div style="margin-bottom: 2rem; font-weight: 400;">
                            <code>{paramsText}</code>
                        </div>

                        {detailSection}
                        {hintSection}

                        <p style="font-size: 14px; font-family: monospace;">PostgreSQL error code: {code}</p>

                        <h2>Details:</h2>
                        <p style="font-size: 16px">The exception was raised while running the action: {tshow controller}{additionalInfo}</p>
                    |]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)

        handleSessionError :: HasqlErrors.SessionError -> IO ResponseReceived
        handleSessionError :: SessionError -> IO ResponseReceived
handleSessionError SessionError
sessionError = do
            let title :: Markup
title = [hsx|PostgreSQL Error|]
            let errorMessage :: Markup
errorMessage = [hsx|
                        <h2>Details:</h2>
                        <p style="font-size: 16px">The exception was raised while running the action: {tshow controller}{additionalInfo}</p>
                        <pre class="ihp-error-code">{tshow sessionError}</pre>
                    |]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)

    case SomeException -> Maybe HasqlError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (ModelSupport.HasqlError (HasqlPool.SessionUsageError SessionError
sessionError)) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just case SessionError
sessionError of
            -- Statement with a ServerError
            HasqlErrors.StatementSessionError Int
_pipelineSize Int
_stmtIdx Text
sql [Text]
params Bool
_prepared (HasqlErrors.ServerStatementError serverError :: ServerError
serverError@(HasqlErrors.ServerError Text
code Text
_msg Maybe Text
_ Maybe Text
_ Maybe Int
_))
                -- 42P01 = undefined_table ("relation ... does not exist")
                | Text
code Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"42P01" -> Text -> Markup -> IO ResponseReceived
handlePostgresOutdatedError (ServerError -> Text
forall a. Show a => a -> Text
tshow ServerError
serverError) Markup
"A table is missing."
                -- 42703 = undefined_column ("column ... does not exist")
                | Text
code Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"42703" -> Text -> Markup -> IO ResponseReceived
handlePostgresOutdatedError (ServerError -> Text
forall a. Show a => a -> Text
tshow ServerError
serverError) Markup
"A column is missing."
                -- All other server errors on statements
                | Bool
otherwise -> Text -> [Text] -> ServerError -> IO ResponseReceived
handleServerError Text
sql [Text]
params ServerError
serverError
            -- Script (multi-statement) with a ServerError
            HasqlErrors.ScriptSessionError Text
sql serverError :: ServerError
serverError@(HasqlErrors.ServerError Text
code Text
_msg Maybe Text
_ Maybe Text
_ Maybe Int
_)
                | Text
code Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"42P01" -> Text -> Markup -> IO ResponseReceived
handlePostgresOutdatedError (ServerError -> Text
forall a. Show a => a -> Text
tshow ServerError
serverError) Markup
"A table is missing."
                | Text
code Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"42703" -> Text -> Markup -> IO ResponseReceived
handlePostgresOutdatedError (ServerError -> Text
forall a. Show a => a -> Text
tshow ServerError
serverError) Markup
"A column is missing."
                | Bool
otherwise -> Text -> [Text] -> ServerError -> IO ResponseReceived
handleServerError Text
sql [] ServerError
serverError
            -- Any other session error (connection errors, type mismatches, etc.)
            SessionError
other -> SessionError -> IO ResponseReceived
handleSessionError SessionError
other
        Just (ModelSupport.HasqlError UsageError
_otherUsageError) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just do
            let title :: Markup
title = [hsx|Database Connection Error|]
            let errorMessage :: Markup
errorMessage = [hsx|
                        <h2>Details:</h2>
                        <p style="font-size: 16px">The exception was raised while running the action: {tshow controller}{additionalInfo}</p>
                        <pre class="ihp-error-code">{tshow _otherUsageError}</pre>
                    |]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)
        Maybe HasqlError
Nothing -> Maybe (IO ResponseReceived)
forall a. Maybe a
Nothing

patternMatchFailureHandler :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
patternMatchFailureHandler :: forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
patternMatchFailureHandler SomeException
exception controller
controller Text
additionalInfo = do
    case SomeException -> Maybe PatternMatchFail
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (PatternMatchFail
exception :: Exception.PatternMatchFail) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just do
            let (Text
controllerPath, Text
_) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
":" (PatternMatchFail -> Text
forall a. Show a => a -> Text
tshow PatternMatchFail
exception)
            let errorMessage :: Markup
errorMessage = [hsx|
                    <h2>Possible Solutions</h2>
                    <p>a) Maybe the action function is missing for {tshow controller}? You can fix this by adding an action handler like this to the controller '{controllerPath}':</p>
                    <pre>{codeSample}</pre>
                    <p style="margin-bottom: 2rem">b) A pattern match like 'let (Just value) = ...' failed. Please see the details section.</p>

                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]
                    where
                        codeSample :: Text
codeSample = Text
"    action (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> controller -> Text
forall a. Show a => a -> Text
tshow controller
controller Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") = do\n        renderPlain \"Hello World\""

            let title :: Markup
title = [hsx|Pattern match failed while executing {tshow controller}|]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)
        Maybe PatternMatchFail
Nothing -> Maybe (IO ResponseReceived)
forall a. Maybe a
Nothing

-- Handler for 'IHP.Controller.Param.ParamNotFoundException'
-- Only used in dev mode of the app.

paramNotFoundExceptionHandler :: (Show controller, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
paramNotFoundExceptionHandler :: forall controller.
(Show controller, ?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
paramNotFoundExceptionHandler SomeException
exception controller
controller Text
additionalInfo = do
    case SomeException -> Maybe ParamException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (exception :: ParamException
exception@(Param.ParamNotFoundException ByteString
paramName)) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just do
            let (Text
controllerPath, Text
_) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
":" (ParamException -> Text
forall a. Show a => a -> Text
tshow ParamException
exception)

            let renderParam :: (a, a) -> Markup
renderParam (a
paramName, a
paramValue) = [hsx|<li>{paramName}: {paramValue}</li>|]
            let solutionHint :: Markup
solutionHint =
                    if Query -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty Query
(?request::Request) => Query
Param.allParams
                        then [hsx|
                                This action was called without any parameters at all.
                                You can pass this parameter by appending <code>?{paramName}=someValue</code> to the URL.
                            |]
                        else [hsx|
                            <p>The following parameters are provided by the request:</p>
                            <ul>{forEach Param.allParams renderParam}</ul>

                            <p>a) Is there a typo in your call to <code>param {tshow paramName}</code>?</p>
                            <p>b) You can pass this parameter by appending <code>&{paramName}=someValue</code> to the URL.</p>
                            <p>c) You can pass this parameter using a form input like <code>{"<input type=\"text\" name=\"" <> paramName <> "\"/>" :: ByteString}</code>.</p>
                        |]
            let errorMessage :: Markup
errorMessage = [hsx|
                    <h2>
                        This exception was caused by a call to <code>param {tshow paramName}</code> in {tshow controller}.
                    </h2>
                    <p>
                        A request parameter is just a query parameter like <code>/MyAction?someParameter=someValue&secondParameter=1</code>
                        or a form input when the request was submitted from a html form or via ajax.
                    </p>
                    <h2>Possible Solutions:</h2>
                    {solutionHint}

                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]



            let title :: Markup
title = [hsx|Parameter <q>{paramName}</q> not found in the request|]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)
        Just (exception :: ParamException
exception@(Param.ParamCouldNotBeParsedException { ByteString
name :: ByteString
name :: ParamException -> ByteString
name, ByteString
parserError :: ByteString
parserError :: ParamException -> ByteString
parserError })) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just do
            let (Text
controllerPath, Text
_) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
":" (ParamException -> Text
forall a. Show a => a -> Text
tshow ParamException
exception)

            let renderParam :: (a, a) -> Markup
renderParam (a
paramName, a
paramValue) = [hsx|<li>{paramName}: {paramValue}</li>|]
            let errorMessage :: Markup
errorMessage = [hsx|
                    <h2>
                        This exception was caused by a call to <code>param {tshow name}</code> in {tshow controller}.
                    </h2>
                    <p>
                        Here's the error output from the parser: {parserError}
                    </p>

                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]



            let title :: Markup
title = [hsx|Parameter <q>{name}</q> was invalid|]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)
        Maybe ParamException
Nothing -> Maybe (IO ResponseReceived)
forall a. Maybe a
Nothing

-- Handler for 'IHP.ModelSupport.RecordNotFoundException'
--
-- Used only in development mode of the app.
recordNotFoundExceptionHandlerDev :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
recordNotFoundExceptionHandlerDev :: forall controller.
(Show controller, ?context::ControllerContext,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
recordNotFoundExceptionHandlerDev SomeException
exception controller
controller Text
additionalInfo =
    case SomeException -> Maybe RecordNotFoundException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (exception :: RecordNotFoundException
exception@(ModelSupport.RecordNotFoundException { Text
queryAndParams :: Text
queryAndParams :: RecordNotFoundException -> Text
queryAndParams })) -> IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just do
            let (Text
controllerPath, Text
_) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
":" (RecordNotFoundException -> Text
forall a. Show a => a -> Text
tshow RecordNotFoundException
exception)
            let errorMessage :: Markup
errorMessage = [hsx|
                    <p>
                        The following SQL was executed:
                        <pre class="ihp-error-code">{queryAndParams}</pre>
                    </p>

                    <p>
                        This exception was caused by a call to <code>fetchOne</code> in {tshow controller}.
                    </p>

                    <h2>Possible Solutions:</h2>

                    <p>
                        a) Use <span class="ihp-error-inline-code">fetchOneOrNothing</span>. This will return a <span class="ihp-error-inline-code">Nothing</span>
                        when no results are returned by the database.
                    </p>

                    <p>
                        b) Make sure the the data you are querying is actually there.
                    </p>


                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]



            let title :: Markup
title = [hsx|Call to fetchOne failed. No records returned.|]
            ?respond::Respond
Respond
?respond Respond -> Respond
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
status500 [(HeaderName
hContentType, ByteString
"text/html")] ((Environment -> Markup -> Markup -> Markup
renderError Environment
Environment.Development Markup
title Markup
errorMessage) Markup -> (Markup -> Builder) -> Builder
forall a b. a -> (a -> b) -> b
|> Markup -> Builder
forall {k} (a :: k). MarkupM a -> Builder
getBuilder)
        Maybe RecordNotFoundException
Nothing -> Maybe (IO ResponseReceived)
forall a. Maybe a
Nothing

-- Handler for 'IHP.ModelSupport.RecordNotFoundException'
--
-- Used only in production mode of the app. The exception is handled by calling 'handleNotFound'
recordNotFoundExceptionHandlerProd :: (?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
recordNotFoundExceptionHandlerProd :: forall controller.
(?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
SomeException -> controller -> Text -> Maybe (IO ResponseReceived)
recordNotFoundExceptionHandlerProd SomeException
exception controller
controller Text
additionalInfo =
    case SomeException -> Maybe RecordNotFoundException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (exception :: RecordNotFoundException
exception@(ModelSupport.RecordNotFoundException {})) ->
            IO ResponseReceived -> Maybe (IO ResponseReceived)
forall a. a -> Maybe a
Just (Request -> Respond -> IO ResponseReceived
handleNotFound ?request::Request
Request
?request ?respond::Respond
Respond
?respond)
        Maybe RecordNotFoundException
Nothing -> Maybe (IO ResponseReceived)
forall a. Maybe a
Nothing

renderError :: Environment.Environment -> Markup -> Markup -> Markup
renderError :: Environment -> Markup -> Markup -> Markup
renderError Environment
environment Markup
errorTitle Markup
view = [hsx|
<!DOCTYPE html>
<html lang="en">
    <head>
        <meta charset="utf-8"/>
        <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no"/>

        <title>IHP Error</title>
        <style>
            * { -webkit-font-smoothing: antialiased }
            h2 {
                color: white;
                font-size: 1.25rem;
            }
            body {
                margin: 0;
                font-family: -apple-system, BlinkMacSystemFont, "Segoe UI", "Roboto", "Helvetica Neue", Arial, sans-serif;
            }

            body a {
                color: hsla(196, 13%, 80%, 1);
            }

            .ihp-error-other-solutions {
                margin-top: 2rem;
                padding-top: 0.5rem;
                font-size: 1rem;
                color: hsla(196, 13%, 80%, 1);
                border-top: 1px solid hsla(196, 13%, 60%, 0.4);
            }

            .ihp-error-other-solutions a {
                color: hsla(196, 13%, 80%, 0.9);
                text-decoration: none !important;
                margin-right: 1rem;
                font-size: 0.8rem;
            }
            .ihp-error-other-solutions a:hover {
                color: hsla(196, 13%, 80%, 1);
            }

            .ihp-error-inline-code, .ihp-error-code {
                background-color: rgba(0, 43, 54, 0.5);
                color: white;
                border-radius: 3px;
            }

            .ihp-error-code {
                padding: 1rem;
                overflow-x: auto;
            }

            .ihp-error-inline-code {
                padding: 3px;
                font-family: monospace;
            }
        </style>
    </head>
    <body>
        <div style="background-color: #657b83; padding-top: 2rem; padding-bottom: 2rem; color:hsla(196, 13%, 96%, 1)">
            <div style="max-width: 800px; margin-left: auto; margin-right: auto">
                <h1 style="margin-bottom: 2rem; font-size: 2rem; font-weight: 500; border-bottom: 1px solid white; padding-bottom: 0.25rem; border-color: hsla(196, 13%, 60%, 1)">{errorTitle}</h1>
                <div style="margin-top: 1rem; font-size: 1.25rem; color:hsla(196, 13%, 80%, 1)">
                    {view}
                </div>

                {when shouldShowHelpFooter helpFooter}
            </div>
        </div>
    </body>
</html>
    |]
        where
            shouldShowHelpFooter :: Bool
shouldShowHelpFooter = Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
            helpFooter :: Markup
helpFooter = [hsx|
                <div class="ihp-error-other-solutions">
                    <a href="https://stackoverflow.com/questions/tagged/ihp" target="_blank">Ask the IHP Community on StackOverflow</a>
                    <a href="https://github.com/digitallyinduced/ihp/wiki/Troubleshooting" target="_blank">Check the Troubleshooting</a>
                    <a href="https://github.com/digitallyinduced/ihp/issues/new" target="_blank">Open GitHub Issue</a>
                    <a href="https://ihp.digitallyinduced.com/Slack" target="_blank">Slack</a>
                    <a href="https://www.reddit.com/r/IHPFramework/" target="_blank">Reddit</a>
                    <a href="https://stackshare.io/ihp" target="_blank">StackShare</a>
                </div>
            |]

-- | Middleware that catches exceptions and displays appropriate error pages.
--
-- This middleware should be placed near the top of the middleware stack so it can
-- catch exceptions from controllers, routing, and other middleware.
errorHandlerMiddleware :: FrameworkConfig -> Middleware
errorHandlerMiddleware :: FrameworkConfig -> Middleware
errorHandlerMiddleware FrameworkConfig
frameworkConfig Request -> Respond -> IO ResponseReceived
app Request
request Respond
respond =
    Request -> Respond -> IO ResponseReceived
app Request
request Respond
respond IO ResponseReceived
-> (SomeException -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
exception :: SomeException) -> do
        let environment :: Environment
environment = FrameworkConfig
frameworkConfig.environment
        let actionType :: Maybe ActionType
actionType = Key ActionType -> Vault -> Maybe ActionType
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key ActionType
actionTypeVaultKey (Request -> Vault
vault Request
request)
        let actionDescription :: Text
actionDescription = Text -> (ActionType -> Text) -> Maybe ActionType -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\(ActionType TypeRep
t) -> Text
" while running " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a. Show a => a -> Text
tshow TypeRep
t) Maybe ActionType
actionType

        -- Unwrap InitContextException to get the inner exception and add context
        let (SomeException
actualException, Text
fullDescription) = case SomeException -> Maybe InitContextException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                Just (InitContextException SomeException
inner) -> (SomeException
inner, Text
actionDescription Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" while calling initContext")
                Maybe InitContextException
Nothing -> (SomeException
exception, Text
actionDescription)

        -- Call exception tracker in production
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Production) do
            FrameworkConfig
frameworkConfig.exceptionTracker.onException (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
request) SomeException
actualException

        response <- FrameworkConfig -> Request -> SomeException -> Text -> IO Response
handleExceptionMiddleware FrameworkConfig
frameworkConfig Request
request SomeException
actualException Text
fullDescription
        respond response

-- | Handle an exception and return an appropriate Response.
--
-- This is used by the error handler middleware.
handleExceptionMiddleware :: FrameworkConfig -> Request -> SomeException -> Text -> IO Response
handleExceptionMiddleware :: FrameworkConfig -> Request -> SomeException -> Text -> IO Response
handleExceptionMiddleware FrameworkConfig
frameworkConfig Request
request SomeException
exception Text
actionDescription = do
    let environment :: Environment
environment = FrameworkConfig
frameworkConfig.environment

    -- Dev handlers display helpful tips on how to resolve the problem
    let devHandlers :: [SomeException -> Maybe (IO Response)]
devHandlers =
            [ FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
routerExceptionHandlerMiddleware FrameworkConfig
frameworkConfig Request
request
            , FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
postgresHandlerMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription
            , FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
paramNotFoundExceptionHandlerMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription
            , FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
patternMatchFailureHandlerMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription
            , FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
recordNotFoundExceptionHandlerDevMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription
            ]

    -- Prod handlers should not leak any information about the system
    let prodHandlers :: [SomeException -> Maybe (IO Response)]
prodHandlers =
            [ FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
routerExceptionHandlerMiddleware FrameworkConfig
frameworkConfig Request
request
            , FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
recordNotFoundExceptionHandlerProdMiddleware FrameworkConfig
frameworkConfig Request
request
            ]

    let allHandlers :: [SomeException -> Maybe (IO Response)]
allHandlers = if Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
            then [SomeException -> Maybe (IO Response)]
devHandlers
            else [SomeException -> Maybe (IO Response)]
prodHandlers

    let supportingHandlers :: [IO Response]
supportingHandlers = [SomeException -> Maybe (IO Response)]
allHandlers [SomeException -> Maybe (IO Response)]
-> ([SomeException -> Maybe (IO Response)] -> [IO Response])
-> [IO Response]
forall a b. a -> (a -> b) -> b
|> ((SomeException -> Maybe (IO Response)) -> Maybe (IO Response))
-> [SomeException -> Maybe (IO Response)] -> [IO Response]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\SomeException -> Maybe (IO Response)
f -> SomeException -> Maybe (IO Response)
f SomeException
exception)

    let displayGenericError :: IO Response
displayGenericError = FrameworkConfig -> Request -> SomeException -> Text -> IO Response
genericHandlerMiddleware FrameworkConfig
frameworkConfig Request
request SomeException
exception Text
actionDescription

    [IO Response]
supportingHandlers
        [IO Response]
-> ([IO Response] -> Maybe (IO Response)) -> Maybe (IO Response)
forall a b. a -> (a -> b) -> b
|> [IO Response] -> Maybe (IO Response)
forall a. [a] -> Maybe a
listToMaybe
        Maybe (IO Response)
-> (Maybe (IO Response) -> IO Response) -> IO Response
forall a b. a -> (a -> b) -> b
|> IO Response -> Maybe (IO Response) -> IO Response
forall a. a -> Maybe a -> a
fromMaybe IO Response
displayGenericError

-- | Generic error handler for middleware - returns a Response
genericHandlerMiddleware :: FrameworkConfig -> Request -> Exception.SomeException -> Text -> IO Response
genericHandlerMiddleware :: FrameworkConfig -> Request -> SomeException -> Text -> IO Response
genericHandlerMiddleware FrameworkConfig
frameworkConfig Request
request SomeException
exception Text
actionDescription = do
    let environment :: Environment
environment = FrameworkConfig
frameworkConfig.environment
    let errorMessageText :: Text
errorMessageText = Text
"An exception was raised" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription
    let errorMessageTitle :: String
errorMessageTitle = SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception

    let devErrorMessage :: Markup
devErrorMessage = [hsx|{errorMessageText}|]
    let devTitle :: Markup
devTitle = [hsx|{errorMessageTitle}|]

    LogLevel -> Logger -> Text -> IO ()
forall string.
ToLogStr string =>
LogLevel -> Logger -> string -> IO ()
writeLog LogLevel
Error FrameworkConfig
frameworkConfig.logger (Text
errorMessageText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
errorMessageTitle)

    let prodErrorMessage :: Markup
prodErrorMessage = [hsx|An exception was raised while running the action|]
    let prodTitle :: Markup
prodTitle = [hsx|An error happened|]

    let (Markup
errorMessage, Markup
errorTitle, Value
jsonPayload) = if Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
            then
                ( Markup
devErrorMessage
                , Markup
devTitle
                , [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
errorMessageTitle
                    , 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
errorMessageText
                    ]
                )
            else
                ( Markup
prodErrorMessage
                , Markup
prodTitle
                , [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"An error happened" :: Text)
                    , 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
"An exception was raised while running the action" :: Text)
                    ]
                )

    Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status500 Markup
errorTitle Markup
errorMessage Value
jsonPayload

-- | Postgres error handler for middleware - returns Maybe (IO Response)
postgresHandlerMiddleware :: FrameworkConfig -> Request -> Text -> SomeException -> Maybe (IO Response)
postgresHandlerMiddleware :: FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
postgresHandlerMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription SomeException
exception = do
    let
        handlePostgresOutdatedError :: Show exception => exception -> Text -> IO Response
        handlePostgresOutdatedError :: forall exception.
Show exception =>
exception -> Text -> IO Response
handlePostgresOutdatedError exception
exception Text
errorText = do
            let ihpIdeBaseUrl :: Text
ihpIdeBaseUrl = FrameworkConfig
frameworkConfig.ideBaseUrl
            let title :: Markup
title = [hsx|Database looks outdated. {errorText}|]
            let errorMessage :: Markup
errorMessage = [hsx|
                        <h2>Possible Solutions</h2>
                        <div style="margin-bottom: 2rem; font-weight: 400;">
                            Have you clicked on
                            <form method="POST" action={ihpIdeBaseUrl <> "/NewMigration"} target="_blank" style="display: inline">
                                <button type="submit">Migrate DB</button>
                            </form>
                            after updating the Schema?
                        </div>

                        <h2>Details</h2>
                        <p style="font-size: 16px">The exception was raised{actionDescription}</p>
                        <p style="font-family: monospace; font-size: 16px">{tshow exception}</p>
                    |]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Database looks outdated" :: Text)
                    , Key
"reason" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
errorText
                    , 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
"The exception was raised" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription)
                    , Key
"detail" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= exception -> Text
forall a. Show a => a -> Text
tshow exception
exception
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
Environment.Development Status
status500 Markup
title Markup
errorMessage Value
json

        handleSqlError :: ModelSupport.EnhancedSqlError -> IO Response
        handleSqlError :: EnhancedSqlError -> IO Response
handleSqlError EnhancedSqlError
exception = do
            let sqlError :: SqlError
sqlError = EnhancedSqlError
exception.sqlError
            let title :: Markup
title = [hsx|{sqlError.sqlErrorMsg}|]
            let errorMessage :: Markup
errorMessage = [hsx|
                        <h2>While running the following Query:</h2>
                        <div style="margin-bottom: 2rem; font-weight: 400;">
                            <code>{exception.sqlErrorQuery}</code>
                        </div>

                        <h2>With Query Parameters:</h2>
                        <div style="margin-bottom: 2rem; font-weight: 400;">
                            <code>{exception.sqlErrorQueryParams}</code>
                        </div>

                        <h2>Details:</h2>
                        <p style="font-size: 16px">The exception was raised{actionDescription}</p>
                        <p style="font-family: monospace; font-size: 16px">{tshow exception}</p>
                    |]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient SqlError
sqlError.sqlErrorMsg
                    , Key
"query" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Query -> Text
forall a. Show a => a -> Text
tshow EnhancedSqlError
exception.sqlErrorQuery
                    , Key
"params" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EnhancedSqlError
exception.sqlErrorQueryParams
                    , 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
"The exception was raised" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription)
                    , Key
"detail" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EnhancedSqlError -> Text
forall a. Show a => a -> Text
tshow EnhancedSqlError
exception
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
Environment.Development Status
status500 Markup
title Markup
errorMessage Value
json

    case SomeException -> Maybe ResultError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (ResultError
exception :: PG.ResultError) -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just (ResultError -> Text -> IO Response
forall exception.
Show exception =>
exception -> Text -> IO Response
handlePostgresOutdatedError ResultError
exception Text
"The database result does not match the expected type.")
        Maybe ResultError
Nothing -> case SomeException -> Maybe EnhancedSqlError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
            -- Catching  `relation "..." does not exist`
            Just exception :: EnhancedSqlError
exception@ModelSupport.EnhancedSqlError { SqlError
sqlError :: SqlError
sqlError :: EnhancedSqlError -> SqlError
sqlError }
                |  ByteString
"relation" ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` (SqlError
sqlError.sqlErrorMsg)
                Bool -> Bool -> Bool
&& ByteString
"does not exist" ByteString -> ByteString -> Bool
`ByteString.isSuffixOf` (SqlError
sqlError.sqlErrorMsg)
                -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just (EnhancedSqlError -> Text -> IO Response
forall exception.
Show exception =>
exception -> Text -> IO Response
handlePostgresOutdatedError EnhancedSqlError
exception Text
"A table is missing.")

            -- Catching  `columns "..." does not exist`
            Just exception :: EnhancedSqlError
exception@ModelSupport.EnhancedSqlError { SqlError
sqlError :: EnhancedSqlError -> SqlError
sqlError :: SqlError
sqlError }
                |  ByteString
"column" ByteString -> ByteString -> Bool
`ByteString.isPrefixOf` (SqlError
sqlError.sqlErrorMsg)
                Bool -> Bool -> Bool
&& ByteString
"does not exist" ByteString -> ByteString -> Bool
`ByteString.isSuffixOf` (SqlError
sqlError.sqlErrorMsg)
                -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just (EnhancedSqlError -> Text -> IO Response
forall exception.
Show exception =>
exception -> Text -> IO Response
handlePostgresOutdatedError EnhancedSqlError
exception Text
"A column is missing.")
            -- Catching other SQL Errors
            Just EnhancedSqlError
exception -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just (EnhancedSqlError -> IO Response
handleSqlError EnhancedSqlError
exception)
            Maybe EnhancedSqlError
Nothing -> Maybe (IO Response)
forall a. Maybe a
Nothing

-- | Pattern match failure handler for middleware - returns Maybe (IO Response)
patternMatchFailureHandlerMiddleware :: FrameworkConfig -> Request -> Text -> SomeException -> Maybe (IO Response)
patternMatchFailureHandlerMiddleware :: FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
patternMatchFailureHandlerMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription SomeException
exception = do
    case SomeException -> Maybe PatternMatchFail
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (PatternMatchFail
exception :: Exception.PatternMatchFail) -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just do
            let (Text
controllerPath, Text
_) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
":" (PatternMatchFail -> Text
forall a. Show a => a -> Text
tshow PatternMatchFail
exception)
            let errorMessage :: Markup
errorMessage = [hsx|
                    <h2>Possible Solutions</h2>
                    <p>a) Maybe the action function is missing? You can fix this by adding an action handler like this to the controller '{controllerPath}':</p>
                    <pre>{codeSample}</pre>
                    <p style="margin-bottom: 2rem">b) A pattern match like 'let (Just value) = ...' failed. Please see the details section.</p>

                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]
                    where
                        codeSample :: Text
codeSample = Text
"    action (MyAction) = do\n        renderPlain \"Hello World\"" :: Text

            let title :: Markup
title = [hsx|Pattern match failed{actionDescription}|]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Pattern match failed" :: Text)
                    , 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
"Pattern match failed" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription)
                    , Key
"details" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PatternMatchFail -> Text
forall a. Show a => a -> Text
tshow PatternMatchFail
exception
                    , Key
"controllerPath" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
controllerPath
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
Environment.Development Status
status500 Markup
title Markup
errorMessage Value
json
        Maybe PatternMatchFail
Nothing -> Maybe (IO Response)
forall a. Maybe a
Nothing

-- | Param not found handler for middleware - returns Maybe (IO Response)
paramNotFoundExceptionHandlerMiddleware :: FrameworkConfig -> Request -> Text -> SomeException -> Maybe (IO Response)
paramNotFoundExceptionHandlerMiddleware :: FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
paramNotFoundExceptionHandlerMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription SomeException
exception = do
    let allParams :: Query
allParams = Request -> Query
queryString Request
request
    let renderParam :: (a, Maybe a) -> Markup
renderParam (a
paramName, Maybe a
paramValue) = [hsx|<li>{paramName}: {fromMaybe "" paramValue}</li>|]
    case SomeException -> Maybe ParamException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (exception :: ParamException
exception@(Param.ParamNotFoundException ByteString
paramName)) -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just do
            let solutionHint :: Markup
solutionHint =
                    if Query -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty Query
allParams
                        then [hsx|
                                This action was called without any parameters at all.
                                You can pass this parameter by appending <code>?{paramName}=someValue</code> to the URL.
                            |]
                        else [hsx|
                            <p>The following parameters are provided by the request:</p>
                            <ul>{forEach allParams renderParam}</ul>

                            <p>a) Is there a typo in your call to <code>param {tshow paramName}</code>?</p>
                            <p>b) You can pass this parameter by appending <code>&{paramName}=someValue</code> to the URL.</p>
                            <p>c) You can pass this parameter using a form input like <code>{"<input type=\"text\" name=\"" <> paramName <> "\"/>" :: ByteString}</code>.</p>
                        |]
            let errorMessage :: Markup
errorMessage = [hsx|
                    <h2>
                        This exception was caused by a call to <code>param {tshow paramName}</code>{actionDescription}.
                    </h2>
                    <p>
                        A request parameter is just a query parameter like <code>/MyAction?someParameter=someValue&secondParameter=1</code>
                        or a form input when the request was submitted from a html form or via ajax.
                    </p>
                    <h2>Possible Solutions:</h2>
                    {solutionHint}

                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]

            let title :: Markup
title = [hsx|Parameter <q>{paramName}</q> not found in the request|]
            let availableParams :: [Text]
availableParams = ((ByteString, Maybe ByteString) -> Text) -> Query -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
n, Maybe ByteString
_) -> ByteString -> Text
Text.decodeUtf8Lenient ByteString
n) Query
allParams
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Parameter not found" :: Text)
                    , Key
"param" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
paramName
                    , Key
"availableParams" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Text]
availableParams
                    , 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
"The exception was raised by a call to param " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Show a => a -> Text
tshow ByteString
paramName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription)
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
Environment.Development Status
status500 Markup
title Markup
errorMessage Value
json
        Just (exception :: ParamException
exception@(Param.ParamCouldNotBeParsedException { ByteString
name :: ParamException -> ByteString
name :: ByteString
name, ByteString
parserError :: ParamException -> ByteString
parserError :: ByteString
parserError })) -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just do
            let errorMessage :: Markup
errorMessage = [hsx|
                    <h2>
                        This exception was caused by a call to <code>param {tshow name}</code>{actionDescription}.
                    </h2>
                    <p>
                        Here's the error output from the parser: {parserError}
                    </p>

                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]

            let title :: Markup
title = [hsx|Parameter <q>{name}</q> was invalid|]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Parameter invalid" :: Text)
                    , Key
"param" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
name
                    , Key
"parserError" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
parserError
                    , 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
"The exception was raised by a call to param " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Show a => a -> Text
tshow ByteString
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription)
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
Environment.Development Status
status500 Markup
title Markup
errorMessage Value
json
        Maybe ParamException
Nothing -> Maybe (IO Response)
forall a. Maybe a
Nothing

-- | Record not found handler for middleware (dev mode) - returns Maybe (IO Response)
recordNotFoundExceptionHandlerDevMiddleware :: FrameworkConfig -> Request -> Text -> SomeException -> Maybe (IO Response)
recordNotFoundExceptionHandlerDevMiddleware :: FrameworkConfig
-> Request -> Text -> SomeException -> Maybe (IO Response)
recordNotFoundExceptionHandlerDevMiddleware FrameworkConfig
frameworkConfig Request
request Text
actionDescription SomeException
exception =
    case SomeException -> Maybe RecordNotFoundException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (exception :: RecordNotFoundException
exception@(ModelSupport.RecordNotFoundException { Text
queryAndParams :: RecordNotFoundException -> Text
queryAndParams :: Text
queryAndParams })) -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just do
            let errorMessage :: Markup
errorMessage = [hsx|
                    <p>
                        The following SQL was executed:
                        <pre class="ihp-error-code">{queryAndParams}</pre>
                    </p>

                    <p>
                        This exception was caused by a call to <code>fetchOne</code>{actionDescription}.
                    </p>

                    <h2>Possible Solutions:</h2>

                    <p>
                        a) Use <span class="ihp-error-inline-code">fetchOneOrNothing</span>. This will return a <span class="ihp-error-inline-code">Nothing</span>
                        when no results are returned by the database.
                    </p>

                    <p>
                        b) Make sure the the data you are querying is actually there.
                    </p>


                    <h2>Details</h2>
                    <p style="font-size: 16px">{exception}</p>
                |]

            let title :: Markup
title = [hsx|Call to fetchOne failed. No records returned.|]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Call to fetchOne failed. No records returned." :: Text)
                    , Key
"queryAndParams" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
queryAndParams
                    , 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
"The exception was raised by a call to fetchOne" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actionDescription)
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
Environment.Development Status
status500 Markup
title Markup
errorMessage Value
json
        Maybe RecordNotFoundException
Nothing -> Maybe (IO Response)
forall a. Maybe a
Nothing

-- | Record not found handler for middleware (prod mode) - returns Maybe (IO Response)
recordNotFoundExceptionHandlerProdMiddleware :: FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
recordNotFoundExceptionHandlerProdMiddleware :: FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
recordNotFoundExceptionHandlerProdMiddleware FrameworkConfig
frameworkConfig Request
request SomeException
exception =
    case SomeException -> Maybe RecordNotFoundException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (exception :: RecordNotFoundException
exception@(ModelSupport.RecordNotFoundException {})) -> IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just (IO Response -> Maybe (IO Response))
-> IO Response -> Maybe (IO Response)
forall a b. (a -> b) -> a -> b
$
            if Request -> Bool
wantsJsonResponse Request
request
                then Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> ByteString -> Response
responseLBS Status
status404
                        [(HeaderName
hContentType, ByteString
"application/json")]
                        (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode ([Pair] -> Value
Aeson.object [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Not found" :: Text) ]))
                else IO Response
buildNotFoundResponse
        Maybe RecordNotFoundException
Nothing -> Maybe (IO Response)
forall a. Maybe a
Nothing

-- | Router exception handler for middleware - returns Maybe (IO Response)
--
-- Handles exceptions thrown during routing. These are wrapped in RouterException
-- by frontControllerToWAIApp to distinguish them from action exceptions.
routerExceptionHandlerMiddleware :: FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
routerExceptionHandlerMiddleware :: FrameworkConfig -> Request -> SomeException -> Maybe (IO Response)
routerExceptionHandlerMiddleware FrameworkConfig
frameworkConfig Request
request SomeException
exception =
    let environment :: Environment
environment = FrameworkConfig
frameworkConfig.environment
    in case SomeException -> Maybe RouterException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just (RouterException SomeException
innerException) ->
            -- This is a router exception - handle specific types or show generic "Routing failed"
            IO Response -> Maybe (IO Response)
forall a. a -> Maybe a
Just (IO Response -> Maybe (IO Response))
-> IO Response -> Maybe (IO Response)
forall a b. (a -> b) -> a -> b
$ Request -> Environment -> SomeException -> IO Response
handleRouterExceptionImpl Request
request Environment
environment SomeException
innerException
        Maybe RouterException
Nothing ->
            -- Not a router exception
            Maybe (IO Response)
forall a. Maybe a
Nothing

-- | Implementation for handling unwrapped router exceptions
handleRouterExceptionImpl :: Request -> Environment.Environment -> SomeException -> IO Response
handleRouterExceptionImpl :: Request -> Environment -> SomeException -> IO Response
handleRouterExceptionImpl Request
request Environment
environment SomeException
exception =
    case SomeException -> Maybe TypedAutoRouteError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
        Just Router.NoConstructorMatched { ByteString
expectedType :: ByteString
expectedType :: TypedAutoRouteError -> ByteString
expectedType, Maybe ByteString
value :: Maybe ByteString
value :: TypedAutoRouteError -> Maybe ByteString
value, ByteString
field :: ByteString
field :: TypedAutoRouteError -> ByteString
field } -> do
            let routingError :: Markup
routingError = if Environment
environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Environment.Development
                then [hsx|<p>Routing failed with: {tshow exception}</p>|]
                else Markup
""

            let errorMessage :: Markup
errorMessage = [hsx|
                    { routingError }

                    <h2>Possible Solutions</h2>
                    <p>You can pass this parameter by appending <code>&{field}=someValue</code> to the URL.</p>
                |]

            let title :: Markup
title = case Maybe ByteString
value of
                    Just ByteString
value -> [hsx|Expected <strong>{expectedType}</strong> for field <strong>{field}</strong> but got <q>{value}</q>|]
                    Maybe ByteString
Nothing -> [hsx|The action was called without the required <q>{field}</q> parameter|]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Routing failed" :: Text)
                    , Key
"expectedType" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
expectedType
                    , Key
"field" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
field
                    , Key
"value" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8Lenient Maybe ByteString
value
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status400 Markup
title Markup
errorMessage Value
json
        Just Router.BadType { ByteString
expectedType :: TypedAutoRouteError -> ByteString
expectedType :: ByteString
expectedType, value :: TypedAutoRouteError -> Maybe ByteString
value = Just ByteString
value, ByteString
field :: TypedAutoRouteError -> ByteString
field :: ByteString
field } -> do
            let errorMessage :: Markup
errorMessage = [hsx|
                    <p>Routing failed with: {tshow exception}</p>
                |]
            let title :: Markup
title = [hsx|Query parameter <q>{field}</q> needs to be a <q>{expectedType}</q> but got <q>{value}</q>|]
            let json :: Value
json = [Pair] -> Value
Aeson.object
                    [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Routing failed" :: Text)
                    , Key
"field" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
field
                    , Key
"expectedType" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
expectedType
                    , Key
"value" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8Lenient ByteString
value
                    ]
            Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status400 Markup
title Markup
errorMessage Value
json
        Maybe TypedAutoRouteError
_ -> case SomeException -> Maybe UnexpectedMethodException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
            Just Router.UnexpectedMethodException { allowedMethods :: UnexpectedMethodException -> [StdMethod]
allowedMethods = [StdMethod
Router.DELETE], method :: UnexpectedMethodException -> StdMethod
method = StdMethod
Router.GET } -> do
                let Text
exampleLink :: Text = Text
"<a href={DeleteProjectAction} class=\"js-delete\">Delete Project</a>"
                let Text
formExample :: Text = Text
"<form method=\"POST\" action={DeleteProjectAction}>\n    <input type=\"hidden\" name=\"_method\" value=\"DELETE\"/>\n    <button type=\"submit\">Delete Project</button>\n</form>"
                let errorMessage :: Markup
errorMessage = [hsx|
                        <p>
                            You cannot directly link to Delete Action.
                            GET requests should not have any external side effects, as a user could accidentally trigger it by following a normal link.
                        </p>

                        <h2>Possible Solutions</h2>
                        <p>
                            a) Add a <code>js-delete</code> class to your link. IHP's helper.js will intercept link clicks on these links and use a form with a DELETE request to submit the request.
                            <br /><br/>

                            Example: <br /><br />
                            <code>{exampleLink}</code>
                        </p>
                        <p>
                            b) Use a form to submit the request as a DELETE request:
                            <br /><br/>

                            Example: <br />
                            <pre>{formExample}</pre>
                            HTML forms don't support DELETE requests natively, therefore we use the hidden input field to work around this browser limitation.
                        </p>
                    |]
                let title :: Markup
title = [hsx|Action was called from a GET request, but needs to be called as a DELETE request|]
                let json :: Value
json = [Pair] -> Value
Aeson.object
                        [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Unexpected HTTP method" :: Text)
                        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StdMethod -> Text
forall a. Show a => a -> Text
tshow StdMethod
Router.GET
                        , Key
"allowedMethods" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [StdMethod -> Text
forall a. Show a => a -> Text
tshow StdMethod
Router.DELETE]
                        ]
                Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status400 Markup
title Markup
errorMessage Value
json
            Just Router.UnexpectedMethodException { allowedMethods :: UnexpectedMethodException -> [StdMethod]
allowedMethods = [StdMethod
Router.POST], method :: UnexpectedMethodException -> StdMethod
method = StdMethod
Router.GET } -> do
                let errorMessage :: Markup
errorMessage = [hsx|
                        <p>
                            You cannot directly link to Create Action.
                            GET requests should not have any external side effects, as a user could accidentally trigger it by following a normal link.
                        </p>

                        <h2>Possible Solutions</h2>
                        <p>
                            <a style="text-decoration: none" href="https://ihp.digitallyinduced.com/Guide/form.html" target="_blank">Make a form with <code>formFor</code> to do the request</a>
                        </p>
                    |]
                let title :: Markup
title = [hsx|Action was called from a GET request, but needs to be called as a POST request|]
                let json :: Value
json = [Pair] -> Value
Aeson.object
                        [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Unexpected HTTP method" :: Text)
                        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StdMethod -> Text
forall a. Show a => a -> Text
tshow StdMethod
Router.GET
                        , Key
"allowedMethods" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [StdMethod -> Text
forall a. Show a => a -> Text
tshow StdMethod
Router.POST]
                        ]
                Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status400 Markup
title Markup
errorMessage Value
json
            Just Router.UnexpectedMethodException { [StdMethod]
allowedMethods :: UnexpectedMethodException -> [StdMethod]
allowedMethods :: [StdMethod]
allowedMethods, StdMethod
method :: UnexpectedMethodException -> StdMethod
method :: StdMethod
method } -> do
                let errorMessage :: Markup
errorMessage = [hsx|
                        <p>Routing failed with: {tshow exception}</p>
                        <h2>Possible Solutions</h2>
                        <p>
                            <a style="text-decoration: none" href="https://ihp.digitallyinduced.com/Guide/form.html" target="_blank">Make a form with <code>formFor</code> to do the request</a>
                        </p>
                    |]
                let title :: Markup
title = [hsx|Action was called with a {method} request, but needs to be called with one of these request methods: <q>{allowedMethods}</q>|]
                let json :: Value
json = [Pair] -> Value
Aeson.object
                        [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Unexpected HTTP method" :: Text)
                        , Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StdMethod -> Text
forall a. Show a => a -> Text
tshow StdMethod
method
                        , Key
"allowedMethods" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (StdMethod -> Text) -> [StdMethod] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map StdMethod -> Text
forall a. Show a => a -> Text
tshow [StdMethod]
allowedMethods
                        ]
                Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status400 Markup
title Markup
errorMessage Value
json
            -- Fallback for any other exception during routing
            Maybe UnexpectedMethodException
_ -> do
                let errorMessage :: Markup
errorMessage = [hsx|
                        Routing failed with: {tshow exception}

                        <h2>Possible Solutions</h2>
                        <p>Are you trying to do a DELETE action, but your link is missing class="js-delete"?</p>
                    |]
                let title :: Markup
title = Text -> Markup
forall a. ToHtml a => a -> Markup
toHtml (Text
"Routing failed" :: Text)
                let json :: Value
json = [Pair] -> Value
Aeson.object
                        [ Key
"error" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Routing failed" :: Text)
                        , Key
"detail" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
exception
                        ]
                Request
-> Environment
-> Status
-> Markup
-> Markup
-> Value
-> IO Response
respondError Request
request Environment
environment Status
status500 Markup
title Markup
errorMessage Value
json