module LogMessageIdeaTest where
import Control.Concurrent
import Control.DeepSeq
import Control.Lens
import Data.Default
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import GHC.Generics hiding ( to )
import GHC.Stack
import System.FilePath.Posix
import Text.Printf
import Control.Eff
import Control.Eff.Reader.Lazy
-- | A message data type inspired by the RFC-5424 Syslog Protocol
data LogMessage =
MkLogMessage { _lmFacility :: !Facility
, _lmSeverity :: !Severity
, _lmTimestamp :: (Maybe UTCTime)
, _lmHostname :: (Maybe T.Text)
, _lmAppName :: (Maybe T.Text)
, _lmProcessId :: (Maybe T.Text)
, _lmMessageId :: (Maybe T.Text)
, _lmStructuredData :: [StructuredDataElement]
, _lmThreadId :: (Maybe ThreadId)
, _lmSrcLoc :: (Maybe SrcLoc)
, _lmMessage :: T.Text}
deriving (Eq, Generic)
instance Default LogMessage where
def = MkLogMessage def def def def def def def def def def ""
instance NFData LogMessage
-- | RFC-5424 defines how structured data can be included in a log message.
data StructuredDataElement =
SdElement { _sdElementId :: !T.Text
, _sdElementParameters :: ![SdParameter]}
deriving (Eq, Ord, Generic, Show)
renderSdElement :: StructuredDataElement -> T.Text
renderSdElement (SdElement sdId params) = "[" <> sdName sdId <> if null params
then ""
else " " <> T.unwords (renderSdParameter <$> params) <> "]"
instance NFData StructuredDataElement
-- | Component of an RFC-5424 'StructuredDataElement'
data SdParameter =
MkSdParameter !T.Text !T.Text
deriving (Eq, Ord, Generic, Show)
renderSdParameter :: SdParameter -> T.Text
renderSdParameter (MkSdParameter k v) =
sdName k <> "=\"" <> sdParamValue v <> "\""
-- | Extract the name of an 'SdParameter' the length is cropped to 32 according to RFC 5424.
sdName :: T.Text -> T.Text
sdName =
T.take 32 . T.filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')
-- | Extract the value of an 'SdParameter'.
sdParamValue :: T.Text -> T.Text
sdParamValue = T.concatMap $ \case
'"' -> "\\\""
'\\' -> "\\\\"
']' -> "\\]"
x -> T.singleton x
instance NFData SdParameter
-- | An rfc 5424 severity
newtype Severity =
Severity {fromSeverity :: Int}
deriving (Eq, Ord, Generic, NFData)
instance Show Severity where
show (Severity 1) = "ALERT "
show (Severity 2) = "CRITICAL "
show (Severity 3) = "ERROR "
show (Severity 4) = "WARNING "
show (Severity 5) = "NOTICE "
show (Severity 6) = "INFO "
show (Severity x) | x <= 0 = "EMERGENCY"
| otherwise = "DEBUG "
-- *** Severities
-- | Smart constructor for the RFC-5424 __emergency__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __0__.
-- See 'lmSeverity'.
emergencySeverity :: Severity
emergencySeverity = Severity 0
-- | Smart constructor for the RFC-5424 __alert__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __1__.
-- See 'lmSeverity'.
alertSeverity :: Severity
alertSeverity = Severity 1
-- | Smart constructor for the RFC-5424 __critical__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __2__.
-- See 'lmSeverity'.
criticalSeverity :: Severity
criticalSeverity = Severity 2
-- | Smart constructor for the RFC-5424 __error__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __3__.
-- See 'lmSeverity'.
errorSeverity :: Severity
errorSeverity = Severity 3
-- | Smart constructor for the RFC-5424 __warning__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __4__.
-- See 'lmSeverity'.
warningSeverity :: Severity
warningSeverity = Severity 4
-- | Smart constructor for the RFC-5424 __notice__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __5__.
-- See 'lmSeverity'.
noticeSeverity :: Severity
noticeSeverity = Severity 5
-- | Smart constructor for the RFC-5424 __informational__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __6__.
-- See 'lmSeverity'.
informationalSeverity :: Severity
informationalSeverity = Severity 6
-- | Smart constructor for the RFC-5424 __debug__ 'LogMessage' 'Severity'.
-- This corresponds to the severity value __7__.
-- See 'lmSeverity'.
debugSeverity :: Severity
debugSeverity = Severity 7
instance Default Severity where
def = debugSeverity
-- | An rfc 5424 facility
newtype Facility = Facility {fromFacility :: Int}
deriving (Eq, Ord, Show, Generic, NFData)
-- | Smart constructor for the RFC-5424 'LogMessage' facility @kernelMessages@.
-- See 'lmFacility'.
kernelMessages :: Facility
kernelMessages = Facility 0
-- | Smart constructor for the RFC-5424 'LogMessage' facility @userLevelMessages@.
-- See 'lmFacility'.
userLevelMessages :: Facility
userLevelMessages = Facility 1
-- | Smart constructor for the RFC-5424 'LogMessage' facility @mailSystem@.
-- See 'lmFacility'.
mailSystem :: Facility
mailSystem = Facility 2
-- | Smart constructor for the RFC-5424 'LogMessage' facility @systemDaemons@.
-- See 'lmFacility'.
systemDaemons :: Facility
systemDaemons = Facility 3
-- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages4@.
-- See 'lmFacility'.
securityAuthorizationMessages4 :: Facility
securityAuthorizationMessages4 = Facility 4
-- | Smart constructor for the RFC-5424 'LogMessage' facility @linePrinterSubsystem@.
-- See 'lmFacility'.
linePrinterSubsystem :: Facility
linePrinterSubsystem = Facility 6
-- | Smart constructor for the RFC-5424 'LogMessage' facility @networkNewsSubsystem@.
-- See 'lmFacility'.
networkNewsSubsystem :: Facility
networkNewsSubsystem = Facility 7
-- | Smart constructor for the RFC-5424 'LogMessage' facility @uucpSubsystem@.
-- See 'lmFacility'.
uucpSubsystem :: Facility
uucpSubsystem = Facility 8
-- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon@.
-- See 'lmFacility'.
clockDaemon :: Facility
clockDaemon = Facility 9
-- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages10@.
-- See 'lmFacility'.
securityAuthorizationMessages10 :: Facility
securityAuthorizationMessages10 = Facility 10
-- | Smart constructor for the RFC-5424 'LogMessage' facility @ftpDaemon@.
-- See 'lmFacility'.
ftpDaemon :: Facility
ftpDaemon = Facility 11
-- | Smart constructor for the RFC-5424 'LogMessage' facility @ntpSubsystem@.
-- See 'lmFacility'.
ntpSubsystem :: Facility
ntpSubsystem = Facility 12
-- | Smart constructor for the RFC-5424 'LogMessage' facility @logAuditFacility@.
-- See 'lmFacility'.
logAuditFacility :: Facility
logAuditFacility = Facility 13
-- | Smart constructor for the RFC-5424 'LogMessage' facility @logAlertFacility@.
-- See 'lmFacility'.
logAlertFacility :: Facility
logAlertFacility = Facility 14
-- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon2@.
-- See 'lmFacility'.
clockDaemon2 :: Facility
clockDaemon2 = Facility 15
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local0@.
-- See 'lmFacility'.
local0 :: Facility
local0 = Facility 16
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local1@.
-- See 'lmFacility'.
local1 :: Facility
local1 = Facility 17
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local2@.
-- See 'lmFacility'.
local2 :: Facility
local2 = Facility 18
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local3@.
-- See 'lmFacility'.
local3 :: Facility
local3 = Facility 19
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local4@.
-- See 'lmFacility'.
local4 :: Facility
local4 = Facility 20
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local5@.
-- See 'lmFacility'.
local5 :: Facility
local5 = Facility 21
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local6@.
-- See 'lmFacility'.
local6 :: Facility
local6 = Facility 22
-- | Smart constructor for the RFC-5424 'LogMessage' facility @local7@.
-- See 'lmFacility'.
local7 :: Facility
local7 = Facility 23
instance Default Facility where
def = local7
makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement
-- | A lens for 'SdParameter's
sdElementParameters
:: Functor f
=> ([SdParameter] -> f [SdParameter])
-> StructuredDataElement
-> f StructuredDataElement
-- | A lens for the key or ID of a group of RFC 5424 key-value pairs.
sdElementId
:: Functor f
=> (T.Text -> f T.Text)
-> StructuredDataElement
-> f StructuredDataElement
makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage
-- | A lens for the UTC time of a 'LogMessage'
-- The function 'setLogMessageTimestamp' can be used to set the field.
lmTimestamp
:: Functor f
=> (Maybe UTCTime -> f (Maybe UTCTime))
-> LogMessage
-> f LogMessage
-- | A lens for the 'ThreadId' of a 'LogMessage'
-- The function 'setLogMessageThreadId' can be used to set the field.
lmThreadId
:: Functor f
=> (Maybe ThreadId -> f (Maybe ThreadId))
-> LogMessage
-> f LogMessage
-- | A lens for the 'StructuredDataElement' of a 'LogMessage'
lmStructuredData
:: Functor f
=> ([StructuredDataElement] -> f [StructuredDataElement])
-> LogMessage
-> f LogMessage
-- | A lens for the 'SrcLoc' of a 'LogMessage'
lmSrcLoc
:: Functor f
=> (Maybe SrcLoc -> f (Maybe SrcLoc))
-> LogMessage
-> f LogMessage
-- | A lens for the 'Severity' of a 'LogMessage'
lmSeverity
:: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage
-- | A lens for a user defined of /process/ id of a 'LogMessage'
lmProcessId
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
-- | A lens for a user defined /message id/ of a 'LogMessage'
lmMessageId
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
-- | A lens for the user defined textual message of a 'LogMessage'
lmMessage :: Functor f => (T.Text -> f T.Text) -> LogMessage -> f LogMessage
-- | A lens for the hostname of a 'LogMessage'
-- The function 'setLogMessageHostname' can be used to set the field.
lmHostname
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
-- | A lens for the 'Facility' of a 'LogMessage'
lmFacility
:: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage
-- | A lens for the RFC 5424 /application/ name of a 'LogMessage'
--
-- One useful pattern for using this field, is to implement log filters that allow
-- info and debug message from the application itself while only allowing warning and error
-- messages from third party libraries:
--
-- > debugLogsForAppName myAppName lm =
-- > view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm
--
-- This concept is also implemented in 'discriminateByAppName'.
lmAppName
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
instance Show LogMessage where
show = T.unpack . T.unlines . renderLogMessageBodyFixWidth
type LogRenderer a = LogMessage -> a
withRenderer :: LogRenderer a -> Eff (Reader (LogRenderer a) ': e) b -> Eff e b
withRenderer = runReader
newtype SeverityText = MkSeverityText { fromSeverityText :: T.Text }
deriving (Semigroup)
mkSyslogSeverityText :: LogRenderer SeverityText
mkSyslogSeverityText (MkLogMessage !f !s _ _ _ _ _ _ _ _ _)
= MkSeverityText $ "<" <> T.pack (show (fromSeverity s + fromFacility f * 8)) <> ">"
newtype FacilityText = MkFacilityText { fromFacilityText :: T.Text }
deriving (Semigroup)
mkSyslogFacilityText :: LogRenderer FacilityText
mkSyslogFacilityText _ = MkFacilityText ""
newtype TimestampText = MkTimestampText { fromTimestampText :: T.Text }
deriving (Semigroup)
mkFormattedTimestampText :: LogTimestampFormat -> LogRenderer (Maybe TimestampText)
mkFormattedTimestampText f (MkLogMessage _ _ ts _ _ _ _ _ _ _ _) =
MkTimestampText . formatLogTimestamp f <$> ts
newtype MessageText = MkMessageText { fromMessageText :: T.Text }
deriving (Semigroup)
mkMessageText :: LogRenderer MessageText
mkMessageText = MkMessageText . renderLogMessageBody
renderDevLogMessage :: LogRenderer T.Text
renderDevLogMessage =
run
$ withRenderer mkSyslogSeverityText
$ withRenderer mkSyslogFacilityText
$ withRenderer mkMessageText
$ withRenderer (fromMaybe (MkTimestampText "-") <$> mkFormattedTimestampText rfc5424NoZTimestamp)
$ mkDevLogMessage
mkDevLogMessage ::
( '[ Reader (LogRenderer SeverityText)
, Reader (LogRenderer FacilityText)
, Reader (LogRenderer TimestampText)
, Reader (LogRenderer MessageText)
]
<:: e
)
=> Eff e (LogRenderer T.Text)
mkDevLogMessage =
(\s ts m -> s <> pure " " <> ts <> pure " " <> m)
<$> (fmap fromSeverityText <$> ask)
<*> (fmap fromTimestampText <$> ask)
<*> (fmap fromMessageText <$> ask)
-- | A time stamp formatting function
newtype LogTimestampFormat =
MkLogTimestampFormat { formatLogTimestamp :: UTCTime -> T.Text }
-- | Make a 'LogTimestampFormat' using 'formatTime' in the 'defaultLocale'.
mkLogTimestampFormat
:: String -- ^ The format string that is passed to 'formatTime'
-> LogTimestampFormat
mkLogTimestampFormat s = MkLogTimestampFormat (T.pack . formatTime defaultTimeLocale s)
-- | Don't render the time stamp
suppressTimestamp :: LogTimestampFormat
suppressTimestamp = MkLogTimestampFormat (const "")
-- | Render the time stamp using @"%h %d %H:%M:%S"@
rfc3164Timestamp :: LogTimestampFormat
rfc3164Timestamp = mkLogTimestampFormat "%h %d %H:%M:%S"
-- | Render the time stamp to @'iso8601DateFormat' (Just "%H:%M:%S%6QZ")@
rfc5424Timestamp :: LogTimestampFormat
rfc5424Timestamp = mkLogTimestampFormat (iso8601DateFormat (Just "%H:%M:%S%6QZ"))
-- | Render the time stamp like 'rfc5424Timestamp' does, but omit the terminal @Z@ character.
rfc5424NoZTimestamp :: LogTimestampFormat
rfc5424NoZTimestamp = mkLogTimestampFormat (iso8601DateFormat (Just "%H:%M:%S%6Q"))
-- | Print the /body/ of a 'LogMessage'
renderLogMessageBodyFixWidth :: LogMessage -> [T.Text]
renderLogMessageBodyFixWidth (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =
if T.null msg
then []
else
maybe "" ((<> " -") . T.pack . show) ti
: (msg <> T.replicate (max 0 (60 - T.length msg)) " ")
: maybe
[]
(\sl -> pure
(T.pack $ printf "% 30s line %i"
(takeFileName (srcLocFile sl))
(srcLocStartLine sl)
)
)
loc
-- | Print the /body/ of a 'LogMessage' without any /tab-stops/
renderLogMessageBody :: LogMessage -> T.Text
renderLogMessageBody (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =
maybe "" (\tis -> T.pack (show tis) <> " ") ti
<> msg
<> maybe
""
(\sl ->
T.pack $ printf " at %s:%i"
(takeFileName (srcLocFile sl))
(srcLocStartLine sl)
)
loc