From 723775633fc2608cfdb053606b6e8cba3559e8d3 Mon Sep 17 00:00:00 2001 From: Levi Pearson Date: Thu, 28 Nov 2013 00:16:25 -0700 Subject: [PATCH] Server is semi-functional, users can register and send direct messages to one another --- pipes-irc-server.cabal | 1 + src/Main.hs | 13 +- src/Pipes/IRC/Message/Render.hs | 13 +- src/Pipes/IRC/Message/Types.hs | 24 +++ src/Pipes/IRC/Server.hs | 87 ++++++-- src/Pipes/IRC/Server/EventHandler.hs | 17 +- src/Pipes/IRC/Server/Log.hs | 3 +- src/Pipes/IRC/Server/MessageHandler.hs | 275 +++++++++++++++++++++++-- src/Pipes/IRC/Server/Types.hs | 169 +++++++-------- 9 files changed, 461 insertions(+), 141 deletions(-) diff --git a/pipes-irc-server.cabal b/pipes-irc-server.cabal index c2d7464..634dbe1 100644 --- a/pipes-irc-server.cabal +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 87ae6b3..aab8d6f 100644 --- a/src/Main.hs +++ b/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), - IrcConfig (..)) +import Pipes.IRC.Server.Types (IrcConfig (..)) +import Pipes.Network.TCP (HostPreference (..)) main :: IO () main = let ircConf = - IrcConfig { ircPort = "6665" - , ircHost = Host "127.0.0.1" - , ircMotd = ["Welcome to the IRC Server!"] - , ircPass = Nothing + IrcConfig { _ircPort = "6665" + , _ircHost = Host "127.0.0.1" + , _ircHostName = "pinealservo.com" + , _ircMotd = ["Welcome to the IRC Server!"] + , _ircPass = Nothing } in do listener <- startIrcServer ircConf diff --git a/src/Pipes/IRC/Message/Render.hs b/src/Pipes/IRC/Message/Render.hs index ea3a5af..659baa7 100644 --- a/src/Pipes/IRC/Message/Render.hs +++ b/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 diff --git a/src/Pipes/IRC/Message/Types.hs b/src/Pipes/IRC/Message/Types.hs index 9832448..57d978a 100644 --- a/src/Pipes/IRC/Message/Types.hs +++ b/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" diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index 652b591..c051f16 100644 --- a/src/Pipes/IRC/Server.hs +++ b/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 - ids = ircConnIds srv + let clients = srv ^. ircConnections + 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 - let clients = ircConnections srv - atomically $ modifyTVar' clients $ M.delete cid +delIrcConnection srv cid = + atomically $ do + 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) - let sConf = ircConfig srv - let cState = ClientState { clientReg = userReg - , clientServer = sState - , clientConn = cid } + sState <- readTVar $ srv ^. ircState + let sConf = srv ^. ircConfig + let cState = ClientState { _clientReg = userReg + , _clientServer = sState + , _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 - return (clientReg newState, events) + writeTVar (_ircState srv) $ _clientServer newState + 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 - sPort = (ircPort . ircConfig) srv + let sHost = srv ^. ircConfig . ircHost + sPort = srv ^. ircConfig . ircPort async $ PN.listen sHost sPort (listenHandler srv) diff --git a/src/Pipes/IRC/Server/EventHandler.hs b/src/Pipes/IRC/Server/EventHandler.hs index b2f56f9..a7de0fe 100644 --- a/src/Pipes/IRC/Server/EventHandler.hs +++ b/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 - _ -> return () + Just IrcConnection{..} -> return False + _ -> return True Msg {..} -> do - outConns <- readTVarIO $ ircConnections srv - let os = fmap out $ DM.mapMaybe (`M.lookup` outConns) outDest - sendToMany outMsg os + outConns <- readTVarIO $ srv ^. ircConnections + let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest + sendToMany _outMsg os + return True diff --git a/src/Pipes/IRC/Server/Log.hs b/src/Pipes/IRC/Server/Log.hs index 531b493..03ff10e 100644 --- a/src/Pipes/IRC/Server/Log.hs +++ b/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.Server.Types +import Pipes.IRC.Message.Types logMsg :: IrcMessage -> IO () logMsg msg = BS.putStr $ BS.concat ["LOG: ", renderIrcMessage msg] diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index 6ea49fc..a610484 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/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 - reg <- clientReg <$> get - case reg of - Unreg {} -> unregHandler msg - RegUser {} -> regHandler msg - return () +ircMessageHandler msg = + -- drop messages that have prefixes (until we have Server links) + when (isNothing $ prefix msg) $ do + cReg <- use clientReg + case cReg of + Unreg {} -> unregHandler msg + RegUser {} -> regHandler msg + return () unregHandler :: IrcMessage -> IrcMonad () -unregHandler IrcMessage{..} = +unregHandler msg@IrcMessage{..} = case command of - Left PASS -> undefined - Left NICK -> undefined - Left USER -> undefined - Left QUIT -> undefined + Left PASS -> unregPASS msg + Left NICK -> unregNICK msg + Left USER -> unregUSER msg + 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 JOIN -> undefined - Left PART -> undefined - Left LIST -> undefined - Left NICK -> undefined - Left QUIT -> undefined + Left PRIVMSG -> handlePRIVMSG pMsg + Left JOIN -> return () + Left PART -> return () + Left LIST -> return () + Left NICK -> return () + 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 ] diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs index c735e9b..7a1817b 100644 --- a/src/Pipes/IRC/Server/Types.hs +++ b/src/Pipes/IRC/Server/Types.hs @@ -1,34 +1,106 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Pipes.IRC.Server.Types - ( HostPreference(..) - , IrcMessage - , IrcEvent(..) - , IrcEvents - , IrcConnection(..) - , IrcConfig(..) - , IrcServer(..) - , IrcUser(..) - , IrcChannel(..) - , IrcMonad(..) - , ServerState(..) - , ClientState(..) - , RegState(..) - ) where + ( module Pipes.IRC.Server.Types + , HostPreference (..), ServiceName, SockAddr, Socket + ) +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)