diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Jon Childress + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jon Childress nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# hsyslog-udp +Syslog via UDP in Haskell, supporting message protocols like +[RFC 5424][rfc5424], [RFC 3164][rfc3164], or any arbitrary protocol. + + [rfc5424]: https://tools.ietf.org/html/rfc5424 + [rfc3164]: https://tools.ietf.org/html/rfc3164 + +### TODO (in priority order): +- support for `STRUCTURED-DATA` +- optional validation of string identifiers such as `APP-NAME` or `MSGID` +- ensure `resolveUdpAddress` is actually a datagram socket. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsyslog-udp.cabal b/hsyslog-udp.cabal new file mode 100644 --- /dev/null +++ b/hsyslog-udp.cabal @@ -0,0 +1,46 @@ +name: hsyslog-udp +version: 0.1.1 +synopsis: Log to syslog over a network via UDP +description: Supports , + , or any + arbitrary protocol. +homepage: https://github.com/ThoughtLeadr/hsyslog-udp +bug-reports: https://github.com/ThoughtLeadr/hsyslog-udp/issues +license: BSD3 +license-file: LICENSE +author: Jon Childress +maintainer: jon@childr.es +category: System +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 + +Source-Repository head + type: git + location: git://github.com/ThoughtLeadr/hsyslog-udp.git + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: System.Posix.Syslog.UDP + + Build-Depends: base >= 3 && < 5 + , bytestring == 0.10.* + , hsyslog == 4.* + , network == 2.6.* + , text == 1.2.* + , time == 1.5.* + , unix == 2.7.* + +test-suite specs + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: System.Posix.Syslog.UDPSpec + + Build-Depends: base >= 3 && < 5 + , hspec == 2.2.* + , hsyslog-udp == 0.1.1 + , time == 1.5.* diff --git a/src/System/Posix/Syslog/UDP.hs b/src/System/Posix/Syslog/UDP.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/Syslog/UDP.hs @@ -0,0 +1,421 @@ +{-# 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 (..) + , L.PriorityMask (..) + -- ** 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) +import Data.Monoid ((<>)) +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 + +type Severity = L.Priority +type SeverityMask = L.PriorityMask + +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) + + 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' + } + +-- | 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 = L.NoMask + address = localhost + protocol = rfc3164Protocol + +-- | 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 + | mask == L.NoMask = prival + | masked = Nothing + | otherwise = prival + where + prival = Just . PriVal $ L.makePri fac sev + masked = L._LOG_MASK (L.fromPriority sev) .&. L.fromPriorityMask mask == 0 + +-- 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 <> "]:" + +safely :: IO a -> IO () +safely f = catch (void f) (const $ return () :: SomeException -> IO ()) + +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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified System.Posix.Syslog.UDPSpec as UDPSpec +import System.Posix.Syslog.UDP +import Test.Hspec + +main :: IO () +main = do + logMessages + runSpecs + +logMessages :: IO () +logMessages = do + syslog <- defaultConfig >>= initSyslog + syslog USER Debug "hello thar!" + +runSpecs :: IO () +runSpecs = + hspec $ do + describe "System.Posix.Syslog.UDP" UDPSpec.spec diff --git a/test/System/Posix/Syslog/UDPSpec.hs b/test/System/Posix/Syslog/UDPSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/Syslog/UDPSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Posix.Syslog.UDPSpec (spec) where + +import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, parseTimeM) + +import System.Posix.Syslog.UDP +import Test.Hspec + +spec :: Spec +spec = do + describe "maskedPriVal" $ do + it "returns a Just if priorities remain after masking" $ + let result = maskedPriVal (UpTo Debug) LOCAL4 Notice + in result `shouldBe` Just (PriVal 165) + + it "returns Nothing if all priorities are masked" $ + let result = maskedPriVal (UpTo Info) USER Debug + in result `shouldBe` Nothing + + describe "rfc5424Packet" $ do + let (Just priVal) = maskedPriVal NoMask USER Debug + + it "uses the NILVALUE for Nothing values" $ + let + time = Nothing :: Maybe UTCTime + result = rfc5424Packet priVal time Nothing Nothing Nothing Nothing Nothing "test log message" + expected = "<15>1 - - - - - - test log message" + in + result `shouldBe` expected + + it "uses the NILVALUE for empty bytestring values" $ + let + time = Nothing :: Maybe UTCTime + result = rfc5424Packet priVal time (Just $ HostName "") (Just $ AppName "") (Just $ ProcessID "") (Just $ MessageID "") Nothing "test log message" + expected = "<15>1 - - - - - - test log message" + in + result `shouldBe` expected + + it "uses the correct values otherwise" $ + let + time = Nothing :: Maybe UTCTime + result = rfc5424Packet priVal time (Just $ HostName "host_name") (Just $ AppName "app_name") (Just $ ProcessID "proc_id") (Just $ MessageID "msg_id") Nothing "test log message" + expected = "<15>1 - host_name app_name proc_id msg_id - test log message" + in + result `shouldBe` expected + + it "correctly formats the time" $ + let + time = parseTimeM True defaultTimeLocale "%FT%X%QZ" "2003-10-11T22:14:15.003Z" :: Maybe UTCTime + result = rfc5424Packet priVal time Nothing Nothing Nothing Nothing Nothing "test log message" + expected = "<15>1 2003-10-11T22:14:15.003Z - - - - - test log message" + in + result `shouldBe` expected + + describe "rfc3164Packet" $ do + let + (Just priVal) = maskedPriVal NoMask USER Debug + (Just time) = parseTimeM True defaultTimeLocale "%FT%X%QZ" "2003-10-11T22:14:15.003Z" :: Maybe UTCTime + + it "correctly formats the message" $ + let + result = rfc3164Packet priVal time (HostName "host_name") (AppName "app_name") (ProcessID "12345") "test log message" + expected = "<15>Oct 11 22:14:15 host_name app_name[12345]: test log message" + in + result `shouldBe` expected + + describe "rsyslogPacket" $ do + let + (Just priVal) = maskedPriVal NoMask USER Debug + (Just time) = parseTimeM True defaultTimeLocale "%FT%X%QZ" "2003-10-11T22:14:15.003Z" :: Maybe UTCTime + + it "correctly formats the message" $ + let + result = rsyslogPacket priVal time (HostName "host_name") (AppName "app_name") (ProcessID "12345") "test log message" + expected = "<15>2003-10-11T22:14:15.003Z host_name app_name[12345]: test log message" + in + result `shouldBe` expected