Added idle time notification to message handlers, automatic log rotation

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 :: Int -> IRC ()
-listenerLoop = do
+listenerLoop idleFor = do
   status <- get
   bot@Bot { .. } <- ask
   let nick  = botNick botConfig
 
   nStatus <- liftIO $ do
-    when (status == Kicked) $
+    if idleFor >= (oneSec * botTimeout botConfig)
-      threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
+      then return Disconnected
+    else do
+      when (status == Kicked) $
+        threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
 
-    mLine <- map (map initEx) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket
+      mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket
-    case mLine of
+      case mLine of
-      Nothing -> return Disconnected
+        Nothing -> dispatchHandlers bot IdleMsg >> return Idle
-      Just line -> do
+        Just line -> do
-        now <- getCurrentTime
+          now <- getCurrentTime
-        debug $ "< " ++ line
+          debug $ "< " ++ line
 
-        let message = msgFromLine botConfig now line
+          let message = msgFromLine botConfig now line
-        nStatus <- case message of
+          nStatus <- case message of
-          JoinMsg { .. } | userNick user == nick -> debug "Joined"          >> return Joined
+            JoinMsg { .. } | userNick user == nick -> debug "Joined"          >> return Joined
-          KickMsg { .. } | kickedNick == nick    -> debug "Kicked"          >> return Kicked
+            KickMsg { .. } | kickedNick == nick    -> debug "Kicked"          >> return Kicked
-          ModeMsg { user = Self, .. }            -> sendCommand bot JoinCmd >> return status
+            ModeMsg { user = Self, .. }            -> sendCommand bot JoinCmd >> return Connected
-          _                                      -> return status
+            _                                      -> return Connected
 
-        forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do
+          dispatchHandlers bot message
-          let mMsgHandler = getMsgHandler msgHandlerName
+          return nStatus
-          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
 
   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)

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
+  botConfig <- ask
-  logFileHandle <- liftIO $ do
+  (logFileHandle, curDay) <- liftIO $ do
-    logFileDir <- C.require config "messagelogger.logdir"
+    logFilePath   <- getLogFilePath botConfig
-    createDirectoryIfMissing True logFileDir
+    logFileHandle <- openLogFile logFilePath
-    let logFilePath = logFileDir </> unpack botNick <.> "log"
+    time <- getCurrentTime
-    logFileHandle <- openFile logFilePath AppendMode
+    return (logFileHandle, utctDay time)
-    hSetBuffering logFileHandle LineBuffering
+  put $ toDyn (logFileHandle, curDay)
-    return logFileHandle
-  put $ toDyn logFileHandle
 
 exitMessageLogger :: MonadMsgHandler m => m ()
 exitMessageLogger = do
   mHandle <- map fromDynamic get
   case mHandle of
-    Nothing -> return ()
+    Nothing                            -> return ()
-    Just logFileHandle -> liftIO $ hClose logFileHandle
+    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
+  botConfig <- ask
-  liftIO $ action logFileHandle
+
+  (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

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 }