HLogger-0.0.1.0: HLogger.hs

-- | This is a work in progress for a logging framework that aims to be
--   simple, concurrent and easy-to-use.
--   
--   Use 'startLogger' to acquire a 'HLoggerState', and then use the
--   'HLoggerState' in subsequent logging calls. Use the log functions to log,
--   and don't forget to call 'stopLogger' when you're finished. See the log
--   functions for information about what the different log levels mean.

module HLogger ( startLogger
               , stopLogger
               , logDebug
               , logInfo
               , logNotice
               , logWarning
               , logError
               , logCritical
               , logAlert
               , logEmergency
               , HLoggerState ) where

import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import System.IO (Handle, IOMode (WriteMode), hClose, hFlush, hPutStrLn,
                  openFile)
import System.Locale (defaultTimeLocale)


-- LogLevel indicates the importance of a log entry. The log levels are the
-- same as in the Syslog application. The below list is ordered by priority,
-- Debug being the least significant message.

data LogLevel = Debug     | -- Debug messages
                Info      | -- Purely informational messages
                Notice    | -- Significant messages for normal conditions
                Warning   | -- Warning condition messages
                Error     | -- Error condition messages
                Critical  | -- Critical condition messages
                Alert     | -- Indication that action must be taken
                Emergency   -- Indication that the system is unusable
                deriving (Eq, Ord, Read, Show)


-- | HLoggerState wraps the information HLogger needs to perform logging and
--   to "stop" the logging framework. Applications utilizing HLogger keeps a
--   HLoggerState variable in their states.

data HLoggerState = HLoggerState { channel  :: Chan (Maybe LogMessage)
                                 , handle   :: Handle
                                 , prefix   :: String }


data LogMessage = LogMessage { message :: String, level :: LogLevel }


-- | Call start to get the initial logging state. It takes a String, @prefix@,
-- as its configuration input and creates a file @prefix-YYYYMMDDHHMM.log@ in
-- the current directory. It will use UTC time on system that supports it, and
-- local time otherwise.

startLogger :: String -> IO HLoggerState
startLogger p =
  do c <- newChan
     d <- datetime
     h <- openFile (p ++ "-" ++ d ++ ".log") WriteMode
     forkIO $ logToFile c h
     let s = HLoggerState { channel  = c, prefix = p , handle = h }
     return s
    where
      datetime :: IO String
      datetime = formatTime defaultTimeLocale "%Y%m%d%H%M" <$>
                 getCurrentTime


-- | Stops the logger by closing the log file and exiting the logging thread.

stopLogger :: HLoggerState -> IO ()
stopLogger s =
  do writeChan (channel s) Nothing
     return ()


-- | Logs a debug message. Debug messages are the least significant messages.

logDebug :: HLoggerState -> String -> IO ()
logDebug s m =
  do let m' = toLogMessage m Debug
     writeChan (channel s) (Just m')
     return ()


-- | Logs a purely informational message. Use logNotice instead of the
--   information message is significant.

logInfo :: HLoggerState -> String -> IO ()
logInfo s m =
  do let m' = toLogMessage m Info
     writeChan (channel s) (Just m')
     return ()


-- | Logs a significant purely informational message.
logNotice :: HLoggerState -> String -> IO ()
logNotice s m =
  do let m' = toLogMessage m Notice
     writeChan (channel s) (Just m')
     return ()


-- | Logs a message signaling a warning condition.

logWarning :: HLoggerState -> String -> IO ()
logWarning s m =
  do let m' = toLogMessage m Warning
     writeChan (channel s) (Just m')
     return ()


-- | Logs a message signaling that a non-critical error has occurred.

logError :: HLoggerState -> String -> IO ()
logError s m =
  do let m' = toLogMessage m Error
     writeChan (channel s) (Just m')
     return ()


-- | Logs a message signaling that a critical error has occurred.

logCritical :: HLoggerState -> String -> IO ()
logCritical s m =
  do let m' = toLogMessage m Critical
     writeChan (channel s) (Just m')
     return ()


-- | Logs a message signaling that an action must be taken.

logAlert :: HLoggerState -> String -> IO ()
logAlert s m =
  do let m' = toLogMessage m Alert
     writeChan (channel s) (Just m')
     return ()


-- | Logs a message signaling that the system is unusable.

logEmergency :: HLoggerState -> String -> IO ()
logEmergency s m =
  do let m' = toLogMessage m Emergency
     writeChan (channel s) (Just m')
     return ()


-- Logging loop spawned by the start function.

logToFile :: Chan (Maybe LogMessage) -> Handle -> IO ()
logToFile c h =
  do logMessage <- readChan c
     case logMessage of
       Nothing ->
         do hClose h
       Just m ->
         do let r = show (level m) ++ ": " ++ message m
            hPutStrLn h r
            hFlush h
            logToFile c h


-- Function to wrap a string and a log level into a LogMessage record.

toLogMessage :: String -> LogLevel -> LogMessage
toLogMessage m l = LogMessage { message = m, level = l }