git.iko.soy/typeable/katip
on master help sign in
Fix: autoflushing
143ee56Aleksey Uimanov
katip/src/Katip/Scribes/RotatingHandler.hs+29−19
compare with master
unifiedsplit
@@ -3,6 +3,7 @@ module Katip.Scribes.RotatingHandler where
3import Control.Applicative
3import Control.Applicative
4import Control.Concurrent.Async
4import Control.Concurrent.Async
5import Control.Concurrent.STM
5import Control.Concurrent.STM
6+import Control.Debounce
6import Control.DeepSeq
7import Control.DeepSeq
7import Control.Exception
8import Control.Exception
8import Control.Monad
9import Control.Monad
@@ -29,7 +30,7 @@ data FileOwnerSettings = FileOwnerSettings
29
30
30defaultFileOwnerSettings :: FileOwnerSettings
31defaultFileOwnerSettings :: FileOwnerSettings
31defaultFileOwnerSettings = FileOwnerSettings
32defaultFileOwnerSettings = FileOwnerSettings
32− { fosDebounceFreq = 200000 -- every 200ms
33+ { fosDebounceFreq = Just 200000 -- every 200ms
33 , fosDataQueueLen = 1000
34 , fosDataQueueLen = 1000
34 , fosControlQueueLen = 100
35 , fosControlQueueLen = 100
35 }
36 }
@@ -45,7 +46,8 @@ newFileOwner fp s = do
45 dqueue <- newTBQueueIO $ fosDataQueueLen s
46 dqueue <- newTBQueueIO $ fosDataQueueLen s
46 cqueue <- newTBQueueIO $ fosControlQueueLen s
47 cqueue <- newTBQueueIO $ fosControlQueueLen s
47 let
48 let
49+ newResource = do
48− newResource = openBinaryFile fp AppendMode
50+ openBinaryFile fp AppendMode
49 ack = newResource >>= newIORef
51 ack = newResource >>= newIORef
50 release ref = do
52 release ref = do
51 h <- readIORef ref
53 h <- readIORef ref
@@ -61,24 +63,32 @@ newFileOwner fp s = do
61 readMsg
63 readMsg
62 = (Left <$> readTBQueue cqueue)
64 = (Left <$> readTBQueue cqueue)
63 <|> (Right <$> readAllData)
65 <|> (Right <$> readAllData)
66+ debounce action = case fosDebounceFreq s of
67+ Nothing -> do
68+ return action
69+ Just freq -> mkDebounce $ defaultDebounceSettings
70+ { debounceAction = action
71+ , debounceFreq = freq }
72+ flush <- debounce $ readIORef ref >>= hFlush
73+ let
64− atomically readMsg >>= \case
74+ recur = atomically readMsg >>= \case
65− Right bs -> do
75+ Right bs -> do
66− h <- readIORef ref
67− BL.hPutStr h $ mconcat bs
68− -- flush ref
69− go ref
70− Left c -> case c of
71− CloseMsg -> return ()
72− FlushMsg -> do
73 h <- readIORef ref
76 h <- readIORef ref
74− hFlush h
77+ BL.hPutStr h $ mconcat bs
75− go ref
78+ flush
79+ recur
80+ Left c -> case c of
81+ CloseMsg -> return () -- release will close the handler
82+ FlushMsg -> do
83+ readIORef ref >>= hFlush
84+ recur
76− ReopenMsg -> do
85+ ReopenMsg -> do
77− newH <- newResource
86+ newH <- newResource
78− oldH <- atomicModifyIORef' ref (\oldH -> (newH, oldH))
87+ oldH <- atomicModifyIORef' ref (\oldH -> (newH, oldH))
79− hFlush oldH
88+ hFlush oldH
80− hClose oldH
89+ hClose oldH
81− go ref
90+ recur
91+ recur
82 worker :: IO ()
92 worker :: IO ()
83 worker = bracket ack release go
93 worker = bracket ack release go
84 asyncRet <- async worker
94 asyncRet <- async worker