From bc41947b18eac206bab4734d71f57ec64fec10e1 Mon Sep 17 00:00:00 2001 From: Levi Pearson Date: Mon, 1 Feb 2016 00:37:53 -0700 Subject: [PATCH] Add TOPIC command and fix a couple of small bugs Was using wrong numeric response for unknown channel errors. Now we send JOIN response to user before topic, names, etc. TOPIC now responds with RPL_NOTOPIC when there's no topic set. Added some default cases to pattern matches, though they were not absolutely necessary due to previous checks. Added chanEchoAll action to IrcMonad to send the same message to all on channel, including originating user. --- src/Pipes/IRC/Server/IrcMonad.hs | 25 +++++++++++++++++++----- src/Pipes/IRC/Server/MessageHandler.hs | 27 ++++++++++++++++++++++---- 2 files changed, 43 insertions(+), 9 deletions(-) diff --git a/src/Pipes/IRC/Server/IrcMonad.hs b/src/Pipes/IRC/Server/IrcMonad.hs index d7f6fae..2c1a736 100644 --- a/src/Pipes/IRC/Server/IrcMonad.hs +++ b/src/Pipes/IRC/Server/IrcMonad.hs @@ -3,14 +3,12 @@ module Pipes.IRC.Server.IrcMonad where -import Control.Applicative ((<$>)) import Control.Error import Control.Lens import Control.Monad.RWS import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M -import Data.Maybe (fromJust) import qualified Data.Set as S import Pipes.IRC.Message.Types @@ -60,6 +58,9 @@ changeNick oldN newN = do associateUserWithNick :: IrcUser -> NickKey -> IrcMonad () associateUserWithNick usr nn = clientServer . ircUsers . at nn ?= usr +changeTopicOnChan :: ChanKey -> ByteString -> IrcMonad () +changeTopicOnChan c t = clientServer %= + (ircChannels %~ M.adjust (chanSetTopic t) c) -- * Pretty Printing @@ -149,6 +150,15 @@ chanEcho chans iMsg = do msg <- addUserPrefix iMsg findReceivers chans >>= fwdMsg msg +chanEchoAll :: [ChanKey] -> IrcMessage -> IrcMonad () +chanEchoAll chans iMsg = do + msg <- addUserPrefix iMsg + findReceivers chans >>= fwdMsg msg + mNick <- useNick + case mNick of + Just nn -> findReceivers [nn] >>= fwdMsgNoReplace msg + _ -> return () + allChans :: IrcMonad [ChanKey] allChans = do cs <- runMaybeT $ do @@ -213,7 +223,7 @@ checkRegistration = checkChannelPresence :: ChanKey -> IrcMonadErr IrcChannel checkChannelPresence ckey = - ensureUse (useChan ckey) (err_badchannelkey, [ckey, ":No such channel"]) + ensureUse (useChan ckey) (err_nosuchchannel, [ckey, ":No such channel"]) checkChannelAbsence :: ChanKey -> IrcMonadErr () checkChannelAbsence ckey = do @@ -242,6 +252,10 @@ checkNickFree nickname = do ensure (not $ S.member nickname nickSet) err_nicknameinuse [nickname, ":Nickname is already in use."] +checkTopicChange :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr () +checkTopicChange nn c ch = ensure (chanUserMaySetTopic nn ch) + err_chanoprivsneeded [c, ":You're not channel operator"] + -- * Adding responses to the Writer portion of the monad renderQuitMsg :: Maybe BS.ByteString -> IrcMonad BS.ByteString @@ -284,8 +298,9 @@ tellTOPIC :: ChanKey -> IrcMonad () tellTOPIC cname = do chan <- use $ clientServer . ircChannels . at cname case chan of - Just ch -> when (isJust $ ch ^. chanTopic) $ - tellNumeric rpl_topic [cname, fromJust $ ch ^. chanTopic] + Just ch -> case ch ^. chanTopic of + Just topic -> tellNumeric rpl_topic [cname, BS.append ":" topic] + Nothing -> tellNumeric rpl_notopic [cname, ":No topic is set"] Nothing -> return () tellNAMES :: [ChanKey] -> IrcMonad () diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index 92adf1d..b317d1e 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -56,7 +56,7 @@ regHandler msg@IrcMessage{..} = do Left PING -> handlePING pMsg Left PONG -> handlePONG pMsg Left PRIVMSG -> handlePRIVMSG pMsg - Left TOPIC -> return () + Left TOPIC -> handleTOPIC pMsg Left QUIT -> handleQUIT pMsg Left WHO -> return () Left WHOIS -> return () @@ -131,6 +131,7 @@ handleJOIN msg@IrcMessage{..} = runValidation $ do [cs] -> doJoin msg $ zipParams (parseParamList cs) [] -- Some number of passwords were supplied cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks) + _ -> return () handlePART :: IrcMessage -> IrcMonad () handlePART msg@IrcMessage{..} = runValidation $ do @@ -138,6 +139,7 @@ handlePART msg@IrcMessage{..} = runValidation $ do lift $ case params of [cs] -> doPart msg (parseParamList cs) Nothing cs:pm:_ -> doPart msg (parseParamList cs) (Just pm) + _ -> return () doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad () doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do @@ -152,10 +154,10 @@ doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do lift $ do joinNickToChan nick c + findReceivers [nick] >>= fwdMsgNoReplace msg tellTOPIC c tellNAMES [c] chanEcho [c] msg - findReceivers [nick] >>= fwdMsgNoReplace msg doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad () doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do @@ -165,8 +167,7 @@ doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do let newMsg = msg{params = c : maybe [] ((:[]) . BS.append ":") pmsg} lift $ do - chanEcho [c] newMsg - findReceivers [nn] >>= fwdMsgNoReplace msg + chanEchoAll [c] newMsg partNickFromChan nn c handlePRIVMSG :: IrcMessage -> IrcMonad () @@ -178,6 +179,24 @@ handlePRIVMSG msg@IrcMessage{..} = do in findReceivers rs >>= fwdMsg msg return () +handleTOPIC :: IrcMessage -> IrcMonad () +handleTOPIC msg@IrcMessage{..} = runValidation $ do + nn <- checkRegistration + checkParamLength "TOPIC" params 1 + let cname = head params + ch <- checkChannelPresence cname + case params of + [_] -> lift $ tellTOPIC cname + _:topic:_ -> do + checkUserOnChan nn cname ch + checkTopicChange nn cname ch + lift $ do + changeTopicOnChan cname topic + let newMsg = msg{params = [cname, BS.append ":" topic]} + chanEchoAll [cname] newMsg + _ -> return () + + handleNICK :: IrcMessage -> IrcMonad () handleNICK msg@IrcMessage{..} = runValidation $ do nn <- checkRegistration