Logger.hs

{-# LANGUAGE RecordWildCards #-}
module Wrecker.Logger where
import qualified Control.Concurrent.Chan.Unagi.Bounded as U
import System.IO
import System.Timeout
import Data.Foldable (traverse_)
import Control.Concurrent.MVar
import Control.Concurrent
import Data.Function

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 
    -- Block on the next elemen
    -- If it "Just" print it and loop
    -- Otherwise we are not with the loop
    U.readChan chan >>= traverse_ (\msg -> do
        hPutStrLn handle msg
        next
      )

  putMVar lock ()

-- True if the write was successful or False otherwise
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