module Control.Eff.Log.Message
( LogMessage(..)
, renderRFC5424
, printLogMessage
, relogAsDebugMessages
, logWithSeverity
, logEmergency
, logAlert
, logCritical
, logError
, logWarning
, logNotice
, logInfo
, logDebug
, errorMessage
, infoMessage
, debugMessage
, errorMessageIO
, infoMessageIO
, debugMessageIO
, Severity(fromSeverity)
, emergencySeverity
, alertSeverity
, criticalSeverity
, errorSeverity
, warningSeverity
, noticeSeverity
, informationalSeverity
, debugSeverity
, Facility(fromFacility)
, kernelMessages
, userLevelMessages
, mailSystem
, systemDaemons
, securityAuthorizationMessages4
, linePrinterSubsystem
, networkNewsSubsystem
, uucpSubsystem
, clockDaemon
, securityAuthorizationMessages10
, ftpDaemon
, ntpSubsystem
, logAuditFacility
, logAlertFacility
, clockDaemon2
, local0
, local1
, local2
, local3
, local4
, local5
, local6
, local7
, lmFacility
, lmSeverity
, lmTimestamp
, lmHostname
, lmAppname
, lmProcessId
, lmMessageId
, lmStructuredData
, lmSrcLoc
, lmThreadId
, lmMessage
, setCallStack
, StructuredDataElement(..)
, sdElementId
, sdElementParameters
)
where
import Data.Time.Clock
import Data.Time.Format
import Control.Lens
import Control.Eff
import Control.Eff.Log.Handler
import GHC.Stack
import Data.Default
import Control.DeepSeq
import Control.Monad.IO.Class
import Data.Maybe
import Data.String
import Control.Concurrent
import GHC.Generics
import Text.Printf
import Control.Monad ( (>=>) )
data LogMessage =
LogMessage { _lmFacility :: Facility
, _lmSeverity :: Severity
, _lmTimestamp :: Maybe UTCTime
, _lmHostname :: Maybe String
, _lmAppname :: Maybe String
, _lmProcessId :: Maybe String
, _lmMessageId :: Maybe String
, _lmStructuredData :: [StructuredDataElement]
, _lmThreadId :: Maybe ThreadId
, _lmSrcLoc :: Maybe SrcLoc
, _lmMessage :: String}
deriving (Eq, Generic)
showLmMessage :: LogMessage -> [String]
showLmMessage (LogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =
if null msg
then []
else
maybe "" (printf "[%s]" . show) ti
: msg
: maybe [] (pure . prettySrcLoc) loc
renderLogMessage :: LogMessage -> String
renderLogMessage l@(LogMessage _f s ts hn an pid mi sd _ _ _) =
unwords $ filter
(not . null)
( maybe
""
(formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")))
ts
: fromMaybe "" hn
: show s
: fromMaybe "" an
: fromMaybe "" pid
: fromMaybe "" mi
: (if null sd then "" else show sd)
: showLmMessage l
)
renderRFC5424 :: LogMessage -> String
renderRFC5424 l@(LogMessage f s ts hn an pid mi sd _ _ _) = unwords
( ("<" ++ show (fromSeverity s + fromFacility f * 8) ++ ">" ++ "1")
: maybe
"-"
(formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")))
ts
: fromMaybe "-" hn
: fromMaybe "-" an
: fromMaybe "-" pid
: fromMaybe "-" mi
: (if null sd then "-" else show sd)
: showLmMessage l
)
instance NFData LogMessage
data StructuredDataElement =
SdElement { _sdElementId :: String
, _sdElementParameters :: [SdParameter]}
deriving (Eq, Ord, Generic)
instance Show StructuredDataElement where
show (SdElement sdid params) =
"[" ++ sdName sdid ++ if null params then "" else " " ++ unwords (show <$> params) ++ "]"
instance NFData StructuredDataElement
data SdParameter =
SdParameter String String
deriving (Eq, Ord, Generic)
instance Show SdParameter where
show (SdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\""
sdName :: String -> String
sdName = take 32 . filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')
sdParamValue :: String -> String
sdParamValue e = e >>= \case
'"' -> "\\\""
'\\' -> "\\\\"
']' -> "\\]"
x -> [x]
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 "
newtype Facility = Facility {fromFacility :: Int}
deriving (Eq, Ord, Show, Generic, NFData)
makeLenses ''StructuredDataElement
makeLenses ''LogMessage
setCallStack :: CallStack -> LogMessage -> LogMessage
setCallStack cs m = case getCallStack cs of
[] -> m
(_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc
instance Default LogMessage where
def = setCallStack callStack (LogMessage def def def def def def def def def def "")
instance IsString LogMessage where
fromString = infoMessage
printLogMessage :: LogMessage -> IO ()
printLogMessage =
setLogMessageTimestamp
>=> setLogMessageThreadId
>=> putStrLn
. renderLogMessage
setLogMessageTimestamp :: MonadIO m => LogMessage -> m LogMessage
setLogMessageTimestamp m = do
now <- liftIO getCurrentTime
return (m & lmTimestamp ?~ now)
setLogMessageThreadId :: MonadIO m => LogMessage -> m LogMessage
setLogMessageThreadId m = do
t <- liftIO myThreadId
return (m & lmThreadId ?~ t)
relogAsDebugMessages
:: Member (Logs LogMessage) e => Eff (Logs String ': e) a -> Eff e a
relogAsDebugMessages = withFrozenCallStack . handleLogsWith logDebug
logWithSeverity :: Member (Logs LogMessage) e => Severity -> String -> Eff e ()
logWithSeverity s =
withFrozenCallStack
. logMsg
. setCallStack callStack
. set lmSeverity s
. flip (set lmMessage) def
logEmergency :: Member (Logs LogMessage) e => String -> Eff e ()
logEmergency = withFrozenCallStack . logWithSeverity emergencySeverity
logAlert :: Member (Logs LogMessage) e => String -> Eff e ()
logAlert = withFrozenCallStack . logWithSeverity alertSeverity
logCritical :: Member (Logs LogMessage) e => String -> Eff e ()
logCritical = withFrozenCallStack . logWithSeverity criticalSeverity
logError :: Member (Logs LogMessage) e => String -> Eff e ()
logError = withFrozenCallStack . logWithSeverity errorSeverity
logWarning :: Member (Logs LogMessage) e => String -> Eff e ()
logWarning = withFrozenCallStack . logWithSeverity warningSeverity
logNotice :: Member (Logs LogMessage) e => String -> Eff e ()
logNotice = withFrozenCallStack . logWithSeverity noticeSeverity
logInfo :: Member (Logs LogMessage) e => String -> Eff e ()
logInfo = withFrozenCallStack . logWithSeverity informationalSeverity
logDebug :: Member (Logs LogMessage) e => String -> Eff e ()
logDebug = withFrozenCallStack . logWithSeverity debugSeverity
errorMessage :: String -> LogMessage
errorMessage m = withFrozenCallStack
(def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)
infoMessage :: String -> LogMessage
infoMessage m = withFrozenCallStack
( def
& lmSeverity
.~ informationalSeverity
& lmMessage
.~ m
& setCallStack callStack
)
debugMessage :: String -> LogMessage
debugMessage m = withFrozenCallStack
(def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)
errorMessageIO :: MonadIO m => String -> m LogMessage
errorMessageIO =
(setLogMessageThreadId >=> setLogMessageTimestamp) . errorMessage
infoMessageIO :: MonadIO m => String -> m LogMessage
infoMessageIO =
(setLogMessageThreadId >=> setLogMessageTimestamp) . infoMessage
debugMessageIO :: MonadIO m => String -> m LogMessage
debugMessageIO =
(setLogMessageThreadId >=> setLogMessageTimestamp) . debugMessage
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
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