{-# 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
    , outputFormat
    , autoFlush
    , destination
    , OutputFormat (..)
    , DetailedSettings(..)
    , OutputFormatter
    , OutputFormatterWithDetails
    , OutputFormatterWithDetailsAndHeaders
    , Destination (..)
    , Callback
    , IPAddrSource (..)
    ) where

import System.IO (Handle, hFlush, stdout)
import qualified Data.ByteString.Builder as B (Builder, byteString)
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (pack)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Network.Wai
  ( Request(..), requestBodyLength, RequestBodyLength(..)
  , Middleware
  , Response, responseStatus, responseHeaders
  )
import System.Log.FastLogger
import Network.HTTP.Types as H
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Monoid (mconcat, (<>))
import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File
                         , getRequestBodyType)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as S8
import System.Console.ANSI
import Data.IORef
import System.IO.Unsafe
import Network.Wai.Internal (Response (..))
import Data.Default.Class (Default (def))
import Network.Wai.Logger
import Network.Wai.Middleware.RequestLogger.Internal
import Network.Wai.Header (contentLength)
import Data.Text.Encoding (decodeUtf8')

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

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

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
    }

instance Default RequestLoggerSettings where
    def :: RequestLoggerSettings
def = 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
        }

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
$ ApacheLoggerActions -> Middleware
apacheMiddleware 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 :: ApacheLoggerActions -> Middleware
apacheMiddleware :: ApacheLoggerActions -> Middleware
apacheMiddleware 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
    let msize :: Maybe Integer
msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
    ApacheLoggerActions -> ApacheLogger
apacheLogger ApacheLoggerActions
ala Request
req (Response -> Status
responseStatus Response
res) Maybe Integer
msize
    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 (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ 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
requestBody 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)
mFilterRequests :: Maybe (Request -> Response -> Bool)
mModifyParams :: Maybe (Param -> Maybe Param)
useColors :: 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
  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
$ [LogStr] -> LogStr
forall a. Monoid a => [a] -> a
mconcat ([LogStr] -> LogStr) -> [LogStr] -> LogStr
forall a b. (a -> b) -> a -> b
$ (ByteString -> LogStr) -> [ByteString] -> [LogStr]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ([ByteString] -> [LogStr]) -> [ByteString] -> [LogStr]
forall a b. (a -> b) -> a -> b
$
              ByteString -> [ByteString]
ansiMethod (Request -> ByteString
requestMethod Request
req) [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
" ", Request -> ByteString
rawPathInfo Request
req, ByteString
"\n"] [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
              [ByteString]
params [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
reqbody [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
              Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Accept: " [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
accept, ByteString
"\n"] [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
              if Bool
isRaw then [] else
                  Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Status: " [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
                  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) [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
                  [ByteString
" ", 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, ByteString
"\n"]
      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



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