{-# LANGUAGE QuantifiedConstraints #-}
module Control.Eff.Log.Message
(
LogMessage(..)
, lmFacility
, lmSeverity
, lmTimestamp
, lmHostname
, lmAppName
, lmProcessId
, lmMessageId
, lmStructuredData
, lmSrcLoc
, lmThreadId
, lmMessage
, setCallStack
, prefixLogMessagesWith
, setLogMessageTimestamp
, setLogMessageThreadId
, setLogMessageHostname
, errorMessage
, infoMessage
, debugMessage
, ToLogMessage(..)
, errorMessageIO
, infoMessageIO
, debugMessageIO
, LogPredicate
, allLogMessages
, noLogMessages
, lmSeverityIs
, lmSeverityIsAtLeast
, lmMessageStartsWith
, discriminateByAppName
, StructuredDataElement(..)
, SdParameter(..)
, sdElementId
, sdElementParameters
, Severity(fromSeverity)
, emergencySeverity
, alertSeverity
, criticalSeverity
, errorSeverity
, warningSeverity
, noticeSeverity
, informationalSeverity
, debugSeverity
, Facility (..)
, kernelMessages
, userLevelMessages
, mailSystem
, systemDaemons
, securityAuthorizationMessages4
, linePrinterSubsystem
, networkNewsSubsystem
, uucpSubsystem
, clockDaemon
, securityAuthorizationMessages10
, ftpDaemon
, ntpSubsystem
, logAuditFacility
, logAlertFacility
, clockDaemon2
, local0
, local1
, local2
, local3
, local4
, local5
, local6
, local7
)
where
import Control.Concurrent
import Control.DeepSeq
import Control.Lens
import Control.Monad ( (>=>) )
import Control.Monad.IO.Class
import Data.Default
import Data.Maybe
import Data.String (IsString(..))
import qualified Data.Text as T
import Data.Time.Clock
import GHC.Generics hiding ( to )
import GHC.Stack
import Network.HostName as Network
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 Show LogMessage where
show = T.unpack . _lmMessage
instance NFData LogMessage
data StructuredDataElement =
SdElement { _sdElementId :: !T.Text
, _sdElementParameters :: ![SdParameter]}
deriving (Eq, Ord, Generic, Show)
instance NFData StructuredDataElement
data SdParameter =
MkSdParameter !T.Text !T.Text
deriving (Eq, Ord, Generic, Show)
instance NFData SdParameter
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 "
emergencySeverity :: Severity
emergencySeverity = Severity 0
alertSeverity :: Severity
alertSeverity = Severity 1
criticalSeverity :: Severity
criticalSeverity = Severity 2
errorSeverity :: Severity
errorSeverity = Severity 3
warningSeverity :: Severity
warningSeverity = Severity 4
noticeSeverity :: Severity
noticeSeverity = Severity 5
informationalSeverity :: Severity
informationalSeverity = Severity 6
debugSeverity :: Severity
debugSeverity = Severity 7
instance Default Severity where
def = debugSeverity
newtype Facility = Facility {fromFacility :: Int}
deriving (Eq, Ord, Show, Generic, NFData)
kernelMessages :: Facility
kernelMessages = Facility 0
userLevelMessages :: Facility
userLevelMessages = Facility 1
mailSystem :: Facility
mailSystem = Facility 2
systemDaemons :: Facility
systemDaemons = Facility 3
securityAuthorizationMessages4 :: Facility
securityAuthorizationMessages4 = Facility 4
linePrinterSubsystem :: Facility
linePrinterSubsystem = Facility 6
networkNewsSubsystem :: Facility
networkNewsSubsystem = Facility 7
uucpSubsystem :: Facility
uucpSubsystem = Facility 8
clockDaemon :: Facility
clockDaemon = Facility 9
securityAuthorizationMessages10 :: Facility
securityAuthorizationMessages10 = Facility 10
ftpDaemon :: Facility
ftpDaemon = Facility 11
ntpSubsystem :: Facility
ntpSubsystem = Facility 12
logAuditFacility :: Facility
logAuditFacility = Facility 13
logAlertFacility :: Facility
logAlertFacility = Facility 14
clockDaemon2 :: Facility
clockDaemon2 = Facility 15
local0 :: Facility
local0 = Facility 16
local1 :: Facility
local1 = Facility 17
local2 :: Facility
local2 = Facility 18
local3 :: Facility
local3 = Facility 19
local4 :: Facility
local4 = Facility 20
local5 :: Facility
local5 = Facility 21
local6 :: Facility
local6 = Facility 22
local7 :: Facility
local7 = Facility 23
instance Default Facility where
def = local7
makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement
sdElementParameters
:: Functor f
=> ([SdParameter] -> f [SdParameter])
-> StructuredDataElement
-> f StructuredDataElement
sdElementId
:: Functor f
=> (T.Text -> f T.Text)
-> StructuredDataElement
-> f StructuredDataElement
makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage
lmTimestamp
:: Functor f
=> (Maybe UTCTime -> f (Maybe UTCTime))
-> LogMessage
-> f LogMessage
lmThreadId
:: Functor f
=> (Maybe ThreadId -> f (Maybe ThreadId))
-> LogMessage
-> f LogMessage
lmStructuredData
:: Functor f
=> ([StructuredDataElement] -> f [StructuredDataElement])
-> LogMessage
-> f LogMessage
lmSrcLoc
:: Functor f
=> (Maybe SrcLoc -> f (Maybe SrcLoc))
-> LogMessage
-> f LogMessage
lmSeverity
:: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage
lmProcessId
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
lmMessageId
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
lmMessage :: Functor f => (T.Text -> f T.Text) -> LogMessage -> f LogMessage
lmHostname
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
lmFacility
:: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage
lmAppName
:: Functor f
=> (Maybe T.Text -> f (Maybe T.Text))
-> LogMessage
-> f LogMessage
setCallStack :: CallStack -> LogMessage -> LogMessage
setCallStack cs m = case getCallStack cs of
[] -> m
(_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc
prefixLogMessagesWith :: T.Text -> LogMessage -> LogMessage
prefixLogMessagesWith = over lmMessage . (<>)
setLogMessageTimestamp :: LogMessage -> IO LogMessage
setLogMessageTimestamp m = if isNothing (m ^. lmTimestamp)
then do
now <- getCurrentTime
return (m & lmTimestamp ?~ now)
else return m
setLogMessageThreadId :: LogMessage -> IO LogMessage
setLogMessageThreadId m = if isNothing (m ^. lmThreadId)
then do
t <- myThreadId
return (m & lmThreadId ?~ t)
else return m
setLogMessageHostname :: LogMessage -> IO LogMessage
setLogMessageHostname m = if isNothing (m ^. lmHostname)
then do
fqdn <- Network.getHostName
return (m & lmHostname ?~ T.pack fqdn)
else return m
errorMessage :: HasCallStack => T.Text -> LogMessage
errorMessage m = withFrozenCallStack
(def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)
infoMessage :: HasCallStack => T.Text -> LogMessage
infoMessage m = withFrozenCallStack
( def
& lmSeverity
.~ informationalSeverity
& lmMessage
.~ m
& setCallStack callStack
)
debugMessage :: HasCallStack => T.Text -> LogMessage
debugMessage m = withFrozenCallStack
(def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)
errorMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage
errorMessageIO =
withFrozenCallStack
$ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)
. errorMessage
infoMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage
infoMessageIO =
withFrozenCallStack
$ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)
. infoMessage
debugMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage
debugMessageIO =
withFrozenCallStack
$ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)
. debugMessage
class ToLogMessage a where
toLogMessage :: a -> LogMessage
instance ToLogMessage LogMessage where
toLogMessage = id
instance ToLogMessage T.Text where
toLogMessage = infoMessage
instance IsString LogMessage where
fromString = infoMessage . T.pack
type LogPredicate = LogMessage -> Bool
allLogMessages :: LogPredicate
allLogMessages = const True
noLogMessages :: LogPredicate
noLogMessages = const False
lmSeverityIs :: Severity -> LogPredicate
lmSeverityIs s = view (lmSeverity . to (== s))
lmSeverityIsAtLeast :: Severity -> LogPredicate
lmSeverityIsAtLeast s = view (lmSeverity . to (<= s))
lmMessageStartsWith :: T.Text -> LogPredicate
lmMessageStartsWith prefix lm = case T.length prefix of
0 -> True
prefixLen -> T.take prefixLen (lm ^. lmMessage) == prefix
discriminateByAppName :: T.Text -> LogPredicate -> LogPredicate -> LogPredicate
discriminateByAppName appName appPredicate otherPredicate lm =
if view lmAppName lm == Just appName
then appPredicate lm
else otherPredicate lm