{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Katip.Scribes.Syslog
( mkSyslogScribe
) where
import Control.Exception (SomeException, try)
import Control.Monad
import Data.Aeson (encode)
import Data.ByteString.Lazy (ByteString)
import Data.String.Conv
import qualified Data.Text as T
import Katip.Core
import System.Posix.Syslog
mkSyslogScribe :: Namespace -> Severity -> Verbosity -> IO (Scribe, IO ())
mkSyslogScribe :: Namespace -> Severity -> Verbosity -> IO (Scribe, IO ())
mkSyslogScribe Namespace
ns Severity
sev Verbosity
verb = do
let identifier :: Text
identifier = Text -> [Text] -> Text
T.intercalate Text
"." (Namespace -> [Text]
unNamespace Namespace
ns)
let cfg :: SyslogConfig
cfg = SyslogConfig
defaultConfig { identifier :: ByteString
identifier = Text -> ByteString
forall a b. StringConv a b => a -> b
toS Text
identifier
, options :: [Option]
options = [Option
PID, Option
CONS, Option
ODELAY, Option
NDELAY]
, priorityMask :: PriorityMask
priorityMask = PriorityMask
NoMask
}
#if (MIN_VERSION_katip(0,5,0))
let scribe :: Scribe
scribe = (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
Scribe (\i :: Item a
i@Item{a
HostName
Maybe Loc
UTCTime
ProcessID
Namespace
Environment
Severity
LogStr
ThreadIdText
_itemApp :: forall a. Item a -> Namespace
_itemEnv :: forall a. Item a -> Environment
_itemSeverity :: forall a. Item a -> Severity
_itemThread :: forall a. Item a -> ThreadIdText
_itemHost :: forall a. Item a -> HostName
_itemProcess :: forall a. Item a -> ProcessID
_itemPayload :: forall a. Item a -> a
_itemMessage :: forall a. Item a -> LogStr
_itemTime :: forall a. Item a -> UTCTime
_itemNamespace :: forall a. Item a -> Namespace
_itemLoc :: forall a. Item a -> Maybe Loc
_itemLoc :: Maybe Loc
_itemNamespace :: Namespace
_itemTime :: UTCTime
_itemMessage :: LogStr
_itemPayload :: a
_itemProcess :: ProcessID
_itemHost :: HostName
_itemThread :: ThreadIdText
_itemSeverity :: Severity
_itemEnv :: Environment
_itemApp :: Namespace
..} -> do
#if (MIN_VERSION_katip(0,8,0))
Bool
permit <- Severity -> Item a -> IO Bool
forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem Severity
sev Item a
i
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
permit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#else
when (permitItem sev i) $ do
#endif
Either SomeException ()
res <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ SyslogConfig -> (SyslogFn -> IO ()) -> IO ()
withSyslog SyslogConfig
cfg ((SyslogFn -> IO ()) -> IO ()) -> (SyslogFn -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SyslogFn
syslog -> SyslogFn
syslog Facility
USER (Severity -> Priority
toSyslogPriority Severity
_itemSeverity) (ByteString -> ByteString
forall a b. StringConv a b => a -> b
toS (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Verbosity -> Item a -> ByteString
forall a. LogItem a => Verbosity -> Item a -> ByteString
formatItem Verbosity
verb Item a
i)
case Either SomeException ()
res of
Left (SomeException
e :: SomeException) -> HostName -> IO ()
putStrLn (SomeException -> HostName
forall a. Show a => a -> HostName
show SomeException
e)
Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#if (MIN_VERSION_katip(0,8,0))
(() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Severity -> Item a -> IO Bool
forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem Severity
sev)
#else
(return ())
#endif
#else
let scribe = Scribe $ \ i@Item{..} -> do
when (permitItem sev i) $ do
res <- try $ withSyslog cfg $ \syslog -> syslog USER (toSyslogPriority _itemSeverity) (toS $ formatItem verb i)
case res of
Left (e :: SomeException) -> putStrLn (show e)
Right () -> return ()
#endif
(Scribe, IO ()) -> IO (Scribe, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Scribe
scribe, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
formatItem :: LogItem a => Verbosity -> Item a -> ByteString
formatItem :: Verbosity -> Item a -> ByteString
formatItem Verbosity
verb = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> (Item a -> Value) -> Item a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Item a -> Value
forall a. LogItem a => Verbosity -> Item a -> Value
itemJson Verbosity
verb
toSyslogPriority :: Severity -> Priority
toSyslogPriority :: Severity -> Priority
toSyslogPriority Severity
DebugS = Priority
Debug
toSyslogPriority Severity
InfoS = Priority
Info
toSyslogPriority Severity
NoticeS = Priority
Notice
toSyslogPriority Severity
WarningS = Priority
Warning
toSyslogPriority Severity
ErrorS = Priority
Error
toSyslogPriority Severity
CriticalS = Priority
Critical
toSyslogPriority Severity
AlertS = Priority
Alert
toSyslogPriority Severity
EmergencyS = Priority
Emergency