{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Network.Wai.Utilities.Server
  ( -- * Server Setup
    Server (..),
    defaultServer,
    newSettings,
    runSettingsWithShutdown,
    runSettingsWithCleanup,
    compile,
    route,

    -- * Middlewares
    requestIdMiddleware,
    catchErrors,
    catchErrorsWithRequestId,
    heavyDebugLogging,
    rethrow5xx,
    lazyResponseBody,

    -- * Utilities
    onError,
    logError,
    logError',
    logErrorMsg,
    flushRequestBody,

    -- * Constants
    defaultRequestIdHeaderName,
    federationRequestIdHeaderName,
  )
where

import Control.Error.Util ((?:))
import Control.Exception (AsyncException (..), throwIO)
import Control.Monad.Catch hiding (onError, onException)
import Data.Aeson (decode, encode)
import Data.ByteString (toStrict)
import Data.ByteString qualified as BS
import Data.ByteString.Builder
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Lazy qualified as LBS
import Data.Domain (domainText)
import Data.Metrics.GC (spawnGCMetricsCollector)
import Data.Streaming.Zlib (ZlibException (..))
import Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy.Encoding qualified as LT
import Data.UUID qualified as UUID
import Data.UUID.V4 qualified as UUID
import Imports
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.Warp.Internal (TimeoutThread)
import Network.Wai.Internal qualified as WaiInt
import Network.Wai.Predicate hiding (Error, err, status)
import Network.Wai.Predicate qualified as P
import Network.Wai.Routing.Route (App, Continue, Routes, Tree)
import Network.Wai.Routing.Route qualified as Route
import Network.Wai.Utilities.Error qualified as Error
import Network.Wai.Utilities.Error qualified as Wai
import Network.Wai.Utilities.JSONResponse
import Network.Wai.Utilities.Request (lookupRequestId)
import Network.Wai.Utilities.Response
import Prometheus qualified as Prom
import System.Logger qualified as Log
import System.Logger.Class hiding (Error, Settings, format)
import System.Posix.Signals (installHandler, sigINT, sigTERM)
import System.Posix.Signals qualified as Sig

--------------------------------------------------------------------------------
-- Server Setup

data Server = Server
  { Server -> String
serverHost :: String,
    Server -> Word16
serverPort :: Word16,
    Server -> Logger
serverLogger :: Logger,
    Server -> Maybe Int
serverTimeout :: Maybe Int
  }

defaultServer :: String -> Word16 -> Logger -> Server
defaultServer :: String -> Word16 -> Logger -> Server
defaultServer String
h Word16
p Logger
l = String -> Word16 -> Logger -> Maybe Int -> Server
Server String
h Word16
p Logger
l Maybe Int
forall a. Maybe a
Nothing

newSettings :: (MonadIO m) => Server -> m Settings
newSettings :: forall (m :: * -> *). MonadIO m => Server -> m Settings
newSettings (Server String
h Word16
p Logger
l Maybe Int
t) = do
  Settings -> m Settings
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Settings -> m Settings) -> Settings -> m Settings
forall a b. (a -> b) -> a -> b
$ HostPreference -> Settings -> Settings
setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString String
h)
      (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
setPort (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
p)
      (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Settings -> Settings
setBeforeMainLoop IO ()
logStart
      (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SockAddr -> IO Bool) -> Settings -> Settings
setOnOpen (IO Bool -> SockAddr -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> SockAddr -> IO Bool) -> IO Bool -> SockAddr -> IO Bool
forall a b. (a -> b) -> a -> b
$ IO ()
connStart IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
      (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SockAddr -> IO ()) -> Settings -> Settings
setOnClose (IO () -> SockAddr -> IO ()
forall a b. a -> b -> a
const IO ()
connEnd)
      (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Settings -> Settings
setTimeout (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
300 Maybe Int
t)
    (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
defaultSettings
  where
    connStart :: IO ()
connStart = Gauge -> IO ()
forall (m :: * -> *). MonadMonitor m => Gauge -> m ()
Prom.incGauge Gauge
netConnections
    connEnd :: IO ()
connEnd = Gauge -> IO ()
forall (m :: * -> *). MonadMonitor m => Gauge -> m ()
Prom.decGauge Gauge
netConnections
    logStart :: IO ()
logStart =
      Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.info Logger
l ((Msg -> Msg) -> IO ())
-> (Builder -> Msg -> Msg) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$
        ByteString -> Builder
val ByteString
"Listening on " Builder -> Builder -> Builder
forall a b. (ToBytes a, ToBytes b) => a -> b -> Builder
+++ String
h String -> Builder -> Builder
forall a b. (ToBytes a, ToBytes b) => a -> b -> Builder
+++ Char
':' Char -> Word16 -> Builder
forall a b. (ToBytes a, ToBytes b) => a -> b -> Builder
+++ Word16
p

{-# NOINLINE netConnections #-}
netConnections :: Prom.Gauge
netConnections :: Gauge
netConnections =
  Metric Gauge -> Gauge
forall s. Metric s -> s
Prom.unsafeRegister (Metric Gauge -> Gauge) -> Metric Gauge -> Gauge
forall a b. (a -> b) -> a -> b
$
    Info -> Metric Gauge
Prom.gauge
      Prom.Info
        { metricName :: Text
Prom.metricName = Text
"net_connections",
          metricHelp :: Text
Prom.metricHelp = Text
"Number of active connections"
        }

-- Run a WAI 'Application', initiating Warp's graceful shutdown
-- on receiving either the INT or TERM signals. After closing
-- the listen socket, Warp will be allowed to drain existing
-- connections up to the given number of seconds.
--
-- See also: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7681
runSettingsWithShutdown :: Settings -> Application -> Maybe Int -> IO ()
runSettingsWithShutdown :: Settings -> Application -> Maybe Int -> IO ()
runSettingsWithShutdown = IO () -> Settings -> Application -> Maybe Int -> IO ()
runSettingsWithCleanup (IO () -> Settings -> Application -> Maybe Int -> IO ())
-> IO () -> Settings -> Application -> Maybe Int -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- As above, but with an additional cleanup action that is called before the server shuts down.
runSettingsWithCleanup :: IO () -> Settings -> Application -> Maybe Int -> IO ()
runSettingsWithCleanup :: IO () -> Settings -> Application -> Maybe Int -> IO ()
runSettingsWithCleanup IO ()
cleanup Settings
s Application
app (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultShutdownTime -> Int
secs) = do
  IO ()
initialization
  let s' :: Settings
s' =
        (IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler IO () -> IO ()
catchSignals
          (Settings -> Settings)
-> (Settings -> Settings) -> Settings -> Settings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Settings -> Settings
setGracefulShutdownTimeout (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
secs)
          (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Settings
s
  Settings -> Application -> IO ()
runSettings Settings
s' Application
app
  where
    initialization :: IO ()
    initialization :: IO ()
initialization = do
      IO ()
spawnGCMetricsCollector
    catchSignals :: IO () -> IO ()
catchSignals IO ()
closeSocket = do
      IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT (IO () -> Handler
Sig.CatchOnce (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally IO ()
cleanup IO ()
closeSocket) Maybe SignalSet
forall a. Maybe a
Nothing
      IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigTERM (IO () -> Handler
Sig.CatchOnce (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally IO ()
cleanup IO ()
closeSocket) Maybe SignalSet
forall a. Maybe a
Nothing

defaultShutdownTime :: Int
defaultShutdownTime :: Int
defaultShutdownTime = Int
30

compile :: (Monad m) => Routes a m b -> Tree (App m)
compile :: forall (m :: * -> *) a b. Monad m => Routes a m b -> Tree (App m)
compile Routes a m b
routes = Routes a m b -> Tree (App m)
forall (m :: * -> *) a b. Monad m => Routes a m b -> Tree (App m)
Route.prepare (Renderer -> Routes a m ()
forall a (m :: * -> *). Renderer -> Routes a m ()
Route.renderer Renderer
forall {f :: * -> *}.
Applicative f =>
Error -> f (LByteString, ResponseHeaders)
predicateError Routes a m () -> Routes a m b -> Routes a m b
forall a b. Routes a m a -> Routes a m b -> Routes a m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Routes a m b
routes)
  where
    predicateError :: Error -> f (LByteString, ResponseHeaders)
predicateError Error
e = (LByteString, ResponseHeaders) -> f (LByteString, ResponseHeaders)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> LByteString
forall a. ToJSON a => a -> LByteString
encode (Error -> LByteString) -> Error -> LByteString
forall a b. (a -> b) -> a -> b
$ Status -> LText -> LText -> Error
Wai.mkError (Error -> Status
P.status Error
e) LText
"client-error" (Error -> LText
format Error
e), [(HeaderName, ByteString)
jsonContent])
    -- [label] 'source' reason: message
    format :: Error -> LText
format Error
e =
      let l :: Maybe Builder
l = [ByteString] -> Maybe Builder
labelStr ([ByteString] -> Maybe Builder) -> [ByteString] -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Error -> [ByteString]
labels Error
e
          s :: Maybe Builder
s = ByteString -> Builder
sourceStr (ByteString -> Builder) -> Maybe ByteString -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> Maybe ByteString
source Error
e
          r :: Maybe Builder
r = Reason -> Builder
forall {a}. IsString a => Reason -> a
reasonStr (Reason -> Builder) -> Maybe Reason -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> Maybe Reason
reason Error
e
          t :: Maybe ByteString
t = Error -> Maybe ByteString
message Error
e
       in case [Maybe Builder] -> [Builder]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Builder
l, Maybe Builder
s, Maybe Builder
r] of
            [] -> LText -> (ByteString -> LText) -> Maybe ByteString -> LText
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LText
"N/A" (OnDecodeError -> LByteString -> LText
LT.decodeUtf8With OnDecodeError
lenientDecode (LByteString -> LText)
-> (ByteString -> LByteString) -> ByteString -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LByteString
LBS.fromStrict) Maybe ByteString
t
            [Builder]
bs -> OnDecodeError -> LByteString -> LText
LT.decodeUtf8With OnDecodeError
lenientDecode (LByteString -> LText)
-> (Builder -> LByteString) -> Builder -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LByteString
toLazyByteString (Builder -> LText) -> Builder -> LText
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe ByteString -> Builder
messageStr Maybe ByteString
t
    labelStr :: [ByteString] -> Maybe Builder
labelStr [] = Maybe Builder
forall a. Maybe a
Nothing
    labelStr [ByteString]
ls =
      Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$
        Char -> Builder
char7 Char
'['
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString (ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"," [ByteString]
ls)
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
']'
          Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
' '
    sourceStr :: ByteString -> Builder
sourceStr ByteString
s = Char -> Builder
char7 Char
'\'' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\'' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
' '
    reasonStr :: Reason -> a
reasonStr Reason
NotAvailable = a
"required"
    reasonStr Reason
TypeError = a
"invalid"
    messageStr :: Maybe ByteString -> Builder
messageStr (Just ByteString
t) = Char -> Builder
char7 Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
t
    messageStr Maybe ByteString
Nothing = Builder
forall a. Monoid a => a
mempty

route :: (MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived
route :: forall (m :: * -> *).
MonadIO m =>
Tree (App m) -> Request -> Continue IO -> m ResponseReceived
route Tree (App m)
rt Request
rq Continue IO
k = Config
-> Tree (App m) -> Request -> Continue m -> m ResponseReceived
forall (m :: * -> *).
Monad m =>
Config
-> Tree (App m) -> Request -> Continue m -> m ResponseReceived
Route.routeWith (Response -> Config
Route.Config (Response -> Config) -> Response -> Config
forall a b. (a -> b) -> a -> b
$ Error -> Response
errorRs Error
noEndpoint) Tree (App m)
rt Request
rq (IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> m ResponseReceived)
-> Continue IO -> Continue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Continue IO
k)
  where
    noEndpoint :: Error
noEndpoint = Status -> LText -> LText -> Error
Wai.mkError Status
status404 LText
"no-endpoint" LText
"The requested endpoint does not exist"
{-# INLINEABLE route #-}

--------------------------------------------------------------------------------
-- Middlewares

requestIdMiddleware :: Logger -> HeaderName -> Middleware
requestIdMiddleware :: Logger -> HeaderName -> Middleware
requestIdMiddleware Logger
logger HeaderName
reqIdHeaderName Application
origApp Request
req Continue IO
responder =
  case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
reqIdHeaderName Request
req.requestHeaders of
    Just ByteString
_ -> Application
origApp Request
req Continue IO
responder
    Maybe ByteString
Nothing -> do
      ByteString
reqId <- Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (UUID -> Text) -> UUID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
UUID.toText (UUID -> ByteString) -> IO UUID -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request
req.rawPathInfo ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"/i/status", ByteString
"/i/metrics", ByteString
"/api-version"]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.info Logger
logger ((Msg -> Msg) -> IO ()) -> (Msg -> Msg) -> IO ()
forall a b. (a -> b) -> a -> b
$
          ByteString -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString
"generated a new request id for local request" :: ByteString)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request" ByteString
reqId
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"method" (Request -> ByteString
requestMethod Request
req)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"path" (Request -> ByteString
rawPathInfo Request
req)
      let reqWithId :: Request
reqWithId = Request
req {requestHeaders = (reqIdHeaderName, reqId) : req.requestHeaders}
      Application
origApp Request
reqWithId Continue IO
responder

catchErrors :: Logger -> HeaderName -> Middleware
catchErrors :: Logger -> HeaderName -> Middleware
catchErrors Logger
l HeaderName
reqIdHeaderName = (Request -> Maybe ByteString) -> Logger -> Middleware
catchErrorsWithRequestId (HeaderName -> Request -> Maybe ByteString
lookupRequestId HeaderName
reqIdHeaderName) Logger
l

-- | Create a middleware that catches exceptions and turns
-- them into appropriate 'Error' responses, thereby logging
-- as well as counting server errors (i.e. exceptions that
-- yield 5xx responses).
--
-- This does not log any 'Response' values with error status.
-- See 'catchErrors'.
catchErrorsWithRequestId ::
  (Request -> Maybe ByteString) ->
  Logger ->
  Middleware
catchErrorsWithRequestId :: (Request -> Maybe ByteString) -> Logger -> Middleware
catchErrorsWithRequestId Request -> Maybe ByteString
getRequestId Logger
l Application
app Request
req Continue IO
k =
  (Request -> Maybe ByteString) -> Logger -> Middleware
rethrow5xx Request -> Maybe ByteString
getRequestId Logger
l Application
app Request
req Continue IO
k IO ResponseReceived
-> (SomeException -> IO ResponseReceived) -> IO ResponseReceived
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> IO ResponseReceived
errorResponse
  where
    mReqId :: Maybe ByteString
mReqId = Request -> Maybe ByteString
getRequestId Request
req

    errorResponse :: SomeException -> IO ResponseReceived
    errorResponse :: SomeException -> IO ResponseReceived
errorResponse SomeException
ex = do
      Either Error JSONResponse
er <- SomeException
-> [Handler IO (Either Error JSONResponse)]
-> IO (Either Error JSONResponse)
forall a. SomeException -> [Handler IO a] -> IO a
runHandlers SomeException
ex [Handler IO (Either Error JSONResponse)]
errorHandlers
      Logger
-> Maybe ByteString
-> Request
-> Continue IO
-> Either Error JSONResponse
-> IO ResponseReceived
forall (m :: * -> *).
MonadIO m =>
Logger
-> Maybe ByteString
-> Request
-> Continue IO
-> Either Error JSONResponse
-> m ResponseReceived
onError Logger
l Maybe ByteString
mReqId Request
req Continue IO
k Either Error JSONResponse
er

{-# INLINEABLE catchErrors #-}

-- | Standard handlers for turning exceptions into appropriate
-- 'Error' responses.
errorHandlers :: [Handler IO (Either Wai.Error JSONResponse)]
errorHandlers :: [Handler IO (Either Error JSONResponse)]
errorHandlers =
  -- a Wai.Error can be converted to a JSONResponse, but doing so here would
  -- prevent us from logging the error cleanly later
  [ (JSONResponse -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((JSONResponse -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (JSONResponse -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \(JSONResponse
x :: JSONResponse) -> Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSONResponse -> Either Error JSONResponse
forall a b. b -> Either a b
Right JSONResponse
x),
    (Error -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((Error -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (Error -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \(Error
x :: Wai.Error) -> Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left Error
x),
    -- warp throws 'ThreadKilled' when the client is gone or when it thinks it's
    -- time to reap the worker thread. Here, there is no point trying to respond
    -- nicely and there is no point logging this as it happens regularly when a
    -- client just closes a long running connection without consuming the whole
    -- body.
    (AsyncException -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((AsyncException -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (AsyncException -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \(AsyncException
x :: AsyncException) ->
      case AsyncException
x of
        AsyncException
ThreadKilled -> AsyncException -> IO (Either Error JSONResponse)
forall e a. Exception e => e -> IO a
throwIO AsyncException
x
        AsyncException
_ ->
          Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error JSONResponse -> IO (Either Error JSONResponse))
-> (Error -> Either Error JSONResponse)
-> Error
-> IO (Either Error JSONResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left (Error -> IO (Either Error JSONResponse))
-> Error -> IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$
            Status -> LText -> LText -> Error
Wai.mkError Status
status500 LText
"server-error" LText
"Server Error",
    (InvalidRequest -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((InvalidRequest -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (InvalidRequest -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \(InvalidRequest
_ :: InvalidRequest) ->
      Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error JSONResponse -> IO (Either Error JSONResponse))
-> (Error -> Either Error JSONResponse)
-> Error
-> IO (Either Error JSONResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left (Error -> IO (Either Error JSONResponse))
-> Error -> IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$
        Status -> LText -> LText -> Error
Wai.mkError Status
status400 LText
"client-error" LText
"Invalid Request",
    (TimeoutThread -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((TimeoutThread -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (TimeoutThread -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \(TimeoutThread
_ :: TimeoutThread) ->
      Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error JSONResponse -> IO (Either Error JSONResponse))
-> (Error -> Either Error JSONResponse)
-> Error
-> IO (Either Error JSONResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left (Error -> IO (Either Error JSONResponse))
-> Error -> IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$
        Status -> LText -> LText -> Error
Wai.mkError Status
status408 LText
"client-error" LText
"Request Timeout",
    (ZlibException -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((ZlibException -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (ZlibException -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \case
      ZlibException (-3) ->
        Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error JSONResponse -> IO (Either Error JSONResponse))
-> (Error -> Either Error JSONResponse)
-> Error
-> IO (Either Error JSONResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left (Error -> IO (Either Error JSONResponse))
-> Error -> IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$
          Status -> LText -> LText -> Error
Wai.mkError Status
status400 LText
"client-error" LText
"Invalid request body compression"
      ZlibException Int
_ ->
        Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error JSONResponse -> IO (Either Error JSONResponse))
-> (Error -> Either Error JSONResponse)
-> Error
-> IO (Either Error JSONResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left (Error -> IO (Either Error JSONResponse))
-> Error -> IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$
          Status -> LText -> LText -> Error
Wai.mkError Status
status500 LText
"server-error" LText
"Server Error",
    (SomeException -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> IO (Either Error JSONResponse))
 -> Handler IO (Either Error JSONResponse))
-> (SomeException -> IO (Either Error JSONResponse))
-> Handler IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) ->
      Either Error JSONResponse -> IO (Either Error JSONResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error JSONResponse -> IO (Either Error JSONResponse))
-> (Error -> Either Error JSONResponse)
-> Error
-> IO (Either Error JSONResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error JSONResponse
forall a b. a -> Either a b
Left (Error -> IO (Either Error JSONResponse))
-> Error -> IO (Either Error JSONResponse)
forall a b. (a -> b) -> a -> b
$
        Status -> LText -> LText -> Error
Wai.mkError Status
status500 LText
"server-error" LText
"Server Error"
  ]
{-# INLINE errorHandlers #-}

-- | If the log level is less sensitive than 'Debug' just call the underlying app unchanged.
-- Otherwise, pull a copy of the request body before running it, and if response status is @>=
-- 400@, log the entire request, including the body.
--
-- The request sanitizer is called on the 'Request' and its body before it is being logged,
-- giving you a chance to erase any confidential information.
--
-- WARNINGS:
--
--  * This may log confidential information if contained in the request.  Use the sanitizer to
--    avoid that.
--  * This does not catch any exceptions in the underlying app, so consider calling
--    'catchErrors' before this.
--  * Be careful with trying this in production: this puts a performance penalty on every
--    request (unless level is less sensitive than 'Debug').
heavyDebugLogging ::
  ((Request, LByteString) -> Maybe (Request, LByteString)) ->
  Level ->
  Logger ->
  HeaderName ->
  Middleware
heavyDebugLogging :: ((Request, LByteString) -> Maybe (Request, LByteString))
-> Level -> Logger -> HeaderName -> Middleware
heavyDebugLogging (Request, LByteString) -> Maybe (Request, LByteString)
sanitizeReq Level
lvl Logger
lgr HeaderName
reqIdHeaderName Application
app = \Request
req Continue IO
cont -> do
  (LByteString
bdy, Request
req') <-
    if Level
lvl Level -> [Level] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Level
Trace, Level
Debug]
      then Request -> IO (LByteString, Request)
cloneBody Request
req
      else (LByteString, Request) -> IO (LByteString, Request)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LByteString
"body omitted because log level was less sensitive than Debug", Request
req)
  Application
app Request
req' (Continue IO -> IO ResponseReceived)
-> Continue IO -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
    Maybe (Request, LByteString)
-> ((Request, LByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Request, LByteString) -> Maybe (Request, LByteString)
sanitizeReq (Request
req', LByteString
bdy)) (((Request, LByteString) -> IO ()) -> IO ())
-> ((Request, LByteString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Request
req'', LByteString
bdy') ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode (Response -> Status
responseStatus Response
resp) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
400) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> LByteString -> Response -> IO ()
logMostlyEverything Request
req'' LByteString
bdy' Response
resp
    Continue IO
cont Response
resp
  where
    cloneBody :: Request -> IO (LByteString, Request)
    cloneBody :: Request -> IO (LByteString, Request)
cloneBody Request
req = do
      LByteString
bdy <- Request -> IO LByteString
lazyRequestBody Request
req
      IO ByteString
requestBody' <- LByteString -> IO (IO ByteString)
emitLByteString LByteString
bdy
      (LByteString, Request) -> IO (LByteString, Request)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LByteString
bdy, Request
req {requestBody = requestBody'})
    logMostlyEverything :: Request -> LByteString -> Response -> IO ()
    logMostlyEverything :: Request -> LByteString -> Response -> IO ()
logMostlyEverything Request
req LByteString
bdy Response
resp = Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.debug Logger
lgr Msg -> Msg
logMsg
      where
        logMsg :: Msg -> Msg
logMsg =
          ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request" (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"N/A" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request -> Maybe ByteString
lookupRequestId HeaderName
reqIdHeaderName Request
req)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request_details" (Request -> String
forall a. Show a => a -> String
show Request
req)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request_body" LByteString
bdy
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"response_status" (Status -> String
forall a. Show a => a -> String
show (Status -> String) -> Status -> String
forall a b. (a -> b) -> a -> b
$ Response -> Status
responseStatus Response
resp)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"response_headers" (ResponseHeaders -> String
forall a. Show a => a -> String
show (ResponseHeaders -> String) -> ResponseHeaders -> String
forall a b. (a -> b) -> a -> b
$ Response -> ResponseHeaders
responseHeaders Response
resp)
            (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"full request details")

-- | Compute a stream from a lazy bytestring suitable for putting into the 'Response'.  This
-- can be used if we want to take a look at the body in a 'Middleware' *after* the request has
-- been processed and the stream flushed.
--
-- This implementation returns the entire body in the first stream chunk.  An alternative,
-- possibly faster implementation would be this:
--
-- >>> emitLByteString lbs = do
-- >>>     chunks <- TVar.newTVarIO (LBS.toChunks lbs)
-- >>>     pure $ do
-- >>>         nextChunk <- atomically $ do
-- >>>             xs <- TVar.readTVar chunks
-- >>>             case xs of
-- >>>                 [] -> pure Nothing
-- >>>                 (x:xs') -> TVar.writeTVar chunks xs' >> pure (Just x)
-- >>>         pure $ fromMaybe "" nextChunk
emitLByteString :: LByteString -> IO (IO ByteString)
emitLByteString :: LByteString -> IO (IO ByteString)
emitLByteString LByteString
lbs = do
  TVar ByteString
tvar <- ByteString -> IO (TVar ByteString)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (LByteString -> ByteString
toStrict LByteString
lbs)
  -- Emit the bytestring on the first read, then always return "" on subsequent reads
  IO ByteString -> IO (IO ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ByteString -> IO (IO ByteString))
-> (STM ByteString -> IO ByteString)
-> STM ByteString
-> IO (IO ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ByteString -> IO (IO ByteString))
-> STM ByteString -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ TVar ByteString -> ByteString -> STM ByteString
forall a. TVar a -> a -> STM a
swapTVar TVar ByteString
tvar ByteString
forall a. Monoid a => a
mempty

-- | Run the 'Application'; check the response status; if >=500, throw a 'Wai.Error' with
-- label @"server-error"@ and the body as the error message.
rethrow5xx :: (Request -> Maybe ByteString) -> Logger -> Middleware
rethrow5xx :: (Request -> Maybe ByteString) -> Logger -> Middleware
rethrow5xx Request -> Maybe ByteString
getRequestId Logger
logger Application
app Request
req Continue IO
k = Application
app Request
req Continue IO
k'
  where
    k' :: Continue IO
k' resp :: Response
resp@WaiInt.ResponseRaw {} = do
      -- See Note [Raw Response]
      let logMsg :: Msg -> Msg
logMsg =
            ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"canoncalpath" ([Text] -> String
forall a. Show a => a -> String
show ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req)
              (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"rawpath" (Request -> ByteString
rawPathInfo Request
req)
              (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request" (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"N/A" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
getRequestId Request
req)
              (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"ResponseRaw - cannot collect metrics or log info on errors")
      Logger -> Level -> (Msg -> Msg) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Log.log Logger
logger Level
Log.Debug Msg -> Msg
logMsg
      Continue IO
k Response
resp
    k' Response
resp = do
      let st :: Status
st = Response -> Status
responseStatus Response
resp
      if Status -> Int
statusCode Status
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
500
        then Continue IO
k Response
resp
        else do
          LByteString
rsbody <- IO LByteString -> IO LByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Response -> IO LByteString
lazyResponseBody Response
resp)
          Error -> IO ResponseReceived
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (Error -> IO ResponseReceived) -> Error -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> LByteString -> Error
wrapError Status
st LByteString
rsbody

-- | Wrap the body of an HTTP error into a Wai.Error structure.
--
-- If the error is already a JSON serialisation of a Wai.Error, avoid creating
-- an unnecessary wrapper.
wrapError :: Status -> LByteString -> Wai.Error
wrapError :: Status -> LByteString -> Error
wrapError Status
st LByteString
body =
  LByteString -> Maybe Error
forall a. FromJSON a => LByteString -> Maybe a
decode LByteString
body Maybe Error -> Error -> Error
forall a. Maybe a -> a -> a
?:
    Status -> LText -> LText -> Error
Wai.mkError Status
st LText
"server-error" (OnDecodeError -> LByteString -> LText
LT.decodeUtf8With OnDecodeError
lenientDecode LByteString
body)

-- | This flushes the response!  If you want to keep using the response, you need to construct
-- a new one with a fresh body stream.
lazyResponseBody :: Response -> IO LByteString
lazyResponseBody :: Response -> IO LByteString
lazyResponseBody Response
rs = case Response
-> (Status, ResponseHeaders, (StreamingBody -> IO ()) -> IO ())
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
rs of
  (Status
_, ResponseHeaders
_, (StreamingBody -> IO ()) -> IO ()
cont :: (StreamingBody -> IO ()) -> IO ()) -> do
    IORef Builder
bref <- Builder -> IO (IORef Builder)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
    let pushstream :: Builder -> IO ()
pushstream Builder
builder = IORef Builder -> (Builder -> Builder) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Builder
bref (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
builder)
    (StreamingBody -> IO ()) -> IO ()
cont ((StreamingBody -> IO ()) -> IO ())
-> (StreamingBody -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StreamingBody
streamingBody ->
      StreamingBody
streamingBody Builder -> IO ()
pushstream (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    Builder -> LByteString
toLazyByteString (Builder -> LByteString) -> IO Builder -> IO LByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Builder -> IO Builder
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Builder
bref

--------------------------------------------------------------------------------
-- Utilities

-- | Send an 'Error' response.
onError ::
  (MonadIO m) =>
  Logger ->
  Maybe ByteString ->
  Request ->
  Continue IO ->
  Either Wai.Error JSONResponse ->
  m ResponseReceived
onError :: forall (m :: * -> *).
MonadIO m =>
Logger
-> Maybe ByteString
-> Request
-> Continue IO
-> Either Error JSONResponse
-> m ResponseReceived
onError Logger
g Maybe ByteString
mReqId Request
r Continue IO
k Either Error JSONResponse
e = IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> m ResponseReceived)
-> IO ResponseReceived -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
  case Either Error JSONResponse
e of
    Left Error
we -> Logger -> Maybe ByteString -> Error -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Maybe ByteString -> Error -> m ()
logError' Logger
g Maybe ByteString
mReqId Error
we
    Right JSONResponse
jr -> Logger -> Maybe ByteString -> JSONResponse -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Maybe ByteString -> JSONResponse -> m ()
logJSONResponse Logger
g Maybe ByteString
mReqId JSONResponse
jr
  let resp :: JSONResponse
resp = (Error -> JSONResponse)
-> (JSONResponse -> JSONResponse)
-> Either Error JSONResponse
-> JSONResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error -> JSONResponse
waiErrorToJSONResponse JSONResponse -> JSONResponse
forall a. a -> a
id Either Error JSONResponse
e
  let code :: Int
code = Status -> Int
statusCode (JSONResponse
resp.status)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> IO ()
forall (m :: * -> *). MonadMonitor m => Counter -> m ()
Prom.incCounter Counter
netErrors
  Request -> IO ()
flushRequestBody Request
r
  Continue IO
k (JSONResponse -> Response
jsonResponseToWai JSONResponse
resp)

{-# NOINLINE netErrors #-}
netErrors :: Prom.Counter
netErrors :: Counter
netErrors =
  Metric Counter -> Counter
forall s. Metric s -> s
Prom.unsafeRegister (Metric Counter -> Counter) -> Metric Counter -> Counter
forall a b. (a -> b) -> a -> b
$
    Info -> Metric Counter
Prom.counter
      Prom.Info
        { metricName :: Text
Prom.metricName = Text
"net_errors",
          metricHelp :: Text
Prom.metricHelp = Text
"Number of exceptions caught by catchErrors middleware"
        }

defaultRequestIdHeaderName :: HeaderName
defaultRequestIdHeaderName :: HeaderName
defaultRequestIdHeaderName = HeaderName
"Request-Id"

federationRequestIdHeaderName :: HeaderName
federationRequestIdHeaderName :: HeaderName
federationRequestIdHeaderName = HeaderName
"Wire-Origin-Request-Id"

-- | Log an 'Error' response for debugging purposes.
--
-- It would be nice to have access to the request body here, but that's already streamed away
-- by the handler in all likelyhood.  See 'heavyDebugLogging'.
logError :: (MonadIO m) => Logger -> Maybe Request -> Wai.Error -> m ()
logError :: forall (m :: * -> *).
MonadIO m =>
Logger -> Maybe Request -> Error -> m ()
logError Logger
g Maybe Request
mr = Logger -> Maybe ByteString -> Error -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Maybe ByteString -> Error -> m ()
logError' Logger
g (HeaderName -> Request -> Maybe ByteString
lookupRequestId HeaderName
defaultRequestIdHeaderName (Request -> Maybe ByteString) -> Maybe Request -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Request
mr)

logError' :: (MonadIO m) => Logger -> Maybe ByteString -> Wai.Error -> m ()
logError' :: forall (m :: * -> *).
MonadIO m =>
Logger -> Maybe ByteString -> Error -> m ()
logError' Logger
g Maybe ByteString
mr Error
e = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> (Msg -> Msg) -> IO ()
doLog Logger
g (Maybe ByteString -> Error -> Msg -> Msg
logErrorMsgWithRequest Maybe ByteString
mr Error
e)
  where
    doLog :: Logger -> (Msg -> Msg) -> IO ()
doLog
      | Status -> Int
statusCode (Error -> Status
Error.code Error
e) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 = Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.err
      | Bool
otherwise = Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.debug

logJSONResponse :: (MonadIO m) => Logger -> Maybe ByteString -> JSONResponse -> m ()
logJSONResponse :: forall (m :: * -> *).
MonadIO m =>
Logger -> Maybe ByteString -> JSONResponse -> m ()
logJSONResponse Logger
g Maybe ByteString
mReqId JSONResponse
e = do
  let r :: ByteString
r = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"N/A" Maybe ByteString
mReqId
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    Logger -> (Msg -> Msg) -> IO ()
doLog Logger
g ((Msg -> Msg) -> IO ()) -> (Msg -> Msg) -> IO ()
forall a b. (a -> b) -> a -> b
$
      ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request" ByteString
r
        (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"code" Int
status
        (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"value" (Value -> LByteString
forall a. ToJSON a => a -> LByteString
encode JSONResponse
e.value)
  where
    status :: Int
status = Status -> Int
statusCode JSONResponse
e.status
    doLog :: Logger -> (Msg -> Msg) -> IO ()
doLog
      | Int
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 = Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.err
      | Bool
otherwise = Logger -> (Msg -> Msg) -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> (Msg -> Msg) -> m ()
Log.debug

logErrorMsg :: Wai.Error -> Msg -> Msg
logErrorMsg :: Error -> Msg -> Msg
logErrorMsg (Wai.Error Status
c LText
l LText
m Maybe ErrorData
md Maybe Error
inner) =
  ByteString -> Int -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"code" (Status -> Int
statusCode Status
c)
    (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LText -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"label" LText
l
    (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Msg -> Msg)
-> (ErrorData -> Msg -> Msg) -> Maybe ErrorData -> Msg -> Msg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Msg -> Msg
forall a. a -> a
id ErrorData -> Msg -> Msg
logErrorData Maybe ErrorData
md
    (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (ByteString -> Builder
val ByteString
"\"" Builder -> Builder -> Builder
forall a b. (ToBytes a, ToBytes b) => a -> b -> Builder
+++ LText
m LText -> Builder -> Builder
forall a b. (ToBytes a, ToBytes b) => a -> b -> Builder
+++ ByteString -> Builder
val ByteString
"\"")
    (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Msg -> Msg) -> (Error -> Msg -> Msg) -> Maybe Error -> Msg -> Msg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Msg -> Msg
forall a. a -> a
id Error -> Msg -> Msg
logErrorMsg Maybe Error
inner
  where
    logErrorData :: ErrorData -> Msg -> Msg
logErrorData (Wai.FederationErrorData Domain
d Text
p) =
      ByteString -> Text -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"domain" (Domain -> Text
domainText Domain
d)
        (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"path" Text
p

logErrorMsgWithRequest :: Maybe ByteString -> Wai.Error -> Msg -> Msg
logErrorMsgWithRequest :: Maybe ByteString -> Error -> Msg -> Msg
logErrorMsgWithRequest Maybe ByteString
mr Error
e =
  ByteString -> ByteString -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"request" (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"N/A" Maybe ByteString
mr) (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Msg -> Msg
logErrorMsg Error
e

runHandlers :: SomeException -> [Handler IO a] -> IO a
runHandlers :: forall a. SomeException -> [Handler IO a] -> IO a
runHandlers SomeException
e [] = SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
runHandlers SomeException
e (Handler e -> IO a
h : [Handler IO a]
hs) = IO a -> (e -> IO a) -> Maybe e -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SomeException -> [Handler IO a] -> IO a
forall a. SomeException -> [Handler IO a] -> IO a
runHandlers SomeException
e [Handler IO a]
hs) e -> IO a
h (SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)

flushRequestBody :: Request -> IO ()
flushRequestBody :: Request -> IO ()
flushRequestBody Request
req = do
  ByteString
bs <- Request -> IO ByteString
getRequestBodyChunk Request
req
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Request -> IO ()
flushRequestBody Request
req