SessionLogger.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Example of Usage:
--
-- @
-- runIOLogger "Applicationname" $ do
--   initLogger
--   logNotice "Just a small notice"
--   logWarn "Something more important"
--   logData "filename" "Logfile Info" "data which is logged to file"
-- @

module System.Log.SessionLogger (
  -- * Binds ...
    (>>>=), (>>>>=)
  -- * Data
  , LoggerData(..), ExtraData, Logger(..)
  -- * Initializing functions
  , initLogger, testLogger, runIOLogger, withExtraData
  -- * Logging functions
  , logNotice, logInfo, logWarn, logError, logInternalInfo
  , logData, logGlobInfo
  -- * Internal/debugging functions
  , getLogId, generateLogId
) where

import System.Locale (defaultTimeLocale)
import System.FilePath.Posix ((</>))
import System.IO (hClose, openFile, hPutStrLn, IOMode(..), hFlush)
import System.Directory (createDirectoryIfMissing)
import System.Log.Logger (errorM, getRootLogger, saveGlobalLogger, setLevel
                         , Priority(..), noticeM, setLevel
                         , setHandlers)
import System.Log.Handler.Syslog (openlog,Facility(..))
import System.Random (randomIO)
import Data.Time.LocalTime (getZonedTime)
import Data.Time.Format (formatTime)
import Control.Monad.Trans (MonadIO(..), MonadTrans)
import Control.Monad.Reader (asks, ReaderT, local, runReaderT, MonadReader(..))
import System.IO (hSetEncoding, utf8)

--------------------------------------------------------------------------------
-- Definitions
--------------------------------------------------------------------------------

type Error = String

_LOGPATH_ = "logs/"
-- TODO: main.log with syslog
_MAIN_LOG_ = "logs/main.log"
_INFO_LOG_ = "logs/info.log"

type ExtraData = [String]
data LoggerData = LoggerData { ld_logId :: String
                             , ld_appName :: String
                             , ld_extraDatas :: [ExtraData]
                             , ld_nolog :: Bool
                             }

--type Logger a = ReaderT LoggerData IO a
newtype Logger m a = Logger (ReaderT LoggerData m a)
    deriving (Monad, MonadIO, MonadTrans)

-- TODO: really the right way?
initLogger :: (MonadIO m) => Logger m ()
initLogger = do
  logger <- liftIO $ getRootLogger
  name <- getAppName
  syslog <- liftIO $ openlog name [] LOCAL3 DEBUG
  liftIO $ saveGlobalLogger (setHandlers [syslog] (setLevel DEBUG logger))
  return ()

testLogger :: MonadIO m => Logger m a -> m a
testLogger (Logger readerT) =
    runReaderT readerT (LoggerData "42" "" [] True)

runIOLogger :: MonadIO m => String -> Logger m a -> m a
runIOLogger appname (Logger readerT) = do
  logid <- liftIO $ generateLogId
  runReaderT readerT (LoggerData logid appname [] False)

--------------------------------------------------------------------------------
-- Public Functions
--------------------------------------------------------------------------------

generateLogId :: IO String
generateLogId = do
  rand <- liftIO $ randomIO
  time <- createVerySimpleTS
  let logid = show (abs $ rand::Int)
  return $ time ++ (take 8 $ extend logid '0' 9)

-- Replace this Function. Inline recursion?
extend :: String -> Char -> Int -> String
extend str chr len = if (length str) < len
                     then (extend (str++(show chr)) chr len)
                     else str

getLogId ::(Monad m) => Logger m String
getLogId = Logger (asks ld_logId)

getAppName :: Monad m => Logger m String
getAppName = Logger (asks ld_appName)

getExtraDatas :: Monad m => Logger m [ExtraData]
getExtraDatas = Logger (asks ld_extraDatas)

getNolog :: Monad m => Logger m Bool
getNolog = Logger (asks ld_nolog)

(>>>>=) :: (MonadIO m, MonadReader LoggerData (Logger m), Show a) =>
           String -> IO a -> Logger m a
(>>>>=) str f = do
  ret <- liftIO f
  logid <- getLogId
  writeLog logid $ str ++ show ret
  logExtraDatas str
  return ret

(>>>=) :: (MonadIO m, MonadReader LoggerData (Logger m), Show a) =>
          String -> IO a -> Logger m a
(>>>=) str f = do
  ret <- liftIO f
  logid <- getLogId
  writeLog logid str
  logExtraDatas str
  return ret

logNotice :: (MonadIO m) => String -> Logger m ()
logNotice str = do
  let text = "NOTICE: " ++ str
  logid <- getLogId
  writeLog logid text

logInfo :: (MonadIO m) => String -> Logger m ()
logInfo str = do
  let text = "INFO: " ++ str
  logid <- getLogId
  writeLog logid text
  logGlobInfo str
  logExtraDatas text
  return ()

logWarn :: (MonadIO m) => String -> Logger m ()
logWarn str = do
  let text = "WARN: " ++ str
  logid <- getLogId
  writeLog logid text
  logExtraDatas text
  logMainSafe text

-- Only logs in syslog if initLogger was called first
logError :: (MonadIO m) => String -> Logger m ()
logError str = do
  let text = "ERROR: " ++ str
  logid <- getLogId
  writeLog logid text
  logExtraDatas text
  logMainSafe text
  appName <- getAppName
  liftIO $ errorM appName text
  return ()

logInternalInfo :: (MonadIO m) => String -> Logger m ()
logInternalInfo str = do
  let text = "INTERNAL INFO: " ++ str
  logid <- getLogId
  logMainSafe text

logData :: (MonadIO m) => String -> String -> String -> Logger m ()
logData filename str dat = do
  timestr <- liftIO $ createSimpleTimeString
  let file = timestr ++ "-" ++ filename
      text = "DATA: " ++ str ++ "\tFile: " ++ file
  logid <- getLogId
  writeLog logid text
  logExtraDatas text
  basepath <- liftIO $ createPath
  liftIO $ createDirectoryIfMissing True (basepath </> logid)
  writeLogFileSafe (logid</>file) dat
  return ()

logGlobInfo :: (MonadIO m) => String -> Logger m ()
logGlobInfo text = do
  time <- liftIO $ createTimeString
  logid <- getLogId
  logGlobInfoRaw (time ++ " \t" ++ logid ++ " \t" ++ text) >> return ()
  return ()

--------------------------------------------------------------------------------
-- Internal Functions
--------------------------------------------------------------------------------

-- TODO: Ring the bell if error occurs (email, short message etc.)
logMainSafe :: (MonadIO m) => String -> Logger m ()
logMainSafe text = do
    time <- liftIO $ createTimeString
    logid <- getLogId
    logMain (time ++ " \t" ++ logid ++ " \t" ++ text) >> return ()
    return ()

logMain :: (MonadIO m) => String -> Logger m (Maybe Error)
logMain text = do
  writeFileSafe _MAIN_LOG_ text
  writeLogFileSafe "main.log"  text

logGlobInfoRaw :: (MonadIO m) => String -> Logger m (Maybe Error)
logGlobInfoRaw text = do
  writeFileSafe _INFO_LOG_ text
  writeLogFileSafe "info.log"  text

--withExtraData :: ExtraData -> Logger m -> Logger m
--withExtraData :: (MonadReader LoggerData m) => ExtraData -> m a -> m a
--withExtraData :: (Monad m) => ExtraData -> Logger m a -> Logger m a
--withExtraData ed = local (\(LoggerData id app eds) -> LoggerData id app (ed:eds))
--withExtraData = undefined
-- local :: (MonadReader r m) => (r -> r) -> m a -> m a
-- Logger (ReaderT LoggerData m a)
withExtraData :: Monad m => ExtraData -> Logger m a -> Logger m a
withExtraData ed (Logger rt) = Logger $ local
                               (\(LoggerData id app eds nl) ->
                                 LoggerData id app (ed:eds) nl) rt

logExtraDatas :: (MonadIO m) => String -> Logger m ()
logExtraDatas str = do
  eds <- getExtraDatas
  mapM_ (logExtraData str) eds

logExtraData :: (MonadIO m) => String -> ExtraData -> Logger m ()
logExtraData str ed = do
  let path = foldl (</>) "" ed
  logid <- getLogId
  basepath <- liftIO $ createPath
  liftIO $ createDirectoryIfMissing True (basepath </> path)
  writeLogFileSafe (path </> logid) str
  return ()

writeLog :: (MonadIO m) => String -> String -> Logger m ()
writeLog logid text = do
  time <- liftIO $ createTimeString
  writeLogFileSafe (logid ++ "/" ++ "log")
    (time ++ "\t" ++ text) >> return ()

-- TODO: Ring the bell if error occurs (email, short message etc.)
writeLogFileSafe :: (MonadIO m) => String -> String -> Logger m (Maybe Error)
writeLogFileSafe filename text = writeLogFile filename text
--  catch (writeLogFile filename text)
--  $ \e -> return $ Just
--          $ "Could not open File " ++ filename ++ "\t\t" ++ (show e)

writeLogFile :: (MonadIO m) => String -> String -> Logger m (Maybe Error)
writeLogFile filename text = do
  path <- liftIO createPath
  liftIO $ createDirectoryIfMissing True path
  let logfile = path </> filename
  writeFileSafe logfile text

writeFileSafe :: (MonadIO m) => String -> String -> Logger m (Maybe Error)
writeFileSafe file text =
  getNolog >>= \dummy ->
  if dummy == False then
    liftIO $ catch (do
                       outh <- openFile file AppendMode
                       hSetEncoding outh utf8
                       hPutStrLn outh text
                       hFlush outh
                       hClose outh
                       return Nothing)
    (\e -> return $ Just ("Could not open File " ++ file ++ "\t\t" ++ (show e)))
  else
    return Nothing

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

createPath :: IO String
createPath = do
  zt <- getZonedTime
  let calDirectory = formatTime defaultTimeLocale "%Y-%m-%d" zt
  createDirectoryIfMissing True $ _LOGPATH_ ++ calDirectory
  return $ _LOGPATH_ ++ calDirectory

createTimeString :: IO String
createTimeString = do
  zt <- getZonedTime
  pico <- generatePicoSeconds
  return $ (formatTime defaultTimeLocale "%H:%M:%S." zt) ++ pico

createSimpleTimeString :: IO String
createSimpleTimeString = do
  zt <- getZonedTime
  pico <- generatePicoSeconds
  return $ (formatTime defaultTimeLocale "%H%M%S." zt) ++ pico

createVerySimpleTS :: IO String
createVerySimpleTS =
  getZonedTime >>= \zt ->
  return $ formatTime defaultTimeLocale "%H%M%S" zt

generatePicoSeconds :: IO String
generatePicoSeconds  =
  getZonedTime >>= \zt ->
  return $ take 5 $ formatTime defaultTimeLocale "%q" zt