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