From 3ef1e2e46e7b1e91d12c069d793a6ecdaa444a58 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sun, 11 May 2014 21:44:55 +0530 Subject: [PATCH] Added idle time notification to message handlers, automatic log rotation --- Network/IRC/Client.hs | 72 ++++++++++++++++++++---------------- Network/IRC/Handlers/Core.hs | 61 ++++++++++++++++++++++-------- Network/IRC/Types.hs | 5 ++- 3 files changed, 88 insertions(+), 50 deletions(-) diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index cf5ff78..9b4291a 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -33,47 +33,55 @@ sendCommand Bot { .. } reply = do TF.hprint socket "{}\r\n" $ TF.Only line TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) -listenerLoop :: IRC () -listenerLoop = do +listenerLoop :: Int -> IRC () +listenerLoop idleFor = do status <- get bot@Bot { .. } <- ask let nick = botNick botConfig nStatus <- liftIO $ do - when (status == Kicked) $ - threadDelay (5 * oneSec) >> sendCommand bot JoinCmd + if idleFor >= (oneSec * botTimeout botConfig) + then return Disconnected + else do + when (status == Kicked) $ + threadDelay (5 * oneSec) >> sendCommand bot JoinCmd - mLine <- map (map initEx) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket - case mLine of - Nothing -> return Disconnected - Just line -> do - now <- getCurrentTime - debug $ "< " ++ line + mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket + case mLine of + Nothing -> dispatchHandlers bot IdleMsg >> return Idle + Just line -> do + now <- getCurrentTime + debug $ "< " ++ line - let message = msgFromLine botConfig now line - nStatus <- case message of - JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined - KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked - ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status - _ -> return status + let message = msgFromLine botConfig now line + nStatus <- case message of + JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined + KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked + ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return Connected + _ -> return Connected - forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do - let mMsgHandler = getMsgHandler msgHandlerName - case mMsgHandler of - Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName - Just msgHandler -> - let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates - in modifyMVar_ msgHandlerState $ \hState -> do - !(mCmd, nhState) <- runMsgHandler msgHandler botConfig hState message - case mCmd of - Nothing -> return () - Just cmd -> sendCommand bot cmd - return nhState - - return nStatus + dispatchHandlers bot message + return nStatus put nStatus - when (nStatus /= Disconnected) listenerLoop + case nStatus of + Idle -> listenerLoop (idleFor + oneSec) + Disconnected -> return () + _ -> listenerLoop 0 + + where + dispatchHandlers bot@Bot { .. } message = forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do + let mMsgHandler = getMsgHandler msgHandlerName + case mMsgHandler of + Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName + Just msgHandler -> + let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates + in modifyMVar_ msgHandlerState $ \hState -> do + !(mCmd, nhState) <- runMsgHandler msgHandler botConfig hState message + case mCmd of + Nothing -> return () + Just cmd -> sendCommand bot cmd + return nhState loadMsgHandlers :: BotConfig -> IO MsgHandlerStates loadMsgHandlers botConfig@BotConfig { .. } = @@ -142,4 +150,4 @@ run botConfig' = withSocketsDo $ do go bot = do sendCommand bot NickCmd sendCommand bot UserCmd - runIRC bot Connected listenerLoop + runIRC bot Connected (listenerLoop 0) diff --git a/Network/IRC/Handlers/Core.hs b/Network/IRC/Handlers/Core.hs index 3d0049d..69bb8f4 100644 --- a/Network/IRC/Handlers/Core.hs +++ b/Network/IRC/Handlers/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-} module Network.IRC.Handlers.Core (getMsgHandler) where @@ -6,13 +6,14 @@ 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, (), (<.>)) +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 +import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..)) import Network.IRC.Types @@ -27,29 +28,57 @@ pingPong :: MonadMsgHandler m => Message -> m (Maybe Command) pingPong Ping { .. } = return . Just $ Pong msg pingPong _ = return 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 <- liftIO $ do - logFileDir <- C.require config "messagelogger.logdir" - createDirectoryIfMissing True logFileDir - let logFilePath = logFileDir unpack botNick <.> "log" - logFileHandle <- openFile logFilePath AppendMode - hSetBuffering logFileHandle LineBuffering - return logFileHandle - put $ toDyn logFileHandle + botConfig <- ask + (logFileHandle, curDay) <- liftIO $ do + logFilePath <- getLogFilePath botConfig + logFileHandle <- openLogFile logFilePath + time <- getCurrentTime + 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 -> liftIO $ hClose logFileHandle + Nothing -> return () + Just (logFileHandle, _ :: UTCTime) -> liftIO $ hClose logFileHandle withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> m (Maybe Command) withLogFile action = do - logFileHandle <- map (`fromDyn` error "No log file set") get - liftIO $ action logFileHandle + 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 diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 151ed66..d528415 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -24,7 +24,8 @@ data User = Self | User { userNick :: !Nick, userServer :: !Text } deriving (Show, Eq) data Message = - ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } + IdleMsg + | ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } | PrivMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text } | Ping { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text } | JoinMsg { msgTime :: !UTCTime, user :: !User, msgLine :: !Text } @@ -71,7 +72,7 @@ data Bot = Bot { botConfig :: !BotConfig , socket :: !Handle , msgHandlerStates :: !MsgHandlerStates } -data BotStatus = Connected | Disconnected | Joined | Kicked | Errored +data BotStatus = Connected | Disconnected | Joined | Kicked | Errored | Idle deriving (Show, Eq) newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }