Break data manipulation functions into separate modules; add some haddocks

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
 

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

src/Pipes/IRC/Server/IrcMonad.hs

@@ -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,
+import           Data.Maybe               (catMaybes, fromJust, isJust)
-                                          isJust, isNothing)
 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
+-- * Pretty Printing
-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
@@ -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

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

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)

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)
+             , _chanUsers     :: !(Set NickKey)
-             , _chanOpers     :: !(Set ByteString)
+             , _chanOpers     :: !(Set NickKey)
-             , _chanVoices    :: !(Set ByteString)
+             , _chanVoices    :: !(Set NickKey)
-             , _chanInvites   :: !(Set ByteString)
+             , _chanInvites   :: !(Set NickKey)
              } deriving (Show, Eq)
 makeLenses ''IrcChannel
 
 data IrcServer =
-  IrcServer { _ircNicks    :: !(Set ByteString)
+  IrcServer { _ircNicks    :: !(Set NickKey)
-            , _ircUsers    :: !(Map ByteString IrcUser)
+            , _ircUsers    :: !(Map NickKey IrcUser)
-            , _ircChannels :: !(Map ByteString IrcChannel)
+            , _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)

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)

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