Added idle time notification to message handlers, automatic log rotation

master
Abhinav Sarkar 2014-05-11 21:44:55 +05:30
parent d952869ba2
commit 3ef1e2e46e
3 changed files with 88 additions and 50 deletions

View File

@ -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)

View File

@ -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

View File

@ -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 }