{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Middleware.RequestLogger (
logStdout,
logStdoutDev,
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 (Default (def))
import Data.IORef
import Data.Maybe (fromMaybe, isJust, mapMaybe)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import Data.Text.Encoding (decodeUtf8')
import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
import Network.HTTP.Types as H
import Network.Wai (
Middleware,
Request (..),
RequestBodyLength (..),
Response,
getRequestBodyChunk,
requestBodyLength,
responseHeaders,
responseStatus,
setRequestBodyChunks,
)
import Network.Wai.Internal (Response (..))
import Network.Wai.Logger
import System.Console.ANSI
import System.IO (Handle, hFlush, stdout)
import System.IO.Unsafe (unsafePerformIO)
import System.Log.FastLogger
import Network.Wai.Header (contentLength)
import Network.Wai.Middleware.RequestLogger.Internal
import Network.Wai.Parse (
File,
Param,
fileName,
getRequestBodyType,
lbsBackEnd,
sinkRequestBody,
)
data OutputFormat
= Apache IPAddrSource
|
ApacheWithSettings ApacheSettings
|
Detailed Bool
|
DetailedWithSettings DetailedSettings
| CustomOutputFormat OutputFormatter
| CustomOutputFormatWithDetails OutputFormatterWithDetails
| CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders
data ApacheSettings = ApacheSettings
{ ApacheSettings -> IPAddrSource
apacheIPAddrSource :: IPAddrSource
, ApacheSettings -> Request -> Maybe ByteString
apacheUserGetter :: Request -> Maybe BS.ByteString
, ApacheSettings -> Request -> Response -> Bool
apacheRequestFilter :: Request -> Response -> Bool
}
defaultApacheSettings :: ApacheSettings
defaultApacheSettings :: ApacheSettings
defaultApacheSettings =
ApacheSettings
{ apacheIPAddrSource :: IPAddrSource
apacheIPAddrSource = IPAddrSource
FromSocket
, apacheRequestFilter :: Request -> Response -> Bool
apacheRequestFilter = \Request
_ Response
_ -> Bool
True
, apacheUserGetter :: Request -> Maybe ByteString
apacheUserGetter = Maybe ByteString -> Request -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing
}
setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings
setApacheIPAddrSource :: IPAddrSource -> ApacheSettings -> ApacheSettings
setApacheIPAddrSource IPAddrSource
x ApacheSettings
y = ApacheSettings
y{apacheIPAddrSource = x}
setApacheRequestFilter
:: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings
setApacheRequestFilter :: (Request -> Response -> Bool) -> ApacheSettings -> ApacheSettings
setApacheRequestFilter Request -> Response -> Bool
x ApacheSettings
y = ApacheSettings
y{apacheRequestFilter = x}
setApacheUserGetter
:: (Request -> Maybe BS.ByteString) -> ApacheSettings -> ApacheSettings
setApacheUserGetter :: (Request -> Maybe ByteString) -> ApacheSettings -> ApacheSettings
setApacheUserGetter Request -> Maybe ByteString
x ApacheSettings
y = ApacheSettings
y{apacheUserGetter = x}
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
}
instance Default DetailedSettings where
def :: DetailedSettings
def =
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
type OutputFormatterWithDetailsAndHeaders =
ZonedDate
-> Request
-> Status
-> Maybe Integer
-> NominalDiffTime
-> [S8.ByteString]
-> B.Builder
-> [Header]
-> LogStr
data Destination
= Handle Handle
| Logger LoggerSet
| Callback Callback
type Callback = LogStr -> IO ()
data RequestLoggerSettings = RequestLoggerSettings
{ RequestLoggerSettings -> OutputFormat
outputFormat :: OutputFormat
, RequestLoggerSettings -> Bool
autoFlush :: Bool
, 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
outputFormat :: RequestLoggerSettings -> OutputFormat
autoFlush :: RequestLoggerSettings -> Bool
destination :: RequestLoggerSettings -> Destination
outputFormat :: OutputFormat
autoFlush :: Bool
destination :: Destination
..} = do
let (LogStr -> IO ()
callback, IO ()
flusher) =
case Destination
destination of
Handle Handle
h -> (Handle -> ByteString -> IO ()
BS.hPutStr Handle
h (ByteString -> IO ()) -> (LogStr -> ByteString) -> LogStr -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
logToByteString, Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFlush (Handle -> IO ()
hFlush Handle
h))
Logger LoggerSet
l -> (LoggerSet -> LogStr -> IO ()
pushLogStr LoggerSet
l, Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoFlush (LoggerSet -> IO ()
flushLogStr LoggerSet
l))
Callback LogStr -> IO ()
c -> (LogStr -> IO ()
c, () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
callbackAndFlush :: LogStr -> IO ()
callbackAndFlush LogStr
str = LogStr -> IO ()
callback LogStr
str IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flusher
case OutputFormat
outputFormat of
Apache IPAddrSource
ipsrc -> do
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
apache <- initLogger ipsrc (LogCallback callback flusher) getdate
return $ apacheMiddleware (\Request
_ Response
_ -> Bool
True) apache
ApacheWithSettings ApacheSettings{IPAddrSource
Request -> Maybe ByteString
Request -> Response -> Bool
apacheIPAddrSource :: ApacheSettings -> IPAddrSource
apacheUserGetter :: ApacheSettings -> Request -> Maybe ByteString
apacheRequestFilter :: ApacheSettings -> Request -> Response -> Bool
apacheIPAddrSource :: IPAddrSource
apacheUserGetter :: Request -> Maybe ByteString
apacheRequestFilter :: Request -> Response -> Bool
..} -> do
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
apache <-
initLoggerUser
(Just apacheUserGetter)
apacheIPAddrSource
(LogCallback callback flusher)
getdate
return $ apacheMiddleware apacheRequestFilter apache
Detailed Bool
useColors ->
let settings :: DetailedSettings
settings = DetailedSettings
forall a. Default a => a
def{useColors = useColors}
in (LogStr -> IO ()) -> DetailedSettings -> IO Middleware
detailedMiddleware LogStr -> IO ()
callbackAndFlush DetailedSettings
settings
DetailedWithSettings DetailedSettings
settings ->
(LogStr -> IO ()) -> DetailedSettings -> IO Middleware
detailedMiddleware LogStr -> IO ()
callbackAndFlush DetailedSettings
settings
CustomOutputFormat OutputFormatter
formatter -> do
getDate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
return $ customMiddleware callbackAndFlush getDate formatter
CustomOutputFormatWithDetails OutputFormatterWithDetails
formatter -> do
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
return $ customMiddlewareWithDetails callbackAndFlush getdate formatter
CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders
formatter -> do
getdate <- IO () -> IO (IO ByteString)
getDateGetter IO ()
flusher
return $
customMiddlewareWithDetailsAndHeaders callbackAndFlush getdate 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
date <- IO ByteString -> IO ByteString
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
getdate
let msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
liftIO $ cb $ formatter date req (responseStatus res) msize
sendResponse 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
(req', reqBody) <- Request -> IO (Request, [ByteString])
getRequestBody Request
req
t0 <- getCurrentTime
app req' $ \Response
res -> do
t1 <- IO UTCTime
getCurrentTime
date <- liftIO getdate
let msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
builderIO <- newIORef $ B.byteString ""
res' <- recordChunks builderIO res
rspRcv <- sendResponse res'
_ <-
liftIO
. cb
. formatter date req' (responseStatus res') msize (t1 `diffUTCTime` t0) reqBody
=<< readIORef builderIO
return 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
(req', reqBody) <- Request -> IO (Request, [ByteString])
getRequestBody Request
req
t0 <- getCurrentTime
app req' $ \Response
res -> do
t1 <- IO UTCTime
getCurrentTime
date <- liftIO getdate
let msize = [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Response -> [(HeaderName, ByteString)]
responseHeaders Response
res)
builderIO <- newIORef $ B.byteString ""
res' <- recordChunks builderIO res
rspRcv <- sendResponse res'
_ <- do
rawResponse <- readIORef builderIO
let status = Response -> Status
responseStatus Response
res'
duration = UTCTime
t1 UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t0
resHeaders = Response -> [(HeaderName, ByteString)]
responseHeaders Response
res'
liftIO . cb $
formatter date req' status msize duration reqBody rawResponse resHeaders
return rspRcv
{-# 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 = Apache FromSocket}
{-# 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
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ (LogStr -> IO ())
-> DetailedSettings
-> (Color -> ByteString -> [ByteString])
-> (ByteString -> [ByteString])
-> (ByteString -> ByteString -> [ByteString])
-> Middleware
detailedMiddleware' LogStr -> IO ()
cb DetailedSettings
settings Color -> ByteString -> [ByteString]
ansiColor ByteString -> [ByteString]
ansiMethod ByteString -> ByteString -> [ByteString]
ansiStatusCode
ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
ansiColor' :: Color -> ByteString -> [ByteString]
ansiColor' Color
color ByteString
bs =
[ String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
color]
, ByteString
bs
, String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]
]
ansiMethod' :: BS.ByteString -> [BS.ByteString]
ansiMethod' :: ByteString -> [ByteString]
ansiMethod' ByteString
m = case ByteString
m of
ByteString
"GET" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Cyan ByteString
m
ByteString
"HEAD" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Cyan ByteString
m
ByteString
"PUT" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Green ByteString
m
ByteString
"POST" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Yellow ByteString
m
ByteString
"DELETE" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Red ByteString
m
ByteString
_ -> Color -> ByteString -> [ByteString]
ansiColor' Color
Magenta ByteString
m
ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
ansiStatusCode' :: ByteString -> ByteString -> [ByteString]
ansiStatusCode' ByteString
c ByteString
t = case Int -> ByteString -> ByteString
S8.take Int
1 ByteString
c of
ByteString
"2" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Green ByteString
t
ByteString
"3" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Yellow ByteString
t
ByteString
"4" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Red ByteString
t
ByteString
"5" -> Color -> ByteString -> [ByteString]
ansiColor' Color
Magenta ByteString
t
ByteString
_ -> Color -> ByteString -> [ByteString]
ansiColor' Color
Blue ByteString
t
recordChunks :: IORef B.Builder -> Response -> IO Response
recordChunks :: IORef Builder -> Response -> IO Response
recordChunks IORef Builder
i (ResponseStream Status
s [(HeaderName, ByteString)]
h StreamingBody
sb) =
Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response)
-> (StreamingBody -> Response) -> StreamingBody -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
ResponseStream Status
s [(HeaderName, ByteString)]
h (StreamingBody -> IO Response) -> StreamingBody -> IO Response
forall a b. (a -> b) -> a -> b
$
(\Builder -> IO ()
send IO ()
flush -> StreamingBody
sb (\Builder
b -> IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
i (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> IO ()
send Builder
b) IO ()
flush)
recordChunks IORef Builder
i (ResponseBuilder Status
s [(HeaderName, ByteString)]
h Builder
b) =
IORef Builder -> (Builder -> Builder) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Builder
i (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b) IO () -> IO Response -> IO Response
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> [(HeaderName, ByteString)] -> Builder -> Response
ResponseBuilder Status
s [(HeaderName, ByteString)]
h Builder
b)
recordChunks IORef Builder
_ Response
r =
Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response
r
getRequestBody :: Request -> IO (Request, [S8.ByteString])
getRequestBody :: Request -> IO (Request, [ByteString])
getRequestBody Request
req = do
let loop :: ([ByteString] -> c) -> IO c
loop [ByteString] -> c
front = do
bs <- Request -> IO ByteString
getRequestBodyChunk Request
req
if S8.null bs
then return $ front []
else loop $ front . (bs :)
body <- ([ByteString] -> [ByteString]) -> IO [ByteString]
forall {c}. ([ByteString] -> c) -> IO c
loop [ByteString] -> [ByteString]
forall a. a -> a
id
ichunks <- newIORef body
let 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' = IO ByteString -> Request -> Request
setRequestBodyChunks IO ByteString
rbody Request
req
return (req', 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)
mModifyParams :: DetailedSettings -> Maybe (Param -> Maybe Param)
mFilterRequests :: DetailedSettings -> Maybe (Request -> Response -> Bool)
useColors :: DetailedSettings -> Bool
mPrelogRequests :: DetailedSettings -> Bool
useColors :: Bool
mModifyParams :: Maybe (Param -> Maybe Param)
mFilterRequests :: Maybe (Request -> Response -> Bool)
mPrelogRequests :: Bool
..} Color -> ByteString -> [ByteString]
ansiColor ByteString -> [ByteString]
ansiMethod ByteString -> ByteString -> [ByteString]
ansiStatusCode Application
app Request
req Response -> IO ResponseReceived
sendResponse = do
(req', body) <-
case (Request -> RequestBodyLength
requestBodyLength Request
req, [(HeaderName, ByteString)] -> Maybe Integer
contentLength (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)) of
(KnownLength Word64
len, Maybe Integer
_) | Word64
len Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
2048 -> Request -> IO (Request, [ByteString])
getRequestBody Request
req
(RequestBodyLength
_, Just Integer
len) | Integer
len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
2048 -> Request -> IO (Request, [ByteString])
getRequestBody Request
req
(RequestBodyLength, Maybe Integer)
_ -> (Request, [ByteString]) -> IO (Request, [ByteString])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req, [])
let reqbodylog p
_ =
if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
body Bool -> Bool -> Bool
|| Maybe (Param -> Maybe Param) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Param -> Maybe Param)
mModifyParams
then [ByteString
""]
else Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
" Request Body: " [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
body [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString
"\n"]
reqbody = (ByteString -> [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
postParams <-
if requestMethod req `elem` ["GET", "HEAD"]
then return []
else do
(unmodifiedPostParams, files) <- liftIO $ allPostParams body
let 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
return $ collectPostParams (postParams, files)
let getParams = (QueryItem -> Param) -> [QueryItem] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map QueryItem -> Param
emptyGetParam ([QueryItem] -> [Param]) -> [QueryItem] -> [Param]
forall a b. (a -> b) -> a -> b
$ Request -> [QueryItem]
queryString Request
req
accept = ByteString -> 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 =
let par :: [ByteString]
par
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Param] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Param]
postParams = [String -> ByteString
pack ([Param] -> String
forall a. Show a => a -> String
show [Param]
postParams)]
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Param] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Param]
getParams = [String -> ByteString
pack ([Param] -> String
forall a. Show a => a -> String
show [Param]
getParams)]
| Bool
otherwise = []
in if [ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
par then [ByteString
""] else Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
" Params: " [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString]
par [ByteString] -> [ByteString] -> [ByteString]
forall a. Semigroup a => a -> a -> a
<> [ByteString
"\n"]
t0 <- getCurrentTime
when mPrelogRequests $
cb $
"PRELOGGING REQUEST: " <> mkRequestLog params reqbody accept
app req' $ \Response
rsp -> do
case Maybe (Request -> Response -> Bool)
mFilterRequests of
Just Request -> Response -> Bool
f | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Request -> Response -> Bool
f Request
req' Response
rsp -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe (Request -> Response -> Bool)
_ -> do
let isRaw :: Bool
isRaw =
case Response
rsp of
ResponseRaw{} -> Bool
True
Response
_ -> Bool
False
stCode :: ByteString
stCode = Response -> ByteString
statusBS Response
rsp
stMsg :: ByteString
stMsg = Response -> ByteString
msgBS Response
rsp
t1 <- IO UTCTime
getCurrentTime
cb $
mkRequestLog params reqbody accept
<> mkResponseLog isRaw stCode stMsg t1 t0
Response -> IO ResponseReceived
sendResponse Response
rsp
where
allPostParams :: [ByteString] -> IO ([Param], [File ByteString])
allPostParams [ByteString]
body =
case Request -> Maybe RequestBodyType
getRequestBodyType Request
req of
Maybe RequestBodyType
Nothing -> ([Param], [File ByteString]) -> IO ([Param], [File ByteString])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
Just RequestBodyType
rbt -> do
ichunks <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
body
let 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)
sinkRequestBody lbsBackEnd rbt rbody
emptyGetParam
:: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
emptyGetParam :: QueryItem -> Param
emptyGetParam (ByteString
k, Just ByteString
v) = (ByteString
k, ByteString
v)
emptyGetParam (ByteString
k, Maybe ByteString
Nothing) = (ByteString
k, ByteString
"")
collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
collectPostParams :: ([Param], [File ByteString]) -> [Param]
collectPostParams ([Param]
postParams, [File ByteString]
files) =
[Param]
postParams
[Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++ (File ByteString -> Param) -> [File ByteString] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k, FileInfo ByteString
v) -> (ByteString
k, ByteString
"FILE: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> FileInfo ByteString -> ByteString
forall c. FileInfo c -> ByteString
fileName FileInfo ByteString
v)) [File ByteString]
files
mkRequestLog :: (Foldable t, ToLogStr m) => t m -> t m -> m -> LogStr
mkRequestLog :: forall (t :: * -> *) m.
(Foldable t, ToLogStr m) =>
t m -> t m -> m -> LogStr
mkRequestLog t m
params t m
reqbody m
accept =
(ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> [ByteString]
ansiMethod (Request -> ByteString
requestMethod Request
req))
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
rawPathInfo Request
req)
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (m -> LogStr) -> t m -> LogStr
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap m -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr t m
params
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (m -> LogStr) -> t m -> LogStr
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap m -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr t m
reqbody
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
" Accept: ")
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> m -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr m
accept
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
mkResponseLog
:: Bool -> S8.ByteString -> S8.ByteString -> UTCTime -> UTCTime -> LogStr
mkResponseLog :: Bool -> ByteString -> ByteString -> UTCTime -> UTCTime -> LogStr
mkResponseLog Bool
isRaw ByteString
stCode ByteString
stMsg UTCTime
t1 UTCTime
t0 =
if Bool
isRaw
then LogStr
""
else
(ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Color -> ByteString -> [ByteString]
ansiColor Color
White ByteString
" Status: ")
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (ByteString -> LogStr) -> [ByteString] -> LogStr
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> ByteString -> [ByteString]
ansiStatusCode ByteString
stCode (ByteString
stCode ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
stMsg))
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" "
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> String
forall a. Show a => a -> String
show (NominalDiffTime -> String) -> NominalDiffTime -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t0)
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
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