Break data manipulation functions into separate modules; add some haddocks
Levi Pearson
parent
9278620b75
commit
b6299f59ba
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -8,14 +8,15 @@ 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 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue