@@ -11,9 +11,12 @@ module Katip.Tests
1111
1212
1313-------------------------------------------------------------------------------
14−import Control.Applicative as A
14+import Control.Applicative as A
15+import Control.Concurrent.STM
16+import Control.Exception.Safe
1517import Data.Aeson
1618import qualified Data.HashMap.Strict as HM
19+import qualified Data.Map.Strict as M
1720import Data.Monoid
1821import Data.Text (Text)
1922import qualified Data.Text.Lazy.Builder as B
@@ -43,6 +46,8 @@ tests = testGroup "Katip"
4346 , testCase "processIDToText is just the number" $ do
4447 processIDToText 123 @?= "123"
4548 , logContextsTests
49+ , closeScribeTests
50+ , closeScribesTests
4651 ]
4752
4853
@@ -65,6 +70,81 @@ logContextsTests = testGroup "logContexts"
6570 ]
6671
6772
73+-------------------------------------------------------------------------------
74+closeScribeTests :: TestTree
75+closeScribeTests = testGroup "closeScribe"
76+ [ testCase "removes the specified scribe" $ do
77+ (scr, finalizerCalled) <- trivialScribe
78+ le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"
79+ le' <- closeScribe "trivial" le
80+ closed <- atomically (readTVar finalizerCalled)
81+ assertBool "finalizer called" closed
82+ assertBool "should not have trivial key in scribes" (not (M.member "trivial" (_logEnvScribes le')))
83+ , testCase "does nothing for a missing scribe" $ do
84+ le <- initLogEnv "ns" "test"
85+ le' <- closeScribe "nah" le
86+ assertBool "does not affect scribes" (M.null (_logEnvScribes le'))
87+ , testCase "re-throws finalizer exceptions" $ do
88+ (scr, finalizerCalled) <- brokenScribe 1
89+ le <- registerScribe "broken" scr defaultScribeSettings =<< initLogEnv "ns" "test"
90+ res <- try (closeScribe "broken" le)
91+ closed <- atomically (readTVar finalizerCalled)
92+ assertBool "finalizer called" closed
93+ case res of
94+ Left (ScribeBroken scribeNo) -> scribeNo @?= 1
95+ Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"
96+ ]
97+
98+
99+-------------------------------------------------------------------------------
100+trivialScribe :: IO (Scribe, TVar Bool)
101+trivialScribe = do
102+ finalizerCalled <- newTVarIO False
103+ let finalizer = atomically (writeTVar finalizerCalled True)
104+ return (Scribe (const (return ())) finalizer, finalizerCalled)
105+
106+
107+-------------------------------------------------------------------------------
108+brokenScribe :: Int -> IO (Scribe, TVar Bool)
109+brokenScribe scribeNum = do
110+ finalizerCalled <- newTVarIO False
111+ let finalizer = do
112+ atomically (writeTVar finalizerCalled True)
113+ throw (ScribeBroken scribeNum)
114+ return (Scribe (const (return ())) finalizer, finalizerCalled)
115+
116+
117+-------------------------------------------------------------------------------
118+data BrokenScribeError = ScribeBroken Int deriving (Show)
119+
120+
121+instance Exception BrokenScribeError
122+
123+-------------------------------------------------------------------------------
124+closeScribesTests :: TestTree
125+closeScribesTests = testGroup "closeScribes"
126+ [ testCase "returns a log env with no scribes" $ do
127+ (scr, finalizerCalled) <- trivialScribe
128+ le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"
129+ le' <- closeScribes le
130+ closed <- atomically (readTVar finalizerCalled)
131+ assertBool "finalizer called" closed
132+ assertBool "remvoes all scribes" (M.null (_logEnvScribes le'))
133+ , testCase "throws the first exception encountered after closing all scribes" $ do
134+ (scr1, finalizerCalled1) <- brokenScribe 1
135+ (scr2, finalizerCalled2) <- brokenScribe 2
136+ le <- registerScribe "broken2" scr2 defaultScribeSettings =<< registerScribe "broken1" scr1 defaultScribeSettings =<< initLogEnv "ns" "test"
137+ res <- try (closeScribes le)
138+ closed1 <- atomically (readTVar finalizerCalled1)
139+ assertBool "finalizer 1 called" closed1
140+ closed2 <- atomically (readTVar finalizerCalled2)
141+ assertBool "finalizer 2 called" closed2
142+ case res of
143+ Left (ScribeBroken scribeNo) -> scribeNo @?= 1
144+ Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"
145+ ]
146+
147+
68148-------------------------------------------------------------------------------
69149data ConservativePayload = ConservativePayload {
70150 oftenShown :: Text