From 9278620b756be8951401ec56f3c41e9a5a26b74b Mon Sep 17 00:00:00 2001 From: Levi Pearson Date: Mon, 27 Jan 2014 00:56:22 -0700 Subject: [PATCH] Re-arranged some code, added basic PING/PONG. Also, channels now go away properly when they become empty. --- pipes-irc-server.cabal | 2 + src/Pipes/IRC/Server.hs | 98 ++++--- src/Pipes/IRC/Server/EventHandler.hs | 4 + src/Pipes/IRC/Server/IrcMonad.hs | 391 +++++++++++++++++++++++++ src/Pipes/IRC/Server/MessageHandler.hs | 255 ++++++---------- src/Pipes/IRC/Server/Types.hs | 49 ++-- 6 files changed, 582 insertions(+), 217 deletions(-) create mode 100644 src/Pipes/IRC/Server/IrcMonad.hs diff --git a/pipes-irc-server.cabal b/pipes-irc-server.cabal index 634dbe1..8973397 100644 --- a/pipes-irc-server.cabal +++ b/pipes-irc-server.cabal @@ -25,6 +25,7 @@ executable pipes-irc-server -- other-extensions: build-depends: base >= 4.6 && < 4.7 , mtl >= 2.1 && < 3 + , errors >= 1.4 && < 2 , mmorph >= 1 && < 2 , containers >= 0.5 && < 1 , bytestring >= 0.10 && < 0.11 @@ -38,6 +39,7 @@ executable pipes-irc-server , pipes-attoparsec >= 0.3 && < 1 , pipes-network >= 0.6 && < 1 , stm >= 2 && < 3 + , time >= 1.4 && < 1.5 , async >= 2 && < 3 , free >= 3 && < 4 , lens >= 3 && < 4 diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index c051f16..caac82e 100644 --- a/src/Pipes/IRC/Server.hs +++ b/src/Pipes/IRC/Server.hs @@ -5,6 +5,7 @@ module Pipes.IRC.Server ) where +import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Lens as L @@ -13,6 +14,7 @@ import Control.Monad.RWS import Data.ByteString.Char8 as BS import Data.Map as M import Data.Set as S +import Data.Time.Clock import Network.Socket as NS import Pipes import Pipes.Attoparsec @@ -21,6 +23,7 @@ import Pipes.IRC.Message.Parse import Pipes.IRC.Message.Render import Pipes.IRC.Message.Types import Pipes.IRC.Server.EventHandler +import Pipes.IRC.Server.IrcMonad import Pipes.IRC.Server.Log import Pipes.IRC.Server.MessageHandler import Pipes.IRC.Server.Types @@ -52,16 +55,6 @@ filterMsgs = forever $ do Right c -> do lift $ logMsg c yield c -removeUser :: BS.ByteString -> IrcServer -> IrcServer -removeUser nn ss = - ss & ircNicks %~ S.delete nn - & case M.lookup nn (ss ^. ircUsers) of - Just u -> let ucs = S.elems $ u ^. userChannels in - (ircUsers %~ M.delete nn) . - (ircChannels %~ \chmap -> - Prelude.foldr (M.adjust (chanUsers %~ S.delete nn)) chmap ucs) - Nothing -> id - addIrcConnection :: ServerState -> IrcConnection -> IO Int addIrcConnection srv client = do let clients = srv ^. ircConnections @@ -75,21 +68,17 @@ addIrcConnection srv client = do return cid delIrcConnection :: ServerState -> Int -> IO () -delIrcConnection srv cid = - atomically $ do - let clients = srv ^. ircConnections - srvState = srv ^. ircState - cs <- readTVar clients - case M.lookup cid cs of - -- Connection is unregistered, but has set a nickname - Just IrcConnection{_reg = Unreg{_rcvdNick = Just nn}} -> - modifyTVar' srvState $ removeUser nn - - -- Connection is registered - Just IrcConnection{_reg = RegUser{_regdNick = NickName nn _ _}} -> - modifyTVar' srvState $ removeUser nn - _ -> return () - modifyTVar' clients $ M.delete cid +delIrcConnection srv cid = atomically $ do + cs <- readTVar (srv ^. ircConnections) + case M.lookup cid cs of + Just conn -> do + let nn = case conn ^. reg of + Unreg{ _rcvdNick = Just n } -> n + RegUser{ _regdNick = NickName n _ _ } -> n + _ -> "" + modifyTVar' (srv ^. ircState) $ ircDelUser nn + _ -> return () + modifyTVar' (srv ^. ircConnections) $ M.delete cid cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO () cmdHandler srv cid = @@ -97,12 +86,13 @@ cmdHandler srv cid = in do conns <- liftIO $ readTVarIO $ srv ^. ircConnections case M.lookup cid conns of - Just c -> handle c cReg + Just c -> handle (c ^. hname) cReg Nothing -> return () where - handle conn userReg = do + handle host userReg = do -- wait for the next command nextMsg <- await + curTime <- liftIO getCurrentTime -- run the handler in a transaction (newReg, events) <- liftIO $ atomically $ do @@ -110,21 +100,55 @@ cmdHandler srv cid = let sConf = srv ^. ircConfig let cState = ClientState { _clientReg = userReg , _clientServer = sState - , _clientHost = conn ^. hname - , _clientConn = cid } + , _clientHost = host + , _clientConn = cid + } -- run the handler in the IrcMonad, returning new state and events let (_, newState, events) = - runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState + runRWS (ircMessageHandler nextMsg) sConf cState - writeTVar (_ircState srv) $ _clientServer newState - return (_clientReg newState, events) + writeTVar (srv ^. ircState) $ + newState ^. clientServer + + modifyTVar' (srv ^. ircConnections) $ + M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid + + return (newState ^. clientReg, events) -- handle resulting events aliveL <- liftIO $ forM events $ ircEventHandler srv -- loop for the next command - when (and aliveL) $ handle conn newReg + when (and aliveL) $ handle host newReg + +idlePinger :: ServerState -> Int -> IO () +idlePinger srv cid = + let + pingMsg = IrcMessage Nothing (Left PING) + [":" `append` (srv ^. ircConfig . ircHostName)] + oneMinute = 60 * 1000000 -- microseconds + getLastCom = do conns <- readTVarIO (srv ^. ircConnections) + return $ conns ! cid ^. lastCom + resetPong = atomically $ modifyTVar' (srv ^. ircConnections) $ + 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 listenHandler :: ServerState -> (Socket, SockAddr) -> IO () listenHandler srv (lsock, _) = @@ -135,6 +159,7 @@ listenHandler srv (lsock, _) = (hName, _) <- getNameInfo [] True False caddr (writeEnd, readEnd) <- spawn Unbounded + curTime <- getCurrentTime let client = IrcConnection { _sock = csock @@ -142,6 +167,8 @@ listenHandler srv (lsock, _) = , _hname = fmap BS.pack hName , _out = writeEnd , _reg = Unreg Nothing Nothing Nothing + , _lastCom = curTime + , _gotPong = False } cid <- addIrcConnection srv client @@ -152,11 +179,14 @@ listenHandler srv (lsock, _) = parseMessage sockReader >-> filterMsgs >-> handler link r + idle <- async $ idlePinger srv cid + link idle + w <- async $ runEffect $ fromInput readEnd >-> renderMessage >-> sockWriter link w - void $ waitEither r w + void $ waitAnyCancel [r, w, idle] delIrcConnection srv cid diff --git a/src/Pipes/IRC/Server/EventHandler.hs b/src/Pipes/IRC/Server/EventHandler.hs index a7de0fe..4e790d7 100644 --- a/src/Pipes/IRC/Server/EventHandler.hs +++ b/src/Pipes/IRC/Server/EventHandler.hs @@ -32,3 +32,7 @@ ircEventHandler srv evt = let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest sendToMany _outMsg os return True + Pong {..} -> do + atomically $ modifyTVar' (srv ^. ircConnections) $ + M.adjust (gotPong .~ False) _pongConn + return True diff --git a/src/Pipes/IRC/Server/IrcMonad.hs b/src/Pipes/IRC/Server/IrcMonad.hs new file mode 100644 index 0000000..54c03af --- /dev/null +++ b/src/Pipes/IRC/Server/IrcMonad.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Pipes.IRC.Server.IrcMonad +where + +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 (catMaybes, fromJust, fromMaybe, + isJust, isNothing) +import qualified Data.Set as S +import Pipes.IRC.Message.Types +import Pipes.IRC.Server.Types + + +-- | IrcUser management + +mkUser :: IrcMonad IrcUser +mkUser = do + conn <- use clientConn + srvname <- view ircHostName + return $ newUser srvname conn + +newUser :: ByteString -> Int -> IrcUser +newUser srvname cid = + IrcUser { _userServerName = srvname + , _userModes = S.empty + , _userChannels = S.empty + , _userConn = cid + , _userInvites = S.empty + } + +userAddChan, userDelChan :: ByteString -> IrcUser -> IrcUser +userAddChan cn = userChannels %~ S.insert cn +userDelChan cn = userChannels %~ S.delete cn + +userAddMode, userDelMode :: IrcUserMode -> IrcUser -> IrcUser +userAddMode um = userModes %~ S.insert um +userDelMode um = userModes %~ S.delete um + +userAddInvite, userDelInvite :: ByteString -> IrcUser -> IrcUser +userAddInvite cn = userInvites %~ S.insert cn +userDelInvite cn = userInvites %~ S.delete cn + +userHasMode :: IrcUserMode -> IrcUser -> Bool +userHasMode um usr = S.member um $ usr ^. userModes + +userInChan :: ByteString -> IrcUser -> Bool +userInChan cn usr = S.member cn $ usr ^. userChannels + +-- | IrcChannel management + +newChannel :: ByteString -> IrcChannel +newChannel creator = IrcChannel { _chanTopic = Nothing + , _chanKey = Nothing + , _chanModeFlags = S.empty + , _chanUsers = S.fromList [creator] + , _chanOpers = S.fromList [creator] + , _chanVoices = S.empty + , _chanInvites = S.empty + } + +chanAddModeFlag, chanDelModeFlag :: IrcChanModeFlags -> IrcChannel -> IrcChannel +chanAddModeFlag cm = chanModeFlags %~ S.insert cm +chanDelModeFlag cm = chanModeFlags %~ S.delete cm + +chanAddUser, chanDelUser :: ByteString -> IrcChannel -> IrcChannel +chanAddUser un = chanUsers %~ S.insert un +chanDelUser un = (chanUsers %~ S.delete un) + . (chanOpers %~ S.delete un) + . (chanVoices %~ S.delete un) + +chanHasUser :: ByteString -> IrcChannel -> Bool +chanHasUser un ch = S.member un $ ch ^. chanUsers + +chanSetTopic :: ByteString -> IrcChannel -> IrcChannel +chanSetTopic top = chanTopic .~ Just top + +chanHasTopic :: IrcChannel -> Bool +chanHasTopic ch = isJust $ ch ^. chanTopic + +chanHasModeFlag :: IrcChanModeFlags -> IrcChannel -> Bool +chanHasModeFlag cm ch = S.member cm $ ch ^. chanModeFlags + +chanSigil :: IrcChannel -> ByteString +chanSigil ch | chanHasModeFlag Secret ch = "@" + | chanHasModeFlag Private ch = "*" + | otherwise = "=" + +chanUserSigil :: ByteString -> IrcChannel -> ByteString +chanUserSigil un ch | S.member un $ ch ^. chanOpers = "@" + | S.member un $ ch ^. chanVoices = "+" + | otherwise = "" + +chanSetKey :: ByteString -> IrcChannel -> IrcChannel +chanSetKey key = chanKey .~ Just key + +chanHasKey :: IrcChannel -> Bool +chanHasKey ch = isJust $ ch ^. chanKey + +chanCheckKey :: ByteString -> IrcChannel -> Bool +chanCheckKey key ch = case ch ^. chanKey of + Just chKey -> key == chKey + Nothing -> True + +chanAddOper, chanDelOper :: ByteString -> IrcChannel -> IrcChannel +chanAddOper un = chanOpers %~ S.insert un +chanDelOper un = chanOpers %~ S.delete un + +chanAddVoice, chanDelVoice :: ByteString -> IrcChannel -> IrcChannel +chanAddVoice un = chanVoices %~ S.insert un +chanDelVoice un = chanVoices %~ S.delete un + +chanAddInvite, chanDelInvite :: ByteString -> IrcChannel -> IrcChannel +chanAddInvite un = chanInvites %~ S.insert un +chanDelInvite un = chanInvites %~ S.delete un + +chanUserIsOper :: ByteString -> IrcChannel -> Bool +chanUserIsOper un ch = S.member un $ ch ^. chanOpers + +chanUserHasVoice :: ByteString -> IrcChannel -> Bool +chanUserHasVoice un ch = S.member un $ ch ^. chanVoices + +chanUserIsInvited :: ByteString -> IrcChannel -> Bool +chanUserIsInvited un ch = S.member un $ ch ^. chanInvites + +chanUserMaySpeak :: ByteString -> IrcChannel -> Bool +chanUserMaySpeak un ch + | (chanHasUser un ch || not (chanHasModeFlag NoOutsideMsgs ch)) + && not (chanHasModeFlag Moderated ch) = True + | chanUserIsOper un ch = True + | chanUserHasVoice un ch = True + | otherwise = False + +chanUserMayJoin :: ByteString -> IrcChannel -> Bool +chanUserMayJoin un ch | not $ chanHasModeFlag InviteOnly ch = True + | chanUserIsInvited un ch = True + | otherwise = False + +chanUserMaySetTopic :: ByteString -> IrcChannel -> Bool +chanUserMaySetTopic un ch + | not (chanHasModeFlag TopicOperOnly ch) && + chanHasUser un ch = True + | chanUserIsOper un ch = True + | otherwise = False + +-- | IrcServer management + +ircAddUser :: ByteString -> IrcUser -> IrcServer -> IrcServer +ircAddUser nn usr = ircUsers %~ M.insert nn usr + +ircDelUser :: ByteString -> IrcServer -> IrcServer +ircDelUser nn srv = + srv & ircNicks %~ S.delete nn + & if ircHasUser nn srv then let + Just usr = M.lookup nn $ srv ^. ircUsers + uchans = S.elems (usr ^. userChannels) + ichans = S.elems (usr ^. userInvites) + in + (ircUsers %~ M.delete nn) . + (ircChannels %~ \cs -> foldr (M.alter $ ircPartChan nn) cs uchans) . + (ircChannels %~ \cs -> foldr (M.adjust $ chanDelInvite nn) cs ichans) + else id + +ircHasUser :: ByteString -> IrcServer -> Bool +ircHasUser nn srv = isJust $ M.lookup nn (srv ^. ircUsers) + +ircHasChan :: ByteString -> IrcServer -> Bool +ircHasChan cn srv = isJust $ M.lookup cn (srv ^. ircChannels) + +ircJoin :: ByteString -> ByteString -> IrcServer -> IrcServer +ircJoin un cn = (ircChannels %~ M.alter alterChan cn) + . (ircUsers %~ M.adjust (userAddChan cn) un) + where + alterChan mChan = Just $ chanAddUser un (fromMaybe (newChannel un) mChan) + +ircPartChan :: ByteString -> Maybe IrcChannel -> Maybe IrcChannel +ircPartChan un chan = case chanDelUser un (fromJust chan) of + IrcChannel{ _chanUsers = us } + | us == S.empty -> Nothing + chan' -> Just chan' + +ircPart :: ByteString -> ByteString -> IrcServer -> IrcServer +ircPart un cn srv = + srv & (ircChannels %~ (M.alter $ ircPartChan un) cn) + & (ircUsers %~ \us -> foldr (M.adjust $ userDelInvite cn) us iusers) + where + chan = fromJust $ M.lookup cn (srv ^. ircChannels) + iusers = S.elems $ chan ^. chanInvites + +ircInvite :: ByteString -> ByteString -> IrcServer -> IrcServer +ircInvite un cn = (ircChannels %~ M.adjust (chanAddInvite un) cn) + . (ircUsers %~ M.adjust (userAddInvite cn) un) + +ircInviteCheck :: ByteString -> IrcChannel -> Bool +ircInviteCheck n chan = + chanHasModeFlag InviteOnly chan && not (chanUserIsInvited n chan) + +ircKeyCheck :: Maybe ByteString -> IrcChannel -> Bool +ircKeyCheck k chan = + chanHasKey chan && (isNothing k || not (chanCheckKey (fromJust k) chan)) + +-- | Misc + +parseParamList :: ByteString -> [ByteString] +parseParamList ps = filter (not . BS.null) $ BS.split ',' ps + +zipParams :: [ByteString] -> [ByteString] + -> [(ByteString, Maybe ByteString)] +zipParams chans chkeys = zip chans (map Just chkeys ++ repeat Nothing) + +-- | Pretty Printing + +ppServiceName :: ServiceName -> ByteString +ppServiceName = BS.pack + +ppHostPreference :: HostPreference -> ByteString +ppHostPreference hp = case hp of + HostAny -> "*" + HostIPv4 -> "*4" + HostIPv6 -> "*6" + Host hn -> BS.pack hn + +-- | Monadic utilities + +useChan :: ByteString -> IrcMonad (Maybe IrcChannel) +useChan cname = fmap (M.lookup cname) $ use (clientServer . ircChannels) + +useNick :: IrcMonad (Maybe ByteString) +useNick = do + regState <- use clientReg + return $ case regState of + Unreg _ (Just nn) _ -> Just nn + RegUser (NickName nn _ _) -> Just nn + _ -> Nothing + +validateNick :: ByteString -> IrcMonad Bool +validateNick nickname = do + nickSet <- use $ clientServer . ircNicks + if S.member nickname nickSet + then do + tellNumeric err_nicknameinuse [nickname, ":Nickname is already in use."] + return False + else return True + +channelTargets :: ByteString -> IrcMonad [Int] +channelTargets chname = do + srv <- use clientServer + Just mynick <- useNick + let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers) + let chmap = srv ^. ircChannels + case M.lookup chname chmap of + Just chan -> fmap catMaybes $ forM (cUsers chan) userTarget + _ -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"] + return [] + +userTarget :: ByteString -> IrcMonad (Maybe Int) +userTarget uname = do + srv <- use clientServer + let umap = srv ^. ircUsers + case M.lookup uname umap of + Just u -> return . Just $ u ^. userConn + _ -> do tellNumeric err_nosuchnick [uname, ":No such nick/channel"] + return Nothing + +findReceivers :: [ByteString] -> IrcMonad [([Int], ByteString)] +findReceivers rcvNames = + fmap catMaybes $ forM rcvNames $ \name -> + if BS.head name == '#' + then do + cids <- channelTargets name + return $ case cids of + [] -> Nothing + cs -> Just (cs, name) + else do + cid <- userTarget name + return $ case cid of + Just c -> Just ([c], name) + Nothing -> Nothing + +fwdMsg :: IrcMessage -> [([Int], ByteString)] -> IrcMonad () +fwdMsg msg rcvs = forM_ rcvs $ \(cId, n) -> do + -- replace multiple targets with the single target we're doing + let m = msg{ params = n : tail (params msg) } + tell [Msg m cId] + +fwdMsgNoReplace :: IrcMessage -> [([Int], ByteString)] -> IrcMonad () +fwdMsgNoReplace msg rcvs = do + m <- addUserPrefix msg + forM_ rcvs $ \(cId, _) -> tell [Msg m cId] + + +addUserPrefix :: IrcMessage -> IrcMonad IrcMessage +addUserPrefix msg = do + regState <- use clientReg + return $ case regState ^? regdNick of + Just nickname -> msg{ prefix = Just . Right $ nickname } + _ -> msg{ prefix = Nothing } + +chanEcho :: [ByteString] -> IrcMessage -> IrcMonad () +chanEcho chans iMsg = do + msg <- addUserPrefix iMsg + findReceivers chans >>= fwdMsg msg + +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 + +-- | Adding responses to the Writer portion of the monad + +tellYOURHOST :: ByteString -> IrcMonad () +tellYOURHOST nickname = do + srvname <- view ircHostName + srvhost <- view ircHost + srvport <- view ircPort + version <- use $ clientServer . ircVersion + let hostStr = ppHostPreference srvhost + portStr = ppServiceName srvport + tellNumeric rpl_yourhost + [ nickname + , BS.concat [ ":Your host is ", srvname + , "[", hostStr, "/", portStr, "], " + , "running version ", version ] + ] + +tellMOTD :: ByteString -> IrcMonad () +tellMOTD nickname = do + motd <- view ircMotd + tellNumeric rpl_motdstart [nickname, ":- Message of the Day -"] + forM_ motd $ \line -> + tellNumeric rpl_motd [nickname, ":- " `BS.append` line] + tellNumeric rpl_endofmotd [nickname, ":End of MOTD"] + +tellWELCOME :: ByteString -> IrcMonad () +tellWELCOME nickname = do + srvname <- view ircHostName + tellNumeric rpl_welcome [ nickname + , BS.append ":Welcome to IRC on " srvname ] + +tellTOPIC :: ByteString -> 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] + Nothing -> return () + +tellNAMES :: [ByteString] -> IrcMonad () +tellNAMES cnames = do + Just nn <- useNick + forM_ cnames $ \cname -> do + mChan <- use $ clientServer . ircChannels . at cname + case mChan of + Just chan -> do + let chanType = chanSigil chan + nickL <- forM (S.elems $ chan ^. chanUsers) $ \uname -> + return $ BS.append (chanUserSigil uname chan) uname + let cUsers = BS.append ":" (BS.intercalate " " nickL) + tellNumeric rpl_namreply [nn, chanType, cname, cUsers] + tellNumeric rpl_endofnames [nn, head cnames, ":End of /NAMES list"] + Nothing -> return () + +tellPrefixedCommand :: IrcCommand -> [IrcParam] -> IrcMonad () +tellPrefixedCommand reply desc = do + srvname <- view ircHostName + connId <- use clientConn + let msg = IrcMessage (Just $ Left srvname) (Left reply) desc + tell [Msg msg [connId]] + +tellCommand :: IrcCommand -> [IrcParam] -> IrcMonad () +tellCommand reply desc = do + connId <- use clientConn + let msg = IrcMessage Nothing (Left reply) desc + tell [Msg msg [connId]] + +tellNumeric :: IrcReply -> [IrcParam] -> IrcMonad () +tellNumeric reply desc = do + srvname <- view ircHostName + connId <- use clientConn + let msg = IrcMessage (Just $ Left srvname) (Right reply) desc + tell [Msg msg [connId]] + return () diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index a610484..93fdaea 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -5,17 +5,18 @@ module Pipes.IRC.Server.MessageHandler ( ircMessageHandler ) where +import Control.Error import Control.Lens import Control.Monad.RWS -import qualified Data.ByteString.Char8 as BS -import Data.Map as M +import qualified Data.ByteString.Char8 as BS +import Data.Map as M import Data.Maybe -import Data.Set as S +import Data.Set as S import Pipes.IRC.Message.Types +import Pipes.IRC.Server.IrcMonad import Pipes.IRC.Server.Types - ircMessageHandler :: IrcMessage -> IrcMonad () ircMessageHandler msg = -- drop messages that have prefixes (until we have Server links) @@ -32,26 +33,19 @@ unregHandler msg@IrcMessage{..} = Left PASS -> unregPASS msg Left NICK -> unregNICK msg Left USER -> unregUSER msg + Left PONG -> handlePONG msg + Left PING -> handlePING msg Left QUIT -> handleQUIT msg _ -> return () unregPASS :: IrcMessage -> IrcMonad () unregPASS IrcMessage{..} = if length params < 1 - then tellNumeric err_needmoreparams [":Need more parameters"] + then tellNumeric err_needmoreparams ["PASS", ":Need more parameters"] else do clientReg . rcvdPass .= (Just $ head params) return () -validateNick :: BS.ByteString -> IrcMonad Bool -validateNick nickname = do - nickSet <- use $ clientServer . ircNicks - if S.member nickname nickSet - then do - tellNumeric err_nicknameinuse [nickname, ":Nickname is already in use."] - return False - else return True - unregNICK :: IrcMessage -> IrcMonad () unregNICK IrcMessage{..} = if length params /= 1 @@ -66,19 +60,11 @@ unregNICK IrcMessage{..} = unregUSER :: IrcMessage -> IrcMonad () unregUSER IrcMessage{..} = if length params < 4 - then tellNumeric err_needmoreparams [":need more parameters"] + then tellNumeric err_needmoreparams ["USER", ":need more parameters"] else do clientReg . rcvdName .= (Just $ head params) tryRegistration -useNick :: IrcMonad (Maybe BS.ByteString) -useNick = do - regState <- use clientReg - return $ case regState of - Unreg _ (Just nick) _ -> Just nick - RegUser (NickName nick _ _) -> Just nick - _ -> Nothing - renderQuitMsg :: Maybe BS.ByteString -> IrcMonad BS.ByteString renderQuitMsg (Just msg) = return $ BS.append "Quit: " msg renderQuitMsg Nothing = useNick >>= \nickname -> @@ -86,17 +72,18 @@ renderQuitMsg Nothing = useNick >>= \nickname -> Just nick -> BS.append "Quit: " nick Nothing -> "" -chanEcho :: IrcMessage -> IrcMonad () -chanEcho iMsg = do - mNick <- useNick - when (isJust mNick) $ do - let nick = fromJust mNick - msg <- addUserPrefix iMsg - mUser <- fmap (M.lookup nick) $ use (clientServer . ircUsers) - when (isJust mUser) $ do - let user = fromJust mUser - let chans = S.elems $ user ^. userChannels - findReceivers chans >>= fwdMsg msg +handlePING :: IrcMessage -> IrcMonad () +handlePING _ = do + srvname <- view ircHostName + tellCommand PONG [":" <> srvname] + +handlePONG :: IrcMessage -> IrcMonad () +handlePONG _ = do + cid <- use clientConn + tell [Pong cid] + +-- JOIN, MODE, KICK, PART, QUIT and of course PRIVMSG/NOTICE need to be +-- echoed to channels that the user belongs to doQuit :: IrcMessage -> Maybe BS.ByteString -> IrcMonad () doQuit msg quitParamIn = do @@ -107,7 +94,7 @@ doQuit msg quitParamIn = do let quitParam = BS.concat [ ":Closing Link: ", hoststr , " (", quitMsg, ")"] tellCommand ERROR [quitParam] - chanEcho msg + allChanEcho msg{params = [quitParam]} tell [Close connId] return () @@ -117,16 +104,72 @@ handleQUIT msg@IrcMessage{..} = [] -> Nothing p:_ -> Just p -mkUser :: NickName -> IrcMonad IrcUser -mkUser nn = do - conn <- use clientConn - srvname <- view ircHostName - return IrcUser { _userNick = nn - , _userServerName = srvname - , _userModes = S.empty - , _userChannels = S.empty - , _userConn = conn - } +handleJOIN :: IrcMessage -> IrcMonad () +handleJOIN msg@IrcMessage{..} = + case params of + [] -> tellNumeric err_needmoreparams ["JOIN", ":Not enough parameters"] + ["0"] -> do + Just nn <- useNick + cs <- use $ clientServer . ircUsers . at nn + let Just chans = fmap (^. userChannels) cs + doPart msg{command=Left PART} (S.elems chans) Nothing + cs:[] -> doJoin msg $ zipParams (parseParamList cs) [] + cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks) + +handlePART :: IrcMessage -> IrcMonad () +handlePART msg@IrcMessage{..} = + case params of + [] -> tellNumeric err_needmoreparams ["PART", ":Not enough parameters"] + cs:[] -> doPart msg (parseParamList cs) Nothing + cs:pm:_ -> doPart msg (parseParamList cs) (Just pm) + +tellErr :: IrcReply -> [IrcParam] -> IrcMonadErr () +tellErr r ps = lift (tellNumeric r ps) >> left [] + +checkRegistration :: IrcMonadErr BS.ByteString +checkRegistration = do + mNick <- lift useNick + when (isNothing mNick) $ + tellErr err_notregistered [":You have not registered"] + right $ fromJust mNick + +doJoin :: IrcMessage -> [(BS.ByteString, Maybe BS.ByteString)] -> IrcMonad () +doJoin msg chans = forM_ chans $ \(c, k) -> runEitherT $ do + nick <- checkRegistration + mChan <- lift $ useChan c + when (isJust mChan) $ do + let chan = fromJust mChan + + when (chanHasUser nick chan) $ left "already on channel" + + when (ircInviteCheck nick chan) $ + tellErr err_inviteonlychan [c, ":Cannot join channel (+i)"] + + when (ircKeyCheck k chan) $ + tellErr err_badchannelkey [c, ":Cannot join channel (+k)"] + + lift $ do + clientServer %= ircJoin nick c + tellTOPIC c + tellNAMES [c] + chanEcho [c] msg + +doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad () +doPart msg chans pmsg = forM_ chans $ \c -> runEitherT $ do + nn <- checkRegistration + mChan <- lift . use $ clientServer . ircChannels . at c + when (isNothing mChan) $ tellErr err_nosuchchannel [c, ":No such channel"] + let ch = fromJust mChan + unless (chanHasUser nn ch) $ tellErr err_notonchannel [c, ":Not on channel"] + + lift $ do + let plist = case pmsg of + Just bs -> [c, BS.append ":" bs] + Nothing -> [c] + let newMsg = msg{params = plist} + chanEcho [c] newMsg + findReceivers [nn] >>= fwdMsgNoReplace msg + clientServer %= ircPart nn c tryRegistration :: IrcMonad () tryRegistration = do @@ -136,30 +179,25 @@ tryRegistration = do Unreg _ (Just nickname) (Just name) -> do let nn = NickName nickname (Just name) hostname clientReg .= RegUser nn - newUser <- mkUser nn - clientServer . ircUsers %= M.insert nickname newUser + usr <- mkUser + clientServer . ircUsers %= M.insert nickname usr tellWELCOME nickname tellYOURHOST nickname tellMOTD nickname _ -> return () -addUserPrefix :: IrcMessage -> IrcMonad IrcMessage -addUserPrefix msg = do - regState <- use clientReg - return $ case regState ^? regdNick of - Just nickname -> msg{ prefix = Just . Right $ nickname } - _ -> msg{ prefix = Nothing } - regHandler :: IrcMessage -> IrcMonad () regHandler msg@IrcMessage{..} = do pMsg <- addUserPrefix msg case command of Left PRIVMSG -> handlePRIVMSG pMsg - Left JOIN -> return () - Left PART -> return () + Left JOIN -> handleJOIN pMsg + Left PART -> handlePART pMsg Left LIST -> return () Left NICK -> return () + Left PING -> handlePING pMsg + Left PONG -> handlePONG pMsg Left QUIT -> handleQUIT pMsg _ -> return () @@ -168,109 +206,6 @@ handlePRIVMSG msg@IrcMessage{..} = do case params of [] -> tellNumeric err_norecipient [] _:[] -> tellNumeric err_notexttosend [] - rsp:_:_ -> let rs = Prelude.filter (not . BS.null) $ BS.split ',' rsp + rsp:_:_ -> let rs = parseParamList rsp in findReceivers rs >>= fwdMsg msg return () - -channelTargets :: BS.ByteString -> IrcMonad [Int] -channelTargets chname = do - srv <- use clientServer - Just mynick <- useNick - let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers) - let chmap = srv ^. ircChannels - case M.lookup chname chmap of - Just chan -> fmap catMaybes $ forM (cUsers chan) userTarget - _ -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"] - return [] - -userTarget :: BS.ByteString -> IrcMonad (Maybe Int) -userTarget uname = do - srv <- use clientServer - let umap = srv ^. ircUsers - case M.lookup uname umap of - Just user -> return . Just $ user ^. userConn - _ -> do tellNumeric err_nosuchnick [uname, ":No such nick/channel"] - return Nothing - -findReceivers :: [BS.ByteString] -> IrcMonad [([Int], BS.ByteString)] -findReceivers rcvNames = - fmap catMaybes $ forM rcvNames $ \name -> - if BS.head name == '#' - then do - cids <- channelTargets name - return $ case cids of - [] -> Nothing - cs -> Just (cs, name) - else do - cid <- userTarget name - return $ case cid of - Just c -> Just ([c], name) - Nothing -> Nothing - -fwdMsg :: IrcMessage -> [([Int], BS.ByteString)] -> IrcMonad () -fwdMsg msg rcvs = forM_ rcvs $ \ (cId, n) -> do - -- replace multiple targets with the single target we're doing - let m = msg{ params = n : tail (params msg) } - tell [Msg m cId] - -tellNumeric :: IrcReply -> [IrcParam] -> IrcMonad () -tellNumeric reply desc = do - srvname <- view ircHostName - connId <- use clientConn - let msg = IrcMessage (Just $ Left srvname) (Right reply) desc - tell [Msg msg [connId]] - return () - -{- -tellPrefixedCommand :: IrcCommand -> [IrcParam] -> IrcMonad () -tellPrefixedCommand reply desc = do - srvname <- view ircHostName - connId <- use clientConn - let msg = IrcMessage (Just $ Left srvname) (Left reply) desc - tell [Msg msg [connId]] --} - -tellCommand :: IrcCommand -> [IrcParam] -> IrcMonad () -tellCommand reply desc = do - connId <- use clientConn - let msg = IrcMessage Nothing (Left reply) desc - tell [Msg msg [connId]] - -ppHostPreference :: HostPreference -> BS.ByteString -ppHostPreference hp = case hp of - HostAny -> "*" - HostIPv4 -> "*4" - HostIPv6 -> "*6" - Host hn -> BS.pack hn - -ppServiceName :: ServiceName -> BS.ByteString -ppServiceName = BS.pack - -tellYOURHOST :: BS.ByteString -> IrcMonad () -tellYOURHOST nickname = do - srvname <- view ircHostName - srvhost <- view ircHost - srvport <- view ircPort - version <- use $ clientServer . ircVersion - let hostStr = ppHostPreference srvhost - portStr = ppServiceName srvport - tellNumeric rpl_yourhost - [ nickname - , BS.concat [ ":Your host is ", srvname - , "[", hostStr, "/", portStr, "], " - , "running version ", version ] - ] - -tellMOTD :: BS.ByteString -> IrcMonad () -tellMOTD nickname = do - motd <- view ircMotd - tellNumeric rpl_motdstart [nickname, ":- Message of the Day -"] - forM_ motd $ \line -> - tellNumeric rpl_motd [nickname, ":- " `BS.append` line] - tellNumeric rpl_endofmotd [nickname, ":End of MOTD"] - -tellWELCOME :: BS.ByteString -> IrcMonad () -tellWELCOME nickname = do - srvname <- view ircHostName - tellNumeric rpl_welcome [ nickname - , BS.append ":Welcome to IRC on " srvname ] diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs index 7a1817b..023525d 100644 --- a/src/Pipes/IRC/Server/Types.hs +++ b/src/Pipes/IRC/Server/Types.hs @@ -8,12 +8,13 @@ module Pipes.IRC.Server.Types where import Control.Concurrent.STM (TVar) +import Control.Error import Control.Lens -import Control.Monad.RWS (MonadReader, MonadState, MonadWriter, - RWS) +import Control.Monad.RWS (RWS) import Data.ByteString (ByteString) import Data.Map (Map) import Data.Set (Set) +import Data.Time.Clock (UTCTime) import Pipes.Concurrent (Output) import Pipes.IRC.Message.Types (IrcMessage, NickName) import Pipes.Network.TCP (HostPreference (..), ServiceName, @@ -25,30 +26,35 @@ data IrcEvent = Msg { _outMsg :: !IrcMessage , _outDest :: ![Int] } | Close { _closeConn :: Int } + | Pong { _pongConn :: Int } deriving (Show) makeLenses ''IrcEvent data IrcUserMode = Away | Invisible | WallOps | Restricted | Oper | LocalOper | ServerNotices - deriving (Show, Eq, Enum) + deriving (Show, Eq, Enum, Ord) data IrcUser = - IrcUser { _userNick :: !NickName - , _userServerName :: !ByteString + IrcUser { _userServerName :: !ByteString , _userModes :: !(Set IrcUserMode) , _userChannels :: !(Set ByteString) , _userConn :: !Int + , _userInvites :: !(Set ByteString) } deriving (Show, Eq) makeLenses ''IrcUser -data IrcChanMode = Anonymous | InviteOnly | Moderated | Quiet | Secret - deriving (Show, Eq, Enum) +data IrcChanModeFlags = Anonymous | InviteOnly | Moderated | NoOutsideMsgs + | Quiet | Private | Secret | TopicOperOnly + deriving (Show, Eq, Enum, Ord) data IrcChannel = - IrcChannel { _chanName :: !ByteString - , _chanTopic :: !ByteString - , _chanModes :: !(Set IrcChanMode) - , _chanUsers :: !(Set ByteString) + IrcChannel { _chanTopic :: !(Maybe ByteString) + , _chanKey :: !(Maybe ByteString) + , _chanModeFlags :: !(Set IrcChanModeFlags) + , _chanUsers :: !(Set ByteString) + , _chanOpers :: !(Set ByteString) + , _chanVoices :: !(Set ByteString) + , _chanInvites :: !(Set ByteString) } deriving (Show, Eq) makeLenses ''IrcChannel @@ -77,11 +83,13 @@ data RegState = Unreg { _rcvdPass :: !(Maybe ByteString) makeLenses ''RegState data IrcConnection = - IrcConnection { _sock :: !Socket - , _addr :: !SockAddr - , _hname :: !(Maybe ByteString) - , _out :: !(Output IrcMessage) - , _reg :: !RegState + IrcConnection { _sock :: !Socket + , _addr :: !SockAddr + , _hname :: !(Maybe ByteString) + , _out :: !(Output IrcMessage) + , _reg :: !RegState + , _lastCom :: !UTCTime + , _gotPong :: !Bool } makeLenses ''IrcConnection @@ -101,10 +109,5 @@ data ClientState = } deriving (Show) makeLenses ''ClientState -newtype IrcMonad a = - IrcMonad { runIrc :: RWS IrcConfig IrcEvents ClientState a } - deriving ( Monad - , Functor - , MonadReader IrcConfig - , MonadWriter IrcEvents - , MonadState ClientState) +type IrcMonad a = RWS IrcConfig IrcEvents ClientState a +type IrcMonadErr a = EitherT String (RWS IrcConfig IrcEvents ClientState) a