ff5ca3b · typeable/katip

git.iko.soy/typeable/katip

Update benchmarks, use bounded stm queue

Some changes: * Dropped tests of just pushing to the handle scribe. This is basically a proxy benchmark for how expensive a queue push is since we don't wait for the write. Since criterion gives us no way to do teardown in tests, these benchmarks interfered with others, so I dropped them. * Added a benchmark that sets up a whole log env with a scribe, writes 1000 lines and shuts it down, thus flushing it. This is a more realistic test and sidesteps the fact that criterion doesn't have teardown because it integrates teardown into the measurement. * Found in my tests that TBQueue seems to be performing better in this case than our use of unagi-chan. That, coupled with the more widespread use of STM was enough to convince me to switch. I'm guessing part of it is that unagi-chan is a chan, meaning it has broadcast features that we don't need. * Keeping the old "clearScribes" and "unregisterScribe" functions for compatibility but updated their doc strings. Named the new functions a better-fitting "closeScribe" and "closeScribes". * Use safe-exceptions everywhere and swallow exceptions in a few critical areas. Still could probably do with adding a simple test that closing scribes removes all the backends.

commitff5ca3b7fe1c1ccb70af8feca6c3b127b1f27fa9 authorMichael Xavier <michael@michaelxavier.net> dateMon 3 Apr 2017, 14:52 (10 years ago) parent85eb6dc

8 files changed+136−89

compare with master

unifiedsplit

katip-elasticsearch/test/Main.hs+1−1 katip/bench/Main.hs+48−46 katip/katip.cabal+5−2 katip/src/Katip.hs+7−1 katip/src/Katip/Core.hs+70−34 katip/src/Katip/Monadic.hs+2−2 katip/src/Katip/Scribes/Handle.hs+2−2 katip/test/Katip/Tests/Scribes/Handle.hs+1−1

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

@@ -267,7 +267,7 @@ withTestLogging' modEnv setup f = do

267267 le <- modEnv <$> initLogEnv ns env

268268 le' <- registerScribe "es" scr defaultScribeSettings le

269269 let done' = do

270− _ <- clearScribes le'

270+ _ <- closeScribes le'

271271 bh (refreshIndex ixn)

272272 runKatipT le' (f done')

273273 where

katip/bench/Main.hs+48−46

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

1+{-# LANGUAGE BangPatterns #-}

12{-# LANGUAGE GeneralizedNewtypeDeriving #-}

23{-# LANGUAGE OverloadedStrings #-}

34{-# LANGUAGE StandaloneDeriving #-}

@@ -10,11 +11,13 @@ module Main

1011-------------------------------------------------------------------------------

1112import Control.Concurrent

1213import Control.DeepSeq

14+import Control.Exception.Safe

15+import Control.Monad

1316import Criterion.Main

1417import Data.Aeson

15−import Data.Monoid as M

16−import Data.Time.Calendar

17−import Data.Time.Clock

18+import Data.Monoid as M

19+import System.Directory

20+import System.FilePath

1821import System.IO

1922import System.Posix

2023-------------------------------------------------------------------------------

@@ -30,36 +33,42 @@ main = defaultMain [

3033

3134-------------------------------------------------------------------------------

3235handleScribeBench :: Benchmark

33−handleScribeBench = bgroup "Katip.Scribes.Handle" [

34− env setupHandleEnv $ \ ~((Scribe push, _), tid) ->

35− bench "Bytestring Builder" $

36− whnfIO $ (push (exItem tid))

37− ]

36+handleScribeBench = bgroup "Katip.Scribes.Handle" $

37+ flip map destinations $ \dest -> bgroup (show dest) [

38+ -- This is variably wildly on disk performance but should be a

39+ -- better test since a push test basically just tests how fast your

40+ -- queue structure is.

41+ bench "full env, flush 1000 writes" $

42+ whnfIO $ do

43+ le <- setupHandleLogEnv dest

44+ runKatipT le $ replicateM_ 1000 $ logItem ExPayload "namespace" Nothing InfoS "example"

45+ closeScribes le

46+ ]

47+ where

48+ destinations = [DevNull, TempFile]

49+ --destinations = [DevNull]

50+

51+

52+-------------------------------------------------------------------------------

53+data HandleDest = DevNull | TempFile deriving (Show, Eq)

3854

3955

4056-------------------------------------------------------------------------------

41−setupHandleEnv :: IO ((Scribe, Finaliser), ThreadIdText)

42−setupHandleEnv = do

43− scribe <- setup

44− tid <- myThreadId

45− return (scribe, mkThreadIdText tid)

57+instance NFData LogEnv where

58+ rnf (LogEnv !_ !_ !_ !_ !_ !_) = ()

59+

60+setupHandleLogEnv :: HandleDest -> IO LogEnv

61+setupHandleLogEnv hd = do

62+ (scr, _) <- setupHandleEnv hd

63+ registerScribe "handle" scr defaultScribeSettings =<< initLogEnv "katip-bench" "bench"

4664

4765

4866-------------------------------------------------------------------------------

49−exItem :: ThreadIdText -> Item ExPayload

50−exItem tid = Item {

51− _itemApp = Namespace ["app"]

52− , _itemEnv = Environment "production"

53− , _itemSeverity = WarningS

54− , _itemThread = tid

55− , _itemHost = "example"

56− , _itemProcess = CPid 123

57− , _itemPayload = ExPayload

58− , _itemMessage = "message"

59− , _itemTime = mkUTCTime 2015 3 14 1 5 9

60− , _itemNamespace = Namespace ["foo"]

61− , _itemLoc = Nothing

62− }

67+setupHandleEnv :: HandleDest -> IO (Scribe, ThreadIdText)

68+setupHandleEnv dest = do

69+ scribe <- setup dest

70+ tid <- myThreadId

71+ return (scribe, mkThreadIdText tid)

6372

6473

6574-------------------------------------------------------------------------------

@@ -75,28 +84,21 @@ instance LogItem ExPayload where

7584

7685

7786-------------------------------------------------------------------------------

78−mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime

79−mkUTCTime y mt d h mn s = UTCTime day dt

80− where

81− day = fromGregorian y mt d

82− dt = h * 60 * 60 + mn * 60 + s

83−

84−

85−-------------------------------------------------------------------------------

86−setup :: IO (Scribe, Finaliser)

87−setup = do

88− h <- openFile "/dev/null" WriteMode

89− (s, f) <- mkHandleScribe ColorIfTerminal h DebugS V0

90− return (s, F f)

87+setup :: HandleDest -> IO Scribe

88+setup dest = do

89+ outFile <- case dest of

90+ TempFile -> do

91+ tmp <- getTemporaryDirectory

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

93+ DevNull -> return ("/dev/null")

94+ h <- openFile outFile WriteMode

95+ s <- mkHandleScribe ColorIfTerminal h DebugS V0

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

97+ return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}

9198

9299

93100-------------------------------------------------------------------------------

94101deriving instance NFData ThreadIdText

95102

96−newtype Finaliser = F (IO ())

97−

98103instance NFData Scribe where

99− rnf (Scribe _) = ()

100−

101−instance NFData Finaliser where

102− rnf (F _) = ()

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

katip/katip.cabal+5−2

@@ -60,7 +60,7 @@ library

6060 , bytestring >= 0.9 && < 0.11

6161 , containers >=0.4 && <0.6

6262 , either >= 4 && < 4.5

63− , exceptions >= 0.5 && < 0.9

63+ , safe-exceptions >= 0.1.0.0

6464 , hostname >=1.0 && <1.1

6565 , old-locale >= 1.0 && < 1.1

6666 , string-conv >= 0.1 && < 0.2

@@ -77,7 +77,7 @@ library

7777 , microlens >= 0.2.0.0 && < 0.5

7878 , microlens-th >= 0.1.0.0 && < 0.5

7979 , semigroups

80− , unagi-chan < 0.5.0.0

80+ , stm >= 2.4

8181

8282 hs-source-dirs: src

8383 default-language: Haskell2010

@@ -142,3 +142,6 @@ benchmark bench

142142 , transformers

143143 , deepseq

144144 , async

145+ , filepath

146+ , safe-exceptions

147+ , directory

katip/src/Katip.hs+7−1

@@ -41,7 +41,9 @@ module Katip

4141 , LogEnv (..)

4242 , SimpleLogPayload, sl

4343 , defaultScribeSettings --TODO: lenses and whatnot to avoid breakage

44− , ScribeSettings(..)

44+ , ScribeSettings

45+ , scribeBufferSize

46+ , _scribeBufferSize

4547

4648 -- ** @lens@-compatible Lenses

4749 , itemApp

@@ -69,8 +71,12 @@ module Katip

6971 -- * Initializing Loggers

7072 , initLogEnv

7173 , registerScribe

74+ -- * Dropping scribes temporarily

7275 , unregisterScribe

7376 , clearScribes

77+ -- * Finalizing scribes at shutdown

78+ , closeScribes

79+ , closeScribe

7480

7581 -- * Logging Functions

7682 , LogStr (..)

katip/src/Katip/Core.hs+70−34

@@ -27,10 +27,11 @@ import Control.Applicative as A

2727import Control.AutoUpdate

2828import Control.Concurrent

2929import qualified Control.Concurrent.Async as Async

30−import qualified Control.Concurrent.Chan.Unagi.Bounded as UB

31−import Control.Monad (void)

30+import Control.Concurrent.STM

31+import qualified Control.Concurrent.STM.TBQueue as BQ

32+import Control.Exception.Safe

33+import Control.Monad (unless, void)

3234import Control.Monad.Base

33−import Control.Monad.Catch

3435import Control.Monad.IO.Class

3536import Control.Monad.Trans.Class

3637import Control.Monad.Trans.Control

@@ -38,7 +39,7 @@ import Control.Monad.Trans.Either

3839import Control.Monad.Trans.Except

3940import Control.Monad.Trans.Maybe

4041import Control.Monad.Trans.Reader

41−import Control.Monad.Trans.Resource

42+import Control.Monad.Trans.Resource (ResourceT)

4243import Control.Monad.Trans.State

4344import Control.Monad.Trans.Writer

4445import Data.Aeson (FromJSON (..),

@@ -503,7 +504,7 @@ itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb

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

504505-- messages on shutdown.

505506data Scribe = Scribe {

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

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

507508 , scribeFinalizer :: IO ()

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

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

@@ -513,7 +514,7 @@ data Scribe = Scribe {

513514

514515instance Semigroup Scribe where

515516 (Scribe pushA finA) <> (Scribe pushB finB) =

516− Scribe (\item -> pushA item >> pushB item) (finA >> finB)

517+ Scribe (\item -> pushA item >> pushB item) (finA `finally` finB)

517518

518519

519520instance Monoid Scribe where

@@ -524,7 +525,7 @@ instance Monoid Scribe where

524525-------------------------------------------------------------------------------

525526data ScribeHandle = ScribeHandle {

526527 shScribe :: Scribe

527− , shChan :: UB.InChan WorkerMessage

528+ , shChan :: BQ.TBQueue WorkerMessage

528529 }

529530

530531

@@ -592,41 +593,42 @@ registerScribe

592593 -> LogEnv

593594 -> IO LogEnv

594595registerScribe nm scribe ScribeSettings {..} le = do

595− (inChan, outChan) <- UB.newChan scribeBufferSize

596− worker <- spawnScribeWorker scribe outChan

596+ queue <- atomically (BQ.newTBQueue _scribeBufferSize)

597+ worker <- spawnScribeWorker scribe queue

597598 let fin = do

598− UB.writeChan inChan PoisonPill

599+ atomically (BQ.writeTBQueue queue PoisonPill)

599600 -- wait for our worker to finish final write

600601 void (Async.waitCatch worker)

601− --TODO: safe exceptions

602602 -- wait for scribe to finish final write

603− scribeFinalizer scribe

603+ void (tryAny (scribeFinalizer scribe))

604604

605− let sh = ScribeHandle (scribe { scribeFinalizer = fin }) inChan

605+ let sh = ScribeHandle (scribe { scribeFinalizer = fin }) queue

606606 return (le & logEnvScribes %~ M.insert nm sh)

607607

608608

609609-------------------------------------------------------------------------------

610−--TODO: should do some reasonable exception handling in the scribe, don't want to crash the loop

611−spawnScribeWorker :: Scribe -> UB.OutChan WorkerMessage -> IO (Async.Async ())

612−spawnScribeWorker (Scribe write _) outChan = Async.async go

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

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

613612 where

614613 go = do

615− newCmd <- UB.readChan outChan

614+ newCmd <- atomically (BQ.readTBQueue queue)

616615 case newCmd of

617616 NewItem a -> do

618− write a

617+ -- Swallow any direct exceptions from the

618+ -- scribe. safe-exceptions won't catch async exceptions.

619+ void (tryAny (write a))

619620 go

620621 PoisonPill -> return ()

621622

622623

623624-------------------------------------------------------------------------------

624625data ScribeSettings = ScribeSettings {

625− scribeBufferSize :: Int

626+ _scribeBufferSize :: Int

626627 }

627628

629+makeLenses ''ScribeSettings

630+

628631

629−--TODO: standardize on american or british spelling of finali{z,s}er

630632-- | Reasonable defaults for a scribe. Buffer

631633-- size of 4096.

632634defaultScribeSettings :: ScribeSettings

@@ -634,30 +636,52 @@ defaultScribeSettings = ScribeSettings 4096

634636

635637

636638-------------------------------------------------------------------------------

637−-- | Remove a scribe from the list. All future log calls will no

638−-- longer use this scribe. If there is a finalizer, it will be called

639−-- in a blocking manner.

639+-- | Remove a scribe from the environment. This does *not* finalize

640+-- the scribe. This mainly only makes sense to use with something like

641+-- MonadReader's @local@ function to temporarily disavow a single

642+-- logger for a block of code.

640643unregisterScribe

644+ :: Text

645+ -- ^ Name of the scribe

646+ -> LogEnv

647+ -> LogEnv

648+unregisterScribe nm = logEnvScribes %~ M.delete nm

649+

650+

651+-------------------------------------------------------------------------------

652+-- | Unregister *all* scribes. Note that this is *not* for closing or

653+-- finalizing scribes, use 'closeScribes' for that. This mainly only

654+-- makes sense to use with something like MonadReader's @local@

655+-- function to temporarily disavow any loggers for a block of code.

656+clearScribes

657+ :: LogEnv

658+ -> LogEnv

659+clearScribes = logEnvScribes .~ mempty

660+

661+

662+-------------------------------------------------------------------------------

663+-- | Finalize a scribe. The scribe is removed from the environment,

664+-- its finalizer is called and it can never be written to again.

665+closeScribe

641666 :: Text

642667 -- ^ Name of the scribe

643668 -> LogEnv

644669 -> IO LogEnv

645−unregisterScribe nm le = do

670+closeScribe nm le = do

646671 maybe (return ()) (scribeFinalizer . shScribe) (M.lookup nm (_logEnvScribes le))

647672 return (le & logEnvScribes %~ M.delete nm)

648673

649674

650675-------------------------------------------------------------------------------

651−-- | Unregister *all* scribes. Logs will go off into space from this

652−-- point onward until new scribes are added. Note that you could use

653−-- this with `local` if you're using a Reader based stack to

654−-- temporarily disable log output. See `katipNoLogging` for an

655−-- example.

656−clearScribes

676+-- | Call this at the end of your program. This is a blocking call

677+-- that stop writing to a scribe's queue, waits for the queue to

678+-- empty, finalizes each scribe in the log environment and then

679+-- removes it.

680+closeScribes

657681 :: LogEnv

658682 -> IO LogEnv

659−clearScribes le =

660− foldrM unregisterScribe le (M.keys (_logEnvScribes le))

683+closeScribes le =

684+ foldrM closeScribe le (M.keys (_logEnvScribes le))

661685

662686

663687-------------------------------------------------------------------------------

@@ -756,9 +780,21 @@ logItem a ns loc sev msg = do

756780 <*> _logEnvTimer

757781 <*> pure (_logEnvApp <> ns)

758782 <*> pure loc

759− FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> UB.tryWriteChan shChan (NewItem item)

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

784+ --TODO: if we use tbqueue, write an atomic tryWriteTBQueue

760785

761786

787+-------------------------------------------------------------------------------

788+tryWriteTBQueue

789+ :: TBQueue a

790+ -> a

791+ -> STM Bool

792+ -- ^ Did we write?

793+tryWriteTBQueue q a = do

794+ full <- isFullTBQueue q

795+ unless full (writeTBQueue q a)

796+ return (not full)

797+

762798-------------------------------------------------------------------------------

763799-- | Log with full context, but without any code location.

764800logF

@@ -788,7 +824,7 @@ logException

788824 -> Severity -- ^ Severity

789825 -> m b -- ^ Main action being run

790826 -> m b

791−logException a ns sev action = action `catchAll` \e -> f e >> throwM e

827+logException a ns sev action = action `catchAny` \e -> f e >> throwM e

792828 where

793829 f e = logF a ns sev (msg e)

794830 msg e = ls (T.pack "An exception has occured: ") <> showLS e

katip/src/Katip/Monadic.hs+2−2

@@ -40,8 +40,8 @@ module Katip.Monadic

4040

4141-------------------------------------------------------------------------------

4242import Control.Applicative

43+import Control.Exception.Safe

4344import Control.Monad.Base

44−import Control.Monad.Catch

4545import Control.Monad.Error.Class

4646import Control.Monad.IO.Class

4747import Control.Monad.Reader

@@ -228,7 +228,7 @@ logExceptionM

228228 => m a -- ^ Main action to run

229229 -> Severity -- ^ Severity

230230 -> m a

231−logExceptionM action sev = action `catchAll` \e -> f e >> throwM e

231+logExceptionM action sev = action `catchAny` \e -> f e >> throwM e

232232 where

233233 f e = logFM sev (msg e)

234234 msg e = ls ("An exception has occured: " :: Text) M.<> showLS e

katip/src/Katip/Scribes/Handle.hs+2−2

@@ -57,7 +57,7 @@ data ColorStrategy

5757-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context

5858-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal

5959--

60−-- Returns the newly-created `Scribe` together with a finaliser the user needs to run to perform resource cleanup.

60+-- Returns the newly-created `Scribe`. The finalizer flushes the handle.

6161mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe

6262mkHandleScribe cs h sev verb = do

6363 hSetBuffering h LineBuffering

@@ -68,7 +68,7 @@ mkHandleScribe cs h sev verb = do

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

6969 when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $

7070 T.hPutStrLn h $ toLazyText $ formatItem colorize verb i

71− return $ Scribe logger (return ()) --TODO: maybe do a hFlush?

71+ return $ Scribe logger (hFlush h)

7272

7373

7474-------------------------------------------------------------------------------

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

@@ -81,7 +81,7 @@ setup = do

8181 s <- mkHandleScribe (ColorLog False) h DebugS V3

8282 le <- initLogEnv "katip-test" "test"

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

84− return (fp, h, void (clearScribes le'), le')

84+ return (fp, h, void (closeScribes le'), le')

8585

8686

8787-------------------------------------------------------------------------------