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

@@ -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) $
+    Just ch -> case ch ^. chanTopic of
-                 tellNumeric rpl_topic [cname, fromJust $ ch ^. chanTopic]
+      Just topic -> tellNumeric rpl_topic [cname, BS.append ":" topic]
+      Nothing    -> tellNumeric rpl_notopic [cname, ":No topic is set"]
     Nothing -> return ()
 
 tellNAMES :: [ChanKey] -> IrcMonad ()

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
+    chanEchoAll [c] newMsg
-    findReceivers [nn] >>= fwdMsgNoReplace msg
     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