@@ -3,22 +3,21 @@
3module Katip.Scribes.Handle where
3module Katip.Scribes.Handle where
5-------------------------------------------------------------------------------
5-------------------------------------------------------------------------------
6−import Control.Applicative as A
6+import Control.Applicative as A
7+import Control.Concurrent
8+import Control.Exception (bracket_)
7import Control.Monad
9import Control.Monad
8−import Control.Exception (onException)
9import Data.Aeson
10import Data.Aeson
10−import qualified Data.HashMap.Strict as HM
11+import qualified Data.HashMap.Strict as HM
11import Data.Monoid
12import Data.Monoid
12−import Data.Text (Text)
13+import Data.Text (Text)
13import Data.Text.Lazy.Builder
14import Data.Text.Lazy.Builder
14−import Data.Text.Lazy.IO as T
15+import Data.Text.Lazy.IO as T
15import System.IO
16import System.IO
16−import System.IO.Unsafe (unsafePerformIO)
17+import System.IO.Unsafe (unsafePerformIO)
17−import qualified Control.Concurrent.Chan.Unagi.Bounded as U
18−import Control.Concurrent.Async
19-------------------------------------------------------------------------------
18-------------------------------------------------------------------------------
20import Katip.Core
19import Katip.Core
21−import Katip.Format.Time (formatAsLogTime)
20+import Katip.Format.Time (formatAsLogTime)
22-------------------------------------------------------------------------------
21-------------------------------------------------------------------------------
@@ -49,12 +48,6 @@ data ColorStrategy
49 | ColorIfTerminal
48 | ColorIfTerminal
50 -- ^ Color if output is a terminal
49 -- ^ Color if output is a terminal
52−-------------------------------------------------------------------------------
53−--TODO: probably drop this stuff since katip does buffering and this isn't doing concurrent writer workers?
58-------------------------------------------------------------------------------
51-------------------------------------------------------------------------------
59-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
52-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
60-- and other information will be flattened out into bracketed
53-- and other information will be flattened out into bracketed
@@ -65,33 +58,18 @@ data WorkerCmd =
65-- > [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
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
67-- Returns the newly-created `Scribe` together with a finaliser the user needs to run to perform resource cleanup.
60-- Returns the newly-created `Scribe` together with a finaliser the user needs to run to perform resource cleanup.
68−mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO (Scribe, IO ())
61+mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe
69mkHandleScribe cs h sev verb = do
62mkHandleScribe cs h sev verb = do
70− (inChan, outChan) <- U.newChan 4096
71− worker <- async $ workerLoop outChan
72− flip onException (stopWorker worker inChan) $ do
73 hSetBuffering h LineBuffering
63 hSetBuffering h LineBuffering
74 colorize <- case cs of
64 colorize <- case cs of
75 ColorIfTerminal -> hIsTerminalDevice h
65 ColorIfTerminal -> hIsTerminalDevice h
76− ColorLog b -> return b
66+ ColorLog b -> return b
77− let scribe = Scribe $ \i ->
67+ lock <- newMVar ()
78− when (permitItem sev i) $ void (U.tryWriteChan inChan (HNewItem (formatItem colorize verb i)))
68+ let logger i@Item{..} = do
79− return (scribe, stopWorker worker inChan)
69+ when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $
80−
70+ T.hPutStrLn h $ toLazyText $ formatItem colorize verb i
81− where
71+ return $ Scribe logger (return ()) --TODO: maybe do a hFlush?
82− stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()
83− stopWorker worker inChan = do
84− U.writeChan inChan HPoisonPill
85− void $ waitCatch worker
87− workerLoop :: U.OutChan WorkerCmd -> IO ()
88− workerLoop outChan = do
89− newCmd <- U.readChan outChan
92− T.hPutStrLn h $ toLazyText b
94− HPoisonPill -> return ()
96-------------------------------------------------------------------------------
74-------------------------------------------------------------------------------
97formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder
75formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder
@@ -114,7 +92,7 @@ formatItem withColor verb Item{..} =
114 CriticalS -> red $ renderSeverity s
92 CriticalS -> red $ renderSeverity s
115 ErrorS -> red $ renderSeverity s
93 ErrorS -> red $ renderSeverity s
116 WarningS -> yellow $ renderSeverity s
94 WarningS -> yellow $ renderSeverity s
117− _ -> renderSeverity s
95+ _ -> renderSeverity s
118 red = colorize "31"
96 red = colorize "31"
119 yellow = colorize "33"
97 yellow = colorize "33"
120 colorize c s
98 colorize c s
@@ -128,8 +106,8 @@ formatItem withColor verb Item{..} =
128_ioLogEnv :: LogEnv
106_ioLogEnv :: LogEnv
129_ioLogEnv = unsafePerformIO $ do
107_ioLogEnv = unsafePerformIO $ do
130 le <- initLogEnv "io" "io"
108 le <- initLogEnv "io" "io"
131− (lh, finalizer) <- mkHandleScribe ColorIfTerminal stdout DebugS V3
109+ lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3
132− registerScribe "stdout" lh (defaultScribeSettings finalizer) le
110+ registerScribe "stdout" lh defaultScribeSettings le
133{-# NOINLINE _ioLogEnv #-}
111{-# NOINLINE _ioLogEnv #-}