Added idle time notification to message handlers, automatic log rotation

Network/IRC/Client.hs

@@ -33,19 +33,22 @@ 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
+    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
+      mLine <- map (map initEx) . timeout oneSec . hGetLine $ socket
       case mLine of
-      Nothing -> return Disconnected
+        Nothing -> dispatchHandlers bot IdleMsg >> return Idle
         Just line -> do
           now <- getCurrentTime
           debug $ "< " ++ line
@@ -54,10 +57,20 @@ listenerLoop = do
           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
+            ModeMsg { user = Self, .. }            -> sendCommand bot JoinCmd >> return Connected
+            _                                      -> return Connected
 
-        forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do
+          dispatchHandlers bot message
+          return nStatus
+
+  put nStatus
+  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
@@ -70,11 +83,6 @@ listenerLoop = do
               Just cmd -> sendCommand bot cmd
             return nhState
 
-        return nStatus
-
-  put nStatus
-  when (nStatus /= Disconnected) listenerLoop
-
 loadMsgHandlers :: BotConfig -> IO MsgHandlerStates
 loadMsgHandlers botConfig@BotConfig { .. } =
   flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do
@@ -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
 
-initMessageLogger :: MonadMsgHandler m => m ()
-initMessageLogger = do
-  BotConfig { .. } <- ask
-  logFileHandle <- liftIO $ do
+getLogFilePath :: BotConfig -> IO FilePath
+getLogFilePath BotConfig { .. } = do
   logFileDir <- C.require config "messagelogger.logdir"
   createDirectoryIfMissing True logFileDir
-    let logFilePath = logFileDir </> unpack botNick <.> "log"
+  return $ logFileDir </> unpack botNick <.> "log"
+
+openLogFile :: FilePath -> IO Handle
+openLogFile logFilePath = do
   logFileHandle <- openFile logFilePath AppendMode
   hSetBuffering logFileHandle LineBuffering
   return logFileHandle
-  put $ toDyn logFileHandle
+
+initMessageLogger :: MonadMsgHandler m => m ()
+initMessageLogger = do
+  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
+    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

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 }