diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index caac82e..1210c72 100644 --- a/src/Pipes/IRC/Server.hs +++ b/src/Pipes/IRC/Server.hs @@ -23,9 +23,9 @@ 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.Server import Pipes.IRC.Server.Types import Pipes.Network.TCP as PN diff --git a/src/Pipes/IRC/Server/Channel.hs b/src/Pipes/IRC/Server/Channel.hs new file mode 100644 index 0000000..101c8a7 --- /dev/null +++ b/src/Pipes/IRC/Server/Channel.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module contains various pure functions for transforming the state of +-- 'IrcChannel' structures as a result of executing IRC commands. +module Pipes.IRC.Server.Channel + ( newChannel + , chanAddModeFlag + , chanDelModeFlag + , chanAddUser + , chanDelUser + , chanHasUser + , chanSetTopic + , chanHasTopic + , chanHasModeFlag + , chanSigil + , chanUserSigil + , chanSetPass + , chanHasPass + , chanCheckPass + , chanAddOper + , chanDelOper + , chanAddVoice + , chanDelVoice + , chanAddInvite + , chanDelInvite + , chanChangeNick + , chanUserIsOper + , chanUserHasVoice + , chanUserIsInvited + , chanUserMaySpeak + , chanUserMayJoin + , chanUserMaySetTopic + ) +where + +import Control.Lens +import Data.ByteString.Char8 (ByteString) +import Data.Maybe (isJust) +import Data.Set (delete, empty, fromList, insert, + member) + +import Pipes.IRC.Server.Types + +newChannel :: NickKey -> IrcChannel +newChannel creator = IrcChannel { _chanTopic = Nothing + , _chanPass = Nothing + , _chanModeFlags = empty + , _chanUsers = fromList [creator] + , _chanOpers = fromList [creator] + , _chanVoices = empty + , _chanInvites = empty + } + +chanAddModeFlag, chanDelModeFlag :: IrcChanModeFlags -> IrcChannel -> IrcChannel +chanAddModeFlag cm = chanModeFlags %~ insert cm +chanDelModeFlag cm = chanModeFlags %~ delete cm + +chanAddUser, chanDelUser :: NickKey -> IrcChannel -> IrcChannel +chanAddUser un = chanUsers %~ insert un +chanDelUser un = (chanUsers %~ delete un) + . (chanOpers %~ delete un) + . (chanVoices %~ delete un) + +chanHasUser :: NickKey -> IrcChannel -> Bool +chanHasUser un ch = 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 = member cm $ ch ^. chanModeFlags + +chanSigil :: IrcChannel -> ByteString +chanSigil ch | chanHasModeFlag Secret ch = "@" + | chanHasModeFlag Private ch = "*" + | otherwise = "=" + +chanUserSigil :: NickKey -> IrcChannel -> ByteString +chanUserSigil un ch | member un $ ch ^. chanOpers = "@" + | member un $ ch ^. chanVoices = "+" + | otherwise = "" + +chanSetPass :: ByteString -> IrcChannel -> IrcChannel +chanSetPass pwd = chanPass .~ Just pwd + +chanHasPass :: IrcChannel -> Bool +chanHasPass ch = isJust $ ch ^. chanPass + +chanCheckPass :: ByteString -> IrcChannel -> Bool +chanCheckPass pwd ch = case ch ^. chanPass of + Just chPass -> pwd == chPass + Nothing -> True + +chanAddOper, chanDelOper :: NickKey -> IrcChannel -> IrcChannel +chanAddOper un = chanOpers %~ insert un +chanDelOper un = chanOpers %~ delete un + +chanAddVoice, chanDelVoice :: NickKey -> IrcChannel -> IrcChannel +chanAddVoice un = chanVoices %~ insert un +chanDelVoice un = chanVoices %~ delete un + +chanAddInvite, chanDelInvite :: NickKey -> IrcChannel -> IrcChannel +chanAddInvite un = chanInvites %~ insert un +chanDelInvite un = chanInvites %~ delete un + +chanChangeNick :: NickKey -> NickKey -> IrcChannel -> IrcChannel +chanChangeNick old new ch = (chOps . chVoice . chInvite . chUsers) ch + where + chOps + | chanUserIsOper old ch = chanDelOper old . chanAddOper new + | otherwise = id + chVoice + | chanUserHasVoice old ch = chanDelVoice old . chanAddVoice new + | otherwise = id + chInvite + | chanUserIsInvited old ch = chanDelInvite old . chanAddInvite new + | otherwise = id + chUsers + | chanHasUser old ch = chanDelUser old . chanAddUser new + | otherwise = id + +chanUserIsOper :: NickKey -> IrcChannel -> Bool +chanUserIsOper un ch = member un $ ch ^. chanOpers + +chanUserHasVoice :: NickKey -> IrcChannel -> Bool +chanUserHasVoice un ch = member un $ ch ^. chanVoices + +chanUserIsInvited :: NickKey -> IrcChannel -> Bool +chanUserIsInvited un ch = member un $ ch ^. chanInvites + +chanUserMaySpeak :: NickKey -> 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 :: NickKey -> IrcChannel -> Bool +chanUserMayJoin un ch + | not $ chanHasModeFlag InviteOnly ch = True + | chanUserIsInvited un ch = True + | otherwise = False + +chanUserMaySetTopic :: NickKey -> IrcChannel -> Bool +chanUserMaySetTopic un ch + | not (chanHasModeFlag TopicOperOnly ch) && + chanHasUser un ch = True + | chanUserIsOper un ch = True + | otherwise = False diff --git a/src/Pipes/IRC/Server/IrcMonad.hs b/src/Pipes/IRC/Server/IrcMonad.hs index 54c03af..accf27c 100644 --- a/src/Pipes/IRC/Server/IrcMonad.hs +++ b/src/Pipes/IRC/Server/IrcMonad.hs @@ -5,17 +5,18 @@ 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 Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust, isJust) +import qualified Data.Set as S + import Pipes.IRC.Message.Types +import Pipes.IRC.Server.Channel import Pipes.IRC.Server.Types +import Pipes.IRC.Server.User - --- | IrcUser management +-- * IrcUser management mkUser :: IrcMonad IrcUser mkUser = do @@ -23,195 +24,7 @@ mkUser = do 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 +-- * Pretty Printing ppServiceName :: ServiceName -> ByteString ppServiceName = BS.pack @@ -223,12 +36,12 @@ ppHostPreference hp = case hp of HostIPv6 -> "*6" Host hn -> BS.pack hn --- | Monadic utilities +-- * Monadic utilities -useChan :: ByteString -> IrcMonad (Maybe IrcChannel) +useChan :: ChanKey -> IrcMonad (Maybe IrcChannel) useChan cname = fmap (M.lookup cname) $ use (clientServer . ircChannels) -useNick :: IrcMonad (Maybe ByteString) +useNick :: IrcMonad (Maybe NickKey) useNick = do regState <- use clientReg return $ case regState of @@ -236,7 +49,7 @@ useNick = do RegUser (NickName nn _ _) -> Just nn _ -> Nothing -validateNick :: ByteString -> IrcMonad Bool +validateNick :: NickKey -> IrcMonad Bool validateNick nickname = do nickSet <- use $ clientServer . ircNicks if S.member nickname nickSet @@ -245,7 +58,7 @@ validateNick nickname = do return False else return True -channelTargets :: ByteString -> IrcMonad [Int] +channelTargets :: ChanKey -> IrcMonad [Int] channelTargets chname = do srv <- use clientServer Just mynick <- useNick @@ -256,7 +69,7 @@ channelTargets chname = do _ -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"] return [] -userTarget :: ByteString -> IrcMonad (Maybe Int) +userTarget :: NickKey -> IrcMonad (Maybe Int) userTarget uname = do srv <- use clientServer let umap = srv ^. ircUsers @@ -299,7 +112,7 @@ addUserPrefix msg = do Just nickname -> msg{ prefix = Just . Right $ nickname } _ -> msg{ prefix = Nothing } -chanEcho :: [ByteString] -> IrcMessage -> IrcMonad () +chanEcho :: [ChanKey] -> IrcMessage -> IrcMonad () chanEcho chans iMsg = do msg <- addUserPrefix iMsg findReceivers chans >>= fwdMsg msg @@ -315,9 +128,9 @@ allChanEcho iMsg = do let chans = S.elems $ usr ^. userChannels chanEcho chans iMsg --- | Adding responses to the Writer portion of the monad +-- * Adding responses to the Writer portion of the monad -tellYOURHOST :: ByteString -> IrcMonad () +tellYOURHOST :: NickKey -> IrcMonad () tellYOURHOST nickname = do srvname <- view ircHostName srvhost <- view ircHost @@ -332,7 +145,7 @@ tellYOURHOST nickname = do , "running version ", version ] ] -tellMOTD :: ByteString -> IrcMonad () +tellMOTD :: NickKey -> IrcMonad () tellMOTD nickname = do motd <- view ircMotd tellNumeric rpl_motdstart [nickname, ":- Message of the Day -"] @@ -340,13 +153,13 @@ tellMOTD nickname = do tellNumeric rpl_motd [nickname, ":- " `BS.append` line] tellNumeric rpl_endofmotd [nickname, ":End of MOTD"] -tellWELCOME :: ByteString -> IrcMonad () +tellWELCOME :: NickKey -> IrcMonad () tellWELCOME nickname = do srvname <- view ircHostName tellNumeric rpl_welcome [ nickname , BS.append ":Welcome to IRC on " srvname ] -tellTOPIC :: ByteString -> IrcMonad () +tellTOPIC :: ChanKey -> IrcMonad () tellTOPIC cname = do chan <- use $ clientServer . ircChannels . at cname case chan of @@ -354,7 +167,7 @@ tellTOPIC cname = do tellNumeric rpl_topic [cname, fromJust $ ch ^. chanTopic] Nothing -> return () -tellNAMES :: [ByteString] -> IrcMonad () +tellNAMES :: [ChanKey] -> IrcMonad () tellNAMES cnames = do Just nn <- useNick forM_ cnames $ \cname -> do diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index 93fdaea..0347f8c 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -12,10 +12,14 @@ import qualified Data.ByteString.Char8 as BS import Data.Map as M import Data.Maybe import Data.Set as S -import Pipes.IRC.Message.Types -import Pipes.IRC.Server.IrcMonad -import Pipes.IRC.Server.Types +import Pipes.IRC.Message.Types +import Pipes.IRC.Server.Channel +import Pipes.IRC.Server.IrcMonad +import Pipes.IRC.Server.Server +import Pipes.IRC.Server.Types +import Pipes.IRC.Server.User +import Pipes.IRC.Server.Util ircMessageHandler :: IrcMessage -> IrcMonad () ircMessageHandler msg = @@ -145,7 +149,7 @@ doJoin msg chans = forM_ chans $ \(c, k) -> runEitherT $ do when (ircInviteCheck nick chan) $ tellErr err_inviteonlychan [c, ":Cannot join channel (+i)"] - when (ircKeyCheck k chan) $ + when (ircPassCheck k chan) $ tellErr err_badchannelkey [c, ":Cannot join channel (+k)"] lift $ do diff --git a/src/Pipes/IRC/Server/Server.hs b/src/Pipes/IRC/Server/Server.hs new file mode 100644 index 0000000..7c7251c --- /dev/null +++ b/src/Pipes/IRC/Server/Server.hs @@ -0,0 +1,142 @@ +-- | This module contains the pure functions for transforming the state of +-- the IRC server record ('IrcServer') as commands are processed. It depends +-- on the "Server.User" and "Server.Channel" modules for some transformations +-- of user and channel ('IrcUser' and 'IrcChannel') structures. +module Pipes.IRC.Server.Server + ( ircAddUser, ircDelUser, ircHasUser, ircHasChan, ircJoin + , ircPart, ircInvite, ircInviteCheck, ircPassCheck + , ircChangeNick ) +where + +import Control.Lens +import Data.ByteString.Char8 (ByteString) +import Data.Map ((!)) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S + +import Pipes.IRC.Server.Channel +import Pipes.IRC.Server.Types +import Pipes.IRC.Server.User +import Pipes.IRC.Server.Util + +-- | Add the user to the server with the given nickname. The +-- nickname should already be in the server's nick list; this +-- function will not check for that condition. +ircAddUser :: NickKey -- ^ nickname of the user + -> IrcUser -- ^ user to add to the server + -> IrcServer -- ^ server to add the user to + -> IrcServer -- ^ new server with user added +ircAddUser nn usr = ircUsers %~ M.insert nn usr + +-- | Delete the user known by the given nickname from the +-- server. This removes the nickname from the nick list and also +-- from any channels the user is in or invited to. +ircDelUser :: NickKey -- ^ nickname of the user to delete + -> IrcServer -- ^ server to delete the user from + -> IrcServer -- ^ new server with user deleted +ircDelUser nn srv = + srv & ircNicks %~ S.delete nn + & if M.notMember nn (srv ^. ircUsers) then id else + let + usr = (srv ^. ircUsers) ! nn + uchans = S.elems (usr ^. userChannels) + ichans = S.elems (usr ^. userInvites) + in + (ircUsers %~ M.delete nn) . + (ircChannels %~ alterAtKeys (ircPartChan nn) uchans) . + (ircChannels %~ adjustAtKeys (chanDelInvite nn) ichans) + +-- | Check whether a user with the given nickname is known by the +-- server. This only checks for fully-registered users; the nick +-- may still be reserved even if this returns 'False'. +ircHasUser :: NickKey -- ^ nickname of the user to check for + -> IrcServer -- ^ server to check + -> Bool -- ^ is the user registered? +ircHasUser nn srv = M.member nn (srv ^. ircUsers) + +-- | Check whether a channel with the given name is known by the +-- server. +ircHasChan :: ChanKey -- ^ name of the channel to check for + -> IrcServer -- ^ server to check + -> Bool -- ^ does the channel exist? +ircHasChan cn srv = M.member cn (srv ^. ircChannels) + +-- | Add the user with the given nickname to the named channel. If the +-- channel does not exist yet, it will be created. This does not do any +-- permissions checks, it just adds the user. +ircJoin :: NickKey -- ^ nickname of the joining user + -> ChanKey -- ^ name of the channel to join + -> IrcServer -- ^ server to perform the join on + -> IrcServer -- ^ new server with join completed +ircJoin un cn = (ircChannels %~ M.alter alterChan cn) + . (ircUsers %~ M.adjust (userAddChan cn) un) + where + alterChan mChan = Just $ chanAddUser un (fromMaybe (newChannel un) mChan) + +-- Helper 'alter' function for ircPart, not exported +ircPartChan :: NickKey -> Maybe IrcChannel -> Maybe IrcChannel +ircPartChan un (Just chan) = case chanDelUser un chan of + IrcChannel{ _chanUsers = us } + | us == S.empty -> Nothing + chan' -> Just chan' +ircPartChan _ Nothing = Nothing + +-- | Remove the user with the given nickname from the named +-- channel. If this causes the channel to become empty, it will be +-- removed from the server. +ircPart :: NickKey -- ^ nickname of parting user + -> ChanKey -- ^ name of the channel to part from + -> IrcServer -- ^ server to perform the part on + -> IrcServer -- ^ new server with part completed +ircPart un cn srv = + srv & (ircChannels %~ (M.alter $ ircPartChan un) cn) + & (ircUsers %~ adjustAtKeys (userDelInvite cn) iusers) + where + chan = (srv ^. ircChannels) ! cn + iusers = S.elems $ chan ^. chanInvites + +-- | Add the user with the given nickname to the invited list for the +-- channel, and add the channel to the user's invited list. +ircInvite :: NickKey -- ^ nickname of user to invite + -> ChanKey -- ^ name of channel user is invited to + -> IrcServer -- ^ server to perform the invitation on + -> IrcServer -- ^ new server with invite completed +ircInvite un cn = (ircChannels %~ M.adjust (chanAddInvite un) cn) + . (ircUsers %~ M.adjust (userAddInvite cn) un) + +-- | Determine whether the user with the given nickname is disallowed +-- from joining the channel due to the 'InviteOnly' flag and lack of +-- invitation. A 'True' value indicates that the user may join. +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) + +-- | Determine whether the given channel will disallow joining due to +-- a missing or incorrect password. A 'True' value indicates that +-- conditions for joining are met. +ircPassCheck :: Maybe ByteString -- ^ 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)) + +-- | Change the nickname of a user from 'old' to 'new', updating the +-- necessary 'IrcServer' structures. No nick collision check is +-- performed; that should be done before calling this. +ircChangeNick :: NickKey -- ^ old nickname of the user + -> NickKey -- ^ new nickname of the user + -> IrcServer -- ^ server to change the nickname on + -> IrcServer -- ^ new server with change performed +ircChangeNick old new srv = + if M.notMember old (srv ^. ircUsers) then + srv + else let + usr = (srv ^. ircUsers) ! old + chs = S.elems (usr ^. userChannels) + in + srv & (ircNicks %~ S.delete old . S.insert new) + & (ircUsers %~ M.delete old . M.insert new usr) + & (ircChannels %~ adjustAtKeys (chanChangeNick old new) chs) diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs index 023525d..6129165 100644 --- a/src/Pipes/IRC/Server/Types.hs +++ b/src/Pipes/IRC/Server/Types.hs @@ -20,6 +20,9 @@ import Pipes.IRC.Message.Types (IrcMessage, NickName) import Pipes.Network.TCP (HostPreference (..), ServiceName, SockAddr, Socket) +type NickKey = ByteString +type ChanKey = ByteString + type IrcEvents = [IrcEvent] data IrcEvent = Msg { _outMsg :: !IrcMessage @@ -37,9 +40,9 @@ data IrcUserMode = Away | Invisible | WallOps | Restricted data IrcUser = IrcUser { _userServerName :: !ByteString , _userModes :: !(Set IrcUserMode) - , _userChannels :: !(Set ByteString) + , _userChannels :: !(Set ChanKey) , _userConn :: !Int - , _userInvites :: !(Set ByteString) + , _userInvites :: !(Set ChanKey) } deriving (Show, Eq) makeLenses ''IrcUser @@ -49,19 +52,19 @@ data IrcChanModeFlags = Anonymous | InviteOnly | Moderated | NoOutsideMsgs data IrcChannel = IrcChannel { _chanTopic :: !(Maybe ByteString) - , _chanKey :: !(Maybe ByteString) + , _chanPass :: !(Maybe ByteString) , _chanModeFlags :: !(Set IrcChanModeFlags) - , _chanUsers :: !(Set ByteString) - , _chanOpers :: !(Set ByteString) - , _chanVoices :: !(Set ByteString) - , _chanInvites :: !(Set ByteString) + , _chanUsers :: !(Set NickKey) + , _chanOpers :: !(Set NickKey) + , _chanVoices :: !(Set NickKey) + , _chanInvites :: !(Set NickKey) } deriving (Show, Eq) makeLenses ''IrcChannel data IrcServer = - IrcServer { _ircNicks :: !(Set ByteString) - , _ircUsers :: !(Map ByteString IrcUser) - , _ircChannels :: !(Map ByteString IrcChannel) + IrcServer { _ircNicks :: !(Set NickKey) + , _ircUsers :: !(Map NickKey IrcUser) + , _ircChannels :: !(Map ChanKey IrcChannel) , _ircVersion :: !ByteString } deriving (Show) makeLenses ''IrcServer @@ -76,7 +79,7 @@ data IrcConfig = makeLenses ''IrcConfig data RegState = Unreg { _rcvdPass :: !(Maybe ByteString) - , _rcvdNick :: !(Maybe ByteString) + , _rcvdNick :: !(Maybe NickKey) , _rcvdName :: !(Maybe ByteString) } | RegUser { _regdNick :: !NickName } deriving (Show) diff --git a/src/Pipes/IRC/Server/User.hs b/src/Pipes/IRC/Server/User.hs new file mode 100644 index 0000000..6e709db --- /dev/null +++ b/src/Pipes/IRC/Server/User.hs @@ -0,0 +1,85 @@ +-- | This module contains pure functions for transforming the state of +-- 'IrcUser' structures while processing IRC commands. +module Pipes.IRC.Server.User + ( newUser + , userAddChan + , userDelChan + , userAddMode + , userDelMode + , userAddInvite + , userDelInvite + , userHasMode + , userInChan + ) +where + +import Control.Lens +import Data.ByteString.Char8 (ByteString) +import Data.Set (delete, empty, insert, member) + +import Pipes.IRC.Server.Types + +-- | Create a new 'IrcUser' record with the given server name and connection +-- id. +newUser :: ByteString -- ^ a 'ByteString' containing the user's server name + -> Int -- ^ the user's connection id + -> IrcUser -- ^ the resulting new 'IrcUser' structure +newUser srvname cid = + IrcUser { _userServerName = srvname + , _userModes = empty + , _userChannels = empty + , _userConn = cid + , _userInvites = empty + } + +userAddChan, userDelChan :: ChanKey -- ^ channel to add or remove from user + -> IrcUser -- ^ user of which to modify channel list + -> IrcUser -- ^ new user with channel list changed + +-- | Add a channel to the user's set of channels. This does not change the +-- set of users in the channel or perform any checking; this just performs +-- the low-level change to the user. +userAddChan cn = userChannels %~ insert cn + +-- | Delete a channel from the user's set of channels. This does not change +-- the set of users in the channel or perform any checking; this just performs +-- the low-level change to the user. +userDelChan cn = userChannels %~ delete cn + + +userAddMode, userDelMode :: IrcUserMode -- ^ mode to add or remove from user + -> IrcUser -- ^ user to perform the mode change on + -> IrcUser -- ^ new user after mode change + +-- | Add the mode to the user's set of modes. +userAddMode um = userModes %~ insert um + +-- | Remove the mode from the user's set of modes. +userDelMode um = userModes %~ delete um + + +userAddInvite, userDelInvite :: ChanKey -- ^ channel name of invitation + -> IrcUser -- ^ user of which to modify invites + -> IrcUser -- ^ new user after invite changes + +-- | Add a channel invite to the user's set of active invites. This does not do +-- any change to the channel; it just performs the low-level change to the user. +userAddInvite cn = userInvites %~ insert cn + +-- | Delete a channel invite from the user's set of active invites. This does +-- not do any change to the channel; it just performs the low-level change to +-- the user. +userDelInvite cn = userInvites %~ delete cn + +-- | Check whether the user has the indicated mode. +userHasMode :: IrcUserMode -- ^ mode to check for presence of + -> IrcUser -- ^ user to check the mode of + -> Bool -- ^ does user have the mode? +userHasMode um usr = member um (usr ^. userModes) + +-- | Check whether the user has the named channel in its set of channels. Note +-- that this does not check anything other than the user's set of channels. +userInChan :: ChanKey -- ^ name of the channel to check for + -> IrcUser -- ^ user to check the channel set of + -> Bool -- ^ is the user on the channel? +userInChan cn usr = member cn (usr ^. userChannels) diff --git a/src/Pipes/IRC/Server/Util.hs b/src/Pipes/IRC/Server/Util.hs new file mode 100644 index 0000000..2143cf5 --- /dev/null +++ b/src/Pipes/IRC/Server/Util.hs @@ -0,0 +1,51 @@ +-- | This module contains various utility functions that don't fit elsewhere. +module Pipes.IRC.Server.Util + ( parseParamList + , zipParams + , adjustAtKeys + , alterAtKeys + ) +where + +import Data.ByteString.Char8 (ByteString, null, split) +import Data.Map (Map, adjust, alter) +import Prelude hiding (null) + +-- | Split a 'ByteString' containing an IRC command parameter list into a +-- list of 'ByteString' parameters. +parseParamList :: ByteString -- ^ comma-delimited string of parameters + -> [ByteString] -- ^ list of parameter strings +parseParamList ps = filter (not . null) $ split ',' ps + +-- | Pair a list of parameters (such as channel names) with a corresponding +-- second list of parameters (such as channel passwords) they should be +-- paired with. The second list may be empty or up to the same length as the +-- first list; differences will be made up with 'Nothing' values. +zipParams :: [ByteString] -- ^ first list of parameter strings + -> [ByteString] -- ^ list of parameters to pair them with + -> [(ByteString, Maybe ByteString)] + -- ^ list of parameter pairs +zipParams chans chkeys = zip chans (map Just chkeys ++ repeat Nothing) + +-- | A "Data.Map" helper that applies an 'adjust' function at each of the +-- given keys. For example: +-- +-- >>> adjustAtKeys (++ "x") [1,3] (fromList [(1, "a"), (2, "b"), (3, "c")]) +-- fromList [(1, "ax"), (2, "b"), (3, "cx")] +-- +adjustAtKeys :: Ord k + => (v -> v) -- ^ function to apply with 'adjust' + -> [k] -- ^ keys to apply the adjustment at + -> Map k v -- ^ map to apply the adjustments to + -> Map k v -- ^ new map resulting from the adjustments +adjustAtKeys f keys dmap = foldr (adjust f) dmap keys + +-- | A "Data.Map" helper that applies an 'alter' function at each of the +-- given keys. This is similar to 'adjustAtKeys' except it may create or +-- remove key/value pairs instead of just changing existing ones. +alterAtKeys :: Ord k + => (Maybe v -> Maybe v) -- ^ function to apply with 'alter' + -> [k] -- ^ keys to apply the alteration at + -> Map k v -- ^ map to apply the alterations to + -> Map k v -- ^ new map resulting from the alterations +alterAtKeys f keys dmap = foldr (alter f) dmap keys