From 91fcf5f78cb4bdb4503fc0347a5483598075e369 Mon Sep 17 00:00:00 2001 From: Levi Pearson Date: Mon, 3 Mar 2014 01:29:28 -0700 Subject: [PATCH] Various refactorings and bugfixes --- src/Pipes/IRC/Message.hs | 3 + src/Pipes/IRC/Message/Render.hs | 12 ++- src/Pipes/IRC/Message/Types.hs | 5 + src/Pipes/IRC/Server.hs | 126 +++++++++++++++---------- src/Pipes/IRC/Server/EventHandler.hs | 4 +- src/Pipes/IRC/Server/IrcMonad.hs | 78 ++++++++++++--- src/Pipes/IRC/Server/Log.hs | 41 ++++++-- src/Pipes/IRC/Server/MessageHandler.hs | 72 +++++++++----- src/Pipes/IRC/Server/Server.hs | 5 +- src/Pipes/IRC/Server/Types.hs | 1 - 10 files changed, 244 insertions(+), 103 deletions(-) diff --git a/src/Pipes/IRC/Message.hs b/src/Pipes/IRC/Message.hs index 1ff1139..e8dab07 100644 --- a/src/Pipes/IRC/Message.hs +++ b/src/Pipes/IRC/Message.hs @@ -1,8 +1,11 @@ module Pipes.IRC.Message ( parseMsgOrLine , parseIrcMessage + , renderIrcMessage + , renderIrcMessageNoNL , module Pipes.IRC.Message.Types ) where import Pipes.IRC.Message.Parse +import Pipes.IRC.Message.Render import Pipes.IRC.Message.Types diff --git a/src/Pipes/IRC/Message/Render.hs b/src/Pipes/IRC/Message/Render.hs index 659baa7..2263776 100644 --- a/src/Pipes/IRC/Message/Render.hs +++ b/src/Pipes/IRC/Message/Render.hs @@ -3,6 +3,7 @@ module Pipes.IRC.Message.Render ( renderIrcMessage + , renderIrcMessageNoNL , renderNickName ) where @@ -15,17 +16,20 @@ import Data.Monoid import Pipes.IRC.Message.Types renderIrcMessage :: IrcMessage -> C8.ByteString -renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage +renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage True + +renderIrcMessageNoNL :: IrcMessage -> ByteString +renderIrcMessageNoNL = toStrict . toLazyByteString . buildIrcMessage False renderNickName :: NickName -> C8.ByteString renderNickName = toStrict . toLazyByteString . buildNickName -buildIrcMessage :: IrcMessage -> Builder -buildIrcMessage IrcMessage {..} = +buildIrcMessage :: Bool -> IrcMessage -> Builder +buildIrcMessage nl IrcMessage {..} = buildMsgPrefix prefix <> buildMsgCommand command <> buildIrcParams params - <> byteString "\r\n" + <> if nl then byteString "\r\n" else mempty buildMsgPrefix :: Maybe MsgPrefix -> Builder buildMsgPrefix Nothing = mempty diff --git a/src/Pipes/IRC/Message/Types.hs b/src/Pipes/IRC/Message/Types.hs index 57d978a..3e8bc65 100644 --- a/src/Pipes/IRC/Message/Types.hs +++ b/src/Pipes/IRC/Message/Types.hs @@ -2,6 +2,7 @@ module Pipes.IRC.Message.Types where import qualified Data.ByteString as B +import Data.Monoid data IrcMessage = IrcMessage { prefix :: Maybe MsgPrefix @@ -71,6 +72,10 @@ data IrcReply = IrcReply , replyName :: !B.ByteString } deriving (Show) +instance Monoid IrcReply where + mempty = mkIrcReply 400 "UNKNOWN ERROR" + _ `mappend` b = b + instance Eq IrcReply where IrcReply { replyCode = a } == IrcReply { replyCode = b } = a == b diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index 1210c72..1523a21 100644 --- a/src/Pipes/IRC/Server.hs +++ b/src/Pipes/IRC/Server.hs @@ -13,27 +13,27 @@ import Control.Monad import Control.Monad.RWS import Data.ByteString.Char8 as BS import Data.Map as M +import Data.Maybe import Data.Set as S import Data.Time.Clock import Network.Socket as NS import Pipes import Pipes.Attoparsec import Pipes.Concurrent as PC -import Pipes.IRC.Message.Parse -import Pipes.IRC.Message.Render -import Pipes.IRC.Message.Types +import Pipes.IRC.Message import Pipes.IRC.Server.EventHandler +import Pipes.IRC.Server.IrcMonad import Pipes.IRC.Server.Log import Pipes.IRC.Server.MessageHandler import Pipes.IRC.Server.Server import Pipes.IRC.Server.Types import Pipes.Network.TCP as PN -version :: BS.ByteString +version :: ByteString version = "0.1a" -parseMessage :: Producer BS.ByteString IO () - -> Producer (Either BS.ByteString IrcMessage) IO () +parseMessage :: Producer ByteString IO () + -> Producer (Either ByteString IrcMessage) IO () parseMessage prod = do void $ for (parseMany parseMsgOrLine prod) $ \res -> case res of @@ -41,19 +41,18 @@ parseMessage prod = do (_, Right val) -> yield $ Right val return () -renderMessage :: Pipe IrcMessage BS.ByteString IO () +renderMessage :: Pipe IrcMessage ByteString IO () renderMessage = forever $ do msg <- await let output = renderIrcMessage msg yield output -filterMsgs :: Pipe (Either BS.ByteString IrcMessage) IrcMessage IO () +filterMsgs :: Pipe (Either ByteString IrcMessage) IrcMessage IO () filterMsgs = forever $ do cmd <- await case cmd of - Left bs -> liftIO $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs] - Right c -> do lift $ logMsg c - yield c + Left bs -> liftIO $ logLine $ BS.concat ["BAD COMMAND: ", bs] + Right c -> yield c addIrcConnection :: ServerState -> IrcConnection -> IO Int addIrcConnection srv client = do @@ -80,6 +79,32 @@ delIrcConnection srv cid = atomically $ do _ -> return () modifyTVar' (srv ^. ircConnections) $ M.delete cid +ircMonadTransaction :: ServerState -> Int -> RegState -> IrcMonad () + -> IO (RegState, [IrcEvent]) +ircMonadTransaction srv cid userReg action = do + cmap <- readTVarIO $ srv ^. ircConnections + let hostname = view (at cid . traverse . hname) cmap + curTime <- getCurrentTime + atomically $ do + sState <- readTVar $ srv ^. ircState + let sConf = srv ^. ircConfig + let cState = ClientState { _clientReg = userReg + , _clientServer = sState + , _clientHost = hostname + , _clientConn = cid } + let (_, newState, events) = runRWS action sConf cState + writeTVar (srv ^. ircState) (newState ^. clientServer) + modifyTVar' (srv ^. ircConnections) $ + M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid + return (newState ^. clientReg, events) + +runIrcMonad :: ServerState -> Int -> IrcMonad () -> IO () +runIrcMonad srv cid action = do + cs <- readTVarIO (srv ^. ircConnections) + let cReg = maybe (Unreg Nothing Nothing Nothing) (view reg) (cs ^. at cid) + (_, events) <- ircMonadTransaction srv cid cReg action + forM_ events $ ircEventHandler srv + cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO () cmdHandler srv cid = let cReg = Unreg Nothing Nothing Nothing @@ -89,38 +114,24 @@ cmdHandler srv cid = Just c -> handle (c ^. hname) cReg Nothing -> return () where - handle host userReg = do + handle h userReg = do -- wait for the next command nextMsg <- await - curTime <- liftIO getCurrentTime + + liftIO $ logMsg nextMsg (fromMaybe "unknown" h) userReg -- run the handler in a transaction - (newReg, events) <- liftIO $ atomically $ do - sState <- readTVar $ srv ^. ircState - let sConf = srv ^. ircConfig - let cState = ClientState { _clientReg = userReg - , _clientServer = sState - , _clientHost = host - , _clientConn = cid - } - - -- run the handler in the IrcMonad, returning new state and events - let (_, newState, events) = - runRWS (ircMessageHandler nextMsg) sConf cState - - writeTVar (srv ^. ircState) $ - newState ^. clientServer - - modifyTVar' (srv ^. ircConnections) $ - M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid - - return (newState ^. clientReg, events) + (newReg, events) <- + liftIO $ ircMonadTransaction srv cid userReg (ircMessageHandler nextMsg) -- handle resulting events aliveL <- liftIO $ forM events $ ircEventHandler srv - +{- -- debug + sState <- liftIO $ readTVarIO $ srv ^. ircState + liftIO $ BS.putStrLn $ BS.pack (show sState) +-} -- loop for the next command - when (and aliveL) $ handle host newReg + when (and aliveL) $ handle h newReg idlePinger :: ServerState -> Int -> IO () idlePinger srv cid = @@ -134,21 +145,28 @@ idlePinger srv cid = M.adjust (gotPong .~ False) cid checkPong = do conns <- readTVarIO (srv ^. ircConnections) return $ conns ! cid ^. gotPong - in - forever $ do - threadDelay oneMinute - curTime <- getCurrentTime - time <- getLastCom - let diffTime = toRational . diffUTCTime curTime $ time - if diffTime > 60 - then do - resetPong - atomically $ do - conns <- readTVar (srv ^. ircConnections) - PC.send (conns ! cid ^. out) pingMsg - threadDelay oneMinute - checkPong - else return True + timeoutLoop b = when b $ do + threadDelay oneMinute + curTime <- getCurrentTime + time <- getLastCom + let diffTime = toRational . diffUTCTime curTime $ time + if diffTime > 60 + then do + resetPong + + atomically $ do + conns <- readTVar (srv ^. ircConnections) + PC.send (conns ! cid ^. out) pingMsg + + threadDelay oneMinute + + checkPong >>= timeoutLoop + else timeoutLoop True + in do + -- timeoutLoop will call itself repeatedly until a timeout occurs + timeoutLoop True + -- Then we need to send a timeout message + runIrcMonad srv cid $ doQuit (Just "Ping timeout") listenHandler :: ServerState -> (Socket, SockAddr) -> IO () listenHandler srv (lsock, _) = @@ -161,6 +179,9 @@ listenHandler srv (lsock, _) = (writeEnd, readEnd) <- spawn Unbounded curTime <- getCurrentTime + logLine $ BS.pack $ + "Accepted connection from " ++ fromMaybe "unknown" hName + let client = IrcConnection { _sock = csock , _addr = caddr @@ -188,6 +209,9 @@ listenHandler srv (lsock, _) = void $ waitAnyCancel [r, w, idle] + logLine $ BS.pack $ + "Connection from " ++ fromMaybe "unknown" hName ++ " terminated" + delIrcConnection srv cid mkIrcServer :: IrcConfig -> IO ServerState @@ -206,4 +230,6 @@ startIrcServer config = do srv <- mkIrcServer config let sHost = srv ^. ircConfig . ircHost sPort = srv ^. ircConfig . ircPort + logLine $ BS.pack $ + mconcat ["Starting server on ", show sHost, " ", show sPort] async $ PN.listen sHost sPort (listenHandler srv) diff --git a/src/Pipes/IRC/Server/EventHandler.hs b/src/Pipes/IRC/Server/EventHandler.hs index 4e790d7..f5007dd 100644 --- a/src/Pipes/IRC/Server/EventHandler.hs +++ b/src/Pipes/IRC/Server/EventHandler.hs @@ -11,6 +11,7 @@ import Control.Monad import Data.Map as M import Data.Maybe as DM import Pipes.Concurrent as PC +import Pipes.IRC.Server.Log import Pipes.IRC.Server.Types sendToMany :: a -> [Output a] -> IO () @@ -31,8 +32,9 @@ ircEventHandler srv evt = outConns <- readTVarIO $ srv ^. ircConnections let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest sendToMany _outMsg os + logOutMsg _outMsg _outDest return True Pong {..} -> do atomically $ modifyTVar' (srv ^. ircConnections) $ - M.adjust (gotPong .~ False) _pongConn + M.adjust (gotPong .~ True) _pongConn return True diff --git a/src/Pipes/IRC/Server/IrcMonad.hs b/src/Pipes/IRC/Server/IrcMonad.hs index 7a06e27..9394666 100644 --- a/src/Pipes/IRC/Server/IrcMonad.hs +++ b/src/Pipes/IRC/Server/IrcMonad.hs @@ -3,6 +3,7 @@ module Pipes.IRC.Server.IrcMonad where +import Control.Applicative ((<$>)) import Control.Error import Control.Lens import Control.Monad.RWS @@ -26,6 +27,40 @@ mkUser = do srvname <- view ircHostName return $ newUser srvname conn +-- * User registration management + +storePassKey :: PassKey -> IrcMonad () +storePassKey k = clientReg . rcvdPass ?= k + +storeNickKey :: NickKey -> IrcMonad () +storeNickKey nn = clientReg . rcvdNick ?= nn + +storeUserName :: ByteString -> IrcMonad () +storeUserName n = clientReg . rcvdName ?= n + +registerUser :: RegState -> IrcMonad () +registerUser rs = clientReg .= rs + +-- * IrcServer management + +joinNickToChan :: NickKey -> ChanKey -> IrcMonad () +joinNickToChan nn c = clientServer %= ircJoin nn c + +partNickFromChan :: NickKey -> ChanKey -> IrcMonad () +partNickFromChan nn c = clientServer %= ircPart nn c + +reserveNick :: NickKey -> IrcMonad () +reserveNick nn = clientServer . ircNicks . contains nn .= True + +changeNick :: NickKey -> NickKey -> IrcMonad () +changeNick oldN newN = do + clientServer %= ircChangeNick oldN newN + clientReg . regdNick %= (\n -> n{nick = newN}) + +associateUserWithNick :: IrcUser -> NickKey -> IrcMonad () +associateUserWithNick usr nn = clientServer . ircUsers . at nn ?= usr + + -- * Pretty Printing ppServiceName :: ServiceName -> ByteString @@ -114,22 +149,36 @@ chanEcho chans iMsg = do msg <- addUserPrefix iMsg findReceivers chans >>= fwdMsg msg +allChans :: IrcMonad [ChanKey] +allChans = do + cs <- runMaybeT $ do + nn <- lift useNick >>= hoistMaybe + usrs <- lift (use $ clientServer . ircUsers) + usr <- hoistMaybe $ M.lookup nn usrs + let chans = S.elems $ usr ^. userChannels + return chans + return $ fromMaybe [] cs + allChanEcho :: IrcMessage -> IrcMonad () allChanEcho iMsg = do - mNick <- useNick - when (isJust mNick) $ do - let nn = fromJust mNick - mUser <- use $ clientServer . ircUsers . at nn - when (isJust mUser) $ do - let usr = fromJust mUser - let chans = S.elems $ usr ^. userChannels - chanEcho chans iMsg + cs <- allChans + chanEcho cs iMsg disconnectUser :: Int -> IrcMessage -> IrcMonad () disconnectUser cid msg = do allChanEcho msg tell [Close cid] +doQuit :: Maybe ByteString -> IrcMonad () +doQuit qmsg = do + connId <- use clientConn + hostname <- fromMaybe "unknown hostname" <$> use clientHost + quitMsg <- renderQuitMsg qmsg + let quitParam = mconcat [":Closing Link: ", hostname, " (", quitMsg, ")"] + let msg = IrcMessage Nothing (Left QUIT) [quitParam] + tellCommand ERROR [quitParam] + disconnectUser connId msg + -- * Command validation utilities type ErrParam = (IrcReply, [IrcParam]) @@ -143,7 +192,7 @@ runValidation :: IrcMonadErr () -> IrcMonad () runValidation = tellErr <=< runEitherT ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr () -ensure p r ps = when p $ left (r, ps) +ensure p r ps = unless p $ left (r, ps) ensureUse :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a ensureUse u e = lift u >>= hoistEither . note e @@ -155,7 +204,7 @@ checkParamLength cmd ps n = checkSuppliedNickname :: [IrcParam] -> IrcMonadErr NickKey checkSuppliedNickname ps = do - ensure (not . null $ ps) err_nonicknamegiven [":must supply a nickname"] + ensure (not $ null ps) err_nonicknamegiven [":must supply a nickname"] return (head ps) checkRegistration :: IrcMonadErr NickKey @@ -166,13 +215,18 @@ checkChannelPresence :: ChanKey -> IrcMonadErr IrcChannel checkChannelPresence ckey = ensureUse (useChan ckey) (err_badchannelkey, [ckey, ":No such channel"]) +checkChannelAbsence :: ChanKey -> IrcMonadErr () +checkChannelAbsence ckey = do + ch <- lift $ useChan ckey + ensure (isNothing ch) mempty mempty + checkUserOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr () checkUserOnChan nn c ch = ensure (chanHasUser nn ch) err_notonchannel [c, ":Not on channel"] checkUserNotOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr () checkUserNotOnChan nn c ch = - ensure (not . chanHasUser nn $ ch) err_notonchannel [c, ":Already on channel"] + ensure (not $ chanHasUser nn ch) err_notonchannel [c, ":Already on channel"] checkInvitation :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr () checkInvitation nn c ch = ensure (ircInviteCheck nn ch) @@ -185,7 +239,7 @@ checkPassKey k c chan = ensure (ircPassCheck k chan) checkNickFree :: NickKey -> IrcMonadErr () checkNickFree nickname = do nickSet <- lift (use $ clientServer . ircNicks) - ensure (S.member nickname nickSet) + ensure (not $ S.member nickname nickSet) err_nicknameinuse [nickname, ":Nickname is already in use."] -- * Adding responses to the Writer portion of the monad diff --git a/src/Pipes/IRC/Server/Log.hs b/src/Pipes/IRC/Server/Log.hs index 03ff10e..e8b6fa1 100644 --- a/src/Pipes/IRC/Server/Log.hs +++ b/src/Pipes/IRC/Server/Log.hs @@ -1,12 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} module Pipes.IRC.Server.Log - ( logMsg ) + ( logMsg + , logLine + , logOutMsg + ) where -import Data.ByteString as BS -import Pipes.IRC.Message.Render -import Pipes.IRC.Message.Types +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Time +import Pipes.IRC.Message +import Pipes.IRC.Server.Types -logMsg :: IrcMessage -> IO () -logMsg msg = BS.putStr $ BS.concat ["LOG: ", renderIrcMessage msg] +logMsg :: IrcMessage -> ByteString -> RegState -> IO () +logMsg msg h userReg = + putLog $ BS.concat ["MSG:", hStr, uStr, renderIrcMessageNoNL msg] + where + hStr = BS.concat [" ", h, " "] + uStr = BS.concat $ case userReg of + Unreg _ (Just nn) Nothing -> [" ", nn, " ? "] + Unreg _ Nothing (Just name) -> [" ? ", name, " "] + Unreg _ (Just nn) (Just name) -> [" ", nn," ", name, " "] + RegUser (NickName nn (Just name) _) -> [" ", nn," ", name, " "] + _ -> [" ? ? "] + +logOutMsg :: IrcMessage -> [Int] -> IO () +logOutMsg msg os = + putLog $ BS.concat [ "OutMSG: " + , BS.intercalate "," $ map (BS.pack . show) os + , ": " + , renderIrcMessageNoNL msg ] + +logLine :: ByteString -> IO () +logLine = putLog + +putLog :: ByteString -> IO () +putLog l = do + now <- getCurrentTime + BS.putStrLn $ BS.concat [BS.pack (show now), " : ", l] diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index 666ad94..c7eaeae 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -5,7 +5,7 @@ module Pipes.IRC.Server.MessageHandler ( ircMessageHandler ) where -import Control.Applicative ((<$>)) +import Control.Applicative (pure, (<$>), (<|>)) import Control.Error import Control.Lens import Control.Monad.RWS @@ -14,7 +14,6 @@ import Data.Set as S import Pipes.IRC.Message.Types import Pipes.IRC.Server.IrcMonad -import Pipes.IRC.Server.Server import Pipes.IRC.Server.Types import Pipes.IRC.Server.Util @@ -43,14 +42,25 @@ regHandler :: IrcMessage -> IrcMonad () regHandler msg@IrcMessage{..} = do pMsg <- addUserPrefix msg case command of - Left PRIVMSG -> handlePRIVMSG pMsg + Left AWAY -> return () + Left INVITE -> return () Left JOIN -> handleJOIN pMsg - Left PART -> handlePART pMsg + Left KICK -> return () + Left KILL -> return () Left LIST -> return () - Left NICK -> return () + Left MODE -> return () + Left NAMES -> return () + Left NICK -> handleNICK pMsg + Left NOTICE -> return () + Left PART -> handlePART pMsg Left PING -> handlePING pMsg Left PONG -> handlePONG pMsg + Left PRIVMSG -> handlePRIVMSG pMsg + Left TOPIC -> return () Left QUIT -> handleQUIT pMsg + Left WHO -> return () + Left WHOIS -> return () + Left WHOWAS -> return () _ -> return () -- * Handlers for messages coming from unregistered users @@ -58,22 +68,22 @@ regHandler msg@IrcMessage{..} = do unregPASS :: IrcMessage -> IrcMonad () unregPASS IrcMessage{..} = runValidation $ do checkParamLength "PASS" params 1 - lift $ clientReg . rcvdPass ?= head params + lift $ storePassKey (head params) unregNICK :: IrcMessage -> IrcMonad () unregNICK IrcMessage{..} = runValidation $ do nickname <- checkSuppliedNickname params checkNickFree nickname lift $ do - clientReg . rcvdNick ?= nickname - clientServer . ircNicks . contains nickname .= True + storeNickKey nickname + reserveNick nickname tryRegistration unregUSER :: IrcMessage -> IrcMonad () unregUSER IrcMessage{..} = runValidation $ do checkParamLength "USER" params 4 lift $ do - clientReg . rcvdName ?= head params + storeUserName (head params) tryRegistration tryRegistration :: IrcMonad () @@ -83,8 +93,8 @@ tryRegistration = do case regState of Unreg _ (Just nickname) (Just name) -> do usr <- mkUser - clientReg .= (RegUser $ NickName nickname (Just name) hostname) - clientServer . ircUsers . at nickname ?= usr + registerUser (RegUser $ NickName nickname (Just name) hostname) + associateUserWithNick usr nickname tellWELCOME nickname tellYOURHOST nickname @@ -107,22 +117,19 @@ handlePONG _ = do -- echoed to channels that the user belongs to handleQUIT :: IrcMessage -> IrcMonad () -handleQUIT msg@IrcMessage{..} = do - connId <- use clientConn - hostname <- fromMaybe "unknown hostname" <$> use clientHost - quitMsg <- renderQuitMsg (headMay params) - let quitParam = mconcat [":Closing Link: ", hostname, " (", quitMsg, ")"] - tellCommand ERROR [quitParam] - disconnectUser connId msg{params = [quitParam]} +handleQUIT IrcMessage{..} = doQuit (headMay params) handleJOIN :: IrcMessage -> IrcMonad () handleJOIN msg@IrcMessage{..} = runValidation $ do checkParamLength "JOIN" params 1 nn <- checkRegistration lift $ case params of + -- Joining channel "0" really means to PART all channels ["0"] -> do cs <- useUserChans nn doPart msg{command=Left PART} (S.elems cs) Nothing + -- No passwords were supplied cs:[] -> doJoin msg $ zipParams (parseParamList cs) [] + -- Some number of passwords were supplied cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks) handlePART :: IrcMessage -> IrcMonad () @@ -135,16 +142,20 @@ handlePART msg@IrcMessage{..} = runValidation $ do doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad () doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do nick <- checkRegistration - chan <- checkChannelPresence c - checkUserNotOnChan nick c chan - checkInvitation nick c chan - checkPassKey k c chan + -- If the channel is absent, joining it will create it + checkChannelAbsence c + -- If it already exists, do some sanity checks first + <|> do chan <- checkChannelPresence c + checkUserNotOnChan nick c chan + checkInvitation nick c chan + checkPassKey k c chan lift $ do - clientServer %= ircJoin nick c + joinNickToChan nick c 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 @@ -155,9 +166,8 @@ doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do lift $ do chanEcho [c] newMsg - rs <- findReceivers [nn] - fwdMsgNoReplace msg rs - clientServer %= ircPart nn c + findReceivers [nn] >>= fwdMsgNoReplace msg + partNickFromChan nn c handlePRIVMSG :: IrcMessage -> IrcMonad () handlePRIVMSG msg@IrcMessage{..} = do @@ -167,3 +177,13 @@ handlePRIVMSG msg@IrcMessage{..} = do rsp:_:_ -> let rs = parseParamList rsp in findReceivers rs >>= fwdMsg msg return () + +handleNICK :: IrcMessage -> IrcMonad () +handleNICK msg@IrcMessage{..} = runValidation $ do + nn <- checkRegistration + newNick <- checkSuppliedNickname params + checkNickFree newNick + lift $ do + cs <- allChans + findReceivers (cs <> [nn]) >>= fwdMsgNoReplace msg + changeNick nn newNick diff --git a/src/Pipes/IRC/Server/Server.hs b/src/Pipes/IRC/Server/Server.hs index 7985495..a63ae7e 100644 --- a/src/Pipes/IRC/Server/Server.hs +++ b/src/Pipes/IRC/Server/Server.hs @@ -9,7 +9,6 @@ module Pipes.IRC.Server.Server where import Control.Lens -import Data.ByteString.Char8 (ByteString) import Data.Map ((!)) import qualified Data.Map as M import Data.Maybe @@ -112,7 +111,7 @@ ircInviteCheck :: NickKey -- ^ nickname of possibly invited user -> IrcChannel -- ^ name of channel to check -> Bool -- ^ may the user join? ircInviteCheck n chan = - chanHasModeFlag InviteOnly chan && not (chanUserIsInvited n chan) + not (chanHasModeFlag InviteOnly chan) || chanUserIsInvited n chan -- | Determine whether the given channel will disallow joining due to -- a missing or incorrect password. A 'True' value indicates that @@ -121,7 +120,7 @@ ircPassCheck :: Maybe PassKey -- ^ password supplied by user -> IrcChannel -- ^ channel to check -> Bool -- ^ may the user join? ircPassCheck k chan = - chanHasPass chan && (isNothing k || not (chanCheckPass (fromJust k) chan)) + not (chanHasPass chan) || (isJust k && chanCheckPass (fromJust k) chan) -- | Change the nickname of a user from 'old' to 'new', updating the -- necessary 'IrcServer' structures. No nick collision check is diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs index a177b46..def112b 100644 --- a/src/Pipes/IRC/Server/Types.hs +++ b/src/Pipes/IRC/Server/Types.hs @@ -8,7 +8,6 @@ module Pipes.IRC.Server.Types where import Control.Concurrent.STM (TVar) -import Control.Error import Control.Lens import Control.Monad.RWS (RWS) import Data.ByteString (ByteString)