gruff-0.4: src/Logger.hs

module Logger where

import Prelude hiding (log)
import Control.Concurrent (forkIO, newChan, readChan, writeChan)
import Control.Monad (when)
import Data.Time (formatTime, getCurrentTime, UTCTime)
import Data.Time.Format (defaultTimeLocale)
import System.FilePath ((</>), (<.>))
import System.IO (openFile, IOMode(WriteMode), hPutStrLn, hClose, hFlush)

data LogLevel = Error | Warn | Info | Debug
  deriving (Read, Show, Eq, Ord, Enum, Bounded)

defLogLevel :: LogLevel
defLogLevel = Info

data Logger = Logger
  { log :: LogLevel -> String -> IO ()
  , close :: IO ()
  }

logger :: FilePath -> IO Logger
logger logDir = do
  date <- getDate
  let logFile = logDir </> filter (':'/=) date <.> "log"
  h <- openFile logFile WriteMode
  c <- newChan
  let log' lvl msg = when (lvl <= defLogLevel) $ do
        d <- getDate
        writeChan c (Just $ d ++ "\t" ++ show lvl ++ "\t" ++ show msg)
      close' = log' Info "closing log" >> writeChan c Nothing
      writer = do
        m <- readChan c
        case m of
          Nothing -> hClose h >> return ()
          Just s -> hPutStrLn h s >> hFlush h >> writer
  _ <- forkIO writer
  log' Info "opening log"
  return Logger{ log = log', close = close' }
  where
    logFormat :: UTCTime -> String
    logFormat = formatTime defaultTimeLocale "%FT%T"
    getDate :: IO String
    getDate = logFormat `fmap` getCurrentTime