diff --git a/changelog.d/3-bug-fixes/structured-json b/changelog.d/3-bug-fixes/structured-json new file mode 100644 index 0000000000..ab8d8fdacb --- /dev/null +++ b/changelog.d/3-bug-fixes/structured-json @@ -0,0 +1 @@ +Correctly detect log level when rendering logs as structured JSON \ No newline at end of file diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index ca3ecbf67b..aee67e062f 100644 --- a/libs/extended/extended.cabal +++ b/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 diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index 7714754d50..5dbe406f6a 100644 --- a/libs/extended/package.yaml +++ b/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 diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index 26ba7b4a3a..ec51ba4870 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/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 diff --git a/libs/extended/test/Spec.hs b/libs/extended/test/Spec.hs new file mode 100644 index 0000000000..7b57431c0d --- /dev/null +++ b/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 +-- +-- 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 . diff --git a/libs/extended/test/Test/System/Logger/ExtendedSpec.hs b/libs/extended/test/Test/System/Logger/ExtendedSpec.hs new file mode 100644 index 0000000000..315878eaae --- /dev/null +++ b/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)