Server is semi-functional, users can register and send direct messages to one another

pipes-irc-server.cabal

@@ -40,6 +40,7 @@ executable pipes-irc-server
                    , stm               >= 2      && < 3
                    , async             >= 2      && < 3
                    , free              >= 3      && < 4
+                   , lens              >= 3      && < 4
                        
   hs-source-dirs:    src
   default-language:  Haskell2010

src/Main.hs

@@ -4,17 +4,18 @@ module Main where
 
 import           Control.Concurrent.Async (wait)
 import           Pipes.IRC.Server         (startIrcServer)
-import           Pipes.IRC.Server.Types   (HostPreference (Host),
+import           Pipes.IRC.Server.Types   (IrcConfig (..))
-                                           IrcConfig (..))
+import           Pipes.Network.TCP        (HostPreference (..))
 
 main :: IO ()
 main =
   let
     ircConf =
-      IrcConfig { ircPort = "6665"
+      IrcConfig { _ircPort = "6665"
-                , ircHost = Host "127.0.0.1"
+                , _ircHost = Host "127.0.0.1"
-                , ircMotd = ["Welcome to the IRC Server!"]
+                , _ircHostName = "pinealservo.com"
-                , ircPass = Nothing
+                , _ircMotd = ["Welcome to the IRC Server!"]
+                , _ircPass = Nothing
                 }
   in do
     listener <- startIrcServer ircConf

src/Pipes/IRC/Message/Render.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE RecordWildCards   #-}
 
 module Pipes.IRC.Message.Render
-  ( renderIrcMessage )
+  ( renderIrcMessage
+  , renderNickName )
 where
 
 import           Data.ByteString                    (ByteString)
@@ -16,6 +17,9 @@ import           Pipes.IRC.Message.Types
 renderIrcMessage :: IrcMessage -> C8.ByteString
 renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage
 
+renderNickName :: NickName -> C8.ByteString
+renderNickName = toStrict . toLazyByteString . buildNickName
+
 buildIrcMessage :: IrcMessage -> Builder
 buildIrcMessage IrcMessage {..} =
      buildMsgPrefix  prefix
@@ -68,7 +72,12 @@ buildIrcCommand cmd =
     _              -> byteString . C8.pack . show $ cmd
 
 buildIrcReply :: IrcReply -> Builder
-buildIrcReply IrcReply {..} = intDec replyCode
+buildIrcReply IrcReply {..} =
+  let
+    h = replyCode `quot` 100
+    t = (replyCode - (h * 100)) `quot` 10
+    o = replyCode - (h * 100) - (t * 10)
+  in intDec h <> intDec t <> intDec o
 
 buildIrcParams :: [IrcParam] -> Builder
 buildIrcParams []     = mempty

src/Pipes/IRC/Message/Types.hs

@@ -80,6 +80,11 @@ instance Ord IrcReply where
 
 instance Enum IrcReply where
   fromEnum = replyCode
+  toEnum 001 = rpl_welcome
+  toEnum 002 = rpl_yourhost
+  toEnum 003 = rpl_created
+  toEnum 004 = rpl_myinfo
+  toEnum 005 = rpl_isupport
   toEnum 200 = rpl_tracelink
   toEnum 201 = rpl_traceconnecting
   toEnum 202 = rpl_tracehandshake
@@ -143,6 +148,7 @@ instance Enum IrcReply where
   toEnum 368 = rpl_endofbanlist
   toEnum 369 = rpl_endofwhowas
   toEnum 371 = rpl_info
+  toEnum 372 = rpl_motd
   toEnum 374 = rpl_endofinfo
   toEnum 375 = rpl_motdstart
   toEnum 376 = rpl_endofmotd
@@ -202,6 +208,21 @@ instance Enum IrcReply where
 mkIrcReply :: Int -> B.ByteString -> IrcReply
 mkIrcReply = IrcReply
 
+rpl_welcome :: IrcReply
+rpl_welcome = mkIrcReply 001 "RPL_WELCOME"
+
+rpl_yourhost :: IrcReply
+rpl_yourhost = mkIrcReply 002 "RPL_YOURHOST"
+
+rpl_created :: IrcReply
+rpl_created = mkIrcReply 003 "RPL_CREATED"
+
+rpl_myinfo :: IrcReply
+rpl_myinfo = mkIrcReply 004 "RPL_MYINFO"
+
+rpl_isupport :: IrcReply
+rpl_isupport = mkIrcReply 005 "RPL_ISUPPORT"
+
 rpl_tracelink :: IrcReply
 rpl_tracelink = mkIrcReply 200 "RPL_TRACELINK"
 
@@ -391,6 +412,9 @@ rpl_endofwhowas = mkIrcReply 369 "RPL_ENDOFWHOWAS"
 rpl_info :: IrcReply
 rpl_info = mkIrcReply 371 "RPL_INFO"
 
+rpl_motd :: IrcReply
+rpl_motd = mkIrcReply 372 "RPL_MOTD"
+
 rpl_endofinfo :: IrcReply
 rpl_endofinfo = mkIrcReply 374 "RPL_ENDOFINFO"
 

src/Pipes/IRC/Server.hs

@@ -2,12 +2,12 @@
 
 module Pipes.IRC.Server
   ( startIrcServer
-  , module Pipes.IRC.Server.Types
   )
 where
 
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
+import           Control.Lens                    as L
 import           Control.Monad
 import           Control.Monad.RWS
 import           Data.ByteString.Char8           as BS
@@ -26,6 +26,9 @@ import           Pipes.IRC.Server.MessageHandler
 import           Pipes.IRC.Server.Types
 import           Pipes.Network.TCP               as PN
 
+version :: BS.ByteString
+version = "0.1a"
+
 parseMessage :: Producer BS.ByteString IO ()
              -> Producer (Either BS.ByteString IrcMessage) IO ()
 parseMessage prod = do
@@ -49,10 +52,20 @@ 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 = ircConnections srv
+  let clients = srv ^. ircConnections
-      ids = ircConnIds srv
+      ids = srv ^. ircConnIds
   cid <- atomically $ do
     lastId <- readTVar ids
     let newId = lastId + 1
@@ -62,58 +75,88 @@ addIrcConnection srv client = do
   return cid
 
 delIrcConnection :: ServerState -> Int -> IO ()
-delIrcConnection srv cid = do
+delIrcConnection srv cid =
-  let clients = ircConnections srv
+  atomically $ do
-  atomically $ modifyTVar' clients $ M.delete cid
+    let clients  = srv ^. ircConnections
+        srvState = srv ^. ircState
+    cs <- readTVar clients
+    case M.lookup cid cs of
+      -- Connection is unregistered, but has set a nickname
+      Just IrcConnection{_reg = Unreg{_rcvdNick = Just nn}} ->
+        modifyTVar' srvState $ removeUser nn
+
+      -- Connection is registered
+      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 =
   let cReg = Unreg Nothing Nothing Nothing
-  in handle cReg
+  in do
+    conns <- liftIO $ readTVarIO $ srv ^. ircConnections
+    case M.lookup cid conns of
+      Just c  -> handle c cReg
+      Nothing -> return ()
   where
-    handle userReg = do
+    handle conn userReg = do
       -- wait for the next command
       nextMsg <- await
 
       -- run the handler in a transaction
       (newReg, events) <- liftIO $ atomically $ do
-        sState <- readTVar (ircState srv)
+        sState <- readTVar $ srv ^. ircState
-        let sConf = ircConfig srv
+        let sConf = srv ^. ircConfig
-        let cState = ClientState { clientReg = userReg
+        let cState = ClientState { _clientReg = userReg
-                                 , clientServer = sState
+                                 , _clientServer = sState
-                                 , clientConn = cid }
+                                 , _clientHost = conn ^. hname
+                                 , _clientConn = cid }
 
         -- run the handler in the IrcMonad, returning new state and events
         let (_, newState, events) =
               runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState
 
-        writeTVar (ircState srv) $ clientServer newState
+        writeTVar (_ircState srv) $ _clientServer newState
-        return (clientReg newState, events)
+        return (_clientReg newState, events)
 
       -- handle resulting events
-      liftIO $ forM_ events $ ircEventHandler srv
+      aliveL <- liftIO $ forM events $ ircEventHandler srv
 
       -- loop for the next command
-      handle newReg
+      when (and aliveL) $ handle conn newReg
 
 listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
 listenHandler srv (lsock, _) =
   forever $ acceptFork lsock $ \(csock, caddr) -> do
     let sockWriter = toSocket csock
         sockReader = fromSocket csock 4096
+
+    (hName, _) <- getNameInfo [] True False caddr
+
     (writeEnd, readEnd) <- spawn Unbounded
-    let client = IrcConnection csock caddr writeEnd
+
+    let client = IrcConnection
+                  { _sock  = csock
+                  , _addr  = caddr
+                  , _hname = fmap BS.pack hName
+                  , _out   = writeEnd
+                  , _reg   = Unreg Nothing Nothing Nothing
+                  }
 
     cid <- addIrcConnection srv client
+
     let handler = cmdHandler srv cid
 
     r <- async $ runEffect $
            parseMessage sockReader >-> filterMsgs >-> handler
+    link r
 
     w <- async $ runEffect $
            fromInput readEnd >-> renderMessage >-> sockWriter
+    link w
 
-    mapM_ wait [r,w]
+    void $ waitEither r w
 
     delIrcConnection srv cid
 
@@ -122,7 +165,7 @@ mkIrcServer config = do
   let nks = S.empty
       urs = M.empty
       chs = M.empty
-      srv = IrcServer nks urs chs
+      srv = IrcServer nks urs chs version
   tvState <- newTVarIO srv
   tvCns <- newTVarIO M.empty
   tvRef <- newTVarIO 0
@@ -131,6 +174,6 @@ mkIrcServer config = do
 startIrcServer :: IrcConfig -> IO (Async ())
 startIrcServer config = do
   srv <- mkIrcServer config
-  let sHost = (ircHost . ircConfig) srv
+  let sHost = srv ^. ircConfig . ircHost
-      sPort = (ircPort . ircConfig) srv
+      sPort = srv ^. ircConfig . ircPort
   async $ PN.listen sHost sPort (listenHandler srv)

src/Pipes/IRC/Server/EventHandler.hs

@@ -6,10 +6,10 @@ where
 
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
+import           Control.Lens
 import           Control.Monad
 import           Data.Map                 as M
 import           Data.Maybe               as DM
-import           Network.Socket           as NS
 import           Pipes.Concurrent         as PC
 import           Pipes.IRC.Server.Types
 
@@ -19,15 +19,16 @@ sendToMany msg outs = do
     async $ atomically $ PC.send o msg
   mapM_ wait resL
 
-ircEventHandler :: ServerState -> IrcEvent -> IO ()
+ircEventHandler :: ServerState -> IrcEvent -> IO Bool
 ircEventHandler srv evt =
   case evt of
     Close connId -> do
-      outConns <- readTVarIO $ ircConnections srv
+      outConns <- readTVarIO $ srv ^. ircConnections
       case M.lookup connId outConns of
-        Just IrcConnection{..} -> NS.close sock
+        Just IrcConnection{..} -> return False
-        _                      -> return ()
+        _                      -> return True
     Msg {..} -> do
-      outConns <- readTVarIO $ ircConnections srv
+      outConns <- readTVarIO $ srv ^. ircConnections
-      let os = fmap out $ DM.mapMaybe (`M.lookup` outConns) outDest
+      let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest
-      sendToMany outMsg os
+      sendToMany _outMsg os
+      return True

src/Pipes/IRC/Server/Log.hs

@@ -6,8 +6,7 @@ where
 
 import           Data.ByteString          as BS
 import           Pipes.IRC.Message.Render
-import           Pipes.IRC.Message.Types  ()
+import           Pipes.IRC.Message.Types
-import           Pipes.IRC.Server.Types
 
 logMsg :: IrcMessage -> IO ()
 logMsg msg = BS.putStr $ BS.concat ["LOG: ", renderIrcMessage msg]

src/Pipes/IRC/Server/MessageHandler.hs

@@ -5,35 +5,272 @@ module Pipes.IRC.Server.MessageHandler
   ( ircMessageHandler )
 where
 
-import           Control.Applicative
+import           Control.Lens
 import           Control.Monad.RWS
+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.Types
 
+
+
 ircMessageHandler :: IrcMessage -> IrcMonad ()
-ircMessageHandler msg = do
+ircMessageHandler msg =
-  reg <- clientReg <$> get
+  -- drop messages that have prefixes (until we have Server links)
-  case reg of
+  when (isNothing $ prefix msg) $ do
-    Unreg   {} -> unregHandler msg
+    cReg <- use clientReg
-    RegUser {} -> regHandler   msg
+    case cReg of
-  return ()
+      Unreg   {} -> unregHandler msg
+      RegUser {} -> regHandler   msg
+    return ()
 
 unregHandler :: IrcMessage -> IrcMonad ()
-unregHandler IrcMessage{..} =
+unregHandler msg@IrcMessage{..} =
   case command of
-    Left PASS -> undefined
+    Left PASS -> unregPASS msg
-    Left NICK -> undefined
+    Left NICK -> unregNICK msg
-    Left USER -> undefined
+    Left USER -> unregUSER msg
-    Left QUIT -> undefined
+    Left QUIT -> handleQUIT msg
     _         -> return ()
 
+unregPASS :: IrcMessage -> IrcMonad ()
+unregPASS IrcMessage{..} =
+  if length params < 1
+  then tellNumeric err_needmoreparams [":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
+  then tellNumeric err_nonicknamegiven [":must supply a nickname"]
+  else let nickname = head params in
+    validateNick nickname >>= flip when
+      (clientReg . rcvdNick .= Just nickname >>
+       clientServer . ircNicks %= S.insert nickname >>
+       tryRegistration)
+
+
+unregUSER :: IrcMessage -> IrcMonad ()
+unregUSER IrcMessage{..} =
+  if length params < 4
+  then tellNumeric err_needmoreparams [":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 ->
+  return $ case nickname of
+    Just nick -> BS.append "Quit: " nick
+    Nothing   -> ""
+
+chanEcho :: IrcMessage -> IrcMonad ()
+chanEcho iMsg = do
+  mNick <- useNick
+  when (isJust mNick) $ do
+    let nick = fromJust mNick
+    msg <- addUserPrefix iMsg
+    mUser <- fmap (M.lookup nick) $ use (clientServer . ircUsers)
+    when (isJust mUser) $ do
+      let user = fromJust mUser
+      let chans = S.elems $ user ^. userChannels
+      findReceivers chans >>= fwdMsg msg
+
+doQuit :: IrcMessage -> Maybe BS.ByteString -> IrcMonad ()
+doQuit msg quitParamIn = do
+  connId <- use clientConn
+  quitMsg <- renderQuitMsg quitParamIn
+  hostname <- use clientHost
+  let hoststr = fromMaybe "unknown hostname" hostname
+  let quitParam = BS.concat [ ":Closing Link: ", hoststr
+                            , " (", quitMsg, ")"]
+  tellCommand ERROR [quitParam]
+  chanEcho msg
+  tell [Close connId]
+  return ()
+
+handleQUIT :: IrcMessage -> IrcMonad ()
+handleQUIT msg@IrcMessage{..} =
+  doQuit msg $ case params of
+    []  -> Nothing
+    p:_ -> Just p
+
+mkUser :: NickName -> IrcMonad IrcUser
+mkUser nn = do
+  conn <- use clientConn
+  srvname <- view ircHostName
+  return IrcUser { _userNick = nn
+                 , _userServerName = srvname
+                 , _userModes = S.empty
+                 , _userChannels = S.empty
+                 , _userConn = conn
+                 }
+
+tryRegistration :: IrcMonad ()
+tryRegistration = do
+  regState <- use clientReg
+  hostname <- use clientHost
+  case regState of
+    Unreg _ (Just nickname) (Just name) -> do
+      let nn = NickName nickname (Just name) hostname
+      clientReg .= RegUser nn
+      newUser <- mkUser nn
+      clientServer . ircUsers %= M.insert nickname newUser
+
+      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 IrcMessage{..} =
+regHandler msg@IrcMessage{..} = do
+  pMsg <- addUserPrefix msg
   case command of
-    Left PRIVMSG -> undefined
+    Left PRIVMSG -> handlePRIVMSG pMsg
-    Left JOIN    -> undefined
+    Left JOIN    -> return ()
-    Left PART    -> undefined
+    Left PART    -> return ()
-    Left LIST    -> undefined
+    Left LIST    -> return ()
-    Left NICK    -> undefined
+    Left NICK    -> return ()
-    Left QUIT    -> undefined
+    Left QUIT    -> handleQUIT pMsg
     _            -> return ()
+
+handlePRIVMSG :: IrcMessage -> IrcMonad ()
+handlePRIVMSG msg@IrcMessage{..} = do
+  case params of
+    []       -> tellNumeric err_norecipient []
+    _:[]     -> tellNumeric err_notexttosend []
+    rsp:_:_  -> let rs = Prelude.filter (not . BS.null) $ BS.split ',' 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

@@ -1,34 +1,106 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell            #-}
 
 module Pipes.IRC.Server.Types
-  ( HostPreference(..)
+  ( module Pipes.IRC.Server.Types
-  , IrcMessage
+  , HostPreference (..), ServiceName, SockAddr, Socket
-  , IrcEvent(..)
+  )
-  , IrcEvents
+where
-  , IrcConnection(..)
-  , IrcConfig(..)
-  , IrcServer(..)
-  , IrcUser(..)
-  , IrcChannel(..)
-  , IrcMonad(..)
-  , ServerState(..)
-  , ClientState(..)
-  , RegState(..)
-  ) where
 
 import           Control.Concurrent.STM  (TVar)
+import           Control.Lens
 import           Control.Monad.RWS       (MonadReader, MonadState, MonadWriter,
                                           RWS)
 import           Data.ByteString         (ByteString)
 import           Data.Map                (Map)
 import           Data.Set                (Set)
 import           Pipes.Concurrent        (Output)
-import           Pipes.IRC.Message.Types (IrcMessage)
+import           Pipes.IRC.Message.Types (IrcMessage, NickName)
 import           Pipes.Network.TCP       (HostPreference (..), ServiceName,
                                           SockAddr, Socket)
 
 type IrcEvents = [IrcEvent]
 
+data IrcEvent = Msg { _outMsg  :: !IrcMessage
+                    , _outDest :: ![Int]
+                    }
+              | Close { _closeConn :: Int }
+               deriving (Show)
+makeLenses ''IrcEvent
+
+data IrcUserMode = Away | Invisible | WallOps | Restricted
+                 | Oper | LocalOper | ServerNotices
+            deriving (Show, Eq, Enum)
+
+data IrcUser =
+  IrcUser { _userNick       :: !NickName
+          , _userServerName :: !ByteString
+          , _userModes      :: !(Set IrcUserMode)
+          , _userChannels   :: !(Set ByteString)
+          , _userConn       :: !Int
+          } deriving (Show, Eq)
+makeLenses ''IrcUser
+
+data IrcChanMode = Anonymous | InviteOnly | Moderated | Quiet | Secret
+            deriving (Show, Eq, Enum)
+
+data IrcChannel =
+  IrcChannel { _chanName  :: !ByteString
+             , _chanTopic :: !ByteString
+             , _chanModes :: !(Set IrcChanMode)
+             , _chanUsers :: !(Set ByteString)
+             } deriving (Show, Eq)
+makeLenses ''IrcChannel
+
+data IrcServer =
+  IrcServer { _ircNicks    :: !(Set ByteString)
+            , _ircUsers    :: !(Map ByteString IrcUser)
+            , _ircChannels :: !(Map ByteString IrcChannel)
+            , _ircVersion  :: !ByteString
+            } deriving (Show)
+makeLenses ''IrcServer
+
+data IrcConfig =
+  IrcConfig { _ircPort     :: !ServiceName
+            , _ircHost     :: !HostPreference
+            , _ircHostName :: !ByteString
+            , _ircMotd     :: ![ByteString]
+            , _ircPass     :: !(Maybe ByteString)
+            } deriving (Show)
+makeLenses ''IrcConfig
+
+data RegState = Unreg   { _rcvdPass :: !(Maybe ByteString)
+                        , _rcvdNick :: !(Maybe ByteString)
+                        , _rcvdName :: !(Maybe ByteString) }
+              | RegUser { _regdNick :: !NickName }
+  deriving (Show)
+makeLenses ''RegState
+
+data IrcConnection =
+  IrcConnection { _sock  :: !Socket
+                , _addr  :: !SockAddr
+                , _hname :: !(Maybe ByteString)
+                , _out   :: !(Output IrcMessage)
+                , _reg   :: !RegState
+                }
+makeLenses ''IrcConnection
+
+data ServerState =
+  ServerState { _ircState       :: !(TVar IrcServer)
+              , _ircConfig      :: !IrcConfig
+              , _ircConnections :: !(TVar (Map Int IrcConnection))
+              , _ircConnIds     :: !(TVar Int)
+              }
+makeLenses ''ServerState
+
+data ClientState =
+  ClientState { _clientReg    :: !RegState
+              , _clientServer :: !IrcServer
+              , _clientHost   :: !(Maybe ByteString)
+              , _clientConn   :: !Int
+              } deriving (Show)
+makeLenses ''ClientState
+
 newtype IrcMonad a =
   IrcMonad { runIrc :: RWS IrcConfig IrcEvents ClientState a }
   deriving ( Monad
@@ -36,70 +108,3 @@ newtype IrcMonad a =
            , MonadReader IrcConfig
            , MonadWriter IrcEvents
            , MonadState  ClientState)
-
-data IrcEvent = Msg { outMsg  :: !IrcMessage
-                    , outDest :: ![Int]
-                    }
-              | Close Int
-               deriving (Show)
-
-data ServerState =
-  ServerState { ircState       :: !(TVar IrcServer)
-              , ircConfig      :: !IrcConfig
-              , ircConnections :: !(TVar (Map Int IrcConnection))
-              , ircConnIds     :: !(TVar Int)
-              }
-
-data RegState = Unreg   { rcvdPass :: !(Maybe ByteString)
-                        , rcvdNick :: !(Maybe ByteString)
-                        , rcvdName :: !(Maybe ByteString) }
-              | RegUser { regdNick :: !ByteString }
-  deriving (Show)
-
-data ClientState =
-  ClientState { clientReg    :: !RegState
-              , clientServer :: !IrcServer
-              , clientConn   :: !Int
-              } deriving (Show)
-
-data IrcServer =
-  IrcServer { ircNicks    :: !(Set ByteString)
-            , ircUsers    :: !(Map ByteString IrcUser)
-            , ircChannels :: !(Map ByteString IrcChannel)
-            } deriving (Show)
-
-data IrcConfig =
-  IrcConfig { ircPort :: !ServiceName
-            , ircHost :: !HostPreference
-            , ircMotd :: ![ByteString]
-            , ircPass :: !(Maybe ByteString)
-            } deriving (Show)
-
-data IrcConnection =
-  IrcConnection { sock :: !Socket
-                , addr :: !SockAddr
-                , out  :: !(Output IrcMessage)
-                }
-
-data IrcUser =
-  IrcUser { userNick       :: !(Maybe ByteString)
-          , userServerName :: !(Maybe ByteString)
-          , userName       :: !(Maybe ByteString)
-          , userHostName   :: !(Maybe ByteString)
-          , userModes      :: ![IrcUserMode]
-          , userConn       :: !Int
-          } deriving (Show, Eq)
-
-data IrcUserMode = Away | Invisible | WallOps | Restricted
-                 | Oper | LocalOper | ServerNotices
-            deriving (Show, Eq, Enum)
-
-data IrcChannel =
-  IrcChannel { chanName  :: !ByteString
-             , chanTopic :: !ByteString
-             , chanModes :: ![IrcChanMode]
-             , chanUsers :: ![IrcUser]
-             } deriving (Show, Eq)
-
-data IrcChanMode = Anonymous | InviteOnly | Moderated | Quiet | Secret
-            deriving (Show, Eq, Enum)