diff --git a/BSD3 b/BSD3 new file mode 100644 --- /dev/null +++ b/BSD3 @@ -0,0 +1,25 @@ +Copyright (c) 2012, Andy Georges +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 the author nor the names of its 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 HOLDER 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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/hGelf.cabal b/hGelf.cabal new file mode 100644 --- /dev/null +++ b/hGelf.cabal @@ -0,0 +1,36 @@ +name: hGelf +version: 0.1 +cabal-version: >=1.14 +build-type: Simple +license: BSD3 +license-file: BSD3 +copyright: Andy Georges +maintainer: itkovian@gmail.com +stability: experimental +synopsis: Haskell GELF library +description: Library for sending messages in the GELF format to a server accepting Graylog2 Extended Log Format messages. +category: Network +author: Andy Georges +tested-with: GHC ==7.4.1 +data-dir: "" +extra-source-files: src/Network/Gelf.hs + +source-repository this + type: git + location: git://github.com/itkovian/hGelf.git + tag: 0.1 + +library + build-depends: QuickCheck -any, aeson >=0.6, base >= 4 && < 5, + bytestring >=0.9.2.1, network >=2.3.0.13, old-time >=1.1.0.0, + text >=0.11.1, time >=1.4, zlib >=0.5.3.3, cereal >= 0.3.5.1, + pureMD5 >= 2.1.0.3 + exposed-modules: Network.Gelf + default-language: Haskell2010 + exposed: True + buildable: True + cpp-options: -DMAIN_FUNCTION=testMain + default-extensions: OverloadedStrings + hs-source-dirs: src + other-modules: Network.Gelf.Chunk + diff --git a/src/Network/Gelf.hs b/src/Network/Gelf.hs new file mode 100644 --- /dev/null +++ b/src/Network/Gelf.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : Network.Gelf +-- Copyright : Andy Georges +-- License : AllRightsReserved +-- +-- Maintainer : itkovian@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Network.Gelf ( + Network.Gelf.send + , encode +) where + +import Codec.Compression.Zlib (compress) +import Control.Arrow (second) +import qualified Data.Aeson as A +import Data.Bits(shiftL, (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Digest.Pure.MD5 (md5) +import Data.Maybe (isJust) +import qualified Data.Text as T +import qualified Data.Serialize as DS (encode) +import Data.Word +import Network.BSD (getHostName) +import Network.Socket +import qualified Network.Socket.ByteString.Lazy as NSBL +import System.Time (getClockTime, ClockTime(TOD)) + +import Network.Gelf.Chunk (split) + +{- TODO: + - * timestamp: specs state microsecond timestamp, so correct this + - * wrap this in a monad stack with IO at the bottom, and some static + - configuration info on top of that, e.g., for setting the hostname, + - the destination port, chunk size, etc. + -} + +catSecondMaybes :: [(a, Maybe b)] + -> [(a, b)] +catSecondMaybes [] = [] +catSecondMaybes ((k, v):vs) = + case v of + Just v' -> (k,v') : cvs + Nothing -> cvs + where cvs = catSecondMaybes vs + + +gelfMessage :: T.Text -- ^Short message + -> Maybe T.Text -- ^Long message (optional) + -> String -- ^Hostname + -> Integer -- ^Timestamp + -> Maybe T.Text -- ^Filename (optional) + -> Maybe Integer -- ^Line number (optional) + -> [(T.Text, Maybe T.Text)] -- ^Additional fields + -> A.Value +gelfMessage shortMessage longMessage hostname timestamp filename lineNumber fields = + let loglevel = 1 :: Int + allFields = [ ("version", A.toJSON `fmap` Just ("1.0" :: T.Text)) + , ("host" , A.toJSON `fmap` Just hostname) + , ("short_message", A.toJSON `fmap` Just shortMessage) + , ("full_message", A.toJSON `fmap` longMessage) + , ("timestamp", A.toJSON `fmap` Just timestamp) + , ("level", A.toJSON `fmap` Just loglevel) + , ("facility", A.toJSON `fmap` Just ("GELF" :: T.Text)) + , ("line", A.toJSON `fmap` Just lineNumber) + , ("file", A.toJSON `fmap` Just filename) ] + ++ map (second (fmap A.toJSON)) fields + in A.object $ catSecondMaybes allFields + + +-- | Encode a log message as a GELF message. +-- +-- This function wraps a given log message in a GELF structure. It creates the +-- JSON object, converts it to a ByteString and GZips the result. +-- If the resulting ByteString is longer than the maximal chunk size, +-- the GELF message is split up into chunks, each at most chunk size in length. +encode :: Int -- ^Maximal chunk size + -> T.Text -- ^Short message + -> Maybe T.Text -- ^Long message (optional) + -> String -- ^Hostname + -> Integer -- ^Timestamp + -> Maybe T.Text -- ^Filename of the file causing the message, e.g., for debugging purposes + -> Maybe Integer -- ^Line number in the file causing the message, e.g., for debugging purposes + -> [(T.Text, Maybe T.Text)] -- ^Additional fields + -> [BSL.ByteString] -- ^One or more chunks +encode chunkSize shortMessage longMessage hostname timestamp filename lineNumber fields = + let j = gelfMessage shortMessage longMessage hostname timestamp filename lineNumber fields + bs = compress $ A.encode j + in if BSL.length bs + 2 < fromIntegral chunkSize + then [bs] + else split chunkSize id bs + where id = foldl1 (\w b -> shiftL w 8 .|. b) . map fromIntegral . BS.unpack . BS.take 8 . DS.encode . md5 . BSLC.pack $ hostname ++ show timestamp :: Word64 + + +-- | Send a log message to a server accepting Graylog2 messages. +send :: HostName -- ^Remote hostname of the graylog server + -> String -- ^Port number + -> Int -- ^Chunk size + -> T.Text -- ^Short message + -> Maybe T.Text -- ^Long message (optional) + -> Maybe T.Text -- ^Filename of the message cause + -> Maybe Integer -- ^Line in the file where the message was sent for + -> [(T.Text, Maybe T.Text)] -- ^Additional fields (name, information), should not contain 'id' as name + -> IO () -- ^Does I/O +send serverName serverPort chunkSize shortMessage longMessage filename lineNumber fields = do + addressInfos <- getAddrInfo Nothing (Just serverName) (Just serverPort) + let serverAddress = head addressInfos -- FIXME: this should handle errors too + sock <- socket (addrFamily serverAddress) Datagram defaultProtocol + connect sock (addrAddress serverAddress) + hostname <- getHostName + timestamp <- getClockTime >>= (\(TOD seconds _) -> return seconds) + let ms = encode chunkSize shortMessage longMessage hostname timestamp filename lineNumber fields + mapM_ (NSBL.send sock) ms diff --git a/src/Network/Gelf/Chunk.hs b/src/Network/Gelf/Chunk.hs new file mode 100644 --- /dev/null +++ b/src/Network/Gelf/Chunk.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : Network.Gelf.Chunk +-- Copyright : Andy Georges +-- License : AllRightsReserved +-- +-- Maintainer : itkovian@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Network.Gelf.Chunk ( + split +) where + +import Data.Bits (shiftR, (.&.)) +import qualified Data.ByteString.Lazy as BSL +import Data.Word + + +split :: Int -- ^Chunk size + -> Word64 -- ^Message identification (8 bytes) + -> BSL.ByteString -- ^Message to split into chunks + -> [BSL.ByteString] -- ^Resulting chunks +split size id bs = + let cs = split' bs + in zipWith (chunkify (length cs)) cs [0..] + where split' :: BSL.ByteString -> [BSL.ByteString] + split' bs = + if BSL.length bs == 0 + then [] + else let (h,ts) = BSL.splitAt (fromIntegral size) bs + in h : split' ts + idBytes = BSL.pack [fromIntegral (shiftR id (x * 8) .&. 0xff) | x <- [7, 6 .. 0]] + chunkify :: Int -- ^Total number of chunks + -> BSL.ByteString -- ^Chunk data + -> Int -- ^Chunk number + -> BSL.ByteString -- ^Resulting bytestring + chunkify total s i = BSL.cons 0x1e $ BSL.cons 0x0f $ BSL.append idBytes $ BSL.cons (fromIntegral i :: Word8) $ BSL.cons (fromIntegral total :: Word8) s