@@ -0,0 +1,69 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+-- | This executable is a test which runs addContext with
3+-- key-compatible log contexts in a tight loop. At time of writing, I
4+-- suspect this will result in a memory leak as we just naively
5+-- concatenate it into a sequence. If instead we eagerly merge the log
6+-- objects, each loop will overwrite the previous context and there
7+-- will be no memory leak. You can pass a numeric argument to this
8+-- executable to specify how many loops to do. -1 goes infinite.
9+--
10+-- If we didn't have to retain the log context and could eagerly merge
11+-- it, this wouldn't be an issue, but unfortunately we don't know
12+-- which keys to keep until log time, not context add time. Further,
13+-- we couldn't accumulate and compose key retention functions for the
14+-- same reason.
15+module Main
16+ ( main
17+ ) where
18+
19+
20+-------------------------------------------------------------------------------
21+import Control.Monad (unless, forever)
22+import qualified Data.Aeson as A
23+import qualified Data.HashMap.Strict as HM
24+import qualified Data.String.Conv as SC
25+import qualified System.Environment as SE
26+-------------------------------------------------------------------------------
27+import qualified Katip as K
28+-------------------------------------------------------------------------------
29+
30+
31+main :: IO ()
32+main = do
33+ args <- SE.getArgs
34+ le <- K.initLogEnv "add_context_loop" "test"
35+ K.runKatipContextT le () "loop" $ case args of
36+ [] -> run (Just 1000000)
37+ ns:_ -> let n = read ns
38+ in if n < 0
39+ then run Nothing
40+ else run (Just n)
41+
42+
43+-------------------------------------------------------------------------------
44+-- | Semantically, each loop adds more context on. If we were using
45+-- something like forever, unfoldM, etc, which is probably what we
46+-- actually want, it would add the same context each time,
47+-- non-redundantly and thus no leak.
48+run :: Maybe Int -> K.KatipContextT IO ()
49+run mlim = go 0
50+ where
51+ go n = do
52+ K.katipAddContext (SomeContext 1000) $ do
53+ K.logFM K.InfoS "loop"
54+ unless (done n) $ go (n + 1)
55+ done n = case mlim of
56+ Nothing -> False
57+ Just lim -> n >= lim
58+
59+
60+-------------------------------------------------------------------------------
61+data SomeContext = SomeContext Int
62+
63+
64+instance K.ToObject SomeContext where
65+ toObject (SomeContext sz) = HM.fromList [ SC.toS (show n) A..= () | n <- [0..sz]]
66+
67+
68+instance K.LogItem SomeContext where
69+ payloadKeys _ _ = K.AllKeys