Various refactorings and bugfixes

src/Pipes/IRC/Message.hs

@@ -1,8 +1,11 @@
 module Pipes.IRC.Message
        ( parseMsgOrLine
        , parseIrcMessage
+       , renderIrcMessage
+       , renderIrcMessageNoNL
        , module Pipes.IRC.Message.Types
        ) where
 
 import           Pipes.IRC.Message.Parse
+import           Pipes.IRC.Message.Render
 import           Pipes.IRC.Message.Types

src/Pipes/IRC/Message/Render.hs

@@ -3,6 +3,7 @@
 
 module Pipes.IRC.Message.Render
   ( renderIrcMessage
+  , renderIrcMessageNoNL
   , renderNickName )
 where
 
@@ -15,17 +16,20 @@ import           Data.Monoid
 import           Pipes.IRC.Message.Types
 
 renderIrcMessage :: IrcMessage -> C8.ByteString
-renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage
+renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage True
+
+renderIrcMessageNoNL :: IrcMessage -> ByteString
+renderIrcMessageNoNL = toStrict . toLazyByteString . buildIrcMessage False
 
 renderNickName :: NickName -> C8.ByteString
 renderNickName = toStrict . toLazyByteString . buildNickName
 
-buildIrcMessage :: IrcMessage -> Builder
+buildIrcMessage :: Bool -> IrcMessage -> Builder
-buildIrcMessage IrcMessage {..} =
+buildIrcMessage nl IrcMessage {..} =
      buildMsgPrefix  prefix
   <> buildMsgCommand command
   <> buildIrcParams  params
-  <> byteString "\r\n"
+  <> if nl then byteString "\r\n" else mempty
 
 buildMsgPrefix :: Maybe MsgPrefix -> Builder
 buildMsgPrefix Nothing = mempty

src/Pipes/IRC/Message/Types.hs

@@ -2,6 +2,7 @@
 module Pipes.IRC.Message.Types where
 
 import qualified Data.ByteString as B
+import           Data.Monoid
 
 data IrcMessage =
   IrcMessage { prefix  :: Maybe MsgPrefix
@@ -71,6 +72,10 @@ data IrcReply = IrcReply
    , replyName :: !B.ByteString
    } deriving (Show)
 
+instance Monoid IrcReply where
+  mempty = mkIrcReply 400 "UNKNOWN ERROR"
+  _ `mappend` b = b
+
 instance Eq IrcReply where
   IrcReply { replyCode = a } == IrcReply { replyCode = b } = a == b
 

src/Pipes/IRC/Server.hs

@@ -13,27 +13,27 @@ import           Control.Monad
 import           Control.Monad.RWS
 import           Data.ByteString.Char8           as BS
 import           Data.Map                        as M
+import           Data.Maybe
 import           Data.Set                        as S
 import           Data.Time.Clock
 import           Network.Socket                  as NS
 import           Pipes
 import           Pipes.Attoparsec
 import           Pipes.Concurrent                as PC
-import           Pipes.IRC.Message.Parse
+import           Pipes.IRC.Message
-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
 
-version :: BS.ByteString
+version :: ByteString
 version = "0.1a"
 
-parseMessage :: Producer BS.ByteString IO ()
+parseMessage :: Producer ByteString IO ()
-             -> Producer (Either BS.ByteString IrcMessage) IO ()
+             -> Producer (Either ByteString IrcMessage) IO ()
 parseMessage prod = do
   void $ for (parseMany parseMsgOrLine prod) $ \res ->
     case res of
@@ -41,19 +41,18 @@ parseMessage prod = do
       (_, Right val) -> yield $ Right val
   return ()
 
-renderMessage :: Pipe IrcMessage BS.ByteString IO ()
+renderMessage :: Pipe IrcMessage ByteString IO ()
 renderMessage = forever $ do
   msg <- await
   let output = renderIrcMessage msg
   yield output
 
-filterMsgs :: Pipe (Either BS.ByteString IrcMessage) IrcMessage IO ()
+filterMsgs :: Pipe (Either ByteString IrcMessage) IrcMessage IO ()
 filterMsgs = forever $ do
   cmd <- await
   case cmd of
-    Left bs -> liftIO $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs]
+    Left bs -> liftIO $ logLine $ BS.concat ["BAD COMMAND: ", bs]
-    Right c -> do lift $ logMsg c
+    Right c -> yield c
-                  yield c
 
 addIrcConnection :: ServerState -> IrcConnection -> IO Int
 addIrcConnection srv client = do
@@ -80,6 +79,32 @@ delIrcConnection srv cid = atomically $ do
     _ -> return ()
   modifyTVar' (srv ^. ircConnections) $ M.delete cid
 
+ircMonadTransaction :: ServerState -> Int -> RegState -> IrcMonad ()
+                    -> IO (RegState, [IrcEvent])
+ircMonadTransaction srv cid userReg action = do
+  cmap <- readTVarIO $ srv ^. ircConnections
+  let hostname = view (at cid . traverse . hname) cmap
+  curTime <- getCurrentTime
+  atomically $ do
+    sState <- readTVar $ srv ^. ircState
+    let sConf = srv ^. ircConfig
+    let cState = ClientState { _clientReg = userReg
+                             , _clientServer = sState
+                             , _clientHost = hostname
+                             , _clientConn = cid }
+    let (_, newState, events) = runRWS action sConf cState
+    writeTVar (srv ^. ircState) (newState ^. clientServer)
+    modifyTVar' (srv ^. ircConnections) $
+      M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid
+    return (newState ^. clientReg, events)
+
+runIrcMonad :: ServerState -> Int -> IrcMonad () -> IO ()
+runIrcMonad srv cid action = do
+  cs <- readTVarIO (srv ^. ircConnections)
+  let cReg = maybe (Unreg Nothing Nothing Nothing) (view reg) (cs ^. at cid)
+  (_, events) <- ircMonadTransaction srv cid cReg action
+  forM_ events $ ircEventHandler srv
+
 cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
 cmdHandler srv cid =
   let cReg = Unreg Nothing Nothing Nothing
@@ -89,38 +114,24 @@ cmdHandler srv cid =
       Just c  -> handle (c ^. hname) cReg
       Nothing -> return ()
   where
-    handle host userReg = do
+    handle h userReg = do
       -- wait for the next command
       nextMsg <- await
-      curTime <- liftIO getCurrentTime
+
+      liftIO $ logMsg nextMsg (fromMaybe "unknown" h) userReg
 
       -- run the handler in a transaction
-      (newReg, events) <- liftIO $ atomically $ do
+      (newReg, events) <-
-        sState <- readTVar $ srv ^. ircState
+        liftIO $ ircMonadTransaction srv cid userReg (ircMessageHandler nextMsg)
-        let sConf = srv ^. ircConfig
-        let cState = ClientState { _clientReg = userReg
-                                 , _clientServer = sState
-                                 , _clientHost = host
-                                 , _clientConn = cid
-                                 }
-
-        -- run the handler in the IrcMonad, returning new state and events
-        let (_, newState, events) =
-              runRWS (ircMessageHandler nextMsg) sConf cState
-
-        writeTVar (srv ^. ircState) $
-          newState ^. clientServer
-
-        modifyTVar' (srv ^. ircConnections) $
-          M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid
-
-        return (newState ^. clientReg, events)
 
       -- handle resulting events
       aliveL <- liftIO $ forM events $ ircEventHandler srv
-
+{-    -- debug
+      sState <- liftIO $ readTVarIO $ srv ^. ircState
+      liftIO $ BS.putStrLn $ BS.pack (show sState)
+-}
       -- loop for the next command
-      when (and aliveL) $ handle host newReg
+      when (and aliveL) $ handle h newReg
 
 idlePinger :: ServerState -> Int -> IO ()
 idlePinger srv cid =
@@ -134,8 +145,7 @@ idlePinger srv cid =
                                M.adjust (gotPong .~ False) cid
     checkPong = do conns <- readTVarIO (srv ^. ircConnections)
                    return $ conns ! cid ^. gotPong
-   in
+    timeoutLoop b = when b $ do
-   forever $ do
       threadDelay oneMinute
       curTime <- getCurrentTime
       time <- getLastCom
@@ -143,12 +153,20 @@ idlePinger srv cid =
       if diffTime > 60
         then do
           resetPong
+
           atomically $ do
             conns <- readTVar (srv ^. ircConnections)
             PC.send (conns ! cid ^. out) pingMsg
+
           threadDelay oneMinute
-            checkPong
+
-       else return True
+          checkPong >>= timeoutLoop
+        else timeoutLoop True
+  in do
+    -- timeoutLoop will call itself repeatedly until a timeout occurs
+    timeoutLoop True
+    -- Then we need to send a timeout message
+    runIrcMonad srv cid $ doQuit (Just "Ping timeout")
 
 listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
 listenHandler srv (lsock, _) =
@@ -161,6 +179,9 @@ listenHandler srv (lsock, _) =
     (writeEnd, readEnd) <- spawn Unbounded
     curTime <- getCurrentTime
 
+    logLine $ BS.pack $
+      "Accepted connection from " ++ fromMaybe "unknown" hName
+
     let client = IrcConnection
                   { _sock  = csock
                   , _addr  = caddr
@@ -188,6 +209,9 @@ listenHandler srv (lsock, _) =
 
     void $ waitAnyCancel [r, w, idle]
 
+    logLine $ BS.pack $
+      "Connection from " ++ fromMaybe "unknown" hName ++ " terminated"
+
     delIrcConnection srv cid
 
 mkIrcServer :: IrcConfig -> IO ServerState
@@ -206,4 +230,6 @@ startIrcServer config = do
   srv <- mkIrcServer config
   let sHost = srv ^. ircConfig . ircHost
       sPort = srv ^. ircConfig . ircPort
+  logLine $ BS.pack $
+    mconcat ["Starting server on ", show sHost, " ", show sPort]
   async $ PN.listen sHost sPort (listenHandler srv)

src/Pipes/IRC/Server/EventHandler.hs

@@ -11,6 +11,7 @@ import           Control.Monad
 import           Data.Map                 as M
 import           Data.Maybe               as DM
 import           Pipes.Concurrent         as PC
+import           Pipes.IRC.Server.Log
 import           Pipes.IRC.Server.Types
 
 sendToMany :: a -> [Output a] -> IO ()
@@ -31,8 +32,9 @@ ircEventHandler srv evt =
       outConns <- readTVarIO $ srv ^. ircConnections
       let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest
       sendToMany _outMsg os
+      logOutMsg _outMsg _outDest
       return True
     Pong {..} -> do
       atomically $ modifyTVar' (srv ^. ircConnections) $
-                     M.adjust (gotPong .~ False) _pongConn
+                     M.adjust (gotPong .~ True) _pongConn
       return True

src/Pipes/IRC/Server/IrcMonad.hs

@@ -3,6 +3,7 @@
 module Pipes.IRC.Server.IrcMonad
 where
 
+import           Control.Applicative      ((<$>))
 import           Control.Error
 import           Control.Lens
 import           Control.Monad.RWS
@@ -26,6 +27,40 @@ mkUser = do
   srvname <- view ircHostName
   return $ newUser srvname conn
 
+-- * User registration management
+
+storePassKey :: PassKey -> IrcMonad ()
+storePassKey k = clientReg . rcvdPass ?= k
+
+storeNickKey :: NickKey -> IrcMonad ()
+storeNickKey nn = clientReg . rcvdNick ?= nn
+
+storeUserName :: ByteString -> IrcMonad ()
+storeUserName n = clientReg . rcvdName ?= n
+
+registerUser :: RegState -> IrcMonad ()
+registerUser rs = clientReg .= rs
+
+-- * IrcServer management
+
+joinNickToChan :: NickKey -> ChanKey -> IrcMonad ()
+joinNickToChan nn c = clientServer %= ircJoin nn c
+
+partNickFromChan :: NickKey -> ChanKey -> IrcMonad ()
+partNickFromChan nn c = clientServer %= ircPart nn c
+
+reserveNick :: NickKey -> IrcMonad ()
+reserveNick nn = clientServer . ircNicks . contains nn .= True
+
+changeNick :: NickKey -> NickKey -> IrcMonad ()
+changeNick oldN newN = do
+  clientServer %= ircChangeNick oldN newN
+  clientReg . regdNick %= (\n -> n{nick = newN})
+
+associateUserWithNick :: IrcUser -> NickKey -> IrcMonad ()
+associateUserWithNick usr nn = clientServer . ircUsers . at nn ?= usr
+
+
 -- * Pretty Printing
 
 ppServiceName :: ServiceName -> ByteString
@@ -114,22 +149,36 @@ chanEcho chans iMsg = do
   msg <- addUserPrefix iMsg
   findReceivers chans >>= fwdMsg msg
 
+allChans :: IrcMonad [ChanKey]
+allChans = do
+  cs <- runMaybeT $ do
+    nn <- lift useNick >>= hoistMaybe
+    usrs <- lift (use $ clientServer . ircUsers)
+    usr <- hoistMaybe $ M.lookup nn usrs
+    let chans = S.elems $ usr ^. userChannels
+    return chans
+  return $ fromMaybe [] cs
+
 allChanEcho :: IrcMessage -> IrcMonad ()
 allChanEcho iMsg = do
-  mNick <- useNick
+  cs <- allChans
-  when (isJust mNick) $ do
+  chanEcho cs iMsg
-    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
 
 disconnectUser :: Int -> IrcMessage -> IrcMonad ()
 disconnectUser cid msg = do
   allChanEcho msg
   tell [Close cid]
 
+doQuit :: Maybe ByteString -> IrcMonad ()
+doQuit qmsg = do
+  connId   <- use clientConn
+  hostname <- fromMaybe "unknown hostname" <$> use clientHost
+  quitMsg  <- renderQuitMsg qmsg
+  let quitParam = mconcat [":Closing Link: ", hostname, " (", quitMsg, ")"]
+  let msg = IrcMessage Nothing (Left QUIT) [quitParam]
+  tellCommand ERROR [quitParam]
+  disconnectUser connId msg
+
 -- * Command validation utilities
 
 type ErrParam    = (IrcReply, [IrcParam])
@@ -143,7 +192,7 @@ runValidation :: IrcMonadErr () -> IrcMonad ()
 runValidation = tellErr <=< runEitherT
 
 ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr ()
-ensure p r ps = when p $ left (r, ps)
+ensure p r ps = unless p $ left (r, ps)
 
 ensureUse :: IrcMonad (Maybe a)  -> ErrParam -> IrcMonadErr a
 ensureUse u e = lift u >>= hoistEither . note e
@@ -155,7 +204,7 @@ checkParamLength cmd ps n =
 
 checkSuppliedNickname :: [IrcParam] -> IrcMonadErr NickKey
 checkSuppliedNickname ps = do
-  ensure (not . null $ ps) err_nonicknamegiven [":must supply a nickname"]
+  ensure (not $ null ps) err_nonicknamegiven [":must supply a nickname"]
   return (head ps)
 
 checkRegistration :: IrcMonadErr NickKey
@@ -166,13 +215,18 @@ checkChannelPresence :: ChanKey -> IrcMonadErr IrcChannel
 checkChannelPresence ckey =
   ensureUse (useChan ckey) (err_badchannelkey, [ckey, ":No such channel"])
 
+checkChannelAbsence :: ChanKey -> IrcMonadErr ()
+checkChannelAbsence ckey = do
+  ch <- lift $ useChan ckey
+  ensure (isNothing ch) mempty mempty
+
 checkUserOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
 checkUserOnChan nn c ch =
   ensure (chanHasUser nn ch) err_notonchannel [c, ":Not on channel"]
 
 checkUserNotOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
 checkUserNotOnChan nn c ch =
-  ensure (not . chanHasUser nn $ ch) err_notonchannel [c, ":Already on channel"]
+  ensure (not $ chanHasUser nn ch) err_notonchannel [c, ":Already on channel"]
 
 checkInvitation :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
 checkInvitation nn c ch = ensure (ircInviteCheck nn ch)
@@ -185,7 +239,7 @@ checkPassKey k c chan = ensure (ircPassCheck k chan)
 checkNickFree :: NickKey -> IrcMonadErr ()
 checkNickFree nickname = do
   nickSet <- lift (use $ clientServer . ircNicks)
-  ensure (S.member nickname nickSet)
+  ensure (not $ S.member nickname nickSet)
          err_nicknameinuse [nickname, ":Nickname is already in use."]
 
 -- * Adding responses to the Writer portion of the monad

src/Pipes/IRC/Server/Log.hs

@@ -1,12 +1,41 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Pipes.IRC.Server.Log
-  ( logMsg )
+  ( logMsg
+  , logLine
+  , logOutMsg
+  )
 where
 
-import           Data.ByteString          as BS
+import           Data.ByteString.Char8  (ByteString)
-import           Pipes.IRC.Message.Render
+import qualified Data.ByteString.Char8  as BS
-import           Pipes.IRC.Message.Types
+import           Data.Time
+import           Pipes.IRC.Message
+import           Pipes.IRC.Server.Types
 
-logMsg :: IrcMessage -> IO ()
+logMsg :: IrcMessage -> ByteString -> RegState -> IO ()
-logMsg msg = BS.putStr $ BS.concat ["LOG: ", renderIrcMessage msg]
+logMsg msg h userReg =
+  putLog $ BS.concat ["MSG:", hStr, uStr, renderIrcMessageNoNL msg]
+ where
+   hStr = BS.concat [" ", h, " "]
+   uStr = BS.concat $ case userReg of
+     Unreg _ (Just nn) Nothing           -> [" ", nn, " ? "]
+     Unreg _ Nothing   (Just name)       -> [" ? ", name, " "]
+     Unreg _ (Just nn) (Just name)       -> [" ", nn," ", name, " "]
+     RegUser (NickName nn (Just name) _) -> [" ", nn," ", name, " "]
+     _                                   -> [" ? ? "]
+
+logOutMsg :: IrcMessage -> [Int] -> IO ()
+logOutMsg msg os =
+  putLog $ BS.concat [ "OutMSG: "
+                     , BS.intercalate "," $ map (BS.pack . show) os
+                     , ": "
+                     , renderIrcMessageNoNL msg ]
+
+logLine :: ByteString -> IO ()
+logLine = putLog
+
+putLog :: ByteString -> IO ()
+putLog l = do
+  now <- getCurrentTime
+  BS.putStrLn $ BS.concat [BS.pack (show now), " : ", l]

src/Pipes/IRC/Server/MessageHandler.hs

@@ -5,7 +5,7 @@ module Pipes.IRC.Server.MessageHandler
   ( ircMessageHandler )
 where
 
-import           Control.Applicative       ((<$>))
+import           Control.Applicative       (pure, (<$>), (<|>))
 import           Control.Error
 import           Control.Lens
 import           Control.Monad.RWS
@@ -14,7 +14,6 @@ import           Data.Set                  as S
 
 import           Pipes.IRC.Message.Types
 import           Pipes.IRC.Server.IrcMonad
-import           Pipes.IRC.Server.Server
 import           Pipes.IRC.Server.Types
 import           Pipes.IRC.Server.Util
 
@@ -43,14 +42,25 @@ regHandler :: IrcMessage -> IrcMonad ()
 regHandler msg@IrcMessage{..} = do
   pMsg <- addUserPrefix msg
   case command of
-    Left PRIVMSG -> handlePRIVMSG pMsg
+    Left AWAY    -> return ()
+    Left INVITE  -> return ()
     Left JOIN    -> handleJOIN pMsg
-    Left PART    -> handlePART pMsg
+    Left KICK    -> return ()
+    Left KILL    -> return ()
     Left LIST    -> return ()
-    Left NICK    -> return ()
+    Left MODE    -> return ()
+    Left NAMES   -> return ()
+    Left NICK    -> handleNICK pMsg
+    Left NOTICE  -> return ()
+    Left PART    -> handlePART pMsg
     Left PING    -> handlePING pMsg
     Left PONG    -> handlePONG pMsg
+    Left PRIVMSG -> handlePRIVMSG pMsg
+    Left TOPIC   -> return ()
     Left QUIT    -> handleQUIT pMsg
+    Left WHO     -> return ()
+    Left WHOIS   -> return ()
+    Left WHOWAS  -> return ()
     _            -> return ()
 
 -- * Handlers for messages coming from unregistered users
@@ -58,22 +68,22 @@ regHandler msg@IrcMessage{..} = do
 unregPASS :: IrcMessage -> IrcMonad ()
 unregPASS IrcMessage{..} = runValidation $ do
   checkParamLength "PASS" params 1
-  lift $ clientReg . rcvdPass ?= head params
+  lift $ storePassKey (head params)
 
 unregNICK :: IrcMessage -> IrcMonad ()
 unregNICK IrcMessage{..} = runValidation $ do
   nickname <- checkSuppliedNickname params
   checkNickFree nickname
   lift $ do
-    clientReg . rcvdNick ?= nickname
+    storeNickKey nickname
-    clientServer . ircNicks . contains nickname .= True
+    reserveNick nickname
     tryRegistration
 
 unregUSER :: IrcMessage -> IrcMonad ()
 unregUSER IrcMessage{..} = runValidation $ do
   checkParamLength "USER" params 4
   lift $ do
-    clientReg . rcvdName ?= head params
+    storeUserName (head params)
     tryRegistration
 
 tryRegistration :: IrcMonad ()
@@ -83,8 +93,8 @@ tryRegistration = do
   case regState of
     Unreg _ (Just nickname) (Just name) -> do
       usr <- mkUser
-      clientReg .= (RegUser $ NickName nickname (Just name) hostname)
+      registerUser (RegUser $ NickName nickname (Just name) hostname)
-      clientServer . ircUsers . at nickname ?= usr
+      associateUserWithNick usr nickname
 
       tellWELCOME  nickname
       tellYOURHOST nickname
@@ -107,22 +117,19 @@ handlePONG _ = do
 -- echoed to channels that the user belongs to
 
 handleQUIT :: IrcMessage -> IrcMonad ()
-handleQUIT msg@IrcMessage{..} = do
+handleQUIT IrcMessage{..} = doQuit (headMay params)
-  connId   <- use clientConn
-  hostname <- fromMaybe "unknown hostname" <$> use clientHost
-  quitMsg  <- renderQuitMsg (headMay params)
-  let quitParam = mconcat [":Closing Link: ", hostname, " (", quitMsg, ")"]
-  tellCommand ERROR [quitParam]
-  disconnectUser connId msg{params = [quitParam]}
 
 handleJOIN :: IrcMessage -> IrcMonad ()
 handleJOIN msg@IrcMessage{..} = runValidation $ do
   checkParamLength "JOIN" params 1
   nn <- checkRegistration
   lift $ case params of
+    -- Joining channel "0" really means to PART all channels
     ["0"]   -> do cs <- useUserChans nn
                   doPart msg{command=Left PART} (S.elems cs) Nothing
+    -- No passwords were supplied
     cs:[]   -> doJoin msg $ zipParams (parseParamList cs) []
+    -- Some number of passwords were supplied
     cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
 
 handlePART :: IrcMessage -> IrcMonad ()
@@ -135,16 +142,20 @@ handlePART msg@IrcMessage{..} = runValidation $ do
 doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
 doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do
   nick <- checkRegistration
-  chan <- checkChannelPresence c
+  -- If the channel is absent, joining it will create it
+  checkChannelAbsence c
+        -- If it already exists, do some sanity checks first
+    <|> do chan <- checkChannelPresence c
            checkUserNotOnChan nick c chan
            checkInvitation nick c chan
            checkPassKey k c chan
 
   lift $ do
-    clientServer %= ircJoin nick c
+    joinNickToChan nick c
     tellTOPIC c
     tellNAMES [c]
     chanEcho [c] msg
+    findReceivers [nick] >>= fwdMsgNoReplace msg
 
 doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad ()
 doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do
@@ -155,9 +166,8 @@ doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do
 
   lift $ do
     chanEcho [c] newMsg
-    rs <- findReceivers [nn]
+    findReceivers [nn] >>= fwdMsgNoReplace msg
-    fwdMsgNoReplace msg rs
+    partNickFromChan nn c
-    clientServer %= ircPart nn c
 
 handlePRIVMSG :: IrcMessage -> IrcMonad ()
 handlePRIVMSG msg@IrcMessage{..} = do
@@ -167,3 +177,13 @@ handlePRIVMSG msg@IrcMessage{..} = do
     rsp:_:_  -> let rs = parseParamList rsp
                 in findReceivers rs >>= fwdMsg msg
   return ()
+
+handleNICK :: IrcMessage -> IrcMonad ()
+handleNICK msg@IrcMessage{..} = runValidation $ do
+  nn <- checkRegistration
+  newNick <- checkSuppliedNickname params
+  checkNickFree newNick
+  lift $ do
+    cs <- allChans
+    findReceivers (cs <> [nn]) >>= fwdMsgNoReplace msg
+    changeNick nn newNick

src/Pipes/IRC/Server/Server.hs

@@ -9,7 +9,6 @@ module Pipes.IRC.Server.Server
 where
 
 import           Control.Lens
-import           Data.ByteString.Char8    (ByteString)
 import           Data.Map                 ((!))
 import qualified Data.Map                 as M
 import           Data.Maybe
@@ -112,7 +111,7 @@ 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)
+  not (chanHasModeFlag InviteOnly chan) || chanUserIsInvited n chan
 
 -- | Determine whether the given channel will disallow joining due to
 -- a missing or incorrect password. A 'True' value indicates that
@@ -121,7 +120,7 @@ ircPassCheck :: Maybe PassKey    -- ^ 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))
+  not (chanHasPass chan) || (isJust k && chanCheckPass (fromJust k) chan)
 
 -- | Change the nickname of a user from 'old' to 'new', updating the
 -- necessary 'IrcServer' structures. No nick collision check is

src/Pipes/IRC/Server/Types.hs

@@ -8,7 +8,6 @@ module Pipes.IRC.Server.Types
 where
 
 import           Control.Concurrent.STM  (TVar)
-import           Control.Error
 import           Control.Lens
 import           Control.Monad.RWS       (RWS)
 import           Data.ByteString         (ByteString)