module LoggerThread
( withLoggerThread
, Logger
) where
import Control.Concurrent.STM.TQueue
import Control.Exception.Safe
import Control.Monad.STM (atomically)
import Data.Text
import Protolude hiding (bracket)
import System.Log.FastLogger
type Logger = Text -> IO ()
toLog :: TQueue Text -> Text -> IO ()
toLog chan s = atomically (writeTQueue chan (s <> singleton '\n'))
withLoggerThread :: (Logger -> IO ()) -> IO ()
withLoggerThread mainThread = do
logChannel <- atomically newTQueue
bracket
(async (loggerThread logChannel))
(\loggerThreadAsync -> do
putText "after the main thread, stop the loggerThread"
threadDelay (1000 * 1000)
cancel loggerThreadAsync
putText "cancelled the loggerThread"
wait loggerThreadAsync)
(\loggerThreadAsync -> do
link loggerThreadAsync
withException
(mainThread (toLog logChannel))
(\e -> do
putText "exception in main thread"
(print :: SomeException -> IO ()) e
putText "main thread exiting"))
loggerThread :: TQueue Text -> IO ()
loggerThread chan =
withFastLogger
(LogStderr 1048576)
(\f ->
withException
(readAndLog chan f)
(\e -> do
putText "exception in logger thread"
(print :: SomeException -> IO ()) e
shutdownLogging chan f))
shutdownLogging :: TQueue Text -> (LogStr -> IO a) -> IO ()
shutdownLogging chan f = do
putText "in shutdownLogging"
maybeValue <- atomically (tryReadTQueue chan)
case maybeValue of
Just t -> (f . (toLogStr :: Text -> LogStr)) t >> shutdownLogging chan f
Nothing -> putText "LoggerThread stopped reading, exiting" >> return ()
readAndLog :: TQueue Text -> (LogStr -> IO a) -> IO ()
readAndLog chan f =
atomically (readTQueue chan) >>= f . (toLogStr :: Text -> LogStr) >>
readAndLog chan f