Correctly detect log level when rendering logs as structured JSON

changelog.d/3-bug-fixes/structured-json

@@ -0,0 +1 @@
+Correctly detect log level when rendering logs as structured JSON

libs/extended/extended.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 040115252374cb428a08ab286b9a4eb9492a407e9197009e7944f163dc1bfdcc
+-- hash: 3aab57e8600541201e0b0f8cd7308f624eb479a4f5601e800399b4787656c449
 
 name:           extended
 version:        0.1.0
@@ -52,3 +52,39 @@ library
     , tinylog
     , wai
   default-language: Haskell2010
+
+test-suite extended-tests
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Test.System.Logger.ExtendedSpec
+      Paths_extended
+  hs-source-dirs:
+      test
+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns
+  ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N
+  build-tool-depends:
+      hspec-discover:hspec-discover
+  build-depends:
+      aeson
+    , base
+    , bytestring
+    , cassandra-util
+    , containers
+    , errors
+    , exceptions
+    , extended
+    , extra
+    , hspec
+    , http-types
+    , imports
+    , metrics-wai
+    , optparse-applicative
+    , servant
+    , servant-server
+    , servant-swagger
+    , string-conversions
+    , temporary
+    , tinylog
+    , wai
+  default-language: Haskell2010

libs/extended/package.yaml

@@ -36,4 +36,17 @@ dependencies:
 - wai
 library:
   source-dirs: src
+tests:
+  extended-tests:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options:
+    - -threaded
+    - -with-rtsopts=-N
+    dependencies:
+    - hspec
+    - extended
+    - temporary
+    build-tools:
+    - hspec-discover:hspec-discover
 stability: experimental

libs/extended/src/System/Logger/Extended.hs

@@ -28,6 +28,7 @@ module System.Logger.Extended
     LoggerT (..),
     runWithLogger,
     netStringsToLogFormat,
+    structuredJSONRenderer,
   )
 where
 
@@ -78,20 +79,20 @@ collect = foldr go (Element' mempty [])
 jsonRenderer :: Renderer
 jsonRenderer _sep _dateFormat _logLevel = fromEncoding . elementToEncoding . collect
 
-data StructuredJSONOutput = StructuredJSONOutput {msgs :: [Text], fields :: Map Text [Text]}
+data StructuredJSONOutput = StructuredJSONOutput {lvl :: Maybe Level, msgs :: [Text], fields :: Map Text [Text]}
 
 -- | Displays all the 'Bytes' segments in a list under key @msgs@ and 'Field'
 -- segments as key-value pair in a JSON
 --
--- >>> logElems = [Bytes "I", Bytes "The message", Field "field1" "val1", Field "field2" "val2", Field "field1" "val1.1"]
+-- >>> logElems = [Bytes "W", Bytes "The message", Field "field1" "val1", Field "field2" "val2", Field "field1" "val1.1"]
 -- >>> B.toLazyByteString $ structuredJSONRenderer "," iso8601UTC Info logElems
--- "{\"msgs\":[\"I\",\"The message\"],\"field1\":[\"val1\",\"val1.1\"],\"field2\":\"val2\",\"level\":\"Info\"}"
+-- "{\"msgs\":[\"The message\"],\"field1\":[\"val1\",\"val1.1\"],\"field2\":\"val2\",\"level\":\"Warn\"}"
 structuredJSONRenderer :: Renderer
-structuredJSONRenderer _sep _dateFmt lvl logElems =
+structuredJSONRenderer _sep _dateFmt _lvlThreshold logElems =
   let structuredJSON = toStructuredJSONOutput logElems
    in fromEncoding . toEncoding $
         object
-          ( [ "level" Aeson..= lvl,
+          ( [ "level" Aeson..= lvl structuredJSON,
               "msgs" Aeson..= msgs structuredJSON
             ]
               <> Map.foldMapWithKey (\k v -> [k Aeson..= renderTextList v]) (fields structuredJSON)
@@ -106,14 +107,29 @@ structuredJSONRenderer _sep _dateFmt lvl logElems =
     builderToText :: Builder -> Text
     builderToText = cs . eval
 
+    -- We need to do this to work around https://gitlab.com/twittner/tinylog/-/issues/5
+    parseLevel :: Text -> Maybe Level
+    parseLevel = \case
+      "T" -> Just Trace
+      "D" -> Just Debug
+      "I" -> Just Info
+      "W" -> Just Warn
+      "E" -> Just Log.Error
+      "F" -> Just Fatal
+      _ -> Nothing
+
     toStructuredJSONOutput :: [Element] -> StructuredJSONOutput
     toStructuredJSONOutput =
       foldr
         ( \e o -> case e of
-            Bytes b -> o {msgs = builderToText b : msgs o}
+            Bytes b ->
+              let buildMsg = builderToText b
+               in case parseLevel buildMsg of
+                    Nothing -> o {msgs = builderToText b : msgs o}
+                    Just lvl -> o {lvl = Just lvl}
             Field k v -> o {fields = Map.insertWith (<>) (builderToText k) (map builderToText [v]) (fields o)}
         )
-        (StructuredJSONOutput mempty mempty)
+        (StructuredJSONOutput Nothing [] mempty)
 
 -- | Here for backwards-compatibility reasons
 netStringsToLogFormat :: Bool -> LogFormat

libs/extended/test/Spec.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.

libs/extended/test/Test/System/Logger/ExtendedSpec.hs

@@ -0,0 +1,49 @@
+module Test.System.Logger.ExtendedSpec where
+
+import Data.Aeson ((.=))
+import qualified Data.Aeson as Aeson
+import Data.String.Conversions (cs)
+import Imports
+import System.IO.Temp
+import System.Logger.Extended hiding ((.=))
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec =
+  describe "System.Loggger.Extended" $ do
+    describe "LogFormat: StructuredJSON" $ do
+      it "should encode logs as new line separated structured JSON with log level, messages and fields" $ do
+        withSystemTempFile "structured-json" $ \f h -> do
+          hClose h -- The handle is not required
+          l <-
+            new
+              . setRenderer structuredJSONRenderer
+              . setOutput (Path f)
+              . setFormat Nothing -- date format, not having it makes it easier to test.
+              $ defSettings
+
+          warn l $
+            msg ("first message" :: ByteString)
+              . field "field1" ("val 1.1" :: ByteString)
+              . field "field2" ("val 2" :: ByteString)
+              . field "field1" ("val 1.2" :: ByteString)
+              . msg ("second message" :: ByteString)
+          info l $ msg ("just a message" :: ByteString)
+
+          flush l
+          close l
+          actualLogs <- map (Aeson.eitherDecode @Aeson.Value . cs) . lines <$> readFile f
+
+          let expectedLogs =
+                [ Aeson.object
+                    [ "level" .= Warn,
+                      "msgs" .= ["first message" :: Text, "second message"],
+                      "field1" .= ["val 1.1" :: Text, "val 1.2"],
+                      "field2" .= ("val 2" :: Text)
+                    ],
+                  Aeson.object
+                    [ "level" .= Info,
+                      "msgs" .= ["just a message" :: Text]
+                    ]
+                ]
+          actualLogs `shouldBe` (Right <$> expectedLogs)