abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adds support for automatic nick recovery.

Browse Source
This commit is contained in:
Abhinav Sarkar 2015-06-21 15:14:32 +05:30
parent 3d42577e62
commit fdf641d187
8 changed files with 119 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

36
hask-irc-core/Network/IRC/Bot.hs
View File

@ -93,10 +93,11 @@ messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
messageProcessLoop inChan messageChan = loop 0
where
loop !idleFor = do
status <- get
Bot { .. } <- ask
let nick = botNick botConfig
mpass <- io $ CF.lookup (config botConfig) "password"
status <- get
Bot { .. } <- ask
let nick = botNick botConfig
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
| Just (JoinMsg user) <- fromMessage message, userNick user == nick =
sendWhoisMessage nick origNick =
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

13
hask-irc-core/Network/IRC/Client.hs
View File

@ -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
Errored -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
Disconnected -> 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

6
hask-irc-core/Network/IRC/Handlers/Core.hs
View File

@ -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
, handlerHelp = return $ singletonMap "!help" helpMsg }
go _ _ = return $ newMsgHandler { onMessage = help
, handlerHelp = return $ singletonMap "!help" helpMsg }
helpMsg = "Get help. !help or !help <command>"
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message]

8
hask-irc-core/Network/IRC/Internal/Types.hs
View File

@ -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.

43
hask-irc-core/Network/IRC/Message/Types.hs
View File

@ -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

54
hask-irc-core/Network/IRC/Protocol.hs
View File

@ -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 (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
| Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick'
| Just UserCmd <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
| Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel
| Just QuitCmd <- fromMessage message = Just "QUIT"
| Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel
| Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg
| Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
| Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick'
| Just UserCmd <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
| Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel
| Just QuitCmd <- fromMessage message = Just "QUIT"
| 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 =

2
hask-irc-core/Network/IRC/Types.hs
View File

@ -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 (..)