module Network.Wai.Middleware.FilterLogger.Internal where
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS hiding (ByteString)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Lazy as BL (ByteString,
fromStrict,
toStrict)
import Data.Char
import Data.Default
import Data.Semigroup
import Data.Time.Clock (NominalDiffTime)
import Data.Word
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Logger
import Network.Wai.Middleware.FilterLogger.Colorizer
import Network.Wai.Middleware.RequestLogger
import System.IO.Unsafe
import System.Log.FastLogger
import Text.Printf (printf)
data FilterOptions = FilterOptions {
detailed :: Bool
, logOnEmptyBody :: Bool
}
instance Default FilterOptions where
def = FilterOptions True True
class LogShowable a where
logShow :: a -> ByteString
instance LogShowable ByteString where
logShow = id
instance LogShowable BL.ByteString where
logShow = BL.toStrict
logShowJSON :: (ToJSON a) => a -> ByteString
logShowJSON = BL.toStrict . encodePretty
logFilterJSON :: (FromJSON a) => ByteString -> Maybe a
logFilterJSON = decodeStrict'
class LogFilterable a where
prep :: ByteString -> Maybe a
instance LogFilterable ByteString where
prep = return
instance LogFilterable BL.ByteString where
prep = return . BL.fromStrict
class (LogFilterable a, LogShowable a) => Loggable a where
instance Loggable ByteString where
instance Loggable BL.ByteString where
type LogFilter a = a -> Maybe a
logFilter :: (Loggable a) => ByteString -> LogFilter a -> Maybe a
logFilter bs lf = prep bs >>= lf
mkDefaultFilterLogger :: (Loggable a) => LogFilter a -> Middleware
mkDefaultFilterLogger = mkFilterLogger def
mkFilterLogger :: (Loggable a) => FilterOptions -> LogFilter a -> Middleware
mkFilterLogger opts lf = unsafePerformIO $
mkRequestLogger def { outputFormat = CustomOutputFormatWithDetails $ customOutputFormatter opts lf }
customOutputFormatter :: (Loggable a) => FilterOptions -> LogFilter a -> OutputFormatterWithDetails
customOutputFormatter FilterOptions{..} lf date req status responseSize time reqBody builder =
maybe mempty (buildLog detailed date req status responseSize time builder) bodyToLog
where bodyToLog
| null reqBody && logOnEmptyBody = Just BS.empty
| otherwise = logShow <$> logFilter (BS.concat reqBody) lf
type MyOutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> Builder -> ByteString -> LogStr
buildLog :: Bool -> MyOutputFormatter
buildLog detail date req status responseSize time builder body = logString detail
where
dfromRational :: Rational -> Double
dfromRational = fromRational
inMS = printf "%.2f" . dfromRational $ toRational time * 1000
header = colorizedUrl <> "\n" <>
date <> "\n" <>
colorizedStatusCode <> "\n"
buildRespSize (Just s) = "Response Size: " <> toBS (show s) <> "\n"
buildRespSize Nothing = ""
buildDuration = toBS inMS <> "ms" <> "\n"
buildDetails True = buildRespSize responseSize <> buildDuration
buildDetails False = ""
formattedBody
| BS.null body = body
| otherwise = yellow $ body <> "\n"
logString detailed = toLogStr (
header <>
buildDetails detail <>
formattedBody)
colorizedUrl = cyan $ rawPathInfo req <> rawQueryString req
colorizedStatusCode
| code < 300 = green str
| code < 400 = yellow str
| otherwise = red str
where str = toBS (show code) <> " " <> codeMsg
code = statusCode status
codeMsg = statusMessage status