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

master
Levi Pearson 2013-11-28 00:16:25 -07:00
parent 6e2ceafe97
commit 723775633f
9 changed files with 461 additions and 141 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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)

View File

@ -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

View File

@ -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]

View File

@ -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
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 ()
regHandler :: IrcMessage -> IrcMonad ()
regHandler IrcMessage{..} =
case command of
Left PRIVMSG -> undefined
Left JOIN -> undefined
Left PART -> undefined
Left LIST -> undefined
Left NICK -> undefined
Left QUIT -> undefined
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 msg@IrcMessage{..} = do
pMsg <- addUserPrefix msg
case command of
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 ]

View File

@ -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)