ff5ca3b · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Update benchmarks, use bounded stm queue

ff5ca3bMichael Xavier10 years ago

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

compare with master

unifiedsplit

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

267 le <- modEnv <$> initLogEnv ns env

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

269 let done' = do

270− _ <- clearScribes le'

270+ _ <- closeScribes le'

271 bh (refreshIndex ixn)

272 runKatipT le' (f done')

273 where

katip/bench/Main.hs+48−46

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

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE StandaloneDeriving #-}

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

10-------------------------------------------------------------------------------

11-------------------------------------------------------------------------------

11import Control.Concurrent

12import Control.Concurrent

12import Control.DeepSeq

13import Control.DeepSeq

14+import Control.Exception.Safe

15+import Control.Monad

13import Criterion.Main

16import Criterion.Main

14import Data.Aeson

17import Data.Aeson

15−import Data.Monoid as M

18+import Data.Monoid as M

16−import Data.Time.Calendar

19+import System.Directory

17−import Data.Time.Clock

20+import System.FilePath

18import System.IO

21import System.IO

19import System.Posix

22import System.Posix

20-------------------------------------------------------------------------------

23-------------------------------------------------------------------------------

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

31-------------------------------------------------------------------------------

34-------------------------------------------------------------------------------

32handleScribeBench :: Benchmark

35handleScribeBench :: Benchmark

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

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

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

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

35− bench "Bytestring Builder" $

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" $

36− whnfIO $ (push (exItem tid))

42+ whnfIO $ do

37− ]

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)

40-------------------------------------------------------------------------------

56-------------------------------------------------------------------------------

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

57+instance NFData LogEnv where

42−setupHandleEnv = do

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

43− scribe <- setup

59+

44− tid <- myThreadId

60+setupHandleLogEnv :: HandleDest -> IO LogEnv

45− return (scribe, mkThreadIdText tid)

61+setupHandleLogEnv hd = do

62+ (scr, _) <- setupHandleEnv hd

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

48-------------------------------------------------------------------------------

66-------------------------------------------------------------------------------

49−exItem :: ThreadIdText -> Item ExPayload

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

50−exItem tid = Item {

68+setupHandleEnv dest = do

51− _itemApp = Namespace ["app"]

69+ scribe <- setup dest

52− , _itemEnv = Environment "production"

70+ tid <- myThreadId

53− , _itemSeverity = WarningS

71+ return (scribe, mkThreadIdText tid)

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− }

65-------------------------------------------------------------------------------

74-------------------------------------------------------------------------------

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

77-------------------------------------------------------------------------------

86-------------------------------------------------------------------------------

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

87+setup :: HandleDest -> IO Scribe

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+setup dest = do

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

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

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

95+ s <- mkHandleScribe ColorIfTerminal h DebugS V0

90− return (s, F f)

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

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

93-------------------------------------------------------------------------------

100-------------------------------------------------------------------------------

94deriving instance NFData ThreadIdText

101deriving instance NFData ThreadIdText

102

96−newtype Finaliser = F (IO ())

97−

98instance NFData Scribe where

103instance NFData Scribe where

99− rnf (Scribe _) = ()

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

100−

101−instance NFData Finaliser where

102− rnf (F _) = ()

katip/katip.cabal+5−2

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

60 , bytestring >= 0.9 && < 0.11

61 , containers >=0.4 && <0.6

62 , either >= 4 && < 4.5

63− , exceptions >= 0.5 && < 0.9

63+ , safe-exceptions >= 0.1.0.0

64 , hostname >=1.0 && <1.1

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

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

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

77 , microlens >= 0.2.0.0 && < 0.5

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

79 , semigroups

80− , unagi-chan < 0.5.0.0

80+ , stm >= 2.4

82 hs-source-dirs: src

83 default-language: Haskell2010

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

142 , transformers

143 , deepseq

144 , async

145+ , filepath

146+ , safe-exceptions

147+ , directory

katip/src/Katip.hs+7−1

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

41 , LogEnv (..)

42 , SimpleLogPayload, sl

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

44− , ScribeSettings(..)

44+ , ScribeSettings

45+ , scribeBufferSize

46+ , _scribeBufferSize

46 -- ** @lens@-compatible Lenses

48 -- ** @lens@-compatible Lenses

47 , itemApp

49 , itemApp

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

69 -- * Initializing Loggers

71 -- * Initializing Loggers

70 , initLogEnv

72 , initLogEnv

71 , registerScribe

73 , registerScribe

74+ -- * Dropping scribes temporarily

72 , unregisterScribe

75 , unregisterScribe

73 , clearScribes

76 , clearScribes

77+ -- * Finalizing scribes at shutdown

78+ , closeScribes

79+ , closeScribe

75 -- * Logging Functions

81 -- * Logging Functions

76 , LogStr (..)

82 , LogStr (..)

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

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

27import Control.AutoUpdate

28import Control.Concurrent

29import qualified Control.Concurrent.Async as Async

30+import Control.Concurrent.STM

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

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

32+import Control.Exception.Safe

31−import Control.Monad (void)

33+import Control.Monad (unless, void)

32import Control.Monad.Base

34import Control.Monad.Base

33−import Control.Monad.Catch

34import Control.Monad.IO.Class

35import Control.Monad.IO.Class

35import Control.Monad.Trans.Class

36import Control.Monad.Trans.Class

36import Control.Monad.Trans.Control

37import Control.Monad.Trans.Control

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

38import Control.Monad.Trans.Except

39import Control.Monad.Trans.Except

39import Control.Monad.Trans.Maybe

40import Control.Monad.Trans.Maybe

40import Control.Monad.Trans.Reader

41import Control.Monad.Trans.Reader

41−import Control.Monad.Trans.Resource

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

42import Control.Monad.Trans.State

43import Control.Monad.Trans.State

43import Control.Monad.Trans.Writer

44import Control.Monad.Trans.Writer

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

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

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

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

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

504-- messages on shutdown.

505-- messages on shutdown.

505data Scribe = Scribe {

506data Scribe = Scribe {

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

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

507 , scribeFinalizer :: IO ()

508 , scribeFinalizer :: IO ()

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

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

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

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

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

513

514

514instance Semigroup Scribe where

515instance Semigroup Scribe where

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

516 (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)

517

518

519

519instance Monoid Scribe where

520instance Monoid Scribe where

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

524-------------------------------------------------------------------------------

525-------------------------------------------------------------------------------

525data ScribeHandle = ScribeHandle {

526data ScribeHandle = ScribeHandle {

526 shScribe :: Scribe

527 shScribe :: Scribe

527− , shChan :: UB.InChan WorkerMessage

528+ , shChan :: BQ.TBQueue WorkerMessage

528 }

529 }

529

530

531

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

592 -> LogEnv

593 -> LogEnv

593 -> IO LogEnv

594 -> IO LogEnv

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

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

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

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

596− worker <- spawnScribeWorker scribe outChan

597+ worker <- spawnScribeWorker scribe queue

597 let fin = do

598 let fin = do

598− UB.writeChan inChan PoisonPill

599+ atomically (BQ.writeTBQueue queue PoisonPill)

599 -- wait for our worker to finish final write

600 -- wait for our worker to finish final write

600 void (Async.waitCatch worker)

601 void (Async.waitCatch worker)

601− --TODO: safe exceptions

602 -- wait for scribe to finish final write

603− scribeFinalizer scribe

603+ void (tryAny (scribeFinalizer scribe))

604

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

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

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

607

608

609-------------------------------------------------------------------------------

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 ())

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

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

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

613 where

612 where

614 go = do

613 go = do

615− newCmd <- UB.readChan outChan

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

616 case newCmd of

615 case newCmd of

617 NewItem a -> do

616 NewItem a -> do

617+ -- Swallow any direct exceptions from the

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

618− write a

619+ void (tryAny (write a))

619 go

620 go

620 PoisonPill -> return ()

621 PoisonPill -> return ()

621

622

623

623-------------------------------------------------------------------------------

624-------------------------------------------------------------------------------

624data ScribeSettings = ScribeSettings {

625data ScribeSettings = ScribeSettings {

625− scribeBufferSize :: Int

626+ _scribeBufferSize :: Int

626 }

627 }

627

628

629+makeLenses ''ScribeSettings

630+

628

631

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

630-- | Reasonable defaults for a scribe. Buffer

632-- | Reasonable defaults for a scribe. Buffer

631-- size of 4096.

633-- size of 4096.

632defaultScribeSettings :: ScribeSettings

634defaultScribeSettings :: ScribeSettings

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

634

636

635

637

636-------------------------------------------------------------------------------

638-------------------------------------------------------------------------------

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

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

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

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

639−-- in a blocking manner.

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

642+-- logger for a block of code.

640unregisterScribe

643unregisterScribe

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

641 :: Text

666 :: Text

642 -- ^ Name of the scribe

667 -- ^ Name of the scribe

643 -> LogEnv

668 -> LogEnv

644 -> IO LogEnv

669 -> IO LogEnv

645−unregisterScribe nm le = do

670+closeScribe nm le = do

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

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

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

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

648

673

649

674

650-------------------------------------------------------------------------------

675-------------------------------------------------------------------------------

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

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

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

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

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

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

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

679+-- removes it.

655−-- example.

680+closeScribes

656−clearScribes

657 :: LogEnv

681 :: LogEnv

658 -> IO LogEnv

682 -> IO LogEnv

659−clearScribes le =

683+closeScribes le =

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

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

661

685

662

686

663-------------------------------------------------------------------------------

687-------------------------------------------------------------------------------

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

756 <*> _logEnvTimer

780 <*> _logEnvTimer

757 <*> pure (_logEnvApp <> ns)

781 <*> pure (_logEnvApp <> ns)

758 <*> pure loc

782 <*> 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

760

785

761

786

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+

762-------------------------------------------------------------------------------

798-------------------------------------------------------------------------------

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

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

764logF

800logF

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

788 -> Severity -- ^ Severity

824 -> Severity -- ^ Severity

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

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

790 -> m b

826 -> 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

792 where

828 where

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

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

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

830 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

41-------------------------------------------------------------------------------

42import Control.Applicative

43+import Control.Exception.Safe

43import Control.Monad.Base

44import Control.Monad.Base

44−import Control.Monad.Catch

45import Control.Monad.Error.Class

46import Control.Monad.IO.Class

47import Control.Monad.Reader

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

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

229 -> Severity -- ^ Severity

230 -> m a

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

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

232 where

233 f e = logFM sev (msg e)

234 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

57-- > [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

58-- > [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

59--

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.

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

62mkHandleScribe cs h sev verb = do

63 hSetBuffering h LineBuffering

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

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

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

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

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

71+ return $ Scribe logger (hFlush h)

74-------------------------------------------------------------------------------

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

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

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

82 le <- initLogEnv "katip-test" "test"

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

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

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

87-------------------------------------------------------------------------------