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)
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
-> Maybe T.Text
-> String
-> Integer
-> Maybe T.Text
-> Maybe Integer
-> [(T.Text, Maybe T.Text)]
-> 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 :: Int
-> T.Text
-> Maybe T.Text
-> String
-> Integer
-> Maybe T.Text
-> Maybe Integer
-> [(T.Text, Maybe T.Text)]
-> [BSL.ByteString]
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 :: HostName
-> String
-> Int
-> T.Text
-> Maybe T.Text
-> Maybe T.Text
-> Maybe Integer
-> [(T.Text, Maybe T.Text)]
-> IO ()
send serverName serverPort chunkSize shortMessage longMessage filename lineNumber fields = do
addressInfos <- getAddrInfo Nothing (Just serverName) (Just serverPort)
let serverAddress = head addressInfos
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