packages feed

hsyslog-udp (empty) → 0.1.1

raw patch · 7 files changed

+611/−0 lines, 7 filesdep +basedep +bytestringdep +hspecsetup-changed

Dependencies added: base, bytestring, hspec, hsyslog, hsyslog-udp, network, text, time, unix

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsyslog-udp.cabal view
@@ -0,0 +1,46 @@+name:                   hsyslog-udp+version:                0.1.1+synopsis:               Log to syslog over a network via UDP+description:            Supports <https://tools.ietf.org/html/rfc5424 RFC 5424>,+                        <https://tools.ietf.org/html/rfc3164 RFC 3164>, 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.*
+ src/System/Posix/Syslog/UDP.hs view
@@ -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+  <https://tools.ietf.org/html/rfc5424 RFC 5424> or+  <https://tools.ietf.org/html/rfc3164 RFC 3164>.++  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 <http://hackage.haskell.org/package/hsyslog hsyslog>+    L.Priority (..)+  , L.Facility (..)+  , L.PriorityMask (..)+    -- ** Newtypes for various String/Int values+    -- | Refer to+    -- <https://tools.ietf.org/html/rfc5424#section-6.2 RFC 5424 section 6.2>+    -- as to the purpose of each.+  , AppName (..)+  , HostName (..)+  , PriVal (..)+  , ProcessID (..)+  , MessageID (..)+    -- ** Type aliases+    -- | What syslog refers to as 'L.Priority',+    -- <https://tools.ietf.org/html/rfc5424 RFC 5424> 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 @<https://tools.ietf.org/html/rfc5424#section-6.2.5 APP-NAME>@+  deriving (Eq, Show)++newtype HostName+  = HostName ByteString+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.4 HOSTNAME>@;+  -- fetch via 'getHostName'+  deriving (Eq, Show)++newtype PriVal+  = PriVal CInt+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.1 PRI>@;+  -- construct via 'maskedPriVal'+  deriving (Eq, Show)++newtype ProcessID+  = ProcessID ByteString+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.6 PROCID>@;+  -- fetch via 'getProcessId'+  deriving (Eq, Show)++newtype MessageID+  = MessageID ByteString+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.7 MSGID>@+  deriving (Eq, Show)++data StructuredData+  = StructuredData+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.3 STRUCTURED-DATA>@+  -- (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 @<https://tools.ietf.org/html/rfc5424#section-6.2.5 APP-NAME>@;+    -- fetch via 'getAppName'+  , hostName :: !HostName+    -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.4 HOSTNAME>@;+    -- fetch via 'getHostName'+  , processId :: !ProcessID+    -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.6 PROCID>@;+    -- 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+-- <https://tools.ietf.org/html/rfc5424 RFC 5424>. 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 @<https://tools.ietf.org/html/rfc5424#section-6.2.1 PRI>@;+  -- construct via 'maskedPriVal'+  -> Maybe t+  -- ^ time of message, converted to+  -- @<https://tools.ietf.org/html/rfc5424#section-6.2.3 TIMESTAMP>@+  -> Maybe HostName+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.4 HOSTNAME>@;+  -- fetch via 'getHostName'+  -> Maybe AppName+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.5 APP-NAME>@;+  -- fetch via 'getAppName'+  -> Maybe ProcessID+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.6 PROCID>@;+  -- fetch via 'getProcessId'+  -> Maybe MessageID+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.2.7 MSGID>@+  -> Maybe StructuredData+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.3 STRUCTURED-DATA>@+  -- (unsupported)+  -> Text+  -- ^ see @<https://tools.ietf.org/html/rfc5424#section-6.4 MSG>@+  -> 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+-- <https://tools.ietf.org/html/rfc3164 RFC 3164>. 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 @<https://tools.ietf.org/html/rfc3164#section-4.1.1 PRI>@;+  -- construct via 'maskedPriVal'+  -> t+  -- ^ time of message, converted to @TIMESTAMP@ in+  -- @<https://tools.ietf.org/html/rfc3164#section-4.1.2 HEADER>@+  -> HostName+  -- ^ the @HOSTNAME@ of the+  -- @<https://tools.ietf.org/html/rfc3164#section-4.1.2 HEADER>@;+  -- fetch via 'getHostName'+  -> AppName+  -- ^ the program name in the @TAG@ portion of the+  -- @<https://tools.ietf.org/html/rfc3164#section-4.1.3 MSG>@; fetch via+  -- 'getAppName'+  -> ProcessID+  -- ^ the process identifier in the @TAG@ portion of the+  -- @<https://tools.ietf.org/html/rfc3164#section-4.1.3 MSG>@; fetch via+  -- 'getProcessId'+  -> Text+  -- ^ the @CONTENT@ portion of the+  -- @<https://tools.ietf.org/html/rfc3164#section-4.1.3 MSG>@+  -> ByteString+rfc3164Packet = rfc3164Variant timeFormat+  where+    timeFormat = B.pack . formatTime defaultTimeLocale "%b %e %X"++rfc3164Protocol :: Protocol+rfc3164Protocol = rfc3164Packet++-- | Recommended rsyslog template+-- @<http://www.rsyslog.com/doc/v8-stable/configuration/templates.html RSYSLOG_ForwardFormat>@.+-- 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 <https://tools.ietf.org/html/rfc3339 RFC 3339> 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 @<https://tools.ietf.org/html/rfc5424#section-6.2.1 PRI>@.+-- '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
+ test/Main.hs view
@@ -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
+ test/System/Posix/Syslog/UDPSpec.hs view
@@ -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