{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should
-- not use CPP.
-- EDIT: Fixed this by adding two "zero-width spaces" in between the "*/*"
module Network.Wai.Middleware.RequestLogger (
    -- * Basic stdout logging
    logStdout,
    logStdoutDev,

    -- * Create more versions
    mkRequestLogger,
    -- ** Settings type
    RequestLoggerSettings,
    defaultRequestLoggerSettings,
    -- *** Settings fields
    outputFormat,
    autoFlush,
    destination,
    -- ** More settings
    OutputFormat (..),
    ApacheSettings,
    defaultApacheSettings,
    setApacheIPAddrSource,
    setApacheRequestFilter,
    setApacheUserGetter,
    DetailedSettings (..),
    defaultDetailedSettings,
    OutputFormatter,
    OutputFormatterWithDetails,
    OutputFormatterWithDetailsAndHeaders,
    Destination (..),
    Callback,
    IPAddrSource (..),
) where

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B (Builder, byteString)
import Data.ByteString.Char8 (pack)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Default (Default (def))
import Data.IORef
import Data.Maybe (fromMaybe, isJust, mapMaybe)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import Data.Text.Encoding (decodeUtf8')
import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
import Network.HTTP.Types as H
import Network.Wai (
    Middleware,
    Request (..),
    RequestBodyLength (..),
    Response,
    getRequestBodyChunk,
    requestBodyLength,
    responseHeaders,
    responseStatus,
    setRequestBodyChunks,
 )
import Network.Wai.Internal (Response (..))
import Network.Wai.Logger
import System.Console.ANSI
import System.IO (Handle, hFlush, stdout)
import System.IO.Unsafe (unsafePerformIO)
import System.Log.FastLogger

import Network.Wai.Header (contentLength)
import Network.Wai.Middleware.RequestLogger.Internal
import Network.Wai.Parse (
    File,
    Param,
    fileName,
    getRequestBodyType,
    lbsBackEnd,
    sinkRequestBody,
 )

-- | The logging format.
--
-- @since 1.3.0
data OutputFormat
    = Apache IPAddrSource
    | -- | @since 3.1.8
      ApacheWithSettings ApacheSettings
    | -- | use colors?
      Detailed Bool
    | -- | @since 3.1.3
      DetailedWithSettings DetailedSettings
    | CustomOutputFormat OutputFormatter
    | CustomOutputFormatWithDetails OutputFormatterWithDetails
    | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders

-- | Settings for the `ApacheWithSettings` `OutputFormat`. This is purposely kept as an abstract data
-- type so that new settings can be added without breaking backwards
-- compatibility. In order to create an 'ApacheSettings' value, use 'defaultApacheSettings'
-- and the various \'setApache\' functions to modify individual fields. For example:
--
-- > setApacheIPAddrSource FromHeader defaultApacheSettings
--
-- @since 3.1.8
data ApacheSettings = ApacheSettings
    { ApacheSettings -> IPAddrSource
apacheIPAddrSource :: IPAddrSource
    , ApacheSettings -> Request -> Maybe ByteString
apacheUserGetter :: Request -> Maybe BS.ByteString
    , ApacheSettings -> Request -> Response -> Bool
apacheRequestFilter :: Request -> Response -> Bool
    }

defaultApacheSettings :: ApacheSettings
defaultApacheSettings :: ApacheSettings
defaultApacheSettings =
    ApacheSettings
        { apacheIPAddrSource :: IPAddrSource
apacheIPAddrSource = IPAddrSource
FromSocket
        , apacheRequestFilter :: Request -> Response -> Bool
apacheRequestFilter = \Request
_ Response
_ -> Bool
True
        , apacheUserGetter :: Request -> Maybe ByteString
apacheUserGetter = Maybe ByteString -> Request -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing
        }

-- | Where to take IP addresses for clients from. See 'IPAddrSource' for more information.
--
-- Default value: FromSocket
--
-- @since 3.1.8
setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings
setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings
setApacheIPAddrSource IPAddrSource
x ApacheSettings
y = ApacheSettings
y{apacheIPAddrSource = x}

-- | Function that allows you to filter which requests are logged, based on
-- the request and response
--
-- Default: log all requests
--
-- @since 3.1.8
setApacheRequestFilter
    :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings
setApacheRequestFilter :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings
setApacheRequestFilter Request -> Response -> Bool
x ApacheSettings
y = ApacheSettings
y{apacheRequestFilter = x}

-- | Function that allows you to get the current user from the request, which
-- will then be added in the log.
--
-- Default: return no user
--
-- @since 3.1.8
setApacheUserGetter
    :: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings
setApacheUserGetter :: (Request -> Maybe ByteString) -> ApacheSettings -> ApacheSettings
setApacheUserGetter Request -> Maybe ByteString
x ApacheSettings
y = ApacheSettings
y{apacheUserGetter = x}

-- | Settings for the `Detailed` `OutputFormat`.
--
-- `mModifyParams` allows you to pass a function to hide confidential
-- information (such as passwords) from the logs. If result is `Nothing`, then
-- the parameter is hidden. For example:
-- > myformat = Detailed True (Just hidePasswords)
-- >   where hidePasswords p@(k,v) = if k = "password" then (k, "***REDACTED***") else p
--
-- `mFilterRequests` allows you to filter which requests are logged, based on
-- the request and response.
--
-- @since 3.1.3
data DetailedSettings = DetailedSettings
    { DetailedSettings -> Bool
useColors :: Bool
    , DetailedSettings -> Maybe (Param -> Maybe Param)
mModifyParams :: Maybe (Param -> Maybe Param)
    , DetailedSettings -> Maybe (Request -> Response -> Bool)
mFilterRequests :: Maybe (Request -> Response -> Bool)
    , DetailedSettings -> Bool
mPrelogRequests :: Bool
    -- ^ @since 3.1.7
    }

-- | DO NOT USE THIS INSTANCE!
-- Please use 'defaultDetailedSettings'
--
-- This instance will be removed in a future major version.
instance Default DetailedSettings where
    def :: DetailedSettings
def = DetailedSettings
defaultDetailedSettings

-- | Default 'DetailedSettings'
--
-- Uses colors, but doesn't modify nor filter anything.
-- Also doesn't prelog requests.
--
-- @since 3.1.16
defaultDetailedSettings :: DetailedSettings
defaultDetailedSettings :: DetailedSettings
defaultDetailedSettings =
    DetailedSettings
        { useColors :: Bool
useColors = Bool
True
        , mModifyParams :: Maybe (Param -> Maybe Param)
mModifyParams = Maybe (Param -> Maybe Param)
forall a. Maybe a
Nothing
        , mFilterRequests :: Maybe (Request -> Response -> Bool)
mFilterRequests = Maybe (Request -> Response -> Bool)
forall a. Maybe a
Nothing
        , mPrelogRequests :: Bool
mPrelogRequests = Bool
False
        }

type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr

type OutputFormatterWithDetails =
    ZonedDate
    -> Request
    -> Status
    -> Maybe Integer
    -> NominalDiffTime
    -> [S8.ByteString]
    -> B.Builder
    -> LogStr

-- | Same as @OutputFormatterWithDetails@ but with response headers included
--
-- This is useful if you wish to include arbitrary application data in your
-- logs, e.g., an authenticated user ID, which you would set in a response
-- header in your application and retrieve in the log formatter.
--
-- @since 3.0.27
type OutputFormatterWithDetailsAndHeaders =
    ZonedDate
    -- ^ When the log message was generated
    -> Request
    -- ^ The WAI request
    -> Status
    -- ^ HTTP status code
    -> Maybe Integer
    -- ^ Response size
    -> NominalDiffTime
    -- ^ Duration of the request
    -> [S8.ByteString]
    -- ^ The request body
    -> B.Builder
    -- ^ Raw response
    -> [Header]
    -- ^ The response headers
    -> LogStr

-- | Where to send the logs to.
--
-- @since 1.3.0
data Destination
    = Handle Handle
    | Logger LoggerSet
    | Callback Callback


-- | When using a callback as a destination.
--
-- @since 1.3.0
type Callback = LogStr -> IO ()

-- | Settings for the request logger.
--
-- Sets what which format,
--
-- @outputFormat@, @autoFlush@, and @destination@ are record fields
-- for the record type @RequestLoggerSettings@, so they can be used to
-- modify settings values using record syntax.
--
-- @since 1.3.0
data RequestLoggerSettings = RequestLoggerSettings
    { RequestLoggerSettings -> OutputFormat
outputFormat :: OutputFormat
    -- ^ Default value: @Detailed True@.
    --
    -- @since 1.3.0
    , RequestLoggerSettings -> Bool
autoFlush :: Bool
    -- ^ Only applies when using the 'Handle' constructor for 'destination'.
    --
    -- Default value: @True@.
    --
    -- @since 1.3.0
    , RequestLoggerSettings -> Destination
destination :: Destination
    -- ^ Default: @Handle stdout@.
    --
    -- @since 1.3.0
    }

-- | Default 'RequestLoggerSettings'.
--
-- Use this to create 'RequestLoggerSettings', and use the
-- accompanying fields to edit these settings.
--
-- @since 3.1.8
defaultRequestLoggerSettings :: RequestLoggerSettings
defaultRequestLoggerSettings :: RequestLoggerSettings
defaultRequestLoggerSettings =
    RequestLoggerSettings
        { outputFormat :: OutputFormat
outputFormat = Bool -> OutputFormat
Detailed Bool
True
        , autoFlush :: Bool
autoFlush = Bool
True
        , destination :: Destination
destination = Handle -> Destination
Handle Handle
stdout
        }

-- | DO NOT USE THIS INSTANCE!
-- Please use 'defaultRequestLoggerSettings' instead.
--
-- This instance will be removed in a future major release.
instance Default RequestLoggerSettings where
    def :: RequestLoggerSettings
def = RequestLoggerSettings
defaultRequestLoggerSettings

-- | Create the 'Middleware' using the given 'RequestLoggerSettings'
--
-- @since 1.3.0
mkRequestLogger :: RequestLoggerSettings -> IO Middleware
mkRequestLogger :: RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings{Bool
Destination
OutputFormat
outputFormat :: RequestLoggerSettings -> OutputFormat
autoFlush :: RequestLoggerSettings -> Bool
destination :: RequestLoggerSettings -> Destination
outputFormat :: OutputFormat
autoFlush :: Bool
destination :: Destination
..} = do
    let (LogStr -> IO ()
callback, IO ()
flusher) =
            case Destination
destination of
                Handle Handle
h -> (Handle -> ByteString -> IO ()
BS.hPutStr Handle
h (ByteString -> IO ()) -> (LogStr -> ByteString) -> LogStr -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
logToByteString, Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFlush (Handle -> IO ()
hFlush Handle
h))
                Logger LoggerSet
l -> (LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
l, Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFlush (LoggerSet -> IO ()
flushLogStr LoggerSet
l))
                Callback LogStr -> IO ()
c -> (LogStr -> IO ()
c, () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        callbackAndFlush :: LogStr -> IO ()
callbackAndFlush LogStr
str = LogStr -> IO ()
callback LogStr
str IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flusher
    case OutputFormat
outputFormat of
        Apache IPAddrSource
ipsrc -> do
            IO ByteString
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
            ApacheLoggerActions
apache <- IPAddrSource -> LogType -> IO ByteString -> IO ApacheLoggerActions
initLogger IPAddrSource
ipsrc ((LogStr -> IO ()) -> IO () -> LogType
forall a. (a -> IO ()) -> IO () -> LogType' a
LogCallback LogStr -> IO ()
callback IO ()
flusher) IO ByteString
getdate
            Middleware -> IO Middleware
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ (Request -> Response -> Bool) -> ApacheLoggerActions -> Middleware
apacheMiddleware (\Request
_ Response
_ -> Bool
True) ApacheLoggerActions
apache
        ApacheWithSettings ApacheSettings{IPAddrSource
Request -> Maybe ByteString
Request -> Response -> Bool
apacheIPAddrSource :: ApacheSettings -> IPAddrSource
apacheUserGetter :: ApacheSettings -> Request -> Maybe ByteString
apacheRequestFilter :: ApacheSettings -> Request -> Response -> Bool
apacheIPAddrSource :: IPAddrSource
apacheUserGetter :: Request -> Maybe ByteString
apacheRequestFilter :: Request -> Response -> Bool
..} -> do
            IO ByteString
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
            ApacheLoggerActions
apache <-
                Maybe (Request -> Maybe ByteString)
-> IPAddrSource
-> LogType
-> IO ByteString
-> IO ApacheLoggerActions
forall user.
ToLogStr user =>
Maybe (Request -> Maybe user)
-> IPAddrSource
-> LogType
-> IO ByteString
-> IO ApacheLoggerActions
initLoggerUser
                    ((Request -> Maybe ByteString)
-> Maybe (Request -> Maybe ByteString)
forall a. a -> Maybe a
Just Request -> Maybe ByteString
apacheUserGetter)
                    IPAddrSource
apacheIPAddrSource
                    ((LogStr -> IO ()) -> IO () -> LogType
forall a. (a -> IO ()) -> IO () -> LogType' a
LogCallback LogStr -> IO ()
callback IO ()
flusher)
                    IO ByteString
getdate
            Middleware -> IO Middleware
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ (Request -> Response -> Bool) -> ApacheLoggerActions -> Middleware
apacheMiddleware Request -> Response -> Bool
apacheRequestFilter ApacheLoggerActions
apache
        Detailed Bool
useColors ->
            let settings :: DetailedSettings
settings = DetailedSettings
defaultDetailedSettings{useColors = useColors}
             in (LogStr -> IO ()) -> DetailedSettings -> IO Middleware
detailedMiddleware LogStr -> IO ()
callbackAndFlush DetailedSettings
settings
        DetailedWithSettings DetailedSettings
settings ->
            (LogStr -> IO ()) -> DetailedSettings -> IO Middleware
detailedMiddleware LogStr -> IO ()
callbackAndFlush DetailedSettings
settings
        CustomOutputFormat OutputFormatter
formatter -> do
            IO ByteString
getDate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
            Middleware -> IO Middleware
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ (LogStr -> IO ()) -> IO ByteString -> OutputFormatter -> Middleware
customMiddleware LogStr -> IO ()
callbackAndFlush IO ByteString
getDate OutputFormatter
formatter
        CustomOutputFormatWithDetails OutputFormatterWithDetails
formatter -> do
            IO ByteString
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
            Middleware -> IO Middleware
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ (LogStr -> IO ())
-> IO ByteString -> OutputFormatterWithDetails -> Middleware
customMiddlewareWithDetails LogStr -> IO ()
callbackAndFlush IO ByteString
getdate OutputFormatterWithDetails
formatter
        CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders
formatter -> do
            IO ByteString
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
            Middleware -> IO Middleware
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$
                (LogStr -> IO ())
-> IO ByteString
-> OutputFormatterWithDetailsAndHeaders
-> Middleware
customMiddlewareWithDetailsAndHeaders LogStr -> IO ()
callbackAndFlush IO ByteString
getdate OutputFormatterWithDetailsAndHeaders
formatter

apacheMiddleware
    :: (Request -> Response -> Bool) -> ApacheLoggerActions -> Middleware
apacheMiddleware :: (Request -> Response -> Bool) -> ApacheLoggerActions -> Middleware
apacheMiddleware Request -> Response -> Bool
applyRequestFilter ApacheLoggerActions
ala Application
app Request
req Response -> IO ResponseReceived
sendResponse = Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Request -> Response -> Bool
applyRequestFilter Request
req Response
res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ApacheLoggerActions -> ApacheLogger
apacheLogger ApacheLoggerActions
ala Request
req (Response -> Status
responseStatus Response
res) (Maybe Integer -> IO ()) -> Maybe Integer -> IO ()
forall a b. (a -> b) -> a -> b
$
            [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
    Response -> IO ResponseReceived
sendResponse Response
res

customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
customMiddleware :: (LogStr -> IO ()) -> IO ByteString -> OutputFormatter -> Middleware
customMiddleware LogStr -> IO ()
cb IO ByteString
getdate OutputFormatter
formatter Application
app Request
req Response -> IO ResponseReceived
sendResponse = Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    ByteString
date <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
getdate
    let msize :: Maybe Integer
msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
    IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> IO ()
cb (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ OutputFormatter
formatter ByteString
date Request
req (Response -> Status
responseStatus Response
res) Maybe Integer
msize
    Response -> IO ResponseReceived
sendResponse Response
res

customMiddlewareWithDetails
    :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware
customMiddlewareWithDetails :: (LogStr -> IO ())
-> IO ByteString -> OutputFormatterWithDetails -> Middleware
customMiddlewareWithDetails LogStr -> IO ()
cb IO ByteString
getdate OutputFormatterWithDetails
formatter Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
    (Request
req', [ByteString]
reqBody) <- Request -> IO (Request, [ByteString])
getRequestBody Request
req
    UTCTime
t0 <- IO UTCTime
getCurrentTime
    Application
app Request
req' ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        UTCTime
t1 <- IO UTCTime
getCurrentTime
        ByteString
date <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
getdate
        let msize :: Maybe Integer
msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
        IORef Builder
builderIO <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef (Builder -> IO (IORef Builder)) -> Builder -> IO (IORef Builder)
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString ByteString
""
        Response
res' <- IORef Builder -> Response -> IO Response
recordChunks IORef Builder
builderIO Response
res
        ResponseReceived
rspRcv <- Response -> IO ResponseReceived
sendResponse Response
res'
        ()
_ <-
            IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                (IO () -> IO ()) -> (Builder -> IO ()) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> IO ()
cb
                (LogStr -> IO ()) -> (Builder -> LogStr) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputFormatterWithDetails
formatter ByteString
date Request
req' (Response -> Status
responseStatus Response
res') Maybe Integer
msize (UTCTime
t1 UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t0) [ByteString]
reqBody
                (Builder -> IO ()) -> IO Builder -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
builderIO
        ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rspRcv

customMiddlewareWithDetailsAndHeaders
    :: Callback -> IO ZonedDate -> OutputFormatterWithDetailsAndHeaders -> Middleware
customMiddlewareWithDetailsAndHeaders :: (LogStr -> IO ())
-> IO ByteString
-> OutputFormatterWithDetailsAndHeaders
-> Middleware
customMiddlewareWithDetailsAndHeaders LogStr -> IO ()
cb IO ByteString
getdate OutputFormatterWithDetailsAndHeaders
formatter Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
    (Request
req', [ByteString]
reqBody) <- Request -> IO (Request, [ByteString])
getRequestBody Request
req
    UTCTime
t0 <- IO UTCTime
getCurrentTime
    Application
app Request
req' ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        UTCTime
t1 <- IO UTCTime
getCurrentTime
        ByteString
date <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
getdate
        let msize :: Maybe Integer
msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
        IORef Builder
builderIO <- Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef (Builder -> IO (IORef Builder)) -> Builder -> IO (IORef Builder)
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
B.byteString ByteString
""
        Response
res' <- IORef Builder -> Response -> IO Response
recordChunks IORef Builder
builderIO Response
res
        ResponseReceived
rspRcv <- Response -> IO ResponseReceived
sendResponse Response
res'
        ()
_ <- do
            Builder
rawResponse <- IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
builderIO
            let status :: Status
status = Response -> Status
responseStatus Response
res'
                duration :: NominalDiffTime
duration = UTCTime
t1 UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t0
                resHeaders :: [(HeaderName, ByteString)]
resHeaders = Response -> [(HeaderName, ByteString)]
responseHeaders Response
res'
            IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (LogStr -> IO ()) -> LogStr -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> IO ()
cb (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$
                OutputFormatterWithDetailsAndHeaders
formatter ByteString
date Request
req' Status
status Maybe Integer
msize NominalDiffTime
duration [ByteString]
reqBody Builder
rawResponse [(HeaderName, ByteString)]
resHeaders
        ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rspRcv

-- | Production request logger middleware.
--
-- This uses the 'Apache' logging format, and takes IP addresses for clients from
-- the socket (see 'IPAddrSource' for more information). It logs to 'stdout'.
{-# NOINLINE logStdout #-}
logStdout :: Middleware
logStdout :: Middleware
logStdout =
    IO Middleware -> Middleware
forall a. IO a -> a
unsafePerformIO (IO Middleware -> Middleware) -> IO Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
        RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings
defaultRequestLoggerSettings{outputFormat = Apache FromSocket}

-- | Development request logger middleware.
--
-- This uses the 'Detailed' 'True' logging format and logs to 'stdout'.
{-# NOINLINE logStdoutDev #-}
logStdoutDev :: Middleware
logStdoutDev :: Middleware
logStdoutDev = IO Middleware -> Middleware
forall a. IO a -> a
unsafePerformIO (IO Middleware -> Middleware) -> IO Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings
defaultRequestLoggerSettings

-- | Prints a message using the given callback function for each request.
-- This is not for serious production use- it is inefficient.
-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
--
-- Note that it logs the request immediately when it is received.
-- This meanst that you can accurately see the interleaving of requests.
-- And if the app crashes you have still logged the request.
-- However, if you are simulating 10 simultaneous users you may find this confusing.
--
-- This is lower-level - use 'logStdoutDev' unless you need greater control.
--
-- Example ouput:
--
-- > GET search
-- >   Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*​/​*;q=0.8
-- >   Status: 200 OK 0.010555s
-- >
-- > GET static/css/normalize.css
-- >   Params: [("LXwioiBG","")]
-- >   Accept: text/css,*​/​*;q=0.1
-- >   Status: 304 Not Modified 0.010555s
detailedMiddleware :: Callback -> DetailedSettings -> IO Middleware
-- NB: The *​/​* in the comments above have "zero-width spaces" in them, so the
-- CPP doesn't screw up everything. So don't copy those; they're technically wrong.
detailedMiddleware :: (LogStr -> IO ()) -> DetailedSettings -> IO Middleware
detailedMiddleware LogStr -> IO ()
cb DetailedSettings
settings =
    let (Color -> ByteString -> [ByteString]
ansiColor, ByteString -> [ByteString]
ansiMethod, ByteString -> ByteString -> [ByteString]
ansiStatusCode) =
            if DetailedSettings -> Bool
useColors DetailedSettings
settings
                then (Color -> ByteString -> [ByteString]
ansiColor', ByteString -> [ByteString]
ansiMethod', ByteString -> ByteString -> [ByteString]
ansiStatusCode')
                else (\Color
_ ByteString
t -> [ByteString
t], (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: []), \ByteString
_ ByteString
t -> [ByteString
t])
     in Middleware -> IO Middleware
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ (LogStr -> IO ())
-> DetailedSettings
-> (Color -> ByteString -> [ByteString])
-> (ByteString -> [ByteString])
-> (ByteString -> ByteString -> [ByteString])
-> Middleware
detailedMiddleware' LogStr -> IO ()
cb DetailedSettings
settings Color -> ByteString -> [ByteString]
ansiColor ByteString -> [ByteString]
ansiMethod ByteString -> ByteString -> [ByteString]
ansiStatusCode

ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
ansiColor' :: Color -> ByteString -> [ByteString]
ansiColor' Color
color ByteString
bs =
    [ String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
color]
    , ByteString
bs
    , String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]
    ]

-- | Tags http method with a unique color.
ansiMethod' :: BS.ByteString -> [BS.ByteString]
ansiMethod' :: ByteString -> [ByteString]
ansiMethod' ByteString
m = case ByteString
m of
    ByteString
"GET" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Cyan ByteString
m
    ByteString
"HEAD" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Cyan ByteString
m
    ByteString
"PUT" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Green ByteString
m
    ByteString
"POST" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Yellow ByteString
m
    ByteString
"DELETE" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Red ByteString
m
    ByteString
_ -> Color -> ByteString -> [ByteString]
ansiColor' Color
Magenta ByteString
m

ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
ansiStatusCode' :: ByteString -> ByteString -> [ByteString]
ansiStatusCode' ByteString
c ByteString
t = case Int -> ByteString -> ByteString
S8.take Int
1 ByteString
c of
    ByteString
"2" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Green ByteString
t
    ByteString
"3" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Yellow ByteString
t
    ByteString
"4" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Red ByteString
t
    ByteString
"5" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Magenta ByteString
t
    ByteString
_ -> Color -> ByteString -> [ByteString]
ansiColor' Color
Blue ByteString
t

recordChunks :: IORef B.Builder -> Response -> IO Response
recordChunks :: IORef Builder -> Response -> IO Response
recordChunks IORef Builder
i (ResponseStream Status
s [(HeaderName, ByteString)]
h StreamingBody
sb) =
    Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response)
-> (StreamingBody -> Response) -> StreamingBody -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
ResponseStream Status
s [(HeaderName, ByteString)]
h (StreamingBody -> IO Response) -> StreamingBody -> IO Response
forall a b. (a -> b) -> a -> b
$
        (\Builder -> IO ()
send IO ()
flush -> StreamingBody
sb (\Builder
b -> IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
i (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> IO ()
send Builder
b) IO ()
flush)
recordChunks IORef Builder
i (ResponseBuilder Status
s [(HeaderName, ByteString)]
h Builder
b) =
    IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
i (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b) IO () -> IO Response -> IO Response
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> [(HeaderName, ByteString)] -> Builder -> Response
ResponseBuilder Status
s [(HeaderName, ByteString)]
h Builder
b)
recordChunks IORef Builder
_ Response
r =
    Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response
r

getRequestBody :: Request -> IO (Request, [S8.ByteString])
getRequestBody :: Request -> IO (Request, [ByteString])
getRequestBody Request
req = do
    let loop :: ([ByteString] -> c) -> IO c
loop [ByteString] -> c
front = do
            ByteString
bs <- Request -> IO ByteString
getRequestBodyChunk Request
req
            if ByteString -> Bool
S8.null ByteString
bs
                then c -> IO c
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> IO c) -> c -> IO c
forall a b. (a -> b) -> a -> b
$ [ByteString] -> c
front []
                else ([ByteString] -> c) -> IO c
loop (([ByteString] -> c) -> IO c) -> ([ByteString] -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ [ByteString] -> c
front ([ByteString] -> c)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)
    [ByteString]
body <- ([ByteString] -> [ByteString]) -> IO [ByteString]
forall {c}. ([ByteString] -> c) -> IO c
loop [ByteString] -> [ByteString]
forall a. a -> a
id
    -- logging the body here consumes it, so fill it back up
    -- obviously not efficient, but this is the development logger
    --
    -- Note: previously, we simply used CL.sourceList. However,
    -- that meant that you could read the request body in twice.
    -- While that in itself is not a problem, the issue is that,
    -- in production, you wouldn't be able to do this, and
    -- therefore some bugs wouldn't show up during testing. This
    -- implementation ensures that each chunk is only returned
    -- once.
    IORef [ByteString]
ichunks <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
body
    let rbody :: IO ByteString
rbody = IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ichunks (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \[ByteString]
chunks ->
            case [ByteString]
chunks of
                [] -> ([], ByteString
S8.empty)
                ByteString
x : [ByteString]
y -> ([ByteString]
y, ByteString
x)
    let req' :: Request
req' = IO ByteString -> Request -> Request
setRequestBodyChunks IO ByteString
rbody Request
req
    (Request, [ByteString]) -> IO (Request, [ByteString])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req', [ByteString]
body)

{- HLint ignore getRequestBody "Use lambda-case" -}

detailedMiddleware'
    :: Callback
    -> DetailedSettings
    -> (Color -> BS.ByteString -> [BS.ByteString])
    -> (BS.ByteString -> [BS.ByteString])
    -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
    -> Middleware
detailedMiddleware' :: (LogStr -> IO ())
-> DetailedSettings
-> (Color -> ByteString -> [ByteString])
-> (ByteString -> [ByteString])
-> (ByteString -> ByteString -> [ByteString])
-> Middleware
detailedMiddleware' LogStr -> IO ()
cb DetailedSettings{Bool
Maybe (Param -> Maybe Param)
Maybe (Request -> Response -> Bool)
mModifyParams :: DetailedSettings -> Maybe (Param -> Maybe Param)
mFilterRequests :: DetailedSettings -> Maybe (Request -> Response -> Bool)
useColors :: DetailedSettings -> Bool
mPrelogRequests :: DetailedSettings -> Bool
useColors :: Bool
mModifyParams :: Maybe (Param -> Maybe Param)
mFilterRequests :: Maybe (Request -> Response -> Bool)
mPrelogRequests :: Bool
..} Color -> ByteString -> [ByteString]
ansiColor ByteString -> [ByteString]
ansiMethod ByteString -> ByteString -> [ByteString]
ansiStatusCode Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
    (Request
req', [ByteString]
body) <-
        -- second tuple item should not be necessary, but a test runner might mess it up
        case (Request -> RequestBodyLength
requestBodyLength Request
req, [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)) of
            -- log the request body if it is small
            (KnownLength Word64
len, Maybe Integer
_) | Word64
len Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
2048 -> Request -> IO (Request, [ByteString])
getRequestBody Request
req
            (RequestBodyLength
_, Just Integer
len) | Integer
len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
2048 -> Request -> IO (Request, [ByteString])
getRequestBody Request
req
            (RequestBodyLength, Maybe Integer)
_ -> (Request, [ByteString]) -> IO (Request, [ByteString])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, [])

    let reqbodylog :: p -> [ByteString]
reqbodylog p
_ =
            if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
body Bool -> Bool -> Bool
|| Maybe (Param -> Maybe Param) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Param -> Maybe Param)
mModifyParams
                then [ByteString
""]
                else Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Request Body: " [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
body [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString
"\n"]
        reqbody :: [ByteString]
reqbody = (ByteString -> [ByteString]) -> [ByteString] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((UnicodeException -> [ByteString])
-> (Text -> [ByteString])
-> Either UnicodeException Text
-> [ByteString]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([ByteString] -> UnicodeException -> [ByteString]
forall a b. a -> b -> a
const [ByteString
""]) Text -> [ByteString]
forall {p}. p -> [ByteString]
reqbodylog (Either UnicodeException Text -> [ByteString])
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8') [ByteString]
body
    [Param]
postParams <-
        if Request -> ByteString
requestMethod Request
req ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"GET", ByteString
"HEAD"]
            then [Param] -> IO [Param]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else do
                ([Param]
unmodifiedPostParams, [File ByteString]
files) <- IO ([Param], [File ByteString]) -> IO ([Param], [File ByteString])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Param], [File ByteString])
 -> IO ([Param], [File ByteString]))
-> IO ([Param], [File ByteString])
-> IO ([Param], [File ByteString])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> IO ([Param], [File ByteString])
allPostParams [ByteString]
body
                let postParams :: [Param]
postParams =
                        case Maybe (Param -> Maybe Param)
mModifyParams of
                            Just Param -> Maybe Param
modifyParams -> (Param -> Maybe Param) -> [Param] -> [Param]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Param -> Maybe Param
modifyParams [Param]
unmodifiedPostParams
                            Maybe (Param -> Maybe Param)
Nothing -> [Param]
unmodifiedPostParams
                [Param] -> IO [Param]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Param] -> IO [Param]) -> [Param] -> IO [Param]
forall a b. (a -> b) -> a -> b
$ ([Param], [File ByteString]) -> [Param]
collectPostParams ([Param]
postParams, [File ByteString]
files)

    let getParams :: [Param]
getParams = (QueryItem -> Param) -> [QueryItem] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map QueryItem -> Param
emptyGetParam ([QueryItem] -> [Param]) -> [QueryItem] -> [Param]
forall a b. (a -> b) -> a -> b
$ Request -> [QueryItem]
queryString Request
req
        accept :: ByteString
accept = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
H.hAccept ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
        params :: [ByteString]
params =
            let par :: [ByteString]
par
                    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Param] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Param]
postParams = [String -> ByteString
pack ([Param] -> String
forall a. Show a => a -> String
show [Param]
postParams)]
                    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Param] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Param]
getParams = [String -> ByteString
pack ([Param] -> String
forall a. Show a => a -> String
show [Param]
getParams)]
                    | Bool
otherwise = []
             in if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
par then [ByteString
""] else Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Params: " [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
par [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString
"\n"]

    UTCTime
t0 <- IO UTCTime
getCurrentTime

    -- Optionally prelog the request
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mPrelogRequests (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        LogStr -> IO ()
cb (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$
            LogStr
"PRELOGGING REQUEST: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> [ByteString] -> ByteString -> LogStr
forall (t :: * -> *) m.
(Foldable t, ToLogStr m) =>
t m -> t m -> m -> LogStr
mkRequestLog [ByteString]
params [ByteString]
reqbody ByteString
accept

    Application
app Request
req' ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
rsp -> do
        case Maybe (Request -> Response -> Bool)
mFilterRequests of
            Just Request -> Response -> Bool
f | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Request -> Response -> Bool
f Request
req' Response
rsp -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe (Request -> Response -> Bool)
_ -> do
                let isRaw :: Bool
isRaw =
                        case Response
rsp of
                            ResponseRaw{} -> Bool
True
                            Response
_ -> Bool
False
                    stCode :: ByteString
stCode = Response -> ByteString
statusBS Response
rsp
                    stMsg :: ByteString
stMsg = Response -> ByteString
msgBS Response
rsp
                UTCTime
t1 <- IO UTCTime
getCurrentTime

                -- log the status of the response
                LogStr -> IO ()
cb (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [ByteString] -> [ByteString] -> ByteString -> LogStr
forall (t :: * -> *) m.
(Foldable t, ToLogStr m) =>
t m -> t m -> m -> LogStr
mkRequestLog [ByteString]
params [ByteString]
reqbody ByteString
accept
                        LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Bool -> ByteString -> ByteString -> UTCTime -> UTCTime -> LogStr
mkResponseLog Bool
isRaw ByteString
stCode ByteString
stMsg UTCTime
t1 UTCTime
t0

        Response -> IO ResponseReceived
sendResponse Response
rsp
  where
    allPostParams :: [ByteString] -> IO ([Param], [File ByteString])
allPostParams [ByteString]
body =
        case Request -> Maybe RequestBodyType
getRequestBodyType Request
req of
            Maybe RequestBodyType
Nothing -> ([Param], [File ByteString]) -> IO ([Param], [File ByteString])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
            Just RequestBodyType
rbt -> do
                IORef [ByteString]
ichunks <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
body
                let rbody :: IO ByteString
rbody = IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ichunks (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \[ByteString]
chunks ->
                        case [ByteString]
chunks of
                            [] -> ([], ByteString
S8.empty)
                            ByteString
x : [ByteString]
y -> ([ByteString]
y, ByteString
x)
                BackEnd ByteString
-> RequestBodyType
-> IO ByteString
-> IO ([Param], [File ByteString])
forall y.
BackEnd y
-> RequestBodyType -> IO ByteString -> IO ([Param], [File y])
sinkRequestBody BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd RequestBodyType
rbt IO ByteString
rbody

    emptyGetParam
        :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
    emptyGetParam :: QueryItem -> Param
emptyGetParam (ByteString
k, Just ByteString
v) = (ByteString
k, ByteString
v)
    emptyGetParam (ByteString
k, Maybe ByteString
Nothing) = (ByteString
k, ByteString
"")

    collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
    collectPostParams :: ([Param], [File ByteString]) -> [Param]
collectPostParams ([Param]
postParams, [File ByteString]
files) =
        [Param]
postParams
            [Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++ (File ByteString -> Param) -> [File ByteString] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k, FileInfo ByteString
v) -> (ByteString
k, ByteString
"FILE: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> FileInfo ByteString -> ByteString
forall c. FileInfo c -> ByteString
fileName FileInfo ByteString
v)) [File ByteString]
files

    mkRequestLog :: (Foldable t, ToLogStr m) => t m -> t m -> m -> LogStr
    mkRequestLog :: forall (t :: * -> *) m.
(Foldable t, ToLogStr m) =>
t m -> t m -> m -> LogStr
mkRequestLog t m
params t m
reqbody m
accept =
        (ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> [ByteString]
ansiMethod (Request -> ByteString
requestMethod Request
req))
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
rawPathInfo Request
req)
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (m -> LogStr) -> t m -> LogStr
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap m -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr t m
params
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (m -> LogStr) -> t m -> LogStr
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap m -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr t m
reqbody
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Accept: ")
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> m -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr m
accept
            LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

    mkResponseLog
        :: Bool -> S8.ByteString -> S8.ByteString -> UTCTime -> UTCTime -> LogStr
    mkResponseLog :: Bool -> ByteString -> ByteString -> UTCTime -> UTCTime -> LogStr
mkResponseLog Bool
isRaw ByteString
stCode ByteString
stMsg UTCTime
t1 UTCTime
t0 =
        if Bool
isRaw
            then LogStr
""
            else
                (ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Status: ")
                    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> ByteString -> [ByteString]
ansiStatusCode ByteString
stCode (ByteString
stCode ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
stMsg))
                    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
                    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> String
forall a. Show a => a -> String
show (NominalDiffTime -> String) -> NominalDiffTime -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t0)
                    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

{- HLint ignore detailedMiddleware' "Use lambda-case" -}

statusBS :: Response -> BS.ByteString
statusBS :: Response -> ByteString
statusBS = String -> ByteString
pack (String -> ByteString)
-> (Response -> String) -> Response -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Response -> Int) -> Response -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode (Status -> Int) -> (Response -> Status) -> Response -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Status
responseStatus

msgBS :: Response -> BS.ByteString
msgBS :: Response -> ByteString
msgBS = Status -> ByteString
statusMessage (Status -> ByteString)
-> (Response -> Status) -> Response -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Status
responseStatus