Server is semi-functional, users can register and send direct messages to one another
Levi Pearson
parent
6e2ceafe97
commit
723775633f
|
|
@ -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
|
||||
|
|
|
|||
13
src/Main.hs
13
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue