git.iko.soy/typeable/katip
on master help sign in
Add tests for logging, namespace/context addition, nologging
83f6d6bMichael Xavier
katip/test/Katip/Tests.hs+41
compare with master
unifiedsplit
@@ -5,6 +5,7 @@
5{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TemplateHaskell #-}
8{-# OPTIONS_GHC -fno-warn-orphans #-}
9{-# OPTIONS_GHC -fno-warn-orphans #-}
9module Katip.Tests
10module Katip.Tests
10 ( tests
11 ( tests
@@ -49,6 +50,7 @@ tests = testGroup "Katip"
49 , logContextsTests
50 , logContextsTests
50 , closeScribeTests
51 , closeScribeTests
51 , closeScribesTests
52 , closeScribesTests
53+ , loggingTests
52 ]
54 ]
53
55
54
56
@@ -97,6 +99,45 @@ closeScribeTests = testGroup "closeScribe"
97 ]
99 ]
98
100
99
101
102+-------------------------------------------------------------------------------
103+loggingTests :: TestTree
104+loggingTests = testGroup "logging"
105+ [ testCase "logs in order with contexts, namespaces, etc" $ do
106+ (le, items) <- recordingEnv
107+ runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ do
108+ $(logTM) InfoS "basic log"
109+ katipNoLogging $ do
110+ $(logTM) InfoS "you cant see this"
111+ katipAddNamespace "added" $ do
112+ katipAddNamespace "namespace" $ do
113+ $(logTM) InfoS "with namespaces"
114+ katipAddContext (sl "additional" True) $ do
115+ $(logTM) InfoS "additional context"
116+ _ <- closeScribes le
117+ summary <- fmap summarizeItem <$> readTVarIO items
118+ let baseCtx = HM.singleton "base_context" (Number 42)
119+ let baseNS = "tests" <> "base_namespace"
120+ summary @?=
121+ [ (baseNS, baseCtx, "basic log")
122+ , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")
123+ , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")
124+ ]
125+ ]
126+ where
127+ recordingEnv :: IO (LogEnv, TVar [Item Object])
128+ recordingEnv = do
129+ items <- newTVarIO mempty
130+ let scribe = Scribe
131+ { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))
132+ , scribeFinalizer = return ()
133+ }
134+ le1 <- initLogEnv "tests" "test"
135+ le2 <- registerScribe "recorder" scribe defaultScribeSettings le1
136+ return (le2, items)
137+ summarizeItem :: Item Object -> (Namespace, Object, LogStr)
138+ summarizeItem Item {..} = (_itemNamespace, _itemPayload, _itemMessage)
139+
140+
100-------------------------------------------------------------------------------
141-------------------------------------------------------------------------------
101trivialScribe :: IO (Scribe, TVar Bool)
142trivialScribe :: IO (Scribe, TVar Bool)
102trivialScribe = do
143trivialScribe = do