@@ -3,22 +3,21 @@
33module Katip.Scribes.Handle where
44
55-------------------------------------------------------------------------------
6−import Control.Applicative as A
6+import Control.Applicative as A
7+import Control.Concurrent
8+import Control.Exception (bracket_)
79import Control.Monad
8−import Control.Exception (onException)
910import Data.Aeson
10−import qualified Data.HashMap.Strict as HM
11+import qualified Data.HashMap.Strict as HM
1112import Data.Monoid
12−import Data.Text (Text)
13+import Data.Text (Text)
1314import Data.Text.Lazy.Builder
14−import Data.Text.Lazy.IO as T
15+import Data.Text.Lazy.IO as T
1516import System.IO
16−import System.IO.Unsafe (unsafePerformIO)
17−import qualified Control.Concurrent.Chan.Unagi.Bounded as U
18−import Control.Concurrent.Async
17+import System.IO.Unsafe (unsafePerformIO)
1918-------------------------------------------------------------------------------
2019import Katip.Core
21−import Katip.Format.Time (formatAsLogTime)
20+import Katip.Format.Time (formatAsLogTime)
2221-------------------------------------------------------------------------------
2322
2423
@@ -49,12 +48,6 @@ data ColorStrategy
4948 | ColorIfTerminal
5049 -- ^ Color if output is a terminal
5150
52−-------------------------------------------------------------------------------
53−--TODO: probably drop this stuff since katip does buffering and this isn't doing concurrent writer workers?
54−data WorkerCmd =
55− HNewItem Builder
56− | HPoisonPill
57−
5851-------------------------------------------------------------------------------
5952-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
6053-- and other information will be flattened out into bracketed
@@ -65,33 +58,18 @@ data WorkerCmd =
6558-- > [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
6659--
6760-- 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
6962mkHandleScribe cs h sev verb = do
70− (inChan, outChan) <- U.newChan 4096
71− worker <- async $ workerLoop outChan
72− flip onException (stopWorker worker inChan) $ do
7363 hSetBuffering h LineBuffering
7464 colorize <- case cs of
7565 ColorIfTerminal -> hIsTerminalDevice h
76− ColorLog b -> return b
77− let scribe = Scribe $ \i ->
78− when (permitItem sev i) $ void (U.tryWriteChan inChan (HNewItem (formatItem colorize verb i)))
79− return (scribe, stopWorker worker inChan)
80−
81− where
82− stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()
83− stopWorker worker inChan = do
84− U.writeChan inChan HPoisonPill
85− void $ waitCatch worker
66+ ColorLog b -> return b
67+ lock <- newMVar ()
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?
8672
87− workerLoop :: U.OutChan WorkerCmd -> IO ()
88− workerLoop outChan = do
89− newCmd <- U.readChan outChan
90− case newCmd of
91− HNewItem b -> do
92− T.hPutStrLn h $ toLazyText b
93− workerLoop outChan
94− HPoisonPill -> return ()
9573
9674-------------------------------------------------------------------------------
9775formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder
@@ -114,7 +92,7 @@ formatItem withColor verb Item{..} =
11492 CriticalS -> red $ renderSeverity s
11593 ErrorS -> red $ renderSeverity s
11694 WarningS -> yellow $ renderSeverity s
117− _ -> renderSeverity s
95+ _ -> renderSeverity s
11896 red = colorize "31"
11997 yellow = colorize "33"
12098 colorize c s
@@ -128,8 +106,8 @@ formatItem withColor verb Item{..} =
128106_ioLogEnv :: LogEnv
129107_ioLogEnv = unsafePerformIO $ do
130108 le <- initLogEnv "io" "io"
131− (lh, finalizer) <- mkHandleScribe ColorIfTerminal stdout DebugS V3
132− registerScribe "stdout" lh (defaultScribeSettings finalizer) le
109+ lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3
110+ registerScribe "stdout" lh defaultScribeSettings le
133111{-# NOINLINE _ioLogEnv #-}
134112
135113