diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ömer Sinan Ağacan (c) 2017 + +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 Author name here 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,1 @@ +# hsyslog-tcp 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-tcp.cabal b/hsyslog-tcp.cabal new file mode 100644 --- /dev/null +++ b/hsyslog-tcp.cabal @@ -0,0 +1,33 @@ +name: hsyslog-tcp +version: 0.1.0.0 +synopsis: syslog over TCP +description: +homepage: https://github.com/osa1/hsyslog-tcp#readme +license: BSD3 +license-file: LICENSE +author: Ömer Sinan Ağacan +maintainer: omeragacan@gmail.com +copyright: 2017 Ömer Sinan Ağacan +category: System +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/osa1/hsyslog-tcp + +library + hs-source-dirs: src + exposed-modules: + System.Posix.Syslog.TCP + build-depends: + base >= 4.7 && < 5, + bytestring, + hsyslog, + hsyslog-udp, + network, + text, + time + default-language: Haskell2010 + ghc-options: -Wall -O2 diff --git a/src/System/Posix/Syslog/TCP.hs b/src/System/Posix/Syslog/TCP.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/Syslog/TCP.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | + Module : System.Posix.Syslog.TCP + Maintainer : omeragacan@gmail.com + Stability : provisional + Portability : Posix + + Log messages to syslog over a network via TCP, with protocols such as + or + . + + Most of the code adapted from . + +-} +module System.Posix.Syslog.TCP + ( + -- * Haskell API to syslog via TCP + initSyslog + , SyslogFn + , SyslogConfig (..) + , defaultConfig + + -- * Utilities for constructing `SyslogConfig` + , getAppName + , getHostName + , getProcessId + + -- * Protocols for use with 'SyslogConfig' + , Protocol + , rfc5424TCPProtocol + , rfc3164TCPProtocol + , rsyslogTCPProtocol + + -- * Syslog TCP 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 (..) + , ProcessID (..) + , MessageID (..) + + -- ** Type aliases + -- | What syslog refers to as 'L.Priority', + -- calls 'Severity'. + , Severity + , SeverityMask + ) where + +-------------------------------------------------------------------------------- +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) +-------------------------------------------------------------------------------- + +-- | Return a function that logs to syslog via TCP. +-- +-- The function re-throws exceptions, blocks when the TCP socket is not ready +-- for writing. +initSyslog :: SyslogConfig -> IO SyslogFn +initSyslog config = do + let addr = _address config + socket <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr) + N.connect socket (N.addrAddress addr) + return $ \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 + +type SyslogFn + = L.Facility -- ^ facility to log to + -> Severity -- ^ severity under which to log + -> T.Text -- ^ message body (should not contain newline) + -> 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 :: !N.AddrInfo + -- ^ where to send the syslog packets; find via 'N.getAddrInfo' + , _protocol :: !Protocol + -- ^ protocol for formatting the message, such as 'rfc5424TCPProtocol' or + -- 'rfc3164TCPProtocol' + } + +-- | A helper for constructing a 'SyslogConfig'. Uses `rsyslogTCPProtocol`. +-- Returns `Nothing` when `N.getAddrInfo` fails. +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 + } + +{- +test :: T.Text -> IO () +test str = do + Just cfg <- defaultConfig "127.0.0.1" "8012" + log <- initSyslog cfg + log USER Debug str +-} + +-------------------------------------------------------------------------------- +-- * Protocol implementations adapted from +-- . + +newtype Protocol = Protocol + { getProtocol + :: PriVal + -> UTCTime + -> HostName + -> AppName + -> ProcessID + -> T.Text + -> BS.ByteString } + +rfc5424TCPPacket + :: FormatTime t + => PriVal + -- ^ see @@; + -- construct via 'maskedPriVal' + -> t + -- ^ time of message, converted to + -- @@ + -> HostName + -- ^ see @@; + -- fetch via 'getHostName' + -> AppName + -- ^ see @@; + -- fetch via 'getAppName' + -> ProcessID + -- ^ see @@; + -- fetch via 'getProcessId' + -> Maybe MessageID + -- ^ see @@ + -> Maybe StructuredData + -- ^ see @@ + -- (unsupported) + -> T.Text + -- ^ see @@ + -> 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 + +-- | Construct a syslog TCP 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! + +rfc3164TCPPacket + :: 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' + -> T.Text + -- ^ the @CONTENT@ portion of the + -- @@ + -> BS.ByteString +rfc3164TCPPacket = rfc3164Variant timeFormat + where + timeFormat = BS8.pack . formatTime defaultTimeLocale "%b %e %X" + +rfc3164TCPProtocol :: Protocol +rfc3164TCPProtocol = Protocol rfc3164TCPPacket + +-- | Recommended rsyslog template +-- @@. +-- Same fields as RFC 3164, but with an RFC 3339 high-precision timestamp. +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 +{-# INLINE sp #-}