{-# LANGUAGE QuantifiedConstraints #-}
module Control.Eff.Log.MessageRenderer
(
LogMessageRenderer
, renderLogMessageSyslog
, renderLogMessageConsoleLog
, renderRFC3164
, renderRFC3164WithRFC5424Timestamps
, renderRFC3164WithTimestamp
, renderRFC5424
, renderRFC5424Header
, renderRFC5424NoLocation
, renderSyslogSeverityAndFacility
, renderLogMessageSrcLoc
, renderMaybeLogMessageLens
, renderLogMessageBodyNoLocation
, renderLogMessageBody
, renderLogMessageBodyFixWidth
, LogMessageTimeRenderer()
, mkLogMessageTimeRenderer
, suppressTimestamp
, rfc3164Timestamp
, rfc5424Timestamp
, rfc5424NoZTimestamp
)
where
import Control.Eff.Log.Message
import Control.Lens
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import GHC.Stack
import System.FilePath.Posix
import Text.Printf
type LogMessageRenderer a = LogMessage -> a
newtype LogMessageTimeRenderer =
MkLogMessageTimeRenderer { renderLogMessageTime :: UTCTime -> T.Text }
mkLogMessageTimeRenderer
:: String
-> LogMessageTimeRenderer
mkLogMessageTimeRenderer s =
MkLogMessageTimeRenderer (T.pack . formatTime defaultTimeLocale s)
suppressTimestamp :: LogMessageTimeRenderer
suppressTimestamp = MkLogMessageTimeRenderer (const "")
rfc3164Timestamp :: LogMessageTimeRenderer
rfc3164Timestamp = mkLogMessageTimeRenderer "%h %d %H:%M:%S"
rfc5424Timestamp :: LogMessageTimeRenderer
rfc5424Timestamp =
mkLogMessageTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6QZ"))
rfc5424NoZTimestamp :: LogMessageTimeRenderer
rfc5424NoZTimestamp =
mkLogMessageTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6Q"))
renderLogMessageBody :: LogMessageRenderer T.Text
renderLogMessageBody = T.unwords . filter (not . T.null) <$> sequence
[ renderLogMessageBodyNoLocation
, fromMaybe "" <$> renderLogMessageSrcLoc
]
renderLogMessageBodyNoLocation :: LogMessageRenderer T.Text
renderLogMessageBodyNoLocation = T.unwords . filter (not . T.null) <$> sequence
[ renderShowMaybeLogMessageLens "" lmThreadId
, view lmMessage
]
renderLogMessageBodyFixWidth :: LogMessageRenderer T.Text
renderLogMessageBodyFixWidth l@(MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti _ msg)
= T.unwords $ filter
(not . T.null)
[ maybe "" ((<> " ") . T.pack . show) ti
, msg <> T.replicate (max 0 (60 - T.length msg)) " "
, fromMaybe "" (renderLogMessageSrcLoc l)
]
renderMaybeLogMessageLens
:: T.Text -> Getter LogMessage (Maybe T.Text) -> LogMessageRenderer T.Text
renderMaybeLogMessageLens x l = fromMaybe x . view l
renderShowMaybeLogMessageLens
:: Show a
=> T.Text
-> Getter LogMessage (Maybe a)
-> LogMessageRenderer T.Text
renderShowMaybeLogMessageLens x l =
renderMaybeLogMessageLens x (l . to (fmap (T.pack . show)))
renderLogMessageSrcLoc :: LogMessageRenderer (Maybe T.Text)
renderLogMessageSrcLoc = view
( lmSrcLoc
. to
(fmap
(\sl -> T.pack $ printf "at %s:%i"
(takeFileName (srcLocFile sl))
(srcLocStartLine sl)
)
)
)
renderSyslogSeverityAndFacility :: LogMessageRenderer T.Text
renderSyslogSeverityAndFacility (MkLogMessage !f !s _ _ _ _ _ _ _ _ _) =
"<" <> T.pack (show (fromSeverity s + fromFacility f * 8)) <> ">"
renderLogMessageSyslog :: LogMessageRenderer T.Text
renderLogMessageSyslog l@(MkLogMessage _ _ _ _ an _ mi _ _ _ _)
= renderSyslogSeverityAndFacility l <> (T.unwords
. filter (not . T.null)
$ [ fromMaybe "" an
, fromMaybe "" mi
, renderLogMessageBody l
])
renderLogMessageConsoleLog :: LogMessageRenderer T.Text
renderLogMessageConsoleLog l@(MkLogMessage _ _ ts _ _ pd _ sd _ _ _) =
T.unwords $ filter
(not . T.null)
[ view (lmSeverity . to (T.pack . show)) l
, fromMaybe " no proc " pd
, maybe "" (renderLogMessageTime rfc5424Timestamp) ts
, renderLogMessageBodyFixWidth l
, if null sd then "" else T.concat (renderSdElement <$> sd)
]
renderRFC3164 :: LogMessageRenderer T.Text
renderRFC3164 = renderRFC3164WithTimestamp rfc3164Timestamp
renderRFC3164WithRFC5424Timestamps :: LogMessageRenderer T.Text
renderRFC3164WithRFC5424Timestamps =
renderRFC3164WithTimestamp rfc5424Timestamp
renderRFC3164WithTimestamp :: LogMessageTimeRenderer -> LogMessageRenderer T.Text
renderRFC3164WithTimestamp renderTime l@(MkLogMessage _ _ ts hn an pid mi _ _ _ _) =
T.unwords
. filter (not . T.null)
$ [ renderSyslogSeverityAndFacility l
, maybe "1979-05-29T00:17:17.000001Z"
(renderLogMessageTime renderTime)
ts
, fromMaybe "localhost" hn
, fromMaybe "haskell" an <> maybe "" (("[" <>) . (<> "]")) pid <> ":"
, fromMaybe "" mi
, renderLogMessageBody l
]
renderRFC5424 :: LogMessageRenderer T.Text
renderRFC5424 = renderRFC5424Header <> const " " <> renderLogMessageBody
renderRFC5424NoLocation :: LogMessageRenderer T.Text
renderRFC5424NoLocation = renderRFC5424Header <> const " " <> renderLogMessageBodyNoLocation
renderRFC5424Header :: LogMessageRenderer T.Text
renderRFC5424Header l@(MkLogMessage _ _ ts hn an pid mi sd _ _ _) =
T.unwords
. filter (not . T.null)
$ [ renderSyslogSeverityAndFacility l <> "1"
, maybe "-" (renderLogMessageTime rfc5424Timestamp) ts
, fromMaybe "-" hn
, fromMaybe "-" an
, fromMaybe "-" pid
, fromMaybe "-" mi
, structuredData
]
where
structuredData = if null sd then "-" else T.concat (renderSdElement <$> sd)
renderSdElement :: StructuredDataElement -> T.Text
renderSdElement (SdElement sdId params) = "[" <> sdName sdId <> if null params
then ""
else " " <> T.unwords (renderSdParameter <$> params) <> "]"
renderSdParameter :: SdParameter -> T.Text
renderSdParameter (MkSdParameter k v) =
sdName k <> "=\"" <> sdParamValue v <> "\""
sdName :: T.Text -> T.Text
sdName =
T.take 32 . T.filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')
sdParamValue :: T.Text -> T.Text
sdParamValue = T.concatMap $ \case
'"' -> "\\\""
'\\' -> "\\\\"
']' -> "\\]"
x -> T.singleton x