@@ -3,21 +3,22 @@
33module Katip.Scribes.Handle where
44
55-------------------------------------------------------------------------------
6−import Control.Applicative as A
7−import Control.Concurrent
8−import Control.Exception (bracket_)
6+import Control.Applicative as A
97import Control.Monad
8+import Control.Exception (onException)
109import Data.Aeson
11−import qualified Data.HashMap.Strict as HM
10+import qualified Data.HashMap.Strict as HM
1211import Data.Monoid
13−import Data.Text (Text)
12+import Data.Text (Text)
1413import Data.Text.Lazy.Builder
15−import Data.Text.Lazy.IO as T
14+import Data.Text.Lazy.IO as T
1615import System.IO
17−import System.IO.Unsafe (unsafePerformIO)
16+import System.IO.Unsafe (unsafePerformIO)
17+import qualified Control.Concurrent.Chan.Unagi.Bounded as U
18+import Control.Concurrent.Async
1819-------------------------------------------------------------------------------
1920import Katip.Core
20−import Katip.Format.Time (formatAsLogTime)
21+import Katip.Format.Time (formatAsLogTime)
2122-------------------------------------------------------------------------------
2223
2324
@@ -48,6 +49,10 @@ data ColorStrategy
4849 | ColorIfTerminal
4950 -- ^ Color if output is a terminal
5051
52+-------------------------------------------------------------------------------
53+data WorkerCmd =
54+ NewItem Builder
55+ | PoisonPill
5156
5257-------------------------------------------------------------------------------
5358-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
@@ -57,17 +62,35 @@ data ColorStrategy
5762-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
5863-- > [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
5964-- > [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
60−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 ())
6168mkHandleScribe cs h sev verb = do
69+ (inChan, outChan) <- U.newChan 4096
70+ worker <- async $ workerLoop outChan
71+ flip onException (stopWorker worker inChan) $ do
6272 hSetBuffering h LineBuffering
6373 colorize <- case cs of
6474 ColorIfTerminal -> hIsTerminalDevice h
6575 ColorLog b -> return b
66− lock <- newMVar ()
67− return $ Scribe $ \ i@Item{..} -> do
68− when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $
69− T.hPutStrLn h $ toLazyText $ formatItem colorize verb i
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)
7079
80+ where
81+ stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()
82+ stopWorker worker inChan = do
83+ U.writeChan inChan PoisonPill
84+ void $ waitCatch worker
85+
86+ workerLoop :: U.OutChan WorkerCmd -> IO ()
87+ workerLoop outChan = do
88+ newCmd <- U.readChan outChan
89+ case newCmd of
90+ NewItem b -> do
91+ T.hPutStrLn h $ toLazyText b
92+ workerLoop outChan
93+ PoisonPill -> return ()
7194
7295-------------------------------------------------------------------------------
7396formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder
@@ -100,10 +123,11 @@ formatItem withColor verb Item{..} =
100123
101124-------------------------------------------------------------------------------
102125-- | 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.
103127_ioLogEnv :: LogEnv
104128_ioLogEnv = unsafePerformIO $ do
105129 le <- initLogEnv "io" "io"
106− lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3
130+ (lh, _) <- mkHandleScribe ColorIfTerminal stdout DebugS V3
107131 return $ registerScribe "stdout" lh le
108132{-# NOINLINE _ioLogEnv #-}
109133