{-# LANGUAGE RecordWildCards #-}
module Wrecker.Logger where
import Control.Concurrent
import qualified Control.Concurrent.Chan.Unagi.Bounded as U
import Data.Foldable (traverse_)
import Data.Function
import System.IO
import System.Timeout
data LogLevel
= LevelDebug
| LevelInfo
| LevelWarn
| LevelError
deriving (Show, Eq, Ord, Read)
data Logger = Logger
{ thread :: ThreadId
, inChan :: U.InChan (Maybe String)
, wait :: IO ()
, currentLevel :: LogLevel
}
newLogger ::
Handle
-> Int
-> LogLevel
-> IO Logger
newLogger handle maxSize currentLevel = do
(inChan, outChan) <- U.newChan maxSize
lock <- newEmptyMVar
thread <- readLoop handle outChan lock
let wait = takeMVar lock
return Logger {..}
newStdErrLogger :: Int -> LogLevel -> IO Logger
newStdErrLogger = newLogger stderr
readLoop :: Handle -> U.OutChan (Maybe String) -> MVar () -> IO ThreadId
readLoop handle chan lock =
forkIO $ do
fix $ \next
-> do
U.readChan chan >>=
traverse_
(\msg -> do
hPutStrLn handle msg
next)
putMVar lock ()
writeLogger :: Logger -> LogLevel -> String -> IO Bool
writeLogger Logger {..} messageLevel msg =
if (currentLevel <= messageLevel)
then U.tryWriteChan inChan $ Just msg
else return False
shutdownLogger :: Int -> Logger -> IO ()
shutdownLogger waitTime logger@(Logger {..}) = do
U.writeChan inChan Nothing
mtimedOut <- timeout waitTime wait
case mtimedOut of
Nothing -> forceShutdownLogger logger
Just () -> return ()
forceShutdownLogger :: Logger -> IO ()
forceShutdownLogger Logger {..} = killThread thread
logDebug :: Logger -> String -> IO Bool
logDebug logger = writeLogger logger LevelDebug
logInfo :: Logger -> String -> IO Bool
logInfo logger = writeLogger logger LevelInfo
logWarn :: Logger -> String -> IO Bool
logWarn logger = writeLogger logger LevelWarn
logError :: Logger -> String -> IO Bool
logError logger = writeLogger logger LevelError