{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module System.Posix.Syslog.UDP
(
L.Priority (..)
, L.Facility (..)
, AppName (..)
, HostName (..)
, PriVal (..)
, ProcessID (..)
, MessageID (..)
, Severity
, SeverityMask
, StructuredData (..)
, initSyslog
, SyslogFn
, SyslogConfig (..)
, defaultConfig
, localhost
, Protocol
, rfc5424Protocol
, rfc3164Protocol
, rsyslogProtocol
, rfc5424Packet
, rfc3164Packet
, rsyslogPacket
, getAppName
, getHostName
, getProcessId
, maskedPriVal
, resolveUdpAddress
, rfc3339Timestamp
) where
import Control.Exception (SomeException, catch)
import Control.Monad (void)
import Data.Bits ((.|.))
import Data.ByteString (ByteString)
#if __GLASGOW_HASKELL__ < 808
import Data.Monoid ((<>))
#endif
import Data.Text (Text)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (FormatTime, formatTime, defaultTimeLocale)
import Foreign.C (CInt)
import System.Environment (getProgName)
import System.Posix.Types (CPid (..))
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as T
import qualified Network.BSD as BSD
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as SB
import qualified System.Posix.Process as P
import qualified System.Posix.Syslog as L
import System.Posix.Syslog.Facility (fromFacility)
import System.Posix.Syslog.Priority (fromPriority)
type Severity = L.Priority
type SeverityMask = [L.Priority]
type Protocol
= PriVal
-> UTCTime
-> HostName
-> AppName
-> ProcessID
-> Text
-> ByteString
newtype AppName
= AppName ByteString
deriving (Eq, Show)
newtype HostName
= HostName ByteString
deriving (Eq, Show)
newtype PriVal
= PriVal CInt
deriving (Eq, Show)
newtype ProcessID
= ProcessID ByteString
deriving (Eq, Show)
newtype MessageID
= MessageID ByteString
deriving (Eq, Show)
data StructuredData
= StructuredData
initSyslog :: SyslogConfig -> IO SyslogFn
initSyslog config = S.withSocketsDo $ do
socket <- S.socket (S.addrFamily $ address config) S.Datagram udpProtoNum
let send = flip (SB.sendTo socket) (S.addrAddress $ address config)
safely f = catch (void f) (onException config)
return $ \facility severity message ->
case maskedPriVal (severityMask config) facility severity of
Nothing -> return ()
Just priVal -> do
time <- getCurrentTime
safely . send $ (protocol config) priVal time (hostName config)
(appName config) (processId config) message
type SyslogFn
= L.Facility
-> Severity
-> Text
-> IO ()
data SyslogConfig = SyslogConfig
{ appName :: !AppName
, hostName :: !HostName
, processId :: !ProcessID
, severityMask :: !SeverityMask
, address :: !S.AddrInfo
, protocol :: Protocol
, onException :: SomeException -> IO ()
}
defaultConfig :: IO SyslogConfig
defaultConfig = do
appName <- getAppName
hostName <- getHostName
processId <- getProcessId
return SyslogConfig {..}
where
severityMask = [minBound..maxBound]
address = localhost
protocol = rfc3164Protocol
onException = const $ return ()
localhost :: S.AddrInfo
localhost =
S.AddrInfo
{ S.addrFlags = []
, S.addrFamily = S.AF_INET
, S.addrSocketType = S.Datagram
, S.addrProtocol = udpProtoNum
, S.addrAddress = S.SockAddrInet 514 16777343
, S.addrCanonName = Nothing
}
rfc5424Packet
:: FormatTime t
=> PriVal
-> Maybe t
-> Maybe HostName
-> Maybe AppName
-> Maybe ProcessID
-> Maybe MessageID
-> Maybe StructuredData
-> Text
-> ByteString
rfc5424Packet priVal time hostName' appName' processId' messageId _ message =
formatPriVal priVal
<> version
`sp` orNil mkTime time
`sp` orNil mkHost hostName'
`sp` orNil mkApp appName'
`sp` orNil mkProcId processId'
`sp` orNil mkMsgId messageId
`sp` structData
`sp` T.encodeUtf8 message
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
rfc5424Protocol :: Protocol
rfc5424Protocol priVal time hostName' appName' processId' message =
rfc5424Packet priVal (Just time) (Just hostName') (Just appName')
(Just processId') Nothing Nothing message
rfc3164Packet
:: FormatTime t
=> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> Text
-> ByteString
rfc3164Packet = rfc3164Variant timeFormat
where
timeFormat = B.pack . formatTime defaultTimeLocale "%b %e %X"
rfc3164Protocol :: Protocol
rfc3164Protocol = rfc3164Packet
rsyslogPacket
:: FormatTime t
=> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> Text
-> ByteString
rsyslogPacket = rfc3164Variant rfc3339Timestamp
rsyslogProtocol :: Protocol
rsyslogProtocol = rsyslogPacket
rfc3339Timestamp :: FormatTime t => t -> ByteString
rfc3339Timestamp = B.pack . formatTime defaultTimeLocale "%FT%X%QZ"
resolveUdpAddress :: Integral n => String -> n -> IO (Maybe S.AddrInfo)
resolveUdpAddress name port = do
host <- BSD.getHostByName name
return $ case BSD.hostAddresses host of
(h:_) ->
Just S.AddrInfo
{ S.addrFlags = []
, S.addrFamily = BSD.hostFamily host
, S.addrSocketType = S.Datagram
, S.addrProtocol = udpProtoNum
, S.addrAddress = S.SockAddrInet (fromIntegral port) h
, S.addrCanonName = Nothing
}
_ ->
Nothing
getAppName :: IO AppName
getAppName = AppName . B.pack <$> getProgName
getHostName :: IO HostName
getHostName = HostName . B.pack <$> BSD.getHostName
getProcessId :: IO ProcessID
getProcessId = do
(CPid pid) <- P.getProcessID
return . ProcessID . B.pack $ show pid
maskedPriVal
:: SeverityMask
-> L.Facility
-> Severity
-> Maybe PriVal
maskedPriVal mask fac sev
| masked = Nothing
| otherwise = prival
where
priority = fromFacility fac .|. fromPriority sev
prival = Just $ PriVal priority
masked = not $ sev `elem` mask
formatPriVal :: PriVal -> ByteString
formatPriVal (PriVal x) = "<" <> B.pack (show x) <> ">"
nilValue :: ByteString
nilValue = "-"
notEmpty :: ByteString -> ByteString
notEmpty bs = if B.null bs then nilValue else bs
orNil :: (a -> ByteString) -> Maybe a -> ByteString
orNil = maybe nilValue
rfc3164Variant
:: (t -> ByteString)
-> PriVal
-> t
-> HostName
-> AppName
-> ProcessID
-> Text
-> ByteString
rfc3164Variant timeFormat priVal time hostName' appName' processId' message =
formatPriVal priVal
<> timeFormat time
`sp` mkHost hostName'
`sp` mkTag appName' processId'
`sp` T.encodeUtf8 message
where
mkHost (HostName x) = notEmpty x
mkTag (AppName name) (ProcessID procId) = name <> "[" <> procId <> "]:"
sp :: ByteString -> ByteString -> ByteString
sp b1 b2 = b1 <> " " <> b2
{-# INLINE sp #-}
udpProtoNum :: CInt
udpProtoNum = 17