Merge pull request #1 from fretlink/support-additional-metav2019-01-15

Support additional meta in GELF messages

3 files changed, 47 insertions, 9 deletions

diff --git a/graylog.cabal b/graylog.cabal
index 5618d7c..dc84862 100644
--- a/graylog.cabal
+++ b/graylog.cabal
@@ -17,7 +17,7 @@ source-repository head
     type:               git
     location:           https://github.com/AndrewRademacher/haskell-graylog.git
 
-library 
+library
    hs-source-dirs:      src
    default-language:    Haskell2010
 
@@ -29,7 +29,7 @@ library
    ghc-options:         -Wall -rtsopts
 
    build-depends:       base            ==4.*
-   
+
                      ,  aeson
                      ,  aeson-casing
                      ,  bytestring
@@ -38,6 +38,7 @@ library
                      ,  scientific
                      ,  text
                      ,  time
+                     ,  unordered-containers
                      ,  vector
 
 test-suite test-state
diff --git a/src/Graylog/Gelf.hs b/src/Graylog/Gelf.hs
index ee17e3d..8ffe24f 100644
--- a/src/Graylog/Gelf.hs
+++ b/src/Graylog/Gelf.hs
@@ -1,17 +1,21 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
 
 -- | Default formatting for Graylog messages,
 -- see http://docs.graylog.org/en/latest/pages/gelf.html
 module Graylog.Gelf where
 
-import           Data.Aeson        (ToJSON (..), Value (..), genericToJSON,
-                                    toJSON)
-import           Data.Aeson.Casing
-import           Data.Text         (Text)
+import           Data.Aeson          (ToJSON (..), Value (..), object, toJSON,
+                                      (.=))
+import           Data.HashMap.Strict (HashMap)
+import           Data.Scientific     (Scientific)
+import           Data.Semigroup      ((<>))
+import           Data.Text           (Text)
 import           Data.Time
 import           Data.Typeable
+import           GHC.Exts            (toList)
 import           GHC.Generics
 
 data GELF
@@ -24,11 +28,44 @@ data GELF
       , _gelfLevel        :: Maybe SyslogLevel
       , _gelfLine         :: Maybe Word
       , _gelfFile         :: Maybe Text
+      , _gelfMeta         :: HashMap Text MetaValue
       }
    deriving (Show, Typeable, Generic)
 
+data MetaValue
+  = TextValue Text
+  | NumberValue Scientific
+  deriving (Show)
+
+instance ToJSON MetaValue where
+  toJSON (TextValue txt) = toJSON txt
+  toJSON (NumberValue n) = toJSON n
+
+class ToMeta a where
+  toMeta :: a -> MetaValue
+
+instance ToMeta Text where
+  toMeta = TextValue
+
+instance ToMeta Scientific where
+  toMeta = NumberValue
+
+instance ToMeta Integer where
+  toMeta = NumberValue . fromInteger
+
+instance ToMeta Int where
+  toMeta = toMeta . toInteger
+
 instance ToJSON GELF where
-   toJSON = genericToJSON $ aesonPrefix snakeCase
+  toJSON GELF{..} = object $ [ "version"        .= _gelfVersion
+                             , "host"           .= _gelfHost
+                             , "short_message"  .= _gelfShortMessage
+                             , "full_message"   .= _gelfFullMessage
+                             , "timestamp"      .= _gelfTimestamp
+                             , "level"          .= _gelfLevel
+                             , "line"           .= _gelfLine
+                             , "file"           .= _gelfFile
+                             ] <> toList (toJSON <$> _gelfMeta)
 
 --
 
@@ -69,4 +106,4 @@ simpleGelf
    -> Text     -- ^ Short message
    -> GELF
 simpleGelf host short =
-   GELF Version1x1 host short Nothing Nothing Nothing Nothing Nothing
+  GELF Version1x1 host short Nothing Nothing Nothing Nothing Nothing mempty
diff --git a/stack.yaml b/stack.yaml
index 55ab633..2ccd75c 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,7 +2,7 @@
 # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
 
 # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: lts-5.4
+resolver: lts-11.5
 
 # Local packages, usually specified by relative directory name
 packages: