793baed · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Merge pull request #12 from Soostone/logcontexts-bias

793baedMichael Xavier11 years ago

katip/katip.cabal+1

compare with master

unifiedsplit

@@ -98,6 +98,7 @@ test-suite test

98 , temporary

99 , directory

100 , regex-tdfa-rc

101+ , unordered-containers

101

102

103

103benchmark bench

104benchmark bench

katip/src/Katip/Core.hs+1

@@ -327,6 +327,7 @@ instance FromJSON ProcessIDJs where

327data PayloadSelection

328 = AllKeys

329 | SomeKeys [Text]

330+ deriving (Show, Eq)

330

331

331instance Monoid PayloadSelection where

332instance Monoid PayloadSelection where

332 mempty = SomeKeys []

333 mempty = SomeKeys []

katip/src/Katip/Monadic.hs+19−5

@@ -53,8 +53,10 @@ import qualified Control.Monad.Trans.State.Strict as Strict (StateT)

53import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)

54import Control.Monad.Writer

55import Data.Aeson

56+import qualified Data.Foldable as FT

56import qualified Data.HashMap.Strict as HM

57import qualified Data.HashMap.Strict as HM

57import Data.Monoid as M

58import Data.Monoid as M

59+import Data.Sequence as Seq

58import Data.Text (Text)

60import Data.Text (Text)

59import Language.Haskell.TH

61import Language.Haskell.TH

60-------------------------------------------------------------------------------

62-------------------------------------------------------------------------------

@@ -72,17 +74,29 @@ data AnyLogContext where

72-- 'LogContext' instance for combining multiple payload policies. This

74-- 'LogContext' instance for combining multiple payload policies. This

73-- is critical for log contexts deep down in a stack to be able to

75-- is critical for log contexts deep down in a stack to be able to

74-- inject their own context without worrying about other context that

76-- inject their own context without worrying about other context that

75−-- has already been set.

77+-- has already been set. Also note that contexts are treated as a

78+-- sequence and '<>' will be appended to the right hand side of the

79+-- sequence. If there are conflicting keys in the contexts, the /right

80+-- side will take precedence/, which is counter to how monoid works

81+-- for 'Map' and 'HashMap', so bear that in mind. The reasoning is

82+-- that if the user is /sequentially/ adding contexts to the right

83+-- side of the sequence, on conflict the intent is to overwrite with

84+-- the newer value (i.e. the rightmost value).

85+--

86+-- Additional note: you should not mappend LogContexts in any sort of

87+-- infinite loop, as it retains all data, so that would be a memory

88+-- leak.

76−newtype LogContexts = LogContexts [AnyLogContext] deriving (Monoid)

89+newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid) --TODO: could we pre-encode this and also capture payloadKeys

78instance ToJSON LogContexts where

91instance ToJSON LogContexts where

79 toJSON (LogContexts cs) =

92 toJSON (LogContexts cs) =

93+ -- flip mappend to get right-biased merge

80− Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) cs

94+ Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs

82instance ToObject LogContexts

96instance ToObject LogContexts

84instance LogItem LogContexts where

98instance LogItem LogContexts where

85− payloadKeys verb (LogContexts vs) = mconcat $ map payloadKeys' vs

99+ payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs

86 where

100 where

87 -- To ensure AllKeys doesn't leak keys from other values when

101 -- To ensure AllKeys doesn't leak keys from other values when

88 -- combined, we resolve AllKeys to its equivalent SomeKeys

102 -- combined, we resolve AllKeys to its equivalent SomeKeys

@@ -96,7 +110,7 @@ instance LogItem LogContexts where

96-- | Lift a log context into the generic wrapper so that it can

110-- | Lift a log context into the generic wrapper so that it can

97-- combine with the existing log context.

111-- combine with the existing log context.

98liftPayload :: (LogItem a) => a -> LogContexts

112liftPayload :: (LogItem a) => a -> LogContexts

99−liftPayload = LogContexts . (:[]) . AnyLogContext

113+liftPayload = LogContexts . Seq.singleton . AnyLogContext

100

114

101

115

102-------------------------------------------------------------------------------

116-------------------------------------------------------------------------------

katip/src/Katip/Scribes/Handle.hs+1−3

@@ -11,7 +11,6 @@ import Data.Text.Lazy.Builder

11import Data.Text.Lazy.IO as T

12import Data.Time

13import qualified Data.Time.Locale.Compat as LC

14−import Lens.Micro

15import System.IO

14import System.IO

16import System.IO.Unsafe (unsafePerformIO)

15import System.IO.Unsafe (unsafePerformIO)

17-------------------------------------------------------------------------------

16-------------------------------------------------------------------------------

@@ -26,8 +25,7 @@ brackets m = fromText "[" <> m <> fromText "]"

27-------------------------------------------------------------------------------

26-------------------------------------------------------------------------------

28getKeys :: LogItem s => Verbosity -> s -> [Builder]

27getKeys :: LogItem s => Verbosity -> s -> [Builder]

29−getKeys verb a = payloadObject verb a ^..

28+getKeys verb a = rendPair <$> HM.toList (payloadObject verb a)

30− to HM.toList . traverse . to rendPair

31 where

29 where

32 rendPair (k,v) = fromText k <> fromText ":" <> (renderPrim v)

30 rendPair (k,v) = fromText k <> fromText ":" <> (renderPrim v)

katip/test/Katip/Tests.hs+44

@@ -1,5 +1,6 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE StandaloneDeriving #-}

5{-# OPTIONS_GHC -fno-warn-orphans #-}

6{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -11,6 +12,9 @@ module Katip.Tests

11-------------------------------------------------------------------------------

12-------------------------------------------------------------------------------

12import Control.Applicative

13import Control.Applicative

13import Data.Aeson

14import Data.Aeson

15+import qualified Data.HashMap.Strict as HM

16+import Data.Monoid

17+import Data.Text (Text)

14import qualified Data.Text.Lazy.Builder as B

18import qualified Data.Text.Lazy.Builder as B

15import Data.Time

19import Data.Time

16import Data.Time.Clock.POSIX

20import Data.Time.Clock.POSIX

@@ -37,9 +41,49 @@ tests = testGroup "Katip"

37 textToProcessID (processIDToText pid) === Just pid

41 textToProcessID (processIDToText pid) === Just pid

38 , testCase "processIDToText is just the number" $ do

42 , testCase "processIDToText is just the number" $ do

39 processIDToText 123 @?= "123"

43 processIDToText 123 @?= "123"

44+ , logContextsTests

40 ]

45 ]

48+-------------------------------------------------------------------------------

49+logContextsTests :: TestTree

50+logContextsTests = testGroup "logContexts"

51+ [

52+ testCase "overwrites with the right-hand side (right-bias)" $ do

53+ let l1 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])

54+ l2 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("b" :: Text))])

55+ l3 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("c" :: Text))])

56+ both = l1 <> l2 <> l3

57+ toObject both @?= HM.singleton "foo" (String "c")

58+ , testCase "respects payloadKeys for each constituent payload" $ do

59+ let everything = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])

60+ conservative = liftPayload (ConservativePayload "always" "rarely")

61+ both = everything <> conservative

62+ payloadKeys V2 both @?= SomeKeys ["often_shown", "rarely_shown", "foo"]

63+ payloadKeys V1 both @?= SomeKeys ["often_shown", "foo"]

64+ ]

65+

66+

67+-------------------------------------------------------------------------------

68+data ConservativePayload = ConservativePayload {

69+ oftenShown :: Text

70+ , rarelyShown :: Text

71+ }

72+

73+

74+instance ToJSON ConservativePayload where

75+ toJSON ConservativePayload {..} = object ["often_shown" .= oftenShown

76+ ,"rarely_shown" .= rarelyShown]

77+

78+

79+instance ToObject ConservativePayload

80+

81+

82+instance LogItem ConservativePayload where

83+ payloadKeys V1 _ = SomeKeys ["often_shown"]

84+ payloadKeys V0 _ = SomeKeys []

85+ payloadKeys _ _ = AllKeys

86+

43-------------------------------------------------------------------------------

87-------------------------------------------------------------------------------

44prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property

88prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property

45prop_json_cycle a = eitherDecode (encode a) === Right a

89prop_json_cycle a = eitherDecode (encode a) === Right a