{-# LANGUAGE RecordWildCards #-}

-- NOTE: Due to https://github.com/yesodweb/wai/issues/192, this module should
-- not use CPP.
module Network.Wai.Middleware.RequestLogger
    ( -- * Basic stdout logging
      logStdout
    , logStdoutDev
      -- * Create more versions
    , mkRequestLogger
    , RequestLoggerSettings
    , defaultRequestLoggerSettings
    , outputFormat
    , autoFlush
    , destination
    , OutputFormat (..)
    , ApacheSettings
    , defaultApacheSettings
    , setApacheIPAddrSource
    , setApacheRequestFilter
    , setApacheUserGetter
    , DetailedSettings (..)
    , 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.Class (Default (def))
import Data.IORef
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Monoid (mconcat, (<>))
import Data.Text.Encoding (decodeUtf8')
import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
import Network.HTTP.Types as H
import Network.Wai
  ( Request(..), requestBodyLength, RequestBodyLength(..)
  , Middleware
  , Response, responseStatus, responseHeaders
  , getRequestBodyChunk
  )
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
  ( Param
  , File
  , fileName
  , getRequestBodyType
  , lbsBackEnd
  , sinkRequestBody
  )

-- | The logging format.
data OutputFormat
  = Apache IPAddrSource
  | ApacheWithSettings ApacheSettings -- ^ @since 3.1.8
  | Detailed Bool -- ^ use colors?
  | DetailedWithSettings DetailedSettings -- ^ @since 3.1.3
  | 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 :: IPAddrSource
-> (Request -> Maybe ByteString)
-> (Request -> Response -> Bool)
-> ApacheSettings
ApacheSettings
    { apacheIPAddrSource :: IPAddrSource
apacheIPAddrSource = IPAddrSource
FromSocket
    , apacheRequestFilter :: Request -> Response -> Bool
apacheRequestFilter = \Request
_ Response
_ -> Bool
True
    , apacheUserGetter :: Request -> Maybe ByteString
apacheUserGetter = \Request
_ -> 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 :: IPAddrSource
apacheIPAddrSource = IPAddrSource
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 :: Request -> Response -> Bool
apacheRequestFilter = Request -> Response -> Bool
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 :: Request -> Maybe ByteString
apacheUserGetter = Request -> Maybe ByteString
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
    }

instance Default DetailedSettings where
    def :: DetailedSettings
def = DetailedSettings :: Bool
-> Maybe (Param -> Maybe Param)
-> Maybe (Request -> Response -> Bool)
-> Bool
-> DetailedSettings
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

data Destination = Handle Handle
                 | Logger LoggerSet
                 | Callback Callback

type Callback = LogStr -> IO ()

-- | @RequestLoggerSettings@ is an instance of Default. See <https://hackage.haskell.org/package/data-default Data.Default> for more information.
--
-- @outputFormat@, @autoFlush@, and @destination@ are record fields
-- for the record type @RequestLoggerSettings@, so they can be used to
-- modify settings values using record syntax.
data RequestLoggerSettings = RequestLoggerSettings
    {
      -- | Default value: @Detailed@ @True@.
      RequestLoggerSettings -> OutputFormat
outputFormat :: OutputFormat
      -- | Only applies when using the @Handle@ constructor for @destination@.
      --
      -- Default value: @True@.
    , RequestLoggerSettings -> Bool
autoFlush :: Bool
      -- | Default: @Handle@ @stdout@.
    , RequestLoggerSettings -> Destination
destination :: Destination
    }

defaultRequestLoggerSettings :: RequestLoggerSettings
defaultRequestLoggerSettings :: RequestLoggerSettings
defaultRequestLoggerSettings = RequestLoggerSettings :: OutputFormat -> Bool -> Destination -> RequestLoggerSettings
RequestLoggerSettings
    { outputFormat :: OutputFormat
outputFormat = Bool -> OutputFormat
Detailed Bool
True
    , autoFlush :: Bool
autoFlush = Bool
True
    , destination :: Destination
destination = Handle -> Destination
Handle Handle
stdout
    }

instance Default RequestLoggerSettings where
    def :: RequestLoggerSettings
def = RequestLoggerSettings
defaultRequestLoggerSettings

mkRequestLogger :: RequestLoggerSettings -> IO Middleware
mkRequestLogger :: RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings{Bool
Destination
OutputFormat
destination :: Destination
autoFlush :: Bool
outputFormat :: OutputFormat
destination :: RequestLoggerSettings -> Destination
autoFlush :: RequestLoggerSettings -> Bool
outputFormat :: RequestLoggerSettings -> OutputFormat
..} = 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 (m :: * -> *) a. Monad m => a -> m a
return ())
        callbackAndFlush :: LogStr -> IO ()
callbackAndFlush LogStr
str = LogStr -> IO ()
callback LogStr
str IO () -> IO () -> IO ()
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 (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
apacheRequestFilter :: Request -> Response -> Bool
apacheUserGetter :: Request -> Maybe ByteString
apacheIPAddrSource :: IPAddrSource
apacheRequestFilter :: ApacheSettings -> Request -> Response -> Bool
apacheUserGetter :: ApacheSettings -> Request -> Maybe ByteString
apacheIPAddrSource :: ApacheSettings -> IPAddrSource
..} -> 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 (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
forall a. Default a => a
def { useColors :: Bool
useColors = Bool
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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
forall a. Default a => a
def { outputFormat :: OutputFormat
outputFormat = IPAddrSource -> OutputFormat
Apache IPAddrSource
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
forall a. Default a => a
def

-- | 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
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 (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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Response -> IO Response
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 (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 (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
bsByteString -> [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' = Request
req { requestBody :: IO ByteString
requestBody = IO ByteString
rbody }
  (Request, [ByteString]) -> IO (Request, [ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req', [ByteString]
body)

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)
mPrelogRequests :: Bool
mFilterRequests :: Maybe (Request -> Response -> Bool)
mModifyParams :: Maybe (Param -> Maybe Param)
useColors :: Bool
mPrelogRequests :: DetailedSettings -> Bool
mFilterRequests :: DetailedSettings -> Maybe (Request -> Response -> Bool)
mModifyParams :: DetailedSettings -> Maybe (Param -> Maybe Param)
useColors :: DetailedSettings -> 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 (m :: * -> *) a. Monad m => a -> m a
return (Request
req, [])

  let reqbodylog :: p -> [ByteString]
reqbodylog p
_ = if [ByteString] -> 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"GET", ByteString
"HEAD"]
      then [Param] -> IO [Param]
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 (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 (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 = ((ByteString, Maybe ByteString) -> Param)
-> [(ByteString, Maybe ByteString)] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> Param
emptyGetParam ([(ByteString, Maybe ByteString)] -> [Param])
-> [(ByteString, Maybe ByteString)] -> [Param]
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
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 (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 (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 (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 (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 (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)
                            x: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 :: (ByteString, Maybe ByteString) -> 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 :: t m -> t m -> m -> LogStr
mkRequestLog t m
params t m
reqbody m
accept =
        (ByteString -> LogStr) -> [ByteString] -> LogStr
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 (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 (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 (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 (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 (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"

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