src/Graylog/Gelf.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric      #-}
   3 {-# LANGUAGE OverloadedStrings  #-}
   4 {-# LANGUAGE RecordWildCards    #-}
   5
   6 -- | Default formatting for Graylog messages,
   7 -- see http://docs.graylog.org/en/latest/pages/gelf.html
   8 module Graylog.Gelf where
   9
  10 import           Data.Aeson          (ToJSON (..), Value (..), object, toJSON,
  11                                       (.=))
  12 import           Data.HashMap.Strict (HashMap)
  13 import           Data.Scientific     (Scientific)
  14 import           Data.Text           (Text)
  15 import           Data.Time
  16 import           Data.Typeable
  17 import           GHC.Exts            (toList)
  18 import           GHC.Generics
  19
  20 data GELF
  21    = GELF
  22       { _gelfVersion      :: Version
  23       , _gelfHost         :: Text
  24       , _gelfShortMessage :: Text
  25       , _gelfFullMessage  :: Maybe Text
  26       , _gelfTimestamp    :: Maybe UTCTime
  27       , _gelfLevel        :: Maybe SyslogLevel
  28       , _gelfLine         :: Maybe Word
  29       , _gelfFile         :: Maybe Text
  30       , _gelfMeta         :: HashMap Text MetaValue
  31       }
  32    deriving (Show, Typeable, Generic)
  33
  34 data MetaValue
  35   = TextValue Text
  36   | NumberValue Scientific
  37   deriving (Show)
  38
  39 instance ToJSON MetaValue where
  40   toJSON (TextValue txt) = toJSON txt
  41   toJSON (NumberValue n) = toJSON n
  42
  43 class ToMeta a where
  44   toMeta :: a -> MetaValue
  45
  46 instance ToMeta Text where
  47   toMeta = TextValue
  48
  49 instance ToMeta Scientific where
  50   toMeta = NumberValue
  51
  52 instance ToMeta Integer where
  53   toMeta = NumberValue . fromInteger
  54
  55 instance ToMeta Int where
  56   toMeta = toMeta . toInteger
  57
  58 instance ToJSON GELF where
  59   toJSON GELF{..} = object $ [ "version"        .= _gelfVersion
  60                              , "host"           .= _gelfHost
  61                              , "short_message"  .= _gelfShortMessage
  62                              , "full_message"   .= _gelfFullMessage
  63                              , "timestamp"      .= _gelfTimestamp
  64                              , "level"          .= _gelfLevel
  65                              , "line"           .= _gelfLine
  66                              , "file"           .= _gelfFile
  67                              ] <> toList (toJSON <$> _gelfMeta)
  68
  69 --
  70
  71 data Version
  72    = Version1x1
  73    deriving (Eq, Show, Typeable, Generic)
  74
  75 instance ToJSON Version where
  76    toJSON Version1x1 = String "1.1"
  77
  78 --
  79
  80 data SyslogLevel
  81    = Emergency
  82    | Alert
  83    | Critical
  84    | Error
  85    | Warning
  86    | Notice
  87    | Informational
  88    | Debug
  89    deriving (Eq, Ord, Show, Typeable, Generic)
  90
  91 instance ToJSON SyslogLevel where
  92    toJSON Emergency     = Number 0
  93    toJSON Alert         = Number 1
  94    toJSON Critical      = Number 2
  95    toJSON Error         = Number 3
  96    toJSON Warning       = Number 4
  97    toJSON Notice        = Number 5
  98    toJSON Informational = Number 6
  99    toJSON Debug         = Number 7
 100
 101 --
 102
 103 simpleGelf
 104    :: Text     -- ^ Hostname
 105    -> Text     -- ^ Short message
 106    -> GELF
 107 simpleGelf host short =
 108   GELF Version1x1 host short Nothing Nothing Nothing Nothing Nothing mempty