{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {- | Module : System.Posix.Syslog.UDP Maintainer : jon@childr.es Stability : provisional Portability : Posix Log messages to syslog over a network via UDP, with protocols such as or . The following features are currently missing (but may be provided in future releases): * validation of string identifiers such as @APP-NAME@ or @MSGID@ * support for @STRUCTURED-DATA@ (RFC 5424 only) -} module System.Posix.Syslog.UDP ( -- * Syslog UDP packet component datatypes -- ** Re-exports from L.Priority (..) , L.Facility (..) -- ** Newtypes for various String/Int values -- | Refer to -- -- as to the purpose of each. , AppName (..) , HostName (..) , PriVal (..) , ProcessID (..) , MessageID (..) -- ** Type aliases -- | What syslog refers to as 'L.Priority', -- calls 'Severity'. , Severity , SeverityMask -- ** Structured Data -- | Currently unsupported; a placeholder for future use. , StructuredData (..) -- * The easy Haskell API to syslog via UDP , initSyslog , SyslogFn , SyslogConfig (..) , defaultConfig , localhost -- ** Common protocols for use with 'SyslogConfig' , Protocol , rfc5424Protocol , rfc3164Protocol , rsyslogProtocol -- * Manually constructing syslog UDP packets , rfc5424Packet , rfc3164Packet , rsyslogPacket -- ** Miscellaneous utilities , 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 -- ^ see @@ deriving (Eq, Show) newtype HostName = HostName ByteString -- ^ see @@; -- fetch via 'getHostName' deriving (Eq, Show) newtype PriVal = PriVal CInt -- ^ see @@; -- construct via 'maskedPriVal' deriving (Eq, Show) newtype ProcessID = ProcessID ByteString -- ^ see @@; -- fetch via 'getProcessId' deriving (Eq, Show) newtype MessageID = MessageID ByteString -- ^ see @@ deriving (Eq, Show) data StructuredData = StructuredData -- ^ see @@ -- (unsupported) -- | Return a function that logs to syslog via UDP. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > import System.Posix.Syslog.UDP -- > -- > main = do -- > syslog <- defaultConfig >>= initSyslog -- > putStrLn "huhu" -- > syslog USER Debug "huhu" -- -- This makes no assumptions about socket connection status or endpoint -- availability. Any errors while sending are silently ignored. 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 -- | The type of function returned by 'initSyslog'. type SyslogFn = L.Facility -- ^ facility to log to -> Severity -- ^ severity under which to log -> Text -- ^ message body -> IO () -- | Configuration options for connecting and logging to your syslog socket. data SyslogConfig = SyslogConfig { appName :: !AppName -- ^ see @@; -- fetch via 'getAppName' , hostName :: !HostName -- ^ see @@; -- fetch via 'getHostName' , processId :: !ProcessID -- ^ see @@; -- fetch via 'getProcessId' , severityMask :: !SeverityMask -- ^ whitelist of priorities of logs to send , address :: !S.AddrInfo -- ^ where to send the syslog packets; construct via 'resolveUdpAddress' or -- find via 'S.getAddrInfo' , protocol :: Protocol -- ^ protocol for formatting the message, such as 'rfc5424Protocol' or -- 'rfc3164Protocol' , onException :: SomeException -> IO () -- ^ custom exception handler } -- | A convenient default config for connecting to 'localhost'. Provided for -- development/testing purposes. defaultConfig :: IO SyslogConfig defaultConfig = do appName <- getAppName hostName <- getHostName processId <- getProcessId return SyslogConfig {..} where severityMask = [minBound..maxBound] address = localhost protocol = rfc3164Protocol onException = const $ return () -- | The default IPv4 address/port for syslog on a local machine. Provided for -- development/testing purposes. 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 } -- | Construct a syslog UDP packet as dictated by -- . Note that fields in a syslog -- packet are whitespace-delineated, so don't allow whitespace in anything but -- the log message! rfc5424Packet :: FormatTime t => PriVal -- ^ see @@; -- construct via 'maskedPriVal' -> Maybe t -- ^ time of message, converted to -- @@ -> Maybe HostName -- ^ see @@; -- fetch via 'getHostName' -> Maybe AppName -- ^ see @@; -- fetch via 'getAppName' -> Maybe ProcessID -- ^ see @@; -- fetch via 'getProcessId' -> Maybe MessageID -- ^ see @@ -> Maybe StructuredData -- ^ see @@ -- (unsupported) -> Text -- ^ see @@ -> 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 -- | Construct a syslog UDP packet as dictated by -- . Note that fields in a syslog -- packet are whitespace-delineated, so don't allow whitespace in anything but -- the log message! rfc3164Packet :: FormatTime t => PriVal -- ^ see @@; -- construct via 'maskedPriVal' -> t -- ^ time of message, converted to @TIMESTAMP@ in -- @@ -> HostName -- ^ the @HOSTNAME@ of the -- @@; -- fetch via 'getHostName' -> AppName -- ^ the program name in the @TAG@ portion of the -- @@; fetch via -- 'getAppName' -> ProcessID -- ^ the process identifier in the @TAG@ portion of the -- @@; fetch via -- 'getProcessId' -> Text -- ^ the @CONTENT@ portion of the -- @@ -> ByteString rfc3164Packet = rfc3164Variant timeFormat where timeFormat = B.pack . formatTime defaultTimeLocale "%b %e %X" rfc3164Protocol :: Protocol rfc3164Protocol = rfc3164Packet -- | Recommended rsyslog template -- @@. -- Same fields as RFC 3164, but with an RFC 3339 high-precision timestamp. rsyslogPacket :: FormatTime t => PriVal -> t -> HostName -> AppName -> ProcessID -> Text -> ByteString rsyslogPacket = rfc3164Variant rfc3339Timestamp rsyslogProtocol :: Protocol rsyslogProtocol = rsyslogPacket -- | An high-precision -- timestamp. rfc3339Timestamp :: FormatTime t => t -> ByteString rfc3339Timestamp = B.pack . formatTime defaultTimeLocale "%FT%X%QZ" -- | Obtain an IPv4 'S.AddrInfo' for your 'SyslogConfig' from a hostname -- (or IPv4 address) and port. Sets the address protocol to 'S.Datagram'. 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 -- | Construct a @@. -- 'Nothing' indicates that the severities are fully masked, and so no packet -- should be sent. 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 -- internal functions 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 #-} -- see http://www.iana.org/assignments/protocol-numbers/protocol-numbers.txt udpProtoNum :: CInt udpProtoNum = 17