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

Added retrying with new nick if nick is already taken. Other minor fixes.

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-10-05 13:12:49 +05:30
parent 0b84c0c837
commit f99815b3b0
5 changed files with 35 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -54,7 +54,7 @@ readMessageLoop = go []
case botStatus of
Disconnected -> closeMessageChannel inChan
_ -> do
mLine <- try $ timeout timeoutDelay readLine'
mLine <- try $ timeout timeoutDelay readLine
msgParts' <- case mLine of
Left (e :: SomeException) -> do
errorM $ "Error while reading from connection: " ++ show e
@ -67,12 +67,12 @@ readMessageLoop = go []
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts
limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
let msgParts'' = concat
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
. groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
go msgParts'' mvBotStatus inChan bot timeoutDelay
let validMsgParts = concat
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
. groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
go validMsgParts mvBotStatus inChan bot timeoutDelay
where
readLine' = do
readLine = do
eof <- hIsEOF botSocket
if eof
then return EOS
@ -98,14 +98,15 @@ messageProcessLoop = go 0
when (status == Kicked) $
threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
mIn <- receiveMessage inChan
mIn <- receiveMessageEither inChan messageChan
case mIn of
Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle
EOD -> infoM "Connection closed" >> return Disconnected
Msg (msg@Message { .. }) -> do
Left Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle
Left EOD -> infoM "Connection closed" >> return Disconnected
Left (Msg (msg@Message { .. })) -> do
nStatus <- handleMsg nick message mpass
sendMessage messageChan msg
return nStatus
Right _ -> return status
put nStatus
case nStatus of
@ -121,7 +122,7 @@ messageProcessLoop = go 0
| Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick =
infoM "Kicked" >> return Kicked
| Just NickInUseMsg <- fromMessage message =
infoM "Nick already in use" >> return NickNotAvailable
infoM "Nick already in use" >> return NickNotAvailable
| Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self = do
whenJust mpass $ \pass -> do
msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass

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

@ -113,17 +113,21 @@ 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
Interrupted -> return ()
NickNotAvailable -> return ()
NickNotAvailable -> debugM "Trying new nick" >> runBotIntenal botConfigWithNewNick
_ -> error "Unsupported status"
where
botConfigWithCore = botConfig' {
msgHandlerInfo =
foldl' (\m name -> insertMap name mempty m) mempty
(hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers),
msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
(hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers)
, msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
}
botConfigWithNewNick = botConfigWithCore {
botNick = Nick $ nickToText (botNick botConfigWithCore) ++ "_"
}
handleErrors :: SomeException -> IO BotStatus

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

@ -28,7 +28,7 @@ data User
= Self
-- | An user other than the bot.
| User
{ userNick :: !Nick -- ^ The user's nick.
{ userNick :: !Nick -- ^ The user's nick.
, userServer :: !Text -- ^ The user's server.
} deriving (Show, Eq, Ord)

5
hask-irc-core/Network/IRC/MessageBus.hs
View File

@ -10,6 +10,7 @@ module Network.IRC.MessageBus
, newMessageChannel
, sendMessage
, receiveMessage
, receiveMessageEither
, closeMessageChannel
, awaitMessageChannel ) where
@ -56,3 +57,7 @@ closeMessageChannel (MessageChannel latch _ _) = doLatch latch
awaitMessageChannel :: MessageChannel a -> IO ()
awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch
receiveMessageEither :: MessageChannel a -> MessageChannel b -> IO (Either a b)
receiveMessageEither chan1 chan2 = atomically $
map Left (receiveMessageSTM chan1) `orElseSTM` map Right (receiveMessageSTM chan2)

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

@ -99,18 +99,17 @@ formatCommand botConfig@BotConfig { .. } message =
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 (ChannelMsgReply msg) <- fromMessage 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 (ChannelMsgReply msg) <- fromMessage message =
Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
| Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
| Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel
| otherwise = Nothing
where
botNick' = nickToText botNick