diff --git a/.gitignore b/.gitignore index 670b628..a5b62dc 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,9 @@ *.hi *.o +*.iml .cabal-sandbox cabal.sandbox.config +.idea dist config.cfg *sublime* diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index 53ddc8e..eb9534b 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/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 - 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 diff --git a/hask-irc-core/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs index 7bcadd6..1b3c384 100644 --- a/hask-irc-core/Network/IRC/Client.hs +++ b/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 - 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 diff --git a/hask-irc-core/Network/IRC/Handlers/Core.hs b/hask-irc-core/Network/IRC/Handlers/Core.hs index 5b26731..32a4da1 100644 --- a/hask-irc-core/Network/IRC/Handlers/Core.hs +++ b/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 - , handlerHelp = return $ singletonMap "!help" helpMsg } + go _ _ = return $ newMsgHandler { onMessage = help + , handlerHelp = return $ singletonMap "!help" helpMsg } helpMsg = "Get help. !help or !help " pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message] diff --git a/hask-irc-core/Network/IRC/Internal/Types.hs b/hask-irc-core/Network/IRC/Internal/Types.hs index 70abac8..2de9643 100644 --- a/hask-irc-core/Network/IRC/Internal/Types.hs +++ b/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. diff --git a/hask-irc-core/Network/IRC/Message/Types.hs b/hask-irc-core/Network/IRC/Message/Types.hs index da55580..10a3ed6 100644 --- a/hask-irc-core/Network/IRC/Message/Types.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 4f0bfbb..031bd7b 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/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 (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 = diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index ee73e88..778c846 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/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 (..)