git.iko.soy/typeable/katip
on master help sign in
Merge pull request #12 from Soostone/logcontexts-bias

Logcontexts bias

commit793baed73f5afdcbff630a74715f3f746d9ec6ac authorMichael Xavier <michael@michaelxavier.net> dateThu 17 Mar 2016, 15:44 (11 years ago) parente1f628eff50a85
5 files changed+66−8
compare with master
unifiedsplit
katip/katip.cabal+1 katip/src/Katip/Core.hs+1 katip/src/Katip/Monadic.hs+19−5 katip/src/Katip/Scribes/Handle.hs+1−3 katip/test/Katip/Tests.hs+44
katip/katip.cabal+1
@@ -98,6 +98,7 @@ test-suite test
9898 , temporary
9999 , directory
100100 , regex-tdfa-rc
101+ , unordered-containers
101102
102103
103104benchmark bench
katip/src/Katip/Core.hs+1
@@ -327,6 +327,7 @@ instance FromJSON ProcessIDJs where
327327data PayloadSelection
328328 = AllKeys
329329 | SomeKeys [Text]
330+ deriving (Show, Eq)
330331
331332instance Monoid PayloadSelection where
332333 mempty = SomeKeys []
katip/src/Katip/Monadic.hs+19−5
@@ -53,8 +53,10 @@ import qualified Control.Monad.Trans.State.Strict as Strict (StateT)
5353import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)
5454import Control.Monad.Writer
5555import Data.Aeson
56+import qualified Data.Foldable as FT
5657import qualified Data.HashMap.Strict as HM
5758import Data.Monoid as M
59+import Data.Sequence as Seq
5860import Data.Text (Text)
5961import Language.Haskell.TH
6062-------------------------------------------------------------------------------
@@ -72,17 +74,29 @@ data AnyLogContext where
7274-- 'LogContext' instance for combining multiple payload policies. This
7375-- is critical for log contexts deep down in a stack to be able to
7476-- inject their own context without worrying about other context that
75−-- has already been set.
76−newtype LogContexts = LogContexts [AnyLogContext] deriving (Monoid)
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.
89+newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid) --TODO: could we pre-encode this and also capture payloadKeys
7790
7891instance ToJSON LogContexts where
7992 toJSON (LogContexts cs) =
80− Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) cs
93+ -- flip mappend to get right-biased merge
94+ Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs
8195
8296instance ToObject LogContexts
8397
8498instance 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
86100 where
87101 -- To ensure AllKeys doesn't leak keys from other values when
88102 -- combined, we resolve AllKeys to its equivalent SomeKeys
@@ -96,7 +110,7 @@ instance LogItem LogContexts where
96110-- | Lift a log context into the generic wrapper so that it can
97111-- combine with the existing log context.
98112liftPayload :: (LogItem a) => a -> LogContexts
99−liftPayload = LogContexts . (:[]) . AnyLogContext
113+liftPayload = LogContexts . Seq.singleton . AnyLogContext
100114
101115
102116-------------------------------------------------------------------------------
katip/src/Katip/Scribes/Handle.hs+1−3
@@ -11,7 +11,6 @@ import Data.Text.Lazy.Builder
1111import Data.Text.Lazy.IO as T
1212import Data.Time
1313import qualified Data.Time.Locale.Compat as LC
14−import Lens.Micro
1514import System.IO
1615import System.IO.Unsafe (unsafePerformIO)
1716-------------------------------------------------------------------------------
@@ -26,8 +25,7 @@ brackets m = fromText "[" <> m <> fromText "]"
2625
2726-------------------------------------------------------------------------------
2827getKeys :: LogItem s => Verbosity -> s -> [Builder]
29−getKeys verb a = payloadObject verb a ^..
30− to HM.toList . traverse . to rendPair
28+getKeys verb a = rendPair <$> HM.toList (payloadObject verb a)
3129 where
3230 rendPair (k,v) = fromText k <> fromText ":" <> (renderPrim v)
3331
katip/test/Katip/Tests.hs+44
@@ -1,5 +1,6 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
34{-# LANGUAGE ScopedTypeVariables #-}
45{-# LANGUAGE StandaloneDeriving #-}
56{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -11,6 +12,9 @@ module Katip.Tests
1112-------------------------------------------------------------------------------
1213import Control.Applicative
1314import Data.Aeson
15+import qualified Data.HashMap.Strict as HM
16+import Data.Monoid
17+import Data.Text (Text)
1418import qualified Data.Text.Lazy.Builder as B
1519import Data.Time
1620import Data.Time.Clock.POSIX
@@ -37,9 +41,49 @@ tests = testGroup "Katip"
3741 textToProcessID (processIDToText pid) === Just pid
3842 , testCase "processIDToText is just the number" $ do
3943 processIDToText 123 @?= "123"
44+ , logContextsTests
4045 ]
4146
4247
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+
4387-------------------------------------------------------------------------------
4488prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property
4589prop_json_cycle a = eitherDecode (encode a) === Right a