{-# 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

--------------------------------------------------------------------------------
-- | A syslog `Scribe` which respects the main Katip's guidelines.
-- Returns a tuple containing the `Scribe` and a finaliser.
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 -- Katip does the masking for us.
                           }
#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 ())

--------------------------------------------------------------------------------
-- | Syslog won't handle correctly things like newlines, so it's programmer's
-- responsibility to escape those.
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