Adds support for automatic nick recovery.

.gitignore

@@ -1,7 +1,9 @@
 *.hi
 *.o
+*.iml
 .cabal-sandbox
 cabal.sandbox.config
+.idea
 dist
 config.cfg
 *sublime*

hask-irc-core/Network/IRC/Bot.hs

@@ -93,10 +93,11 @@ messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
 messageProcessLoop inChan messageChan = loop 0
   where
     loop !idleFor = do
-      status     <- get
+      status       <- get
-      Bot { .. } <- ask
+      Bot { .. }   <- ask
-      let nick   = botNick botConfig
+      let nick     = botNick botConfig
-      mpass      <- io $ CF.lookup (config botConfig) "password"
+      let origNick = botOrigNick botConfig
+      mpass        <- io $ CF.lookup (config botConfig) "password"
 
       nStatus <- io . mask_ $
         if idleFor >= (oneSec * botTimeout botConfig)
@@ -107,10 +108,14 @@ messageProcessLoop inChan messageChan = loop 0
 
             mIn <- receiveMessage inChan
             case mIn of
-              Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle
+              Timeout -> do
+                idleMsg <- newMessage IdleMsg
+                sendMessage messageChan idleMsg
+                sendWhoisMessage nick origNick
+                return Idle
               EOD     -> infoM "Connection closed" >> return Disconnected
               Msg (msg@Message { .. }) -> do
-                nStatus <- handleMsg nick message mpass
+                nStatus <- handleMsg nick origNick message mpass
                 sendMessage messageChan msg
                 return nStatus
 
@@ -119,21 +124,28 @@ messageProcessLoop inChan messageChan = loop 0
         Idle             -> loop (idleFor + oneSec)
         Disconnected     -> return ()
         NickNotAvailable -> return ()
+        NickAvailable    -> return ()
         _                -> loop 0
 
       where
-        handleMsg nick message mpass
+        sendWhoisMessage nick origNick =
-          | Just (JoinMsg user)   <- fromMessage message, userNick user == nick =
+          when (nick /= origNick && idleFor /= 0 && idleFor `mod` (10 * oneSec) == 0) $
+            (newMessage . WhoisCmd . nickToText $ origNick) >>= sendMessage messageChan
+
+        handleMsg nick origNick message mpass
+          | Just (JoinMsg user)     <- fromMessage message, userNick user == nick =
               infoM "Joined" >> return Joined
-          | Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick    =
+          | Just (KickMsg { .. })   <- fromMessage message, kickedNick == nick    =
               infoM "Kicked" >> return Kicked
-          | Just NickInUseMsg     <- fromMessage message                        =
+          | Just NickInUseMsg       <- fromMessage message                        =
               infoM "Nick already in use" >> return NickNotAvailable
-          | Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self      = do
+          | Just (ModeMsg { .. })   <- fromMessage message, modeUser == Self      = do
               whenJust mpass $ \pass -> do
                 msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass
                 sendMessage messageChan msg
               newMessage JoinCmd >>= sendMessage messageChan
               return Connected
-          | otherwise                                                           =
+          | Just (WhoisNoSuchNick n) <- fromMessage message, n == origNick        =
+              infoM "Original nick available" >> return NickAvailable
+          | otherwise                                                             =
               return Connected

hask-irc-core/Network/IRC/Client.hs

@@ -71,7 +71,7 @@ connect botConfig@BotConfig { .. } = do
   where
     connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
                            `catch` (\(e :: SomeException) -> do
-                                      errorM ("Error while connecting: " ++ show e ++ ". Waiting.")
+                                      errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
                                       threadDelay (5 * oneSec)
                                       connectToWithRetry)
 
@@ -110,10 +110,11 @@ runBotIntenal :: BotConfig -> IO ()
 runBotIntenal botConfig' = withSocketsDo $ do
   status <- run
   case status of
-    Disconnected     -> debugM "Restarting .."   >> runBotIntenal botConfigWithCore
+    Disconnected     -> debugM "Restarting .."        >> runBotIntenal botConfigWithCore
-    Errored          -> debugM "Restarting .."   >> runBotIntenal botConfigWithCore
+    Errored          -> debugM "Restarting .."        >> runBotIntenal botConfigWithCore
+    NickNotAvailable -> debugM "Trying new nick"      >> runBotIntenal botConfigWithNewNick
+    NickAvailable    -> debugM "Trying original nick" >> runBotIntenal botConfigWithOrigNick
     Interrupted      -> return ()
-    NickNotAvailable -> debugM "Trying new nick" >> runBotIntenal botConfigWithNewNick
     _                -> error "Unsupported status"
   where
     botConfigWithCore = botConfig' {
@@ -127,6 +128,10 @@ runBotIntenal botConfig' = withSocketsDo $ do
       botNick = Nick $ nickToText (botNick botConfigWithCore) ++ "_"
     }
 
+    botConfigWithOrigNick = botConfigWithCore {
+      botNick = botOrigNick botConfigWithCore
+    }
+
     handleErrors :: SomeException -> IO BotStatus
     handleErrors e = case fromException e of
         Just UserInterrupt -> debugM "User interrupt"          >> return Interrupted

hask-irc-core/Network/IRC/Handlers/Core.hs

@@ -10,7 +10,7 @@ import Network.IRC.Util
 coreMsgHandlerMakers :: Map MsgHandlerName MsgHandlerMaker
 coreMsgHandlerMakers = mapFromList [
     ("pingpong", pingPongMsgHandlerMaker)
-  , ("help", helpMsgHandlerMaker)
+  , ("help"    , helpMsgHandlerMaker)
   ]
 
 pingPongMsgHandlerMaker :: MsgHandlerMaker
@@ -23,8 +23,8 @@ pingPongMsgHandlerMaker = MsgHandlerMaker "pingpong" go
 helpMsgHandlerMaker :: MsgHandlerMaker
 helpMsgHandlerMaker = MsgHandlerMaker "help" go
   where
-    go _ _ = return $ newMsgHandler { onMessage = help
+    go _ _ = return $ newMsgHandler { onMessage   = help
-                                    , handlerHelp  = return $ singletonMap "!help" helpMsg }
+                                    , handlerHelp = return $ singletonMap "!help" helpMsg }
     helpMsg = "Get help. !help or !help <command>"
 
 pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message]

hask-irc-core/Network/IRC/Internal/Types.hs

@@ -59,7 +59,8 @@ data BotConfig = BotConfig
   , botPort          :: !Int
   -- | The channel to join.
   , botChannel       :: !Text
-  -- | Nick of the bot.
+  , botOrigNick      :: !Nick
+  -- | Current nick of the bot.
   , botNick          :: !Nick
   -- | The timeout in seconds after which bot automatically disconnects and tries to reconnect.
   -- Should be few seconds more than the ping timeout of the server.
@@ -94,7 +95,7 @@ newBotConfig :: Text       -- ^ server
              -> Int        -- ^ botTimeout
              -> BotConfig
 newBotConfig server port channel botNick botTimeout =
-  BotConfig server port channel botNick botTimeout mempty mempty [] [] CF.empty
+  BotConfig server port channel botNick botNick botTimeout mempty mempty [] [] CF.empty
 
 -- | The bot.
 data Bot = Bot
@@ -116,7 +117,8 @@ data BotStatus = Connected               -- ^ Connected to the server
                | Idle                    -- ^ No communication with the server. The bot is idle.
                                          -- If the bot stays idle for 'botTimeout' seconds, it disconnects.
                | Interrupted             -- ^ Interrupted using external signals like SIGINT.
-               | NickNotAvailable        -- ^ Bot's nick already taken on the server.
+               | NickNotAvailable        -- ^ Bot's current nick already taken on the server.
+               | NickAvailable           -- ^ Bot's original nick is available on the server.
                deriving (Show, Eq, Ord)
 
 -- | An IRC action to be run.

hask-irc-core/Network/IRC/Message/Types.hs

@@ -68,63 +68,75 @@ newMessage msg = do
   return $ Message t "" (toMessage msg)
 
 -- | The internal (non-IRC) message received when the bot is idle.
-data IdleMsg      = IdleMsg deriving (Typeable, Show, Eq, Ord)
+data IdleMsg       = IdleMsg deriving (Typeable, Show, Eq, Ord)
 instance MessageC IdleMsg
 
 -- | The message received when the bot's current nick is already in use.
-data NickInUseMsg = NickInUseMsg deriving (Typeable, Show, Eq, Ord)
+data NickInUseMsg  = NickInUseMsg deriving (Typeable, Show, Eq, Ord)
 instance MessageC NickInUseMsg
 
 -- | A /PING/ message. Must be replied with a 'PongCmd'.
-data PingMsg      = PingMsg !Text deriving (Typeable, Show, Eq, Ord)
+data PingMsg       = PingMsg !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC PingMsg
 
 -- | A /PONG/ message. Received in response to a 'PingCmd'.
-data PongMsg      = PongMsg !Text deriving (Typeable, Show, Eq, Ord)
+data PongMsg       = PongMsg !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC PongMsg
 
 -- | A /NAMES/ message which contains a list of nicks of all users in the channel.
-data NamesMsg     = NamesMsg ![Nick] deriving (Typeable, Show, Eq, Ord)
+data NamesMsg      = NamesMsg ![Nick] deriving (Typeable, Show, Eq, Ord)
 instance MessageC NamesMsg
 
 -- | A /PRIVMSG/ message sent to the channel from a user.
-data ChannelMsg   = ChannelMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+data ChannelMsg    = ChannelMsg !User !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC ChannelMsg
 
 -- | A /PRIVMSG/ private message sent to the bot from a user.
-data PrivMsg      = PrivMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+data PrivMsg       = PrivMsg !User !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC PrivMsg
 
 -- | An /PRIVMSG/ action message sent to the channel from a user.
-data ActionMsg    = ActionMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+data ActionMsg     = ActionMsg !User !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC ActionMsg
 
 -- | A /JOIN/ message received when a user joins the channel.
-data JoinMsg      = JoinMsg !User deriving (Typeable, Show, Eq, Ord)
+data JoinMsg       = JoinMsg !User deriving (Typeable, Show, Eq, Ord)
 instance MessageC JoinMsg
 
 -- | A /QUIT/ message received when a user quits the server.
-data QuitMsg      = QuitMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+data QuitMsg       = QuitMsg !User !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC QuitMsg
 
 -- | A /PART/ message received when a user leaves the channel.
-data PartMsg      = PartMsg !User !Text deriving (Typeable, Show, Eq, Ord)
+data PartMsg       = PartMsg !User !Text deriving (Typeable, Show, Eq, Ord)
 instance MessageC PartMsg
 
 -- | A /NICK/ message received when a user changes their nick.
-data NickMsg      = NickMsg !User !Nick deriving (Typeable, Show, Eq, Ord)
+data NickMsg       = NickMsg !User !Nick deriving (Typeable, Show, Eq, Ord)
 instance MessageC NickMsg
 
 -- | A /KICK/ message received when a user kicks another user from the channel.
-data KickMsg      = KickMsg { kickUser :: !User, kickedNick :: !Nick, kickMsg :: !Text }
+data KickMsg       = KickMsg { kickUser :: !User, kickedNick :: !Nick, kickMsg :: !Text }
                     deriving (Typeable, Show, Eq, Ord)
 instance MessageC KickMsg
 
 -- | A /MODE/ message received when a user's mode changes.
-data ModeMsg      = ModeMsg { modeUser :: !User, modeTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
+data ModeMsg       = ModeMsg { modeUser :: !User, modeTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
                     deriving (Typeable, Show, Eq, Ord)
 instance MessageC ModeMsg
 
+data WhoisReplyMsg = WhoisNoSuchNick { whoisNick :: !Nick }
+                   | WhoisReplyMsg {
+                       whoisNick        :: !Nick
+                     , whoisUser        :: !Text
+                     , whoisHost        :: !Text
+                     , whoisRealName    :: !Text
+                     , whoisChannels    :: ![Text]
+                     , whoisServer      :: !Text
+                     , whoisServerInfo  :: !Text
+                     } deriving (Typeable, Show, Eq, Ord)
+instance MessageC WhoisReplyMsg
+
 -- | All other messages which are not parsed as any of the above types.
 data OtherMsg     = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
                     deriving (Typeable, Show, Eq, Ord)
@@ -166,3 +178,6 @@ instance MessageC QuitCmd
 -- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
 data NamesCmd        = NamesCmd deriving (Typeable, Show, Eq, Ord)
 instance MessageC NamesCmd
+
+data WhoisCmd       = WhoisCmd !Text deriving (Typeable, Show, Eq, Ord)
+instance MessageC WhoisCmd

hask-irc-core/Network/IRC/Protocol.hs

@@ -2,6 +2,7 @@ module Network.IRC.Protocol (parseLine, formatCommand) where
 
 import ClassyPrelude
 import Data.Foldable (msum)
+import Data.Maybe    (fromJust)
 import Data.List     ((!!))
 import Data.Text     (strip)
 
@@ -17,7 +18,7 @@ parseLine botConfig@BotConfig { .. } time line msgParts =
          Partial msgParts'      -> ([], (singletonMap msgParserId msgParts'))
          Done message msgParts' -> ([message], (singletonMap msgParserId msgParts'))
   where
-    parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser]
+    parsers = [pingParser, namesParser, whoisParser, lineParser] ++ msgParsers ++ [defaultParser]
 
 pingParser :: MessageParser
 pingParser = MessageParser "ping" go
@@ -91,24 +92,59 @@ namesParser = MessageParser "names" go
             in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
           _     -> Reject
       where
-        (_ : command : target : _) = words line
+        (_, command, _ , target, _) = parseMsgLine line
         stripNickPrefix  = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
         namesNicks line' =
           map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
 
+whoisParser :: MessageParser
+whoisParser = MessageParser "whois" go
+  where
+    go BotConfig { .. } time line msgParts
+      | "PING :" `isPrefixOf` line = Reject
+      | command `elem` ["401", "311", "319", "312", "317"] =
+          Partial $ MessagePart target time line : msgParts
+      | command == "318" = let
+          (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
+          allLines = intercalate "\r\n" . reverse . (line :) . map msgPartLine $ myMsgParts
+          in Done (Message time allLines . toMessage $ parse myMsgParts) otherMsgParts
+      | otherwise = Reject
+      where
+        (_, command, _, target, _) = parseMsgLine line
+
+    parse :: [MessagePart] -> WhoisReplyMsg
+    parse myMsgParts =
+      let partMap = asMap $ foldl' (\m MessagePart { .. } ->
+                                      insertMap (words msgPartLine !! 1) msgPartLine m)
+                                   mempty myMsgParts
+      in case lookup "401" partMap of
+           Just line -> WhoisNoSuchNick . Nick $ words line !! 3
+           Nothing   -> let
+               splits311   = words . fromJust . lookup "311" $ partMap
+               nick        = Nick (splits311 !! 3)
+               user        = splits311 !! 4
+               host        = splits311 !! 5
+               realName    = drop 1 $ splits311 !! 7
+               channels    = mconcat . maybeToList . map (words . drop 1 . unwords . drop 4 . words) . lookup "319" $ partMap
+               splits312   = words . fromJust . lookup "312" $ partMap
+               server      = splits312 !! 4
+               serverInfo  = drop 1 $ splits312 !! 5
+             in WhoisReplyMsg nick user host realName channels server serverInfo
+
 formatCommand :: CommandFormatter
 formatCommand botConfig@BotConfig { .. } message =
   msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters
 
 defaultCommandFormatter :: CommandFormatter
 defaultCommandFormatter BotConfig { .. } Message { .. }
-  | Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg
+  | Just (PongCmd msg)   <- fromMessage message = Just $ "PONG :" ++ msg
-  | Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
+  | Just (PingCmd msg)   <- fromMessage message = Just $ "PING :" ++ msg
-  | Just NickCmd       <- fromMessage message = Just $ "NICK " ++ botNick'
+  | Just NickCmd         <- fromMessage message = Just $ "NICK " ++ botNick'
-  | Just UserCmd       <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
+  | Just UserCmd         <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
-  | Just JoinCmd       <- fromMessage message = Just $ "JOIN " ++ botChannel
+  | Just JoinCmd         <- fromMessage message = Just $ "JOIN " ++ botChannel
-  | Just QuitCmd       <- fromMessage message = Just "QUIT"
+  | Just QuitCmd         <- fromMessage message = Just "QUIT"
-  | Just NamesCmd      <- fromMessage message = Just $ "NAMES " ++ botChannel
+  | Just NamesCmd        <- fromMessage message = Just $ "NAMES " ++ botChannel
+  | Just (WhoisCmd nick) <- fromMessage message = Just $ "WHOIS " ++ nick
   | Just (ChannelMsgReply msg) <- fromMessage message            =
       Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
   | Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =

hask-irc-core/Network/IRC/Types.hs

@@ -31,6 +31,7 @@ module Network.IRC.Types
   , NickMsg (..)
   , KickMsg (..)
   , ModeMsg (..)
+  , WhoisReplyMsg (..)
   , OtherMsg (..)
   -- * IRC Commands
   , PingCmd (..)
@@ -42,6 +43,7 @@ module Network.IRC.Types
   , JoinCmd (..)
   , QuitCmd (..)
   , NamesCmd (..)
+  , WhoisCmd (..)
   -- * Message Parsing
   , MessageParserId
   , MessagePart (..)