111 lines
3.9 KiB
Haskell
111 lines
3.9 KiB
Haskell
{-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-}
|
|
|
|
module Network.IRC.Handlers.MessageLogger (getMsgHandler) where
|
|
|
|
import qualified Data.Configurator as C
|
|
import qualified Data.Text.Format as TF
|
|
import qualified Data.Text.Format.Params as TF
|
|
|
|
import ClassyPrelude hiding (try, (</>), (<.>), FilePath)
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Data.Dynamic
|
|
import Data.Time (diffDays)
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
|
|
|
|
import Network.IRC.Types
|
|
|
|
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler
|
|
getMsgHandler "messagelogger" = Just $ newMsgHandler { msgHandlerInit = initMessageLogger
|
|
, msgHandlerRun = messageLogger
|
|
, msgHandlerExit = exitMessageLogger }
|
|
getMsgHandler _ = Nothing
|
|
|
|
getLogFilePath :: BotConfig -> IO FilePath
|
|
getLogFilePath BotConfig { .. } = do
|
|
logFileDir <- C.require config "messagelogger.logdir"
|
|
createDirectoryIfMissing True logFileDir
|
|
return $ logFileDir </> unpack botNick <.> "log"
|
|
|
|
openLogFile :: FilePath -> IO Handle
|
|
openLogFile logFilePath = do
|
|
logFileHandle <- openFile logFilePath AppendMode
|
|
hSetBuffering logFileHandle LineBuffering
|
|
return logFileHandle
|
|
|
|
initMessageLogger :: MonadMsgHandler m => m ()
|
|
initMessageLogger = do
|
|
botConfig <- ask
|
|
(logFileHandle, curDay) <- liftIO $ do
|
|
logFilePath <- getLogFilePath botConfig
|
|
logFileHandle <- openLogFile logFilePath
|
|
time <- getModificationTime logFilePath
|
|
return (logFileHandle, utctDay time)
|
|
put $ toDyn (logFileHandle, curDay)
|
|
|
|
exitMessageLogger :: MonadMsgHandler m => m ()
|
|
exitMessageLogger = do
|
|
mHandle <- map fromDynamic get
|
|
case mHandle of
|
|
Nothing -> return ()
|
|
Just (logFileHandle, _ :: UTCTime) -> liftIO $ hClose logFileHandle
|
|
|
|
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> m (Maybe Command)
|
|
withLogFile action = do
|
|
botConfig <- ask
|
|
|
|
(logFileHandle, prevDay) <- map (`fromDyn` error "No log file set") get
|
|
|
|
(logFileHandle', curDay) <- liftIO $ do
|
|
curDay <- map utctDay getCurrentTime
|
|
let diff = diffDays curDay prevDay
|
|
logFileHandle'' <- if diff >= 1
|
|
then do
|
|
hClose logFileHandle
|
|
logFilePath <- getLogFilePath botConfig
|
|
copyFile logFilePath (logFilePath <.> show prevDay)
|
|
removeFile logFilePath
|
|
openLogFile logFilePath
|
|
else return logFileHandle
|
|
|
|
action logFileHandle''
|
|
return (logFileHandle'', curDay)
|
|
|
|
put $ toDyn (logFileHandle', curDay)
|
|
return Nothing
|
|
|
|
fmtTime :: UTCTime -> String
|
|
fmtTime = formatTime defaultTimeLocale "%F %T"
|
|
|
|
messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command)
|
|
messageLogger ChannelMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg)
|
|
|
|
messageLogger ActionMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] {}: {} {}\n" $
|
|
TF.buildParams (fmtTime msgTime, userNick user, userNick user, msg)
|
|
|
|
messageLogger KickMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] ** {} KICKED {} :{}\n" $
|
|
TF.buildParams (fmtTime msgTime, userNick user, kickedNick, msg)
|
|
|
|
messageLogger JoinMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] ** {} JOINED\n" $
|
|
TF.buildParams (fmtTime msgTime, userNick user)
|
|
|
|
messageLogger PartMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] ** {} PARTED :{}\n" $
|
|
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
|
|
|
messageLogger QuitMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] ** {} QUIT :{}\n" $
|
|
TF.buildParams (fmtTime msgTime, userNick user, msg)
|
|
|
|
messageLogger NickMsg { .. } = withLogFile $ \logFile ->
|
|
TF.hprint logFile "[{}] ** {} CHANGED NICK TO {}\n" $
|
|
TF.buildParams (fmtTime msgTime, userNick user, nick)
|
|
|
|
messageLogger _ = return Nothing
|