461c1fc · typeable/katip

git.iko.soy/typeable/katip

PermitFunc in Scribe

commit461c1fce342309c7734d791bf74e4ea6171ae348 authorvlatkoB <vlatko.basic@gmail.com> dateWed 19 Dec 2018, 11:34 (8 years ago) parent4b43748

11 files changed+62−37

compare with master

unifiedsplit

katip-elasticsearch/examples/example.hs+1−1 katip-elasticsearch/katip-elasticsearch.cabal+1−1 katip-elasticsearch/src/Katip/Scribes/ElasticSearch/Internal.hs+4−4 katip-elasticsearch/test/Main.hs+1−1 katip/bench/Main.hs+5−2 katip/katip.cabal+1−1 katip/src/Katip/Core.hs+26−9 katip/src/Katip/Scribes/Handle.hs+17−13 katip/test/Katip/Tests.hs+3−2 katip/test/Katip/Tests/Scribes/Handle.hs+2−2 stack.yaml+1−1

katip-elasticsearch/examples/example.hs+1−1

@@ -27,7 +27,7 @@ main = do

2727 bhe

2828 (IndexName "all-indices-prefixed-with")

2929 (MappingName "application-logs")

30− DebugS

30+ (permitItem DebugS)

3131 V3

3232 let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"

3333 bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do

katip-elasticsearch/katip-elasticsearch.cabal+1−1

@@ -1,7 +1,7 @@

11name: katip-elasticsearch

22synopsis: ElasticSearch scribe for the Katip logging framework.

33description: See README.md for more details.

4−version: 0.5.1.1

4+version: 0.8.0.0

55license: BSD3

66license-file: LICENSE

77author: Ozgun Ataman, Michael Xavier

katip-elasticsearch/src/Katip/Scribes/ElasticSearch/Internal.hs+4−4

@@ -269,10 +269,10 @@ mkEsScribe

269269 -> IndexName v

270270 -- ^ Treated as a prefix if index sharding is enabled

271271 -> MappingName v

272− -> Severity

272+ -> PermitFunc

273273 -> Verbosity

274274 -> IO Scribe

275−mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do

275+mkEsScribe cfg@EsScribeCfg {..} env ix mapping permit verb = do

276276 q <- newTBMQueueIO $ unEsQueueSize essQueueSize

277277 endSig <- newEmptyMVar

278278

@@ -308,10 +308,10 @@ mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do

308308 putMVar endSig ()

309309

310310 let finalizer = putMVar endSig () >> takeMVar endSig

311− return (Scribe (logger q) finalizer)

311+ return (Scribe (logger q) finalizer permit)

312312 where

313313 logger :: forall a. LogItem a => TBMQueue (IndexName v, Value) -> Item a -> IO ()

314− logger q i = when (_itemSeverity i >= sev) $

314+ logger q i =

315315 void $ atomically $ tryWriteTBMQueue q (chooseIxn prx ix essIndexSharding i, itemJson' i)

316316 prx :: Typeable.Proxy v

317317 prx = Typeable.Proxy

katip-elasticsearch/test/Main.hs+1−1

@@ -161,7 +161,7 @@ setupSearch

161161setupSearch prx modScribeCfg = do

162162 bh prx (dropESSchema prx)

163163 mgr <- newManager defaultManagerSettings

164− mkEsScribe cfg (mkBHEnv prx (svr prx) mgr) (ixn prx) (mn prx) DebugS V3

164+ mkEsScribe cfg (mkBHEnv prx (svr prx) mgr) (ixn prx) (mn prx) (permitItem DebugS) V3

165165 where

166166 cfg :: EsScribeCfg v

167167 cfg = modScribeCfg $

katip/bench/Main.hs+5−2

@@ -92,7 +92,7 @@ setup dest = do

9292 return (tmp </> "katip-bench.log")

9393 DevNull -> return ("/dev/null")

9494 h <- openFile outFile WriteMode

95− s <- mkHandleScribe ColorIfTerminal h DebugS V0

95+ s <- mkHandleScribe ColorIfTerminal h (permitItem DebugS) V0

9696 let cleanupHandle = hClose h `finally` (when (dest == TempFile) (removeLink outFile))

9797 return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}

9898

@@ -101,4 +101,7 @@ setup dest = do

101101deriving instance NFData ThreadIdText

102102

103103instance NFData Scribe where

104− rnf (Scribe a b) = (a :: Item ExPayload -> IO ()) `seq` b `seq` ()

104+ rnf (Scribe a b p) = (a :: Item ExPayload -> IO ())

105+ `seq` b

106+ `seq` (p :: Item ExPayload -> IO Bool)

107+ `seq` ()

katip/katip.cabal+1−1

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

11name: katip

2−version: 0.7.0.0

2+version: 0.8.0.0

33synopsis: A structured logging framework.

44description:

55 Katip is a structured logging framework. See README.md for more details.

katip/src/Katip/Core.hs+26−9

@@ -29,7 +29,7 @@ import qualified Control.Concurrent.Async as Async

2929import Control.Concurrent.STM

3030import qualified Control.Concurrent.STM.TBQueue as BQ

3131import Control.Exception.Safe

32−import Control.Monad (unless, void)

32+import Control.Monad (unless, void, when)

3333import Control.Monad.Base

3434import Control.Monad.IO.Class

3535import Control.Monad.IO.Unlift

@@ -555,22 +555,38 @@ itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb

555555-- down gracefully before returning. This can be hooked into your

556556-- application's shutdown routine to ensure you never miss any log

557557-- messages on shutdown.

558+

559+

560+-- | Signature of a function passed to `Scribe` constructor and mkScribe* functions

561+-- that decides which messages to be logged

562+type PermitFunc = forall a. Item a -> IO Bool

563+

564+

558565data Scribe = Scribe {

559566 liPush :: forall a. LogItem a => Item a -> IO ()

560567 , scribeFinalizer :: IO ()

561568 -- ^ Provide a *blocking* finalizer to call when your scribe is

562569 -- removed. If this is not relevant to your scribe, return () is

563570 -- fine.

571+ , scribePermitItem :: PermitFunc

572+ -- ^ Provide a filtering function to allow the item to be logged, or not.

573+ -- It can check Severity or some string in item's body.

564574 }

565575

576+whenM :: Monad m => m Bool -> m () -> m ()

577+whenM mbool = (>>=) mbool . flip when

566578

567579instance Semigroup Scribe where

568− (Scribe pushA finA) <> (Scribe pushB finB) =

569− Scribe (\item -> pushA item >> pushB item) (finA `finally` finB)

580+ (Scribe pushA finA permitA) <> (Scribe pushB finB permitB) =

581+ Scribe (\item -> whenM (permitA item) (pushA item)

582+ >> whenM (permitB item) (pushB item)

583+ )

584+ (finA `finally` finB)

585+ (\item -> (||) <$> permitA item <*> permitB item)

570586

571587

572588instance Monoid Scribe where

573− mempty = Scribe (const (return ())) (return ())

589+ mempty = Scribe (const (return ())) (return ()) (permitItem DebugS)

574590 mappend = (<>)

575591

576592

@@ -589,8 +605,8 @@ data WorkerMessage where

589605

590606-------------------------------------------------------------------------------

591607-- | Should this item be logged given the user's maximum severity?

592−permitItem :: Severity -> Item a -> Bool

593−permitItem sev i = _itemSeverity i >= sev

608+permitItem :: Monad m => Severity -> Item a -> m Bool

609+permitItem sev Item{..} = return $ _itemSeverity >= sev

594610

595611

596612-------------------------------------------------------------------------------

@@ -660,7 +676,7 @@ registerScribe nm scribe ScribeSettings {..} le = do

660676

661677-------------------------------------------------------------------------------

662678spawnScribeWorker :: Scribe -> BQ.TBQueue WorkerMessage -> IO (Async.Async ())

663−spawnScribeWorker (Scribe write _) queue = Async.async go

679+spawnScribeWorker (Scribe write _ _) queue = Async.async go

664680 where

665681 go = do

666682 newCmd <- atomically (BQ.readTBQueue queue)

@@ -896,8 +912,9 @@ logItem a ns loc sev msg = do

896912 <*> _logEnvTimer

897913 <*> pure (_logEnvApp <> ns)

898914 <*> pure loc

899− FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> atomically (tryWriteTBQueue shChan (NewItem item))

900−

915+ FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> do

916+ whenM (scribePermitItem shScribe item) $

917+ void $ atomically (tryWriteTBQueue shChan (NewItem item))

901918

902919-------------------------------------------------------------------------------

903920tryWriteTBQueue

katip/src/Katip/Scribes/Handle.hs+17−13

@@ -4,7 +4,6 @@ module Katip.Scribes.Handle where

44import Control.Applicative as A

55import Control.Concurrent

66import Control.Exception (bracket_, finally)

7−import Control.Monad

87import Data.Aeson

98import Data.Text.Lazy (toStrict)

109import Data.Text.Lazy.Encoding (decodeUtf8)

@@ -63,7 +62,7 @@ data ColorStrategy

6362--

6463-- Returns the newly-created `Scribe`. The finalizer flushes the

6564-- handle. Handle mode is set to 'LineBuffering' automatically.

66−mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe

65+mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe

6766mkHandleScribe = mkHandleScribeWithFormatter bracketFormat

6867

6968-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom

@@ -71,17 +70,22 @@ mkHandleScribe = mkHandleScribeWithFormatter bracketFormat

7170--

7271-- Returns the newly-created `Scribe`. The finalizer flushes the

7372-- handle. Handle mode is set to 'LineBuffering' automatically.

74−mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a) -> ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe

75−mkHandleScribeWithFormatter itemFormatter cs h sev verb = do

73+mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)

74+ -> ColorStrategy

75+ -> Handle

76+ -> PermitFunc

77+ -> Verbosity

78+ -> IO Scribe

79+mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do

7680 hSetBuffering h LineBuffering

7781 colorize <- case cs of

7882 ColorIfTerminal -> hIsTerminalDevice h

7983 ColorLog b -> return b

8084 lock <- newMVar ()

8185 let logger i@Item{..} = do

82− when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $

86+ bracket_ (takeMVar lock) (putMVar lock ()) $

8387 T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i

84− return $ Scribe logger (hFlush h)

88+ return $ Scribe logger (hFlush h) permitF

8589

8690

8791-------------------------------------------------------------------------------

@@ -90,11 +94,11 @@ mkHandleScribeWithFormatter itemFormatter cs h sev verb = do

9094-- 'AppendMode' and will close the file handle on

9195-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle

9296-- to 'LineBuffering' mode.

93−mkFileScribe :: FilePath -> Severity -> Verbosity -> IO Scribe

94−mkFileScribe f sev verb = do

97+mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe

98+mkFileScribe f permitF verb = do

9599 h <- openFile f AppendMode

96− Scribe logger finalizer <- mkHandleScribe (ColorLog False) h sev verb

97− return (Scribe logger (finalizer `finally` hClose h))

100+ Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb

101+ return (Scribe logger (finalizer `finally` hClose h) permit)

98102

99103

100104-------------------------------------------------------------------------------

@@ -169,8 +173,8 @@ colorBySeverity withColor severity msg = case severity of

169173-- stdout. This is a decent example of how to build a LogEnv and is

170174-- best for scripts that just need a quick, reasonable set up to log

171175-- to stdout.

172−ioLogEnv :: Severity -> Verbosity -> IO LogEnv

173−ioLogEnv sev verb = do

176+ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv

177+ioLogEnv permit verb = do

174178 le <- initLogEnv "io" "io"

175− lh <- mkHandleScribe ColorIfTerminal stdout sev verb

179+ lh <- mkHandleScribe ColorIfTerminal stdout permit verb

176180 registerScribe "stdout" lh defaultScribeSettings le

katip/test/Katip/Tests.hs+3−2

@@ -141,6 +141,7 @@ loggingTests = testGroup "logging"

141141 let scribe = Scribe

142142 { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))

143143 , scribeFinalizer = return ()

144+ , scribePermitItem = permitItem DebugS

144145 }

145146 le1 <- initLogEnv "tests" "test"

146147 le2 <- registerScribe "recorder" scribe defaultScribeSettings le1

@@ -154,7 +155,7 @@ trivialScribe :: IO (Scribe, TVar Bool)

154155trivialScribe = do

155156 finalizerCalled <- newTVarIO False

156157 let finalizer = atomically (writeTVar finalizerCalled True)

157− return (Scribe (const (return ())) finalizer, finalizerCalled)

158+ return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled)

158159

159160

160161-------------------------------------------------------------------------------

@@ -164,7 +165,7 @@ brokenScribe scribeNum = do

164165 let finalizer = do

165166 atomically (writeTVar finalizerCalled True)

166167 throw (ScribeBroken scribeNum)

167− return (Scribe (const (return ())) finalizer, finalizerCalled)

168+ return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled)

168169

169170

170171-------------------------------------------------------------------------------

katip/test/Katip/Tests/Scribes/Handle.hs+2−2

@@ -92,7 +92,7 @@ setup :: IO (FilePath, Handle, IO (), LogEnv)

9292setup = do

9393 tempDir <- getTemporaryDirectory

9494 (fp, h) <- openTempFile tempDir "katip.log"

95− s <- mkHandleScribe (ColorLog False) h DebugS V3

95+ s <- mkHandleScribe (ColorLog False) h (permitItem DebugS) V3

9696 le <- initLogEnv "katip-test" "test"

9797 le' <- registerScribe "handle" s defaultScribeSettings le

9898 return (fp, h, void (closeScribes le'), le')

@@ -111,7 +111,7 @@ setupFile = do

111111 tempDir <- getTemporaryDirectory

112112 (fp, h) <- openTempFile tempDir "katip.log"

113113 hClose h

114− s <- mkFileScribe fp DebugS V3

114+ s <- mkFileScribe fp (permitItem DebugS) V3

115115 le <- initLogEnv "katip-test" "test"

116116 le' <- registerScribe "handle" s defaultScribeSettings le

117117 return (fp, void (closeScribes le'), le')

stack.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: lts-11.14

1+resolver: lts-12.22

22packages:

33 - katip

44 - katip-elasticsearch