diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index df6712e..99f78ba 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.hs @@ -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 diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index ba37ba4..ad60de6 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/hask-irc-core/Network/IRC/Client.hs @@ -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 diff --git a/hask-irc-core/Network/IRC/Message/Types.hs b/hask-irc-core/Network/IRC/Message/Types.hs index f6c1fa0..1eb8b09 100644 --- a/hask-irc-core/Network/IRC/Message/Types.hs +++ b/hask-irc-core/Network/IRC/Message/Types.hs @@ -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) diff --git a/hask-irc-core/Network/IRC/MessageBus.hs b/hask-irc-core/Network/IRC/MessageBus.hs index 199e6c6..b6713c3 100644 --- a/hask-irc-core/Network/IRC/MessageBus.hs +++ b/hask-irc-core/Network/IRC/MessageBus.hs @@ -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) diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 19363b9..e20c8f0 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/hask-irc-core/Network/IRC/Protocol.hs @@ -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