A simple IRC bot written in Haskell
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

MessageLogger.hs 4.0KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899
  1. {-# LANGUAGE FlexibleContexts #-}
  2. module Network.IRC.Handlers.MessageLogger (messageLoggerMsgHandlerMaker) where
  3. import qualified Data.Text.Format as TF
  4. import qualified Data.Text.Format.Params as TF
  5. import ClassyPrelude hiding ((</>), (<.>), FilePath, log)
  6. import Data.Time (diffDays)
  7. import System.Directory (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
  8. import System.FilePath (FilePath, (</>), (<.>))
  9. import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
  10. import qualified Network.IRC.Configuration as CF
  11. import Network.IRC
  12. import Network.IRC.Util
  13. type LoggerState = Maybe (Handle, Day)
  14. messageLoggerMsgHandlerMaker :: MsgHandlerMaker
  15. messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go
  16. where
  17. go botConfig _ = do
  18. state <- io $ newIORef Nothing
  19. initMessageLogger botConfig state
  20. return $ newMsgHandler { onMessage = flip messageLogger state
  21. , onStop = exitMessageLogger state }
  22. getLogFilePath :: BotConfig -> IO FilePath
  23. getLogFilePath BotConfig { .. } = do
  24. let logFileDir = CF.require "messagelogger.logdir" config :: Text
  25. createDirectoryIfMissing True (unpack logFileDir)
  26. return $ unpack logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
  27. openLogFile :: FilePath -> IO Handle
  28. openLogFile logFilePath = do
  29. logFileHandle <- openFile logFilePath AppendMode
  30. hSetBuffering logFileHandle LineBuffering
  31. return logFileHandle
  32. initMessageLogger :: BotConfig -> IORef LoggerState -> IO ()
  33. initMessageLogger botConfig state = do
  34. logFilePath <- getLogFilePath botConfig
  35. logFileHandle <- openLogFile logFilePath
  36. time <- getModificationTime logFilePath
  37. atomicWriteIORef state $ Just (logFileHandle, utctDay time)
  38. exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
  39. exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
  40. withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Message]
  41. withLogFile action state = do
  42. botConfig <- ask
  43. io $ do
  44. Just (logFileHandle, prevDay) <- readIORef state
  45. curDay <- map utctDay getCurrentTime
  46. let diff = diffDays curDay prevDay
  47. logFileHandle' <- if diff >= 1
  48. then do
  49. hClose logFileHandle
  50. logFilePath <- getLogFilePath botConfig
  51. mask_ $ do
  52. copyFile logFilePath (logFilePath <.> show prevDay)
  53. removeFile logFilePath
  54. openLogFile logFilePath
  55. else return logFileHandle
  56. action logFileHandle'
  57. atomicWriteIORef state $ Just (logFileHandle', curDay)
  58. return []
  59. messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Message]
  60. messageLogger Message { .. }
  61. | Just (ChannelMsg user msg) <- fromMessage message =
  62. log "<{}> {}" [nick user, msg]
  63. | Just (ActionMsg user msg) <- fromMessage message =
  64. log "<{}> {} {}" [nick user, nick user, msg]
  65. | Just (KickMsg user kickedNick msg) <- fromMessage message =
  66. log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg]
  67. | Just (JoinMsg user) <- fromMessage message =
  68. log "** {} JOINED" [nick user]
  69. | Just (PartMsg user msg) <- fromMessage message =
  70. log "** {} PARTED :{}" [nick user, msg]
  71. | Just (QuitMsg user msg) <- fromMessage message =
  72. log "** {} QUIT :{}" [nick user, msg]
  73. | Just (NickMsg user newNick) <- fromMessage message =
  74. log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
  75. | Just (NamesMsg nicks) <- fromMessage message =
  76. log "** USERS {}" [unwords . map nickToText $ nicks]
  77. | otherwise =
  78. const $ return []
  79. where
  80. nick = nickToText . userNick
  81. log format args = withLogFile $ \logFile ->
  82. TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime msgTime : args)
  83. fmtTime = pack . formatTime defaultTimeLocale "%F %T"