{-# 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
    , 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)
#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
  ( 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
    { apacheIPAddrSource :: IPAddrSource
apacheIPAddrSource = IPAddrSource
FromSocket
    , apacheRequestFilter :: Request -> Response -> Bool
apacheRequestFilter = \Request
_ Response
_ -> Bool
True
    , apacheUserGetter :: Request -> Maybe ByteString
apacheUserGetter = \Request
_ -> 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
        { useColors :: Bool
useColors = Bool
True
        , mModifyParams :: Maybe (Param -> Maybe Param)
mModifyParams = forall a. Maybe a
Nothing
        , mFilterRequests :: Maybe (Request -> Response -> Bool)
mFilterRequests = 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 :: 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
logToByteString, forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFlush (Handle -> IO ()
hFlush Handle
h))
                Logger LoggerSet
l -> (LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
l, forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFlush (LoggerSet -> IO ()
flushLogStr LoggerSet
l))
                Callback LogStr -> IO ()
c -> (LogStr -> IO ()
c, forall (m :: * -> *) a. Monad m => a -> m a
return ())
        callbackAndFlush :: LogStr -> IO ()
callbackAndFlush LogStr
str = LogStr -> IO ()
callback LogStr
str 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 (forall a. (a -> IO ()) -> IO () -> LogType' a
LogCallback LogStr -> IO ()
callback IO ()
flusher) IO ByteString
getdate
            forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall user.
ToLogStr user =>
Maybe (Request -> Maybe user)
-> IPAddrSource
-> LogType
-> IO ByteString
-> IO ApacheLoggerActions
initLoggerUser (forall a. a -> Maybe a
Just Request -> Maybe ByteString
apacheUserGetter) IPAddrSource
apacheIPAddrSource (forall a. (a -> IO ()) -> IO () -> LogType' a
LogCallback LogStr -> IO ()
callback IO ()
flusher) IO ByteString
getdate
            forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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
            forall (m :: * -> *) a. Monad m => a -> m a
return 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
            forall (m :: * -> *) a. Monad m => a -> m a
return 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
            forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Request -> Response -> Bool
applyRequestFilter Request
req Response
res) forall a b. (a -> b) -> a -> b
$
        ApacheLoggerActions -> ApacheLogger
apacheLogger ApacheLoggerActions
ala Request
req (Response -> Status
responseStatus Response
res) 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 forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    ByteString
date <- 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)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogStr -> IO ()
cb 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' forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    UTCTime
t1 <- IO UTCTime
getCurrentTime
    ByteString
date <- 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 <- forall a. a -> IO (IORef a)
newIORef 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'
    ()
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> IO ()
cb 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      forall a. IORef a -> IO a
readIORef IORef Builder
builderIO
    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' forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    UTCTime
t1 <- IO UTCTime
getCurrentTime
    ByteString
date <- 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 <- forall a. a -> IO (IORef a)
newIORef 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 <- 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'
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> IO ()
cb 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
    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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ RequestLoggerSettings -> IO Middleware
mkRequestLogger 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ RequestLoggerSettings -> IO Middleware
mkRequestLogger 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

-- 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], (forall a. a -> [a] -> [a]
:[]), \ByteString
_ ByteString
t -> [ByteString
t])

    in forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 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) =
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
ResponseStream Status
s [(HeaderName, ByteString)]
h forall a b. (a -> b) -> a -> b
$ (\Builder -> IO ()
send IO ()
flush -> StreamingBody
sb (\Builder
b -> forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
i (forall a. Semigroup a => a -> a -> a
<> Builder
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) =
  forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
i (forall a. Semigroup a => a -> a -> a
<> Builder
b) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 =
  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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> c
front []
             else ([ByteString] -> c) -> IO c
loop forall a b. (a -> b) -> a -> b
$ [ByteString] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsforall a. a -> [a] -> [a]
:)
  [ByteString]
body <- forall {c}. ([ByteString] -> c) -> IO c
loop 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 <- forall a. a -> IO (IORef a)
newIORef [ByteString]
body
  let rbody :: IO ByteString
rbody = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ichunks 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 }
  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 forall a. Ord a => a -> a -> Bool
<= Word64
2048 -> Request -> IO (Request, [ByteString])
getRequestBody Request
req
          (RequestBodyLength
_, Just Integer
len)        | Integer
len forall a. Ord a => a -> a -> Bool
<= Integer
2048 -> Request -> IO (Request, [ByteString])
getRequestBody Request
req
          (RequestBodyLength, Maybe Integer)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, [])

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

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

  UTCTime
t0 <- IO UTCTime
getCurrentTime

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

  Application
app Request
req' 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 forall a b. (a -> b) -> a -> b
$ Request -> Response -> Bool
f Request
req' Response
rsp -> 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 forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) m.
(Foldable t, ToLogStr m) =>
t m -> t m -> m -> LogStr
mkRequestLog [ByteString]
params [ByteString]
reqbody ByteString
accept
            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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
            Just RequestBodyType
rbt -> do
                IORef [ByteString]
ichunks <- forall a. a -> IO (IORef a)
newIORef [ByteString]
body
                let rbody :: IO ByteString
rbody = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ichunks forall a b. (a -> b) -> a -> b
$ \[ByteString]
chunks ->
                        case [ByteString]
chunks of
                            [] -> ([], ByteString
S8.empty)
                            ByteString
x:[ByteString]
y -> ([ByteString]
y, ByteString
x)
                forall y.
BackEnd y
-> RequestBodyType -> IO ByteString -> IO ([Param], [File y])
sinkRequestBody 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 forall a. [a] -> [a] -> [a]
++
      forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k,FileInfo ByteString
v) -> (ByteString
k, ByteString
"FILE: " forall a. Semigroup a => a -> a -> a
<> 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 =
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> [ByteString]
ansiMethod (Request -> ByteString
requestMethod Request
req))
        forall a. Semigroup a => a -> a -> a
<> LogStr
" "
        forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
rawPathInfo Request
req)
        forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall msg. ToLogStr msg => msg -> LogStr
toLogStr t m
params
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall msg. ToLogStr msg => msg -> LogStr
toLogStr t m
reqbody
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Accept: ")
        forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr m
accept
        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
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
"  Status: ")
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> ByteString -> [ByteString]
ansiStatusCode ByteString
stCode (ByteString
stCode forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> ByteString
stMsg))
        forall a. Semigroup a => a -> a -> a
<> LogStr
" "
        forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t0)
        forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

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

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