git.iko.soy/typeable/katip
on master help sign in
Break the API by allowing a finaliser to be returned.
commitdc3e8d990711168732a059faea43594bea3ae28f authorAlfredo Di Napoli <alfredo.dinapoli@gmail.com> dateMon 20 Feb 2017, 12:54 (10 years ago) parentb05950a
3 files changed+38−21
compare with master
unifiedsplit
katip/bench/Main.hs+11−5 katip/src/Katip/Scribes/Handle.hs+20−10 katip/test/Katip/Tests/Scribes/Handle.hs+7−6
katip/bench/Main.hs+11−5
@@ -4,6 +4,7 @@
44{-# OPTIONS_GHC -fno-warn-orphans #-}
55module Main
66 ( main
7+ , getFinaliser
78 ) where
89
910
@@ -31,14 +32,14 @@ main = defaultMain [
3132-------------------------------------------------------------------------------
3233handleScribeBench :: Benchmark
3334handleScribeBench = bgroup "Katip.Scribes.Handle" [
34− env setupHandleEnv $ \ ~(Scribe push, tid) ->
35+ env setupHandleEnv $ \ ~((Scribe push, _), tid) ->
3536 bench "Bytestring Builder" $
36− whnfIO $ push $ exItem tid
37+ whnfIO $ (push (exItem tid))
3738 ]
3839
3940
4041-------------------------------------------------------------------------------
41−setupHandleEnv :: IO (Scribe, ThreadIdText)
42+setupHandleEnv :: IO ((Scribe, Finaliser), ThreadIdText)
4243setupHandleEnv = do
4344 scribe <- setup
4445 tid <- myThreadId
@@ -83,15 +84,20 @@ mkUTCTime y mt d h mn s = UTCTime day dt
8384
8485
8586-------------------------------------------------------------------------------
86−setup :: IO Scribe
87+setup :: IO (Scribe, Finaliser)
8788setup = do
8889 h <- openFile "/dev/null" WriteMode
89− mkHandleScribe ColorIfTerminal h DebugS V0
90+ (s, f) <- mkHandleScribe ColorIfTerminal h DebugS V0
91+ return (s, F f)
9092
9193
9294-------------------------------------------------------------------------------
9395deriving instance NFData ThreadIdText
9496
97+newtype Finaliser = F { getFinaliser :: IO () }
9598
9699instance NFData Scribe where
97100 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
55-------------------------------------------------------------------------------
66import Control.Applicative as A
77import Control.Monad
8+import Control.Exception (onException)
89import Data.Aeson
910import qualified Data.HashMap.Strict as HM
1011import Data.Monoid
@@ -61,19 +62,27 @@ data WorkerCmd =
6162-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
6263-- > [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
6364-- > [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−mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe
65+--
66+-- Returns the newly-created `Scribe` together with a finaliser the user needs to run to perform resource cleanup.
67+mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO (Scribe, IO ())
6568mkHandleScribe cs h sev verb = do
6669 (inChan, outChan) <- U.newChan 4096
67− -- TODO: Come up with a good story for resource cleanup.
68− _ <- async $ workerLoop outChan
69− hSetBuffering h LineBuffering
70− colorize <- case cs of
71− ColorIfTerminal -> hIsTerminalDevice h
72− ColorLog b -> return b
73− return $ Scribe $ \i -> when (permitItem sev i) $ do
74− void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i)))
70+ worker <- async $ workerLoop outChan
71+ flip onException (stopWorker worker inChan) $ do
72+ hSetBuffering h LineBuffering
73+ colorize <- case cs of
74+ ColorIfTerminal -> hIsTerminalDevice h
75+ ColorLog b -> return b
76+ let scribe = Scribe $ \i ->
77+ when (permitItem sev i) $ void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i)))
78+ return (scribe, stopWorker worker inChan)
7579
7680 where
81+ stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()
82+ stopWorker worker inChan = do
83+ U.writeChan inChan PoisonPill
84+ wait worker
85+
7786 workerLoop :: U.OutChan WorkerCmd -> IO ()
7887 workerLoop outChan = do
7988 newCmd <- U.readChan outChan
@@ -114,10 +123,11 @@ formatItem withColor verb Item{..} =
114123
115124-------------------------------------------------------------------------------
116125-- | 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.
117127_ioLogEnv :: LogEnv
118128_ioLogEnv = unsafePerformIO $ do
119129 le <- initLogEnv "io" "io"
120− lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3
130+ (lh, _) <- mkHandleScribe ColorIfTerminal stdout DebugS V3
121131 return $ registerScribe "stdout" lh le
122132{-# NOINLINE _ioLogEnv #-}
123133
katip/test/Katip/Tests/Scribes/Handle.hs+7−6
@@ -33,8 +33,9 @@ tests :: TestTree
3333tests = testGroup "Katip.Scribes.Handle"
3434 [
3535 withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do
36− (path, h, le) <- setupScribe
36+ (path, h, fin, le) <- setupScribe
3737 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"
38+ fin
3839 hClose h
3940 res <- readFile path
4041 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"
7374
7475
7576-------------------------------------------------------------------------------
76−setup :: IO (FilePath, Handle, LogEnv)
77+setup :: IO (FilePath, Handle, IO (), LogEnv)
7778setup = do
7879 tempDir <- getTemporaryDirectory
7980 (fp, h) <- openTempFile tempDir "katip.log"
80− s <- mkHandleScribe (ColorLog False) h DebugS V3
81+ (s, finaliser) <- mkHandleScribe (ColorLog False) h DebugS V3
8182 le <- initLogEnv "katip-test" "test"
82− return (fp, h, registerScribe "handle" s le)
83+ return (fp, h, finaliser, registerScribe "handle" s le)
8384
8485
8586-------------------------------------------------------------------------------
86−teardown :: (FilePath, Handle, LogEnv) -> IO ()
87−teardown (_, h, _) = do
87+teardown :: (FilePath, Handle, IO (), LogEnv) -> IO ()
88+teardown (_, h, _, _) = do
8889 chk <- hIsOpen h
8990 when chk $ hClose h
9091