{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module Network.Wai.Utilities.Server
(
Server (..),
defaultServer,
newSettings,
runSettingsWithShutdown,
runSettingsWithCleanup,
compile,
route,
requestIdMiddleware,
catchErrors,
catchErrorsWithRequestId,
heavyDebugLogging,
rethrow5xx,
lazyResponseBody,
onError,
logError,
logError',
logErrorMsg,
flushRequestBody,
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.Id
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
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"
}
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 ()
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])
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
forall s. IsString s => s
defRequestId (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 #-}
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
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 #-}
errorHandlers :: [Handler IO (Either Wai.Error JSONResponse)]
errorHandlers :: [Handler IO (Either Error JSONResponse)]
errorHandlers =
[ (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),
(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 #-}
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
forall s. IsString s => s
defRequestId (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")
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)
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
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
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
forall s. IsString s => s
defRequestId (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
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)
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
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
= HeaderName
"Request-Id"
federationRequestIdHeaderName :: HeaderName
= HeaderName
"Wire-Origin-Request-Id"
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
forall s. IsString s => s
defRequestId 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
forall s. IsString s => s
defRequestId 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