Added reconnected/rejoin support in case of disconnects/kick/kickban

Network/IRC/Client.hs

@@ -2,62 +2,102 @@
 
 module Network.IRC.Client(run) where
 
-import qualified Control.Exception as E
+import Control.Exception
 import Control.Concurrent
 import Control.Monad.Reader
 import Network
+import Prelude hiding (log)
 import System.IO
 import System.Time
+import System.Timeout
 import Text.Printf
 
 import Network.IRC.Handlers
 import Network.IRC.Protocol
 import Network.IRC.Types
 
+data Status = Connected | Disconnected | Joined | Kicked | Errored
+              deriving (Show, Eq)
+
+oneSec = 1000000
+
 io = liftIO
 
+log msg = putStrLn $ "** " ++ msg
+
 sendCommand :: Bot -> Command -> IO ()
 sendCommand Bot{ .. } reply = do
   let line = lineFromCommand botConfig reply
   hPrintf socket "%s\r\n" line >> printf "> %s\n" line
 
-listen :: IRC ()
-listen = forever $ do
+listen :: Status -> IRC Status
+listen status = do
   bot@Bot{ .. } <- ask
+  let nick  = botNick botConfig
 
-  line <- fmap init $ io $ hGetLine socket
-  time <- io getClockTime
+  when (status == Kicked) $
+    io $ threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
 
-  io $ printf "[%s] %s\n" (show time) line
+  mLine <- io . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket
+  case mLine of
+    Nothing -> return Disconnected
+    Just l -> do
+      let line = init l
+      time <- io getClockTime
 
-  io $ forkIO $ case msgFromLine botConfig time line of
-    Ping { .. }                 -> sendCommand bot $ Pong msg
-    ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd
-    msg                         -> forM_ (handlers botConfig) $ \handler -> do
-      cmd <- handleMessage handler botConfig msg
-      case cmd of
-        Nothing  -> return ()
-        Just cmd -> sendCommand bot cmd
+      io $ printf "[%s] %s\n" (show time) line
+
+      let message = msgFromLine botConfig time line
+      nStatus <- io $ case message of
+        JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined
+        KickMsg { .. }                         -> log "Kicked" >> return Kicked
+        _                                      -> do
+          forkIO $ case message of
+            Ping { .. }                 -> sendCommand bot $ Pong msg
+            ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd
+            msg                         -> forM_ (handlers botConfig) $ \handler -> do
+              cmd <- handleMessage handler botConfig msg
+              case cmd of
+                Nothing  -> return ()
+                Just cmd -> sendCommand bot cmd
+          return status
+
+      listen nStatus
 
 connect :: BotConfig -> IO Bot
 connect botConfig@BotConfig{ .. } = do
-  putStrLn "** Connecting ..."
-  handle <- connectTo server (PortNumber (fromIntegral port))
+  log "Connecting ..."
+  handle <- connectToWithRetry
   hSetBuffering handle LineBuffering
   hSetBuffering stdout LineBuffering
-  putStrLn "** Connected"
+  log "Connected"
   return $ Bot botConfig handle
+  where
+    connectToWithRetry = connectTo server (PortNumber (fromIntegral port))
+                           `catch` (\(e :: SomeException) -> do
+                                      log ("Error: " ++ show e ++ ". Waiting.")
+                                      threadDelay (5 * oneSec)
+                                      connectToWithRetry)
 
 disconnect :: Bot -> IO ()
 disconnect bot = do
-  putStrLn "** Disconnecting ..."
+  log "Disconnecting ..."
   hClose . socket $ bot
-  putStrLn "** Disconnected"
+  log "Disconnected"
 
 run :: BotConfig -> IO ()
-run botConfig = E.bracket (connect botConfig) disconnect $ \bot ->
-  E.catch (run_ bot) (\(e :: E.SomeException) -> putStrLn $ "Exception! " ++ show e)
- where
-    run_ bot = do
-      sendCommand bot NickCmd >> sendCommand bot UserCmd
-      runReaderT listen bot
+run botConfig = withSocketsDo $ do
+  status <- run_
+  case status of
+    Disconnected -> log "Connection timedout" >> run botConfig
+    Errored      -> return ()
+  where
+    run_ = bracket (connect botConfig) disconnect $ \bot ->
+      go bot `catch` \(e :: SomeException) -> do
+        log $ "Exception! " ++ show e
+        return Errored
+
+    go bot = do
+      sendCommand bot NickCmd
+      sendCommand bot UserCmd
+      runReaderT (listen Connected) bot

Network/IRC/Main.hs

@@ -19,5 +19,4 @@ main = do
 
   if length args < 4
     then putStrLn ("Usage: " ++ prog ++ " <server> <port> <channel> <nick>") >> exitFailure
-    else run $ BotConfig server port channel botNick handlers
-
+    else run $ BotConfig server port channel botNick 120 handlers

Network/IRC/Protocol.hs

@@ -15,6 +15,7 @@ msgFromLine (BotConfig { .. }) time line
       "JOIN"    -> JoinMsg time user
       "QUIT"    -> QuitMsg time user message
       "PART"    -> PartMsg time user message
+      "KICK"    -> KickMsg time user kickReason
       "MODE"    -> if source == botNick
         then ModeMsg time Self target message []
         else ModeMsg time user target mode modeArgs
@@ -24,16 +25,17 @@ msgFromLine (BotConfig { .. }) time line
         else PrivMsg time user message
       _         -> OtherMsg time source command target message
   where
-    isSpc    = (== ' ')
-    isNotSpc = not . isSpc
-    splits   = splitWhen isSpc line
-    source   = drop 1 . takeWhile isNotSpc $ line
-    target   = splits !! 2
-    command  = splits !! 1
-    message  = drop 1 . unwords . drop 3 $ splits
-    user     = let u = splitWhen (== '!') source in User (u !! 0) (u !! 1)
-    mode     = splits !! 3
-    modeArgs = drop 4 splits
+    isSpc      = (== ' ')
+    isNotSpc   = not . isSpc
+    splits     = splitWhen isSpc line
+    source     = drop 1 . takeWhile isNotSpc $ line
+    target     = splits !! 2
+    command    = splits !! 1
+    message    = drop 1 . unwords . drop 3 $ splits
+    user       = let u = splitWhen (== '!') source in User (u !! 0) (u !! 1)
+    mode       = splits !! 3
+    modeArgs   = drop 4 splits
+    kickReason = drop 1 . unwords . drop 4 $ splits
 
 lineFromCommand :: BotConfig -> Command -> String
 lineFromCommand (BotConfig { .. }) reply = case reply of

Network/IRC/Types.hs

@@ -22,6 +22,7 @@ data Message =
   | NickMsg    { time :: ClockTime, user :: User, nick :: String }
   | QuitMsg    { time :: ClockTime, user :: User, msg :: String }
   | PartMsg    { time :: ClockTime, user :: User, msg :: String }
+  | KickMsg    { time :: ClockTime, user :: User, msg :: String }
   | OtherMsg   { time :: ClockTime, source :: String, command :: String
                , target :: String, msg :: String }
   deriving (Show, Eq)
@@ -39,6 +40,7 @@ data BotConfig = BotConfig { server :: String
                            , port :: Int
                            , channel :: String
                            , botNick :: String
+                           , botTimeout :: Int
                            , handlers :: [HandlerName] }
                  deriving (Show, Eq)
 data Bot = Bot { botConfig :: BotConfig, socket :: Handle } deriving (Show, Eq)