module System.Log.SessionLogger (
(>>>=), (>>>>=)
, LoggerData(..), ExtraData, Logger(..)
, initLogger, testLogger, runIOLogger, withExtraData
, logNotice, logInfo, logWarn, logError, logInternalInfo
, logData, logGlobInfo
, 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)
type Error = String
_LOGPATH_ = "logs/"
_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
}
newtype Logger m a = Logger (ReaderT LoggerData m a)
deriving (Monad, MonadIO, MonadTrans)
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)
generateLogId :: IO String
generateLogId = do
rand <- liftIO $ randomIO
time <- createVerySimpleTS
let logid = show (abs $ rand::Int)
return $ time ++ (take 8 $ extend logid '0' 9)
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
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 ()
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 :: 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 ()
writeLogFileSafe :: (MonadIO m) => String -> String -> Logger m (Maybe Error)
writeLogFileSafe filename text = writeLogFile filename text
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
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