module System.Posix.Syslog.TCP
(
initSyslog
, SyslogFn
, SyslogConn (..)
, SyslogConfig (..)
, defaultConfig
, getAppName
, getHostName
, getProcessId
, Protocol
, rfc5424TCPProtocol
, rfc3164TCPProtocol
, rsyslogTCPProtocol
, L.Priority (..)
, L.Facility (..)
, L.PriorityMask (..)
, AppName (..)
, HostName (..)
, ProcessID (..)
, MessageID (..)
, Severity
, SeverityMask
) where
import Control.Exception (onException, mask)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import qualified Network.Socket as N
import qualified Network.Socket.ByteString as N
import qualified System.Posix.Syslog as L
import System.Posix.Syslog.UDP hiding (Protocol, SyslogConfig (..), SyslogFn,
defaultConfig, initSyslog, rfc3164Packet,
rfc3164Protocol, rfc5424Packet, rfc5424Protocol,
rsyslogPacket, rsyslogProtocol)
type SyslogFn
= L.Facility
-> Severity
-> T.Text
-> IO ()
data SyslogConn = SyslogConn
{
_syslogConnSend :: SyslogFn
, _syslogConnClose :: IO ()
}
initSyslog :: SyslogConfig -> IO SyslogConn
initSyslog config = do
let addr = _address config
mask $ \restore -> do
socket <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
restore (N.connect socket (N.addrAddress addr)) `onException` N.close socket
let
send_fn fac sev msg =
case maskedPriVal (_severityMask config) fac sev of
Nothing -> return ()
Just priVal -> do
time <- getCurrentTime
let bs = getProtocol (_protocol config)
priVal time (_hostName config) (_appName config)
(_processId config) msg
N.sendAll socket bs
close_fn = N.close socket
return (SyslogConn send_fn close_fn)
data SyslogConfig = SyslogConfig
{ _appName :: !AppName
, _hostName :: !HostName
, _processId :: !ProcessID
, _severityMask :: !SeverityMask
, _address :: !N.AddrInfo
, _protocol :: !Protocol
}
defaultConfig :: N.HostName -> N.ServiceName -> IO (Maybe SyslogConfig)
defaultConfig host port = do
appName <- getAppName
hostName <- getHostName
processId <- getProcessId
addrs <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port)
return $ case addrs of
[] ->
Nothing
address : _ ->
Just SyslogConfig
{ _appName = appName
, _hostName = hostName
, _processId = processId
, _severityMask = L.NoMask
, _address = address
, _protocol = rsyslogTCPProtocol
}
newtype Protocol = Protocol
{ getProtocol
:: PriVal
-> UTCTime
-> HostName
-> AppName
-> ProcessID
-> T.Text
-> BS.ByteString }
rfc5424TCPPacket
:: FormatTime t
=> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> Maybe MessageID
-> Maybe StructuredData
-> T.Text
-> BS.ByteString
rfc5424TCPPacket priVal time hostName' appName' processId' messageId _ message =
formatPriVal priVal
<> version
`sp` mkTime time
`sp` mkHost hostName'
`sp` mkApp appName'
`sp` mkProcId processId'
`sp` maybe nilValue mkMsgId messageId
`sp` structData
`sp` T.encodeUtf8 message
<> "\n"
where
version = "1"
mkTime = rfc3339Timestamp
mkHost (HostName x) = notEmpty x
mkApp (AppName x) = notEmpty x
mkProcId (ProcessID x) = notEmpty x
mkMsgId (MessageID x) = notEmpty x
structData = nilValue
rfc5424TCPProtocol :: Protocol
rfc5424TCPProtocol =
Protocol $ \priVal time hostName' appName' processId' message ->
rfc5424TCPPacket priVal time hostName' appName'
processId' Nothing Nothing message
rfc3164TCPPacket
:: FormatTime t
=> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> T.Text
-> BS.ByteString
rfc3164TCPPacket = rfc3164Variant timeFormat
where
timeFormat = BS8.pack . formatTime defaultTimeLocale "%b %e %X"
rfc3164TCPProtocol :: Protocol
rfc3164TCPProtocol = Protocol rfc3164TCPPacket
rsyslogTCPPacket
:: FormatTime t
=> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> T.Text
-> BS.ByteString
rsyslogTCPPacket = rfc3164Variant rfc3339Timestamp
rsyslogTCPProtocol :: Protocol
rsyslogTCPProtocol = Protocol rsyslogTCPPacket
formatPriVal :: PriVal -> BS.ByteString
formatPriVal (PriVal x) = "<" <> BS8.pack (show x) <> ">"
nilValue :: BS.ByteString
nilValue = "-"
notEmpty :: BS.ByteString -> BS.ByteString
notEmpty bs = if BS.null bs then nilValue else bs
rfc3164Variant
:: (t -> BS.ByteString)
-> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> T.Text
-> BS.ByteString
rfc3164Variant timeFormat priVal time hostName' appName' processId' message =
formatPriVal priVal
<> timeFormat time
`sp` mkHost hostName'
`sp` mkTag appName' processId'
`sp` T.encodeUtf8 message
<> "\n"
where
mkHost (HostName x) = notEmpty x
mkTag (AppName name) (ProcessID procId) = name <> "[" <> procId <> "]:"
sp :: BS.ByteString -> BS.ByteString -> BS.ByteString
sp b1 b2 = b1 <> " " <> b2