git.iko.soy/typeable/katip
on master help sign in
Break the API by allowing a finaliser to be returned.
dc3e8d9Alfredo Di Napoli
katip/bench/Main.hs+11−5
compare with master
unifiedsplit
@@ -4,6 +4,7 @@
4{-# OPTIONS_GHC -fno-warn-orphans #-}
4{-# OPTIONS_GHC -fno-warn-orphans #-}
5module Main
5module Main
6 ( main
6 ( main
7+ , getFinaliser
7 ) where
8 ) where
8
9
9
10
@@ -31,14 +32,14 @@ main = defaultMain [
31-------------------------------------------------------------------------------
32-------------------------------------------------------------------------------
32handleScribeBench :: Benchmark
33handleScribeBench :: Benchmark
33handleScribeBench = bgroup "Katip.Scribes.Handle" [
34handleScribeBench = bgroup "Katip.Scribes.Handle" [
34− env setupHandleEnv $ \ ~(Scribe push, tid) ->
35+ env setupHandleEnv $ \ ~((Scribe push, _), tid) ->
35 bench "Bytestring Builder" $
36 bench "Bytestring Builder" $
36− whnfIO $ push $ exItem tid
37+ whnfIO $ (push (exItem tid))
37 ]
38 ]
38
39
39
40
40-------------------------------------------------------------------------------
41-------------------------------------------------------------------------------
41−setupHandleEnv :: IO (Scribe, ThreadIdText)
42+setupHandleEnv :: IO ((Scribe, Finaliser), ThreadIdText)
42setupHandleEnv = do
43setupHandleEnv = do
43 scribe <- setup
44 scribe <- setup
44 tid <- myThreadId
45 tid <- myThreadId
@@ -83,15 +84,20 @@ mkUTCTime y mt d h mn s = UTCTime day dt
83
84
84
85
85-------------------------------------------------------------------------------
86-------------------------------------------------------------------------------
86−setup :: IO Scribe
87+setup :: IO (Scribe, Finaliser)
87setup = do
88setup = do
88 h <- openFile "/dev/null" WriteMode
89 h <- openFile "/dev/null" WriteMode
89− mkHandleScribe ColorIfTerminal h DebugS V0
90+ (s, f) <- mkHandleScribe ColorIfTerminal h DebugS V0
91+ return (s, F f)
90
92
91
93
92-------------------------------------------------------------------------------
94-------------------------------------------------------------------------------
93deriving instance NFData ThreadIdText
95deriving instance NFData ThreadIdText
94
96
97+newtype Finaliser = F { getFinaliser :: IO () }
95
98
96instance NFData Scribe where
99instance NFData Scribe where
97 rnf (Scribe _) = ()
100 rnf (Scribe _) = ()
101+
102+instance NFData Finaliser where
103+ rnf (F _) = ()
katip/src/Katip/Scribes/Handle.hs+20−10
@@ -5,6 +5,7 @@ module Katip.Scribes.Handle where
5-------------------------------------------------------------------------------
5-------------------------------------------------------------------------------
6import Control.Applicative as A
6import Control.Applicative as A
7import Control.Monad
7import Control.Monad
8+import Control.Exception (onException)
8import Data.Aeson
9import Data.Aeson
9import qualified Data.HashMap.Strict as HM
10import qualified Data.HashMap.Strict as HM
10import Data.Monoid
11import Data.Monoid
@@ -61,19 +62,27 @@ data WorkerCmd =
61-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
62-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
62-- > [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
63-- > [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
63-- > [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
64-- > [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
65+--
66+-- Returns the newly-created `Scribe` together with a finaliser the user needs to run to perform resource cleanup.
64−mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe
67+mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO (Scribe, IO ())
65mkHandleScribe cs h sev verb = do
68mkHandleScribe cs h sev verb = do
66 (inChan, outChan) <- U.newChan 4096
69 (inChan, outChan) <- U.newChan 4096
67− -- TODO: Come up with a good story for resource cleanup.
68− _ <- async $ workerLoop outChan
70+ worker <- async $ workerLoop outChan
71+ flip onException (stopWorker worker inChan) $ do
69− hSetBuffering h LineBuffering
72+ hSetBuffering h LineBuffering
70− colorize <- case cs of
73+ colorize <- case cs of
71− ColorIfTerminal -> hIsTerminalDevice h
74+ ColorIfTerminal -> hIsTerminalDevice h
72− ColorLog b -> return b
75+ ColorLog b -> return b
73− return $ Scribe $ \i -> when (permitItem sev i) $ do
76+ let scribe = Scribe $ \i ->
74− void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i)))
77+ when (permitItem sev i) $ void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i)))
78+ return (scribe, stopWorker worker inChan)
75
79
76 where
80 where
81+ stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()
82+ stopWorker worker inChan = do
83+ U.writeChan inChan PoisonPill
84+ wait worker
85+
77 workerLoop :: U.OutChan WorkerCmd -> IO ()
86 workerLoop :: U.OutChan WorkerCmd -> IO ()
78 workerLoop outChan = do
87 workerLoop outChan = do
79 newCmd <- U.readChan outChan
88 newCmd <- U.readChan outChan
@@ -114,10 +123,11 @@ formatItem withColor verb Item{..} =
114
123
115-------------------------------------------------------------------------------
124-------------------------------------------------------------------------------
116-- | An implicit environment to enable logging directly ouf of the IO monad.
125-- | An implicit environment to enable logging directly ouf of the IO monad.
126+-- Be careful as this LogEnv won't perform any resource cleanup for you.
117_ioLogEnv :: LogEnv
127_ioLogEnv :: LogEnv
118_ioLogEnv = unsafePerformIO $ do
128_ioLogEnv = unsafePerformIO $ do
119 le <- initLogEnv "io" "io"
129 le <- initLogEnv "io" "io"
120− lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3
130+ (lh, _) <- mkHandleScribe ColorIfTerminal stdout DebugS V3
121 return $ registerScribe "stdout" lh le
131 return $ registerScribe "stdout" lh le
122{-# NOINLINE _ioLogEnv #-}
132{-# NOINLINE _ioLogEnv #-}
123
133
katip/test/Katip/Tests/Scribes/Handle.hs+7−6
@@ -33,8 +33,9 @@ tests :: TestTree
33tests = testGroup "Katip.Scribes.Handle"
33tests = testGroup "Katip.Scribes.Handle"
34 [
34 [
35 withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do
35 withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do
36− (path, h, le) <- setupScribe
36+ (path, h, fin, le) <- setupScribe
37 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"
37 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"
38+ fin
38 hClose h
39 hClose h
39 res <- readFile path
40 res <- readFile path
40 let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
41 let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
@@ -73,18 +74,18 @@ dummyLogItem = DummyLogItem "some note"
73
74
74
75
75-------------------------------------------------------------------------------
76-------------------------------------------------------------------------------
76−setup :: IO (FilePath, Handle, LogEnv)
77+setup :: IO (FilePath, Handle, IO (), LogEnv)
77setup = do
78setup = do
78 tempDir <- getTemporaryDirectory
79 tempDir <- getTemporaryDirectory
79 (fp, h) <- openTempFile tempDir "katip.log"
80 (fp, h) <- openTempFile tempDir "katip.log"
80− s <- mkHandleScribe (ColorLog False) h DebugS V3
81+ (s, finaliser) <- mkHandleScribe (ColorLog False) h DebugS V3
81 le <- initLogEnv "katip-test" "test"
82 le <- initLogEnv "katip-test" "test"
82− return (fp, h, registerScribe "handle" s le)
83+ return (fp, h, finaliser, registerScribe "handle" s le)
83
84
84
85
85-------------------------------------------------------------------------------
86-------------------------------------------------------------------------------
86−teardown :: (FilePath, Handle, LogEnv) -> IO ()
87+teardown :: (FilePath, Handle, IO (), LogEnv) -> IO ()
87−teardown (_, h, _) = do
88+teardown (_, h, _, _) = do
88 chk <- hIsOpen h
89 chk <- hIsOpen h
89 when chk $ hClose h
90 when chk $ hClose h
90
91