@@ -3,6 +3,7 @@ module Katip.Scribes.RotatingHandler where
33import Control.Applicative
44import Control.Concurrent.Async
55import Control.Concurrent.STM
6+import Control.Debounce
67import Control.DeepSeq
78import Control.Exception
89import Control.Monad
@@ -29,7 +30,7 @@ data FileOwnerSettings = FileOwnerSettings
2930
3031defaultFileOwnerSettings :: FileOwnerSettings
3132defaultFileOwnerSettings = FileOwnerSettings
32− { fosDebounceFreq = 200000 -- every 200ms
33+ { fosDebounceFreq = Just 200000 -- every 200ms
3334 , fosDataQueueLen = 1000
3435 , fosControlQueueLen = 100
3536 }
@@ -45,7 +46,8 @@ newFileOwner fp s = do
4546 dqueue <- newTBQueueIO $ fosDataQueueLen s
4647 cqueue <- newTBQueueIO $ fosControlQueueLen s
4748 let
48− newResource = openBinaryFile fp AppendMode
49+ newResource = do
50+ openBinaryFile fp AppendMode
4951 ack = newResource >>= newIORef
5052 release ref = do
5153 h <- readIORef ref
@@ -61,24 +63,32 @@ newFileOwner fp s = do
6163 readMsg
6264 = (Left <$> readTBQueue cqueue)
6365 <|> (Right <$> readAllData)
64− atomically readMsg >>= \case
65− 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
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
74+ recur = atomically readMsg >>= \case
75+ Right bs -> do
7376 h <- readIORef ref
74− hFlush h
75− go ref
76− ReopenMsg -> do
77− newH <- newResource
78− oldH <- atomicModifyIORef' ref (\oldH -> (newH, oldH))
79− hFlush oldH
80− hClose oldH
81− go ref
77+ BL.hPutStr h $ mconcat bs
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
85+ ReopenMsg -> do
86+ newH <- newResource
87+ oldH <- atomicModifyIORef' ref (\oldH -> (newH, oldH))
88+ hFlush oldH
89+ hClose oldH
90+ recur
91+ recur
8292 worker :: IO ()
8393 worker = bracket ack release go
8494 asyncRet <- async worker