Re-arranged some code, added basic PING/PONG.

Also, channels now go away properly when they become empty.

pipes-irc-server.cabal

@@ -25,6 +25,7 @@ executable pipes-irc-server
   -- other-extensions:    
   build-depends:     base              >= 4.6    && < 4.7
                    , mtl               >= 2.1    && < 3
+                   , errors            >= 1.4    && < 2
                    , mmorph            >= 1      && < 2
                    , containers        >= 0.5    && < 1
                    , bytestring        >= 0.10   && < 0.11
@@ -38,6 +39,7 @@ executable pipes-irc-server
                    , pipes-attoparsec  >= 0.3    && < 1
                    , pipes-network     >= 0.6    && < 1
                    , stm               >= 2      && < 3
+                   , time              >= 1.4    && < 1.5
                    , async             >= 2      && < 3
                    , free              >= 3      && < 4
                    , lens              >= 3      && < 4

src/Pipes/IRC/Server.hs

@@ -5,6 +5,7 @@ module Pipes.IRC.Server
   )
 where
 
+import           Control.Concurrent              (threadDelay)
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Lens                    as L
@@ -13,6 +14,7 @@ import           Control.Monad.RWS
 import           Data.ByteString.Char8           as BS
 import           Data.Map                        as M
 import           Data.Set                        as S
+import           Data.Time.Clock
 import           Network.Socket                  as NS
 import           Pipes
 import           Pipes.Attoparsec
@@ -21,6 +23,7 @@ import           Pipes.IRC.Message.Parse
 import           Pipes.IRC.Message.Render
 import           Pipes.IRC.Message.Types
 import           Pipes.IRC.Server.EventHandler
+import           Pipes.IRC.Server.IrcMonad
 import           Pipes.IRC.Server.Log
 import           Pipes.IRC.Server.MessageHandler
 import           Pipes.IRC.Server.Types
@@ -52,16 +55,6 @@ filterMsgs = forever $ do
     Right c -> do lift $ logMsg c
                   yield c
 
-removeUser :: BS.ByteString -> IrcServer -> IrcServer
-removeUser nn ss =
-  ss & ircNicks %~ S.delete nn
-     & case M.lookup nn (ss ^. ircUsers) of
-         Just u -> let ucs = S.elems $ u ^. userChannels in
-           (ircUsers %~ M.delete nn) .
-           (ircChannels %~ \chmap ->
-             Prelude.foldr (M.adjust (chanUsers %~ S.delete nn)) chmap ucs)
-         Nothing -> id
-
 addIrcConnection :: ServerState -> IrcConnection -> IO Int
 addIrcConnection srv client = do
   let clients = srv ^. ircConnections
@@ -75,21 +68,17 @@ addIrcConnection srv client = do
   return cid
 
 delIrcConnection :: ServerState -> Int -> IO ()
-delIrcConnection srv cid =
+delIrcConnection srv cid = atomically $ do
-  atomically $ do
+  cs <- readTVar (srv ^. ircConnections)
-    let clients  = srv ^. ircConnections
+  case M.lookup cid cs of
-        srvState = srv ^. ircState
+    Just conn -> do
-    cs <- readTVar clients
+      let nn = case conn ^. reg of
-    case M.lookup cid cs of
+            Unreg{ _rcvdNick = Just n }           -> n
-      -- Connection is unregistered, but has set a nickname
+            RegUser{ _regdNick = NickName n _ _ } -> n
-      Just IrcConnection{_reg = Unreg{_rcvdNick = Just nn}} ->
+            _                                     -> ""
-        modifyTVar' srvState $ removeUser nn
+      modifyTVar' (srv ^. ircState) $ ircDelUser nn
-
+    _ -> return ()
-      -- Connection is registered
+  modifyTVar' (srv ^. ircConnections) $ M.delete cid
-      Just IrcConnection{_reg = RegUser{_regdNick = NickName nn _ _}} ->
-        modifyTVar' srvState $ removeUser nn
-      _ -> return ()
-    modifyTVar' clients $ M.delete cid
 
 cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
 cmdHandler srv cid =
@@ -97,12 +86,13 @@ cmdHandler srv cid =
   in do
     conns <- liftIO $ readTVarIO $ srv ^. ircConnections
     case M.lookup cid conns of
-      Just c  -> handle c cReg
+      Just c  -> handle (c ^. hname) cReg
       Nothing -> return ()
   where
-    handle conn userReg = do
+    handle host userReg = do
       -- wait for the next command
       nextMsg <- await
+      curTime <- liftIO getCurrentTime
 
       -- run the handler in a transaction
       (newReg, events) <- liftIO $ atomically $ do
@@ -110,21 +100,55 @@ cmdHandler srv cid =
         let sConf = srv ^. ircConfig
         let cState = ClientState { _clientReg = userReg
                                  , _clientServer = sState
-                                 , _clientHost = conn ^. hname
+                                 , _clientHost = host
-                                 , _clientConn = cid }
+                                 , _clientConn = cid
+                                 }
 
         -- run the handler in the IrcMonad, returning new state and events
         let (_, newState, events) =
-              runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState
+              runRWS (ircMessageHandler nextMsg) sConf cState
 
-        writeTVar (_ircState srv) $ _clientServer newState
+        writeTVar (srv ^. ircState) $
-        return (_clientReg newState, events)
+          newState ^. clientServer
+
+        modifyTVar' (srv ^. ircConnections) $
+          M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid
+
+        return (newState ^. clientReg, events)
 
       -- handle resulting events
       aliveL <- liftIO $ forM events $ ircEventHandler srv
 
       -- loop for the next command
-      when (and aliveL) $ handle conn newReg
+      when (and aliveL) $ handle host newReg
+
+idlePinger :: ServerState -> Int -> IO ()
+idlePinger srv cid =
+  let
+    pingMsg  = IrcMessage Nothing (Left PING)
+                 [":" `append` (srv ^. ircConfig . ircHostName)]
+    oneMinute = 60 * 1000000 -- microseconds
+    getLastCom = do conns <- readTVarIO (srv ^. ircConnections)
+                    return $ conns ! cid ^. lastCom
+    resetPong = atomically $ modifyTVar' (srv ^. ircConnections) $
+                               M.adjust (gotPong .~ False) cid
+    checkPong = do conns <- readTVarIO (srv ^. ircConnections)
+                   return $ conns ! cid ^. gotPong
+   in
+   forever $ do
+     threadDelay oneMinute
+     curTime <- getCurrentTime
+     time <- getLastCom
+     let diffTime = toRational . diffUTCTime curTime $ time
+     if diffTime > 60
+       then do
+            resetPong
+            atomically $ do
+              conns <- readTVar (srv ^. ircConnections)
+              PC.send (conns ! cid ^. out) pingMsg
+            threadDelay oneMinute
+            checkPong
+       else return True
 
 listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
 listenHandler srv (lsock, _) =
@@ -135,6 +159,7 @@ listenHandler srv (lsock, _) =
     (hName, _) <- getNameInfo [] True False caddr
 
     (writeEnd, readEnd) <- spawn Unbounded
+    curTime <- getCurrentTime
 
     let client = IrcConnection
                   { _sock  = csock
@@ -142,6 +167,8 @@ listenHandler srv (lsock, _) =
                   , _hname = fmap BS.pack hName
                   , _out   = writeEnd
                   , _reg   = Unreg Nothing Nothing Nothing
+                  , _lastCom = curTime
+                  , _gotPong = False
                   }
 
     cid <- addIrcConnection srv client
@@ -152,11 +179,14 @@ listenHandler srv (lsock, _) =
            parseMessage sockReader >-> filterMsgs >-> handler
     link r
 
+    idle <- async $ idlePinger srv cid
+    link idle
+
     w <- async $ runEffect $
            fromInput readEnd >-> renderMessage >-> sockWriter
     link w
 
-    void $ waitEither r w
+    void $ waitAnyCancel [r, w, idle]
 
     delIrcConnection srv cid
 

src/Pipes/IRC/Server/EventHandler.hs

@@ -32,3 +32,7 @@ ircEventHandler srv evt =
       let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest
       sendToMany _outMsg os
       return True
+    Pong {..} -> do
+      atomically $ modifyTVar' (srv ^. ircConnections) $
+                     M.adjust (gotPong .~ False) _pongConn
+      return True

src/Pipes/IRC/Server/IrcMonad.hs

@@ -0,0 +1,391 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Pipes.IRC.Server.IrcMonad
+where
+
+import           Control.Lens
+import           Control.Monad.RWS
+import           Data.ByteString.Char8   (ByteString)
+import qualified Data.ByteString.Char8   as BS
+import qualified Data.Map                as M
+import           Data.Maybe              (catMaybes, fromJust, fromMaybe,
+                                          isJust, isNothing)
+import qualified Data.Set                as S
+import           Pipes.IRC.Message.Types
+import           Pipes.IRC.Server.Types
+
+
+-- | IrcUser management
+
+mkUser :: IrcMonad IrcUser
+mkUser = do
+  conn <- use clientConn
+  srvname <- view ircHostName
+  return $ newUser srvname conn
+
+newUser :: ByteString -> Int -> IrcUser
+newUser srvname cid =
+  IrcUser { _userServerName = srvname
+          , _userModes = S.empty
+          , _userChannels = S.empty
+          , _userConn = cid
+          , _userInvites = S.empty
+          }
+
+userAddChan, userDelChan :: ByteString -> IrcUser -> IrcUser
+userAddChan cn = userChannels %~ S.insert cn
+userDelChan cn = userChannels %~ S.delete cn
+
+userAddMode, userDelMode :: IrcUserMode -> IrcUser -> IrcUser
+userAddMode um = userModes %~ S.insert um
+userDelMode um = userModes %~ S.delete um
+
+userAddInvite, userDelInvite :: ByteString -> IrcUser -> IrcUser
+userAddInvite cn = userInvites %~ S.insert cn
+userDelInvite cn = userInvites %~ S.delete cn
+
+userHasMode :: IrcUserMode -> IrcUser -> Bool
+userHasMode um usr = S.member um $ usr ^. userModes
+
+userInChan :: ByteString -> IrcUser -> Bool
+userInChan cn usr = S.member cn $ usr ^. userChannels
+
+-- | IrcChannel management
+
+newChannel :: ByteString -> IrcChannel
+newChannel creator = IrcChannel { _chanTopic = Nothing
+                                , _chanKey   = Nothing
+                                , _chanModeFlags = S.empty
+                                , _chanUsers = S.fromList [creator]
+                                , _chanOpers = S.fromList [creator]
+                                , _chanVoices = S.empty
+                                , _chanInvites = S.empty
+                                }
+
+chanAddModeFlag, chanDelModeFlag :: IrcChanModeFlags -> IrcChannel -> IrcChannel
+chanAddModeFlag cm = chanModeFlags %~ S.insert cm
+chanDelModeFlag cm = chanModeFlags %~ S.delete cm
+
+chanAddUser, chanDelUser :: ByteString -> IrcChannel -> IrcChannel
+chanAddUser un = chanUsers %~ S.insert un
+chanDelUser un = (chanUsers %~ S.delete un)
+               . (chanOpers %~ S.delete un)
+               . (chanVoices %~ S.delete un)
+
+chanHasUser :: ByteString -> IrcChannel -> Bool
+chanHasUser un ch = S.member un $ ch ^. chanUsers
+
+chanSetTopic :: ByteString -> IrcChannel -> IrcChannel
+chanSetTopic top = chanTopic .~ Just top
+
+chanHasTopic :: IrcChannel -> Bool
+chanHasTopic ch = isJust $ ch ^. chanTopic
+
+chanHasModeFlag :: IrcChanModeFlags -> IrcChannel -> Bool
+chanHasModeFlag cm ch = S.member cm $ ch ^. chanModeFlags
+
+chanSigil :: IrcChannel -> ByteString
+chanSigil ch | chanHasModeFlag Secret ch  = "@"
+             | chanHasModeFlag Private ch = "*"
+             | otherwise                  = "="
+
+chanUserSigil :: ByteString -> IrcChannel -> ByteString
+chanUserSigil un ch | S.member un $ ch ^. chanOpers  = "@"
+                    | S.member un $ ch ^. chanVoices = "+"
+                    | otherwise                      = ""
+
+chanSetKey :: ByteString -> IrcChannel -> IrcChannel
+chanSetKey key = chanKey .~ Just key
+
+chanHasKey :: IrcChannel -> Bool
+chanHasKey ch = isJust $ ch ^. chanKey
+
+chanCheckKey :: ByteString -> IrcChannel -> Bool
+chanCheckKey key ch = case ch ^. chanKey of
+  Just chKey -> key == chKey
+  Nothing    -> True
+
+chanAddOper, chanDelOper :: ByteString -> IrcChannel -> IrcChannel
+chanAddOper un = chanOpers %~ S.insert un
+chanDelOper un = chanOpers %~ S.delete un
+
+chanAddVoice, chanDelVoice :: ByteString -> IrcChannel -> IrcChannel
+chanAddVoice un = chanVoices %~ S.insert un
+chanDelVoice un = chanVoices %~ S.delete un
+
+chanAddInvite, chanDelInvite :: ByteString -> IrcChannel -> IrcChannel
+chanAddInvite un = chanInvites %~ S.insert un
+chanDelInvite un = chanInvites %~ S.delete un
+
+chanUserIsOper :: ByteString -> IrcChannel -> Bool
+chanUserIsOper un ch = S.member un $ ch ^. chanOpers
+
+chanUserHasVoice :: ByteString -> IrcChannel -> Bool
+chanUserHasVoice un ch = S.member un $ ch ^. chanVoices
+
+chanUserIsInvited :: ByteString -> IrcChannel -> Bool
+chanUserIsInvited un ch = S.member un $ ch ^. chanInvites
+
+chanUserMaySpeak :: ByteString -> IrcChannel -> Bool
+chanUserMaySpeak un ch
+  | (chanHasUser un ch || not (chanHasModeFlag NoOutsideMsgs ch))
+     && not (chanHasModeFlag Moderated ch) = True
+  | chanUserIsOper un ch                   = True
+  | chanUserHasVoice un ch                 = True
+  | otherwise                              = False
+
+chanUserMayJoin :: ByteString -> IrcChannel -> Bool
+chanUserMayJoin un ch | not $ chanHasModeFlag InviteOnly ch = True
+                      | chanUserIsInvited un ch             = True
+                      | otherwise                           = False
+
+chanUserMaySetTopic :: ByteString -> IrcChannel -> Bool
+chanUserMaySetTopic un ch
+  | not (chanHasModeFlag TopicOperOnly ch) &&
+    chanHasUser un ch    = True
+  | chanUserIsOper un ch = True
+  | otherwise            = False
+
+-- | IrcServer management
+
+ircAddUser :: ByteString -> IrcUser -> IrcServer -> IrcServer
+ircAddUser nn usr = ircUsers %~ M.insert nn usr
+
+ircDelUser :: ByteString -> IrcServer -> IrcServer
+ircDelUser nn srv =
+  srv & ircNicks %~ S.delete nn
+      & if ircHasUser nn srv then let
+           Just usr = M.lookup nn $ srv ^. ircUsers
+           uchans = S.elems (usr ^. userChannels)
+           ichans = S.elems (usr ^. userInvites)
+          in
+           (ircUsers %~ M.delete nn) .
+           (ircChannels %~ \cs -> foldr (M.alter $ ircPartChan nn) cs uchans) .
+           (ircChannels %~ \cs -> foldr (M.adjust $ chanDelInvite nn) cs ichans)
+        else id
+
+ircHasUser :: ByteString -> IrcServer -> Bool
+ircHasUser nn srv = isJust $ M.lookup nn (srv ^. ircUsers)
+
+ircHasChan :: ByteString -> IrcServer -> Bool
+ircHasChan cn srv = isJust $ M.lookup cn (srv ^. ircChannels)
+
+ircJoin :: ByteString -> ByteString -> IrcServer -> IrcServer
+ircJoin un cn = (ircChannels %~ M.alter alterChan cn)
+              . (ircUsers %~ M.adjust (userAddChan cn) un)
+  where
+    alterChan mChan = Just $ chanAddUser un (fromMaybe (newChannel un) mChan)
+
+ircPartChan :: ByteString -> Maybe IrcChannel -> Maybe IrcChannel
+ircPartChan un chan = case chanDelUser un (fromJust chan) of
+                            IrcChannel{ _chanUsers = us }
+                              | us == S.empty             -> Nothing
+                            chan'                         -> Just chan'
+
+ircPart :: ByteString -> ByteString -> IrcServer -> IrcServer
+ircPart un cn srv =
+  srv & (ircChannels %~ (M.alter $ ircPartChan un) cn)
+      & (ircUsers %~ \us -> foldr (M.adjust $ userDelInvite cn) us iusers)
+  where
+    chan = fromJust $ M.lookup cn (srv ^. ircChannels)
+    iusers = S.elems $ chan ^. chanInvites
+
+ircInvite :: ByteString -> ByteString -> IrcServer -> IrcServer
+ircInvite un cn = (ircChannels %~ M.adjust (chanAddInvite un) cn)
+                  . (ircUsers %~ M.adjust (userAddInvite cn) un)
+
+ircInviteCheck :: ByteString -> IrcChannel -> Bool
+ircInviteCheck n chan =
+  chanHasModeFlag InviteOnly chan && not (chanUserIsInvited n chan)
+
+ircKeyCheck :: Maybe ByteString -> IrcChannel -> Bool
+ircKeyCheck k chan =
+  chanHasKey chan && (isNothing k || not (chanCheckKey (fromJust k) chan))
+
+-- | Misc
+
+parseParamList :: ByteString -> [ByteString]
+parseParamList ps = filter (not . BS.null) $ BS.split ',' ps
+
+zipParams :: [ByteString] -> [ByteString]
+          -> [(ByteString, Maybe ByteString)]
+zipParams chans chkeys = zip chans (map Just chkeys ++ repeat Nothing)
+
+-- | Pretty Printing
+
+ppServiceName :: ServiceName -> ByteString
+ppServiceName = BS.pack
+
+ppHostPreference :: HostPreference -> ByteString
+ppHostPreference hp = case hp of
+  HostAny  -> "*"
+  HostIPv4 -> "*4"
+  HostIPv6 -> "*6"
+  Host hn  -> BS.pack hn
+
+-- | Monadic utilities
+
+useChan :: ByteString -> IrcMonad (Maybe IrcChannel)
+useChan cname = fmap (M.lookup cname) $ use (clientServer . ircChannels)
+
+useNick :: IrcMonad (Maybe ByteString)
+useNick = do
+  regState <- use clientReg
+  return $ case regState of
+    Unreg _ (Just nn) _       -> Just nn
+    RegUser (NickName nn _ _) -> Just nn
+    _                         -> Nothing
+
+validateNick :: ByteString -> IrcMonad Bool
+validateNick nickname = do
+  nickSet <- use $ clientServer . ircNicks
+  if S.member nickname nickSet
+   then do
+      tellNumeric err_nicknameinuse [nickname, ":Nickname is already in use."]
+      return False
+   else return True
+
+channelTargets :: ByteString -> IrcMonad [Int]
+channelTargets chname = do
+  srv <- use clientServer
+  Just mynick <- useNick
+  let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers)
+  let chmap = srv ^. ircChannels
+  case M.lookup chname chmap of
+    Just chan -> fmap catMaybes $ forM (cUsers chan) userTarget
+    _         -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"]
+                    return []
+
+userTarget :: ByteString -> IrcMonad (Maybe Int)
+userTarget uname = do
+  srv <- use clientServer
+  let umap = srv ^. ircUsers
+  case M.lookup uname umap of
+    Just u -> return . Just $ u ^. userConn
+    _      -> do tellNumeric err_nosuchnick [uname, ":No such nick/channel"]
+                 return Nothing
+
+findReceivers :: [ByteString] -> IrcMonad [([Int], ByteString)]
+findReceivers rcvNames =
+  fmap catMaybes $ forM rcvNames $ \name ->
+    if BS.head name == '#'
+     then do
+      cids <- channelTargets name
+      return $ case cids of
+        [] -> Nothing
+        cs -> Just (cs, name)
+     else do
+      cid <- userTarget name
+      return $ case cid of
+        Just c  -> Just ([c], name)
+        Nothing -> Nothing
+
+fwdMsg :: IrcMessage -> [([Int], ByteString)] -> IrcMonad ()
+fwdMsg msg rcvs = forM_ rcvs $ \(cId, n) -> do
+  -- replace multiple targets with the single target we're doing
+  let m = msg{ params = n : tail (params msg) }
+  tell [Msg m cId]
+
+fwdMsgNoReplace :: IrcMessage -> [([Int], ByteString)] -> IrcMonad ()
+fwdMsgNoReplace msg rcvs = do
+  m <- addUserPrefix msg
+  forM_ rcvs $ \(cId, _) -> tell [Msg m cId]
+
+
+addUserPrefix :: IrcMessage -> IrcMonad IrcMessage
+addUserPrefix msg = do
+  regState <- use clientReg
+  return $ case regState ^? regdNick of
+    Just nickname -> msg{ prefix = Just . Right $ nickname }
+    _             -> msg{ prefix = Nothing }
+
+chanEcho :: [ByteString] -> IrcMessage -> IrcMonad ()
+chanEcho chans iMsg = do
+  msg <- addUserPrefix iMsg
+  findReceivers chans >>= fwdMsg msg
+
+allChanEcho :: IrcMessage -> IrcMonad ()
+allChanEcho iMsg = do
+  mNick <- useNick
+  when (isJust mNick) $ do
+    let nn = fromJust mNick
+    mUser <- use $ clientServer . ircUsers . at nn
+    when (isJust mUser) $ do
+      let usr = fromJust mUser
+      let chans = S.elems $ usr ^. userChannels
+      chanEcho chans iMsg
+
+-- | Adding responses to the Writer portion of the monad
+
+tellYOURHOST :: ByteString -> IrcMonad ()
+tellYOURHOST nickname = do
+  srvname <- view ircHostName
+  srvhost <- view ircHost
+  srvport <- view ircPort
+  version <- use $ clientServer . ircVersion
+  let hostStr = ppHostPreference srvhost
+      portStr = ppServiceName srvport
+  tellNumeric rpl_yourhost
+    [ nickname
+    , BS.concat [ ":Your host is ", srvname
+                , "[", hostStr, "/", portStr, "], "
+                , "running version ", version ]
+    ]
+
+tellMOTD :: ByteString -> IrcMonad ()
+tellMOTD nickname = do
+  motd <- view ircMotd
+  tellNumeric rpl_motdstart [nickname, ":- Message of the Day -"]
+  forM_ motd $ \line ->
+    tellNumeric rpl_motd [nickname, ":- " `BS.append` line]
+  tellNumeric rpl_endofmotd [nickname, ":End of MOTD"]
+
+tellWELCOME :: ByteString -> IrcMonad ()
+tellWELCOME nickname = do
+  srvname <- view ircHostName
+  tellNumeric rpl_welcome [ nickname
+                          , BS.append ":Welcome to IRC on " srvname ]
+
+tellTOPIC :: ByteString -> IrcMonad ()
+tellTOPIC cname = do
+  chan <- use $ clientServer . ircChannels . at cname
+  case chan of
+    Just ch -> when (isJust $ ch ^. chanTopic) $
+                 tellNumeric rpl_topic [cname, fromJust $ ch ^. chanTopic]
+    Nothing -> return ()
+
+tellNAMES :: [ByteString] -> IrcMonad ()
+tellNAMES cnames = do
+  Just nn <- useNick
+  forM_ cnames $ \cname -> do
+    mChan <- use $ clientServer . ircChannels . at cname
+    case mChan of
+      Just chan -> do
+        let chanType = chanSigil chan
+        nickL <- forM (S.elems $ chan ^. chanUsers) $ \uname ->
+          return $ BS.append (chanUserSigil uname chan) uname
+        let cUsers = BS.append ":" (BS.intercalate " " nickL)
+        tellNumeric rpl_namreply [nn, chanType, cname, cUsers]
+        tellNumeric rpl_endofnames [nn, head cnames, ":End of /NAMES list"]
+      Nothing -> return ()
+
+tellPrefixedCommand :: IrcCommand -> [IrcParam] -> IrcMonad ()
+tellPrefixedCommand reply desc = do
+  srvname <- view ircHostName
+  connId <- use clientConn
+  let msg = IrcMessage (Just $ Left srvname) (Left reply) desc
+  tell [Msg msg [connId]]
+
+tellCommand :: IrcCommand -> [IrcParam] -> IrcMonad ()
+tellCommand reply desc = do
+  connId <- use clientConn
+  let msg = IrcMessage Nothing (Left reply) desc
+  tell [Msg msg [connId]]
+
+tellNumeric :: IrcReply -> [IrcParam] -> IrcMonad ()
+tellNumeric reply desc = do
+  srvname <- view ircHostName
+  connId  <- use clientConn
+  let msg = IrcMessage (Just $ Left srvname) (Right reply) desc
+  tell [Msg msg [connId]]
+  return ()

src/Pipes/IRC/Server/MessageHandler.hs

@@ -5,17 +5,18 @@ module Pipes.IRC.Server.MessageHandler
   ( ircMessageHandler )
 where
 
+import           Control.Error
 import           Control.Lens
 import           Control.Monad.RWS
-import qualified Data.ByteString.Char8   as BS
+import qualified Data.ByteString.Char8     as BS
-import           Data.Map                as M
+import           Data.Map                  as M
 import           Data.Maybe
-import           Data.Set                as S
+import           Data.Set                  as S
 import           Pipes.IRC.Message.Types
+import           Pipes.IRC.Server.IrcMonad
 import           Pipes.IRC.Server.Types
 
 
-
 ircMessageHandler :: IrcMessage -> IrcMonad ()
 ircMessageHandler msg =
   -- drop messages that have prefixes (until we have Server links)
@@ -32,26 +33,19 @@ unregHandler msg@IrcMessage{..} =
     Left PASS -> unregPASS msg
     Left NICK -> unregNICK msg
     Left USER -> unregUSER msg
+    Left PONG -> handlePONG msg
+    Left PING -> handlePING msg
     Left QUIT -> handleQUIT msg
     _         -> return ()
 
 unregPASS :: IrcMessage -> IrcMonad ()
 unregPASS IrcMessage{..} =
   if length params < 1
-  then tellNumeric err_needmoreparams [":Need more parameters"]
+  then tellNumeric err_needmoreparams ["PASS", ":Need more parameters"]
   else do
     clientReg . rcvdPass .= (Just $ head params)
     return ()
 
-validateNick :: BS.ByteString -> IrcMonad Bool
-validateNick nickname = do
-  nickSet <- use $ clientServer . ircNicks
-  if S.member nickname nickSet
-   then do
-      tellNumeric err_nicknameinuse [nickname, ":Nickname is already in use."]
-      return False
-   else return True
-
 unregNICK :: IrcMessage -> IrcMonad ()
 unregNICK IrcMessage{..} =
   if length params /= 1
@@ -66,19 +60,11 @@ unregNICK IrcMessage{..} =
 unregUSER :: IrcMessage -> IrcMonad ()
 unregUSER IrcMessage{..} =
   if length params < 4
-  then tellNumeric err_needmoreparams [":need more parameters"]
+  then tellNumeric err_needmoreparams ["USER", ":need more parameters"]
   else do
     clientReg . rcvdName .= (Just $ head params)
     tryRegistration
 
-useNick :: IrcMonad (Maybe BS.ByteString)
-useNick = do
-  regState <- use clientReg
-  return $ case regState of
-    Unreg _ (Just nick) _       -> Just nick
-    RegUser (NickName nick _ _) -> Just nick
-    _                           -> Nothing
-
 renderQuitMsg :: Maybe BS.ByteString -> IrcMonad BS.ByteString
 renderQuitMsg (Just msg) = return $ BS.append "Quit: " msg
 renderQuitMsg Nothing    = useNick >>= \nickname ->
@@ -86,17 +72,18 @@ renderQuitMsg Nothing    = useNick >>= \nickname ->
     Just nick -> BS.append "Quit: " nick
     Nothing   -> ""
 
-chanEcho :: IrcMessage -> IrcMonad ()
+handlePING :: IrcMessage -> IrcMonad ()
-chanEcho iMsg = do
+handlePING _ = do
-  mNick <- useNick
+  srvname <- view ircHostName
-  when (isJust mNick) $ do
+  tellCommand PONG [":" <> srvname]
-    let nick = fromJust mNick
+
-    msg <- addUserPrefix iMsg
+handlePONG :: IrcMessage -> IrcMonad ()
-    mUser <- fmap (M.lookup nick) $ use (clientServer . ircUsers)
+handlePONG _ = do
-    when (isJust mUser) $ do
+  cid <- use clientConn
-      let user = fromJust mUser
+  tell [Pong cid]
-      let chans = S.elems $ user ^. userChannels
+
-      findReceivers chans >>= fwdMsg msg
+-- JOIN, MODE, KICK, PART, QUIT and of course PRIVMSG/NOTICE need to be
+-- echoed to channels that the user belongs to
 
 doQuit :: IrcMessage -> Maybe BS.ByteString -> IrcMonad ()
 doQuit msg quitParamIn = do
@@ -107,7 +94,7 @@ doQuit msg quitParamIn = do
   let quitParam = BS.concat [ ":Closing Link: ", hoststr
                             , " (", quitMsg, ")"]
   tellCommand ERROR [quitParam]
-  chanEcho msg
+  allChanEcho msg{params = [quitParam]}
   tell [Close connId]
   return ()
 
@@ -117,16 +104,72 @@ handleQUIT msg@IrcMessage{..} =
     []  -> Nothing
     p:_ -> Just p
 
-mkUser :: NickName -> IrcMonad IrcUser
+handleJOIN :: IrcMessage -> IrcMonad ()
-mkUser nn = do
+handleJOIN msg@IrcMessage{..} =
-  conn <- use clientConn
+  case params of
-  srvname <- view ircHostName
+    []      -> tellNumeric err_needmoreparams ["JOIN", ":Not enough parameters"]
-  return IrcUser { _userNick = nn
+    ["0"]   -> do
-                 , _userServerName = srvname
+      Just nn <- useNick
-                 , _userModes = S.empty
+      cs <- use $ clientServer . ircUsers . at nn
-                 , _userChannels = S.empty
+      let Just chans = fmap (^. userChannels) cs
-                 , _userConn = conn
+      doPart msg{command=Left PART} (S.elems chans) Nothing
-                 }
+    cs:[]   -> doJoin msg $ zipParams (parseParamList cs) []
+    cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
+
+handlePART :: IrcMessage -> IrcMonad ()
+handlePART msg@IrcMessage{..} =
+  case params of
+    []      -> tellNumeric err_needmoreparams ["PART", ":Not enough parameters"]
+    cs:[]   -> doPart msg (parseParamList cs) Nothing
+    cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)
+
+tellErr :: IrcReply -> [IrcParam] -> IrcMonadErr ()
+tellErr r ps = lift (tellNumeric r ps) >> left []
+
+checkRegistration :: IrcMonadErr BS.ByteString
+checkRegistration = do
+  mNick <- lift useNick
+  when (isNothing mNick) $
+    tellErr err_notregistered [":You have not registered"]
+  right $ fromJust mNick
+
+doJoin :: IrcMessage -> [(BS.ByteString, Maybe BS.ByteString)] -> IrcMonad ()
+doJoin msg chans = forM_ chans $ \(c, k) -> runEitherT $ do
+  nick <- checkRegistration
+  mChan <- lift $ useChan c
+  when (isJust mChan) $ do
+    let chan = fromJust mChan
+
+    when (chanHasUser nick chan) $ left "already on channel"
+
+    when (ircInviteCheck nick chan) $
+      tellErr err_inviteonlychan [c, ":Cannot join channel (+i)"]
+
+    when (ircKeyCheck k chan) $
+      tellErr err_badchannelkey [c, ":Cannot join channel (+k)"]
+
+  lift $ do
+    clientServer %= ircJoin nick c
+    tellTOPIC c
+    tellNAMES [c]
+    chanEcho [c] msg
+
+doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad ()
+doPart msg chans pmsg = forM_ chans $ \c -> runEitherT $ do
+  nn <- checkRegistration
+  mChan <- lift . use $ clientServer . ircChannels . at c
+  when (isNothing mChan) $ tellErr err_nosuchchannel [c, ":No such channel"]
+  let ch = fromJust mChan
+  unless (chanHasUser nn ch) $ tellErr err_notonchannel [c, ":Not on channel"]
+
+  lift $ do
+    let plist = case pmsg of
+          Just bs -> [c, BS.append ":" bs]
+          Nothing -> [c]
+    let newMsg = msg{params = plist}
+    chanEcho [c] newMsg
+    findReceivers [nn] >>= fwdMsgNoReplace msg
+    clientServer %= ircPart nn c
 
 tryRegistration :: IrcMonad ()
 tryRegistration = do
@@ -136,30 +179,25 @@ tryRegistration = do
     Unreg _ (Just nickname) (Just name) -> do
       let nn = NickName nickname (Just name) hostname
       clientReg .= RegUser nn
-      newUser <- mkUser nn
+      usr <- mkUser
-      clientServer . ircUsers %= M.insert nickname newUser
+      clientServer . ircUsers %= M.insert nickname usr
 
       tellWELCOME  nickname
       tellYOURHOST nickname
       tellMOTD     nickname
     _                               -> return ()
 
-addUserPrefix :: IrcMessage -> IrcMonad IrcMessage
-addUserPrefix msg = do
-  regState <- use clientReg
-  return $ case regState ^? regdNick of
-    Just nickname -> msg{ prefix = Just . Right $ nickname }
-    _             -> msg{ prefix = Nothing }
-
 regHandler :: IrcMessage -> IrcMonad ()
 regHandler msg@IrcMessage{..} = do
   pMsg <- addUserPrefix msg
   case command of
     Left PRIVMSG -> handlePRIVMSG pMsg
-    Left JOIN    -> return ()
+    Left JOIN    -> handleJOIN pMsg
-    Left PART    -> return ()
+    Left PART    -> handlePART pMsg
     Left LIST    -> return ()
     Left NICK    -> return ()
+    Left PING    -> handlePING pMsg
+    Left PONG    -> handlePONG pMsg
     Left QUIT    -> handleQUIT pMsg
     _            -> return ()
 
@@ -168,109 +206,6 @@ handlePRIVMSG msg@IrcMessage{..} = do
   case params of
     []       -> tellNumeric err_norecipient []
     _:[]     -> tellNumeric err_notexttosend []
-    rsp:_:_  -> let rs = Prelude.filter (not . BS.null) $ BS.split ',' rsp
+    rsp:_:_  -> let rs = parseParamList rsp
                 in findReceivers rs >>= fwdMsg msg
   return ()
-
-channelTargets :: BS.ByteString -> IrcMonad [Int]
-channelTargets chname = do
-  srv <- use clientServer
-  Just mynick <- useNick
-  let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers)
-  let chmap = srv ^. ircChannels
-  case M.lookup chname chmap of
-    Just chan -> fmap catMaybes $ forM (cUsers chan) userTarget
-    _         -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"]
-                    return []
-
-userTarget :: BS.ByteString -> IrcMonad (Maybe Int)
-userTarget uname = do
-  srv <- use clientServer
-  let umap = srv ^. ircUsers
-  case M.lookup uname umap of
-    Just user -> return . Just $ user ^. userConn
-    _         -> do tellNumeric err_nosuchnick [uname, ":No such nick/channel"]
-                    return Nothing
-
-findReceivers :: [BS.ByteString] -> IrcMonad [([Int], BS.ByteString)]
-findReceivers rcvNames =
-  fmap catMaybes $ forM rcvNames $ \name ->
-    if BS.head name == '#'
-     then do
-      cids <- channelTargets name
-      return $ case cids of
-        [] -> Nothing
-        cs -> Just (cs, name)
-     else do
-      cid <- userTarget name
-      return $ case cid of
-        Just c  -> Just ([c], name)
-        Nothing -> Nothing
-
-fwdMsg :: IrcMessage -> [([Int], BS.ByteString)] -> IrcMonad ()
-fwdMsg msg rcvs = forM_ rcvs $ \ (cId, n) -> do
-  -- replace multiple targets with the single target we're doing
-  let m = msg{ params = n : tail (params msg) }
-  tell [Msg m cId]
-
-tellNumeric :: IrcReply -> [IrcParam] -> IrcMonad ()
-tellNumeric reply desc = do
-  srvname <- view ircHostName
-  connId  <- use clientConn
-  let msg = IrcMessage (Just $ Left srvname) (Right reply) desc
-  tell [Msg msg [connId]]
-  return ()
-
-{-
-tellPrefixedCommand :: IrcCommand -> [IrcParam] -> IrcMonad ()
-tellPrefixedCommand reply desc = do
-  srvname <- view ircHostName
-  connId <- use clientConn
-  let msg = IrcMessage (Just $ Left srvname) (Left reply) desc
-  tell [Msg msg [connId]]
--}
-
-tellCommand :: IrcCommand -> [IrcParam] -> IrcMonad ()
-tellCommand reply desc = do
-  connId <- use clientConn
-  let msg = IrcMessage Nothing (Left reply) desc
-  tell [Msg msg [connId]]
-
-ppHostPreference :: HostPreference -> BS.ByteString
-ppHostPreference hp = case hp of
-  HostAny  -> "*"
-  HostIPv4 -> "*4"
-  HostIPv6 -> "*6"
-  Host hn  -> BS.pack hn
-
-ppServiceName :: ServiceName -> BS.ByteString
-ppServiceName = BS.pack
-
-tellYOURHOST :: BS.ByteString -> IrcMonad ()
-tellYOURHOST nickname = do
-  srvname <- view ircHostName
-  srvhost <- view ircHost
-  srvport <- view ircPort
-  version <- use $ clientServer . ircVersion
-  let hostStr = ppHostPreference srvhost
-      portStr = ppServiceName srvport
-  tellNumeric rpl_yourhost
-    [ nickname
-    , BS.concat [ ":Your host is ", srvname
-                , "[", hostStr, "/", portStr, "], "
-                , "running version ", version ]
-    ]
-
-tellMOTD :: BS.ByteString -> IrcMonad ()
-tellMOTD nickname = do
-  motd <- view ircMotd
-  tellNumeric rpl_motdstart [nickname, ":- Message of the Day -"]
-  forM_ motd $ \line ->
-    tellNumeric rpl_motd [nickname, ":- " `BS.append` line]
-  tellNumeric rpl_endofmotd [nickname, ":End of MOTD"]
-
-tellWELCOME :: BS.ByteString -> IrcMonad ()
-tellWELCOME nickname = do
-  srvname <- view ircHostName
-  tellNumeric rpl_welcome [ nickname
-                          , BS.append ":Welcome to IRC on " srvname ]

src/Pipes/IRC/Server/Types.hs

@@ -8,12 +8,13 @@ module Pipes.IRC.Server.Types
 where
 
 import           Control.Concurrent.STM  (TVar)
+import           Control.Error
 import           Control.Lens
-import           Control.Monad.RWS       (MonadReader, MonadState, MonadWriter,
+import           Control.Monad.RWS       (RWS)
-                                          RWS)
 import           Data.ByteString         (ByteString)
 import           Data.Map                (Map)
 import           Data.Set                (Set)
+import           Data.Time.Clock         (UTCTime)
 import           Pipes.Concurrent        (Output)
 import           Pipes.IRC.Message.Types (IrcMessage, NickName)
 import           Pipes.Network.TCP       (HostPreference (..), ServiceName,
@@ -25,30 +26,35 @@ data IrcEvent = Msg { _outMsg  :: !IrcMessage
                     , _outDest :: ![Int]
                     }
               | Close { _closeConn :: Int }
+              | Pong { _pongConn :: Int }
                deriving (Show)
 makeLenses ''IrcEvent
 
 data IrcUserMode = Away | Invisible | WallOps | Restricted
                  | Oper | LocalOper | ServerNotices
-            deriving (Show, Eq, Enum)
+            deriving (Show, Eq, Enum, Ord)
 
 data IrcUser =
-  IrcUser { _userNick       :: !NickName
+  IrcUser { _userServerName :: !ByteString
-          , _userServerName :: !ByteString
           , _userModes      :: !(Set IrcUserMode)
           , _userChannels   :: !(Set ByteString)
           , _userConn       :: !Int
+          , _userInvites    :: !(Set ByteString)
           } deriving (Show, Eq)
 makeLenses ''IrcUser
 
-data IrcChanMode = Anonymous | InviteOnly | Moderated | Quiet | Secret
+data IrcChanModeFlags = Anonymous | InviteOnly | Moderated | NoOutsideMsgs
-            deriving (Show, Eq, Enum)
+                      | Quiet | Private | Secret | TopicOperOnly
+            deriving (Show, Eq, Enum, Ord)
 
 data IrcChannel =
-  IrcChannel { _chanName  :: !ByteString
+  IrcChannel { _chanTopic     :: !(Maybe ByteString)
-             , _chanTopic :: !ByteString
+             , _chanKey       :: !(Maybe ByteString)
-             , _chanModes :: !(Set IrcChanMode)
+             , _chanModeFlags :: !(Set IrcChanModeFlags)
-             , _chanUsers :: !(Set ByteString)
+             , _chanUsers     :: !(Set ByteString)
+             , _chanOpers     :: !(Set ByteString)
+             , _chanVoices    :: !(Set ByteString)
+             , _chanInvites   :: !(Set ByteString)
              } deriving (Show, Eq)
 makeLenses ''IrcChannel
 
@@ -77,11 +83,13 @@ data RegState = Unreg   { _rcvdPass :: !(Maybe ByteString)
 makeLenses ''RegState
 
 data IrcConnection =
-  IrcConnection { _sock  :: !Socket
+  IrcConnection { _sock    :: !Socket
-                , _addr  :: !SockAddr
+                , _addr    :: !SockAddr
-                , _hname :: !(Maybe ByteString)
+                , _hname   :: !(Maybe ByteString)
-                , _out   :: !(Output IrcMessage)
+                , _out     :: !(Output IrcMessage)
-                , _reg   :: !RegState
+                , _reg     :: !RegState
+                , _lastCom :: !UTCTime
+                , _gotPong :: !Bool
                 }
 makeLenses ''IrcConnection
 
@@ -101,10 +109,5 @@ data ClientState =
               } deriving (Show)
 makeLenses ''ClientState
 
-newtype IrcMonad a =
+type IrcMonad a = RWS IrcConfig IrcEvents ClientState a
-  IrcMonad { runIrc :: RWS IrcConfig IrcEvents ClientState a }
+type IrcMonadErr a = EitherT String (RWS IrcConfig IrcEvents ClientState) a
-  deriving ( Monad
-           , Functor
-           , MonadReader IrcConfig
-           , MonadWriter IrcEvents
-           , MonadState  ClientState)