hask-irc/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs

100 regels
4.0 KiB
Haskell

{-# LANGUAGE FlexibleContexts #-}
module Network.IRC.Handlers.MessageLogger (messageLoggerMsgHandlerMaker) where
import qualified Data.Text.Format as TF
import qualified Data.Text.Format.Params as TF
import ClassyPrelude hiding ((</>), (<.>), FilePath, log)
import Data.Time (diffDays)
import System.Directory (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
import System.FilePath (FilePath, (</>), (<.>))
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
import qualified Network.IRC.Configuration as CF
import Network.IRC
import Network.IRC.Util
type LoggerState = Maybe (Handle, Day)
messageLoggerMsgHandlerMaker :: MsgHandlerMaker
messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go
where
go botConfig _ = do
state <- io $ newIORef Nothing
initMessageLogger botConfig state
return $ newMsgHandler { onMessage = flip messageLogger state
, onStop = exitMessageLogger state }
getLogFilePath :: BotConfig -> IO FilePath
getLogFilePath BotConfig { .. } = do
let logFileDir = CF.require "messagelogger.logdir" config :: Text
createDirectoryIfMissing True (unpack logFileDir)
return $ (unpack logFileDir) </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
openLogFile :: FilePath -> IO Handle
openLogFile logFilePath = do
logFileHandle <- openFile logFilePath AppendMode
hSetBuffering logFileHandle LineBuffering
return logFileHandle
initMessageLogger :: BotConfig -> IORef LoggerState -> IO ()
initMessageLogger botConfig state = do
logFilePath <- getLogFilePath botConfig
logFileHandle <- openLogFile logFilePath
time <- getModificationTime logFilePath
atomicWriteIORef state $ Just (logFileHandle, utctDay time)
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Message]
withLogFile action state = do
botConfig <- ask
io $ do
Just (logFileHandle, prevDay) <- readIORef state
curDay <- map utctDay getCurrentTime
let diff = diffDays curDay prevDay
logFileHandle' <- if diff >= 1
then do
hClose logFileHandle
logFilePath <- getLogFilePath botConfig
mask_ $ do
copyFile logFilePath (logFilePath <.> show prevDay)
removeFile logFilePath
openLogFile logFilePath
else return logFileHandle
action logFileHandle'
atomicWriteIORef state $ Just (logFileHandle', curDay)
return []
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Message]
messageLogger Message { .. }
| Just (ChannelMsg user msg) <- fromMessage message =
log "<{}> {}" [nick user, msg]
| Just (ActionMsg user msg) <- fromMessage message =
log "<{}> {} {}" [nick user, nick user, msg]
| Just (KickMsg user kickedNick msg) <- fromMessage message =
log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg]
| Just (JoinMsg user) <- fromMessage message =
log "** {} JOINED" [nick user]
| Just (PartMsg user msg) <- fromMessage message =
log "** {} PARTED :{}" [nick user, msg]
| Just (QuitMsg user msg) <- fromMessage message =
log "** {} QUIT :{}" [nick user, msg]
| Just (NickMsg user newNick) <- fromMessage message =
log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
| Just (NamesMsg nicks) <- fromMessage message =
log "** USERS {}" [unwords . map nickToText $ nicks]
| otherwise =
const $ return []
where
nick = nickToText . userNick
log format args = withLogFile $ \logFile ->
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args)
fmtTime = pack . formatTime defaultTimeLocale "%F %T"