Added idle time notification to message handlers, automatic log rotation
This commit is contained in:
parent
d952869ba2
commit
3ef1e2e46e
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
Loading…
Reference in New Issue