Re-arranged some code, added basic PING/PONG.
Also, channels now go away properly when they become empty.master
Levi Pearson
parent
723775633f
commit
9278620b75
|
|
@ -25,6 +25,7 @@ executable pipes-irc-server
|
|||
-- other-extensions:
|
||||
build-depends: base >= 4.6 && < 4.7
|
||||
, mtl >= 2.1 && < 3
|
||||
, errors >= 1.4 && < 2
|
||||
, mmorph >= 1 && < 2
|
||||
, containers >= 0.5 && < 1
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
|
|
@ -38,6 +39,7 @@ executable pipes-irc-server
|
|||
, pipes-attoparsec >= 0.3 && < 1
|
||||
, pipes-network >= 0.6 && < 1
|
||||
, stm >= 2 && < 3
|
||||
, time >= 1.4 && < 1.5
|
||||
, async >= 2 && < 3
|
||||
, free >= 3 && < 4
|
||||
, lens >= 3 && < 4
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ module Pipes.IRC.Server
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Lens as L
|
||||
|
|
@ -13,6 +14,7 @@ import Control.Monad.RWS
|
|||
import Data.ByteString.Char8 as BS
|
||||
import Data.Map as M
|
||||
import Data.Set as S
|
||||
import Data.Time.Clock
|
||||
import Network.Socket as NS
|
||||
import Pipes
|
||||
import Pipes.Attoparsec
|
||||
|
|
@ -21,6 +23,7 @@ import Pipes.IRC.Message.Parse
|
|||
import Pipes.IRC.Message.Render
|
||||
import Pipes.IRC.Message.Types
|
||||
import Pipes.IRC.Server.EventHandler
|
||||
import Pipes.IRC.Server.IrcMonad
|
||||
import Pipes.IRC.Server.Log
|
||||
import Pipes.IRC.Server.MessageHandler
|
||||
import Pipes.IRC.Server.Types
|
||||
|
|
@ -52,16 +55,6 @@ 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 = srv ^. ircConnections
|
||||
|
|
@ -75,21 +68,17 @@ addIrcConnection srv client = do
|
|||
return cid
|
||||
|
||||
delIrcConnection :: ServerState -> Int -> IO ()
|
||||
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
|
||||
delIrcConnection srv cid = atomically $ do
|
||||
cs <- readTVar (srv ^. ircConnections)
|
||||
case M.lookup cid cs of
|
||||
Just conn -> do
|
||||
let nn = case conn ^. reg of
|
||||
Unreg{ _rcvdNick = Just n } -> n
|
||||
RegUser{ _regdNick = NickName n _ _ } -> n
|
||||
_ -> ""
|
||||
modifyTVar' (srv ^. ircState) $ ircDelUser nn
|
||||
_ -> return ()
|
||||
modifyTVar' (srv ^. ircConnections) $ M.delete cid
|
||||
|
||||
cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
|
||||
cmdHandler srv cid =
|
||||
|
|
@ -97,12 +86,13 @@ cmdHandler srv cid =
|
|||
in do
|
||||
conns <- liftIO $ readTVarIO $ srv ^. ircConnections
|
||||
case M.lookup cid conns of
|
||||
Just c -> handle c cReg
|
||||
Just c -> handle (c ^. hname) cReg
|
||||
Nothing -> return ()
|
||||
where
|
||||
handle conn userReg = do
|
||||
handle host userReg = do
|
||||
-- wait for the next command
|
||||
nextMsg <- await
|
||||
curTime <- liftIO getCurrentTime
|
||||
|
||||
-- run the handler in a transaction
|
||||
(newReg, events) <- liftIO $ atomically $ do
|
||||
|
|
@ -110,21 +100,55 @@ cmdHandler srv cid =
|
|||
let sConf = srv ^. ircConfig
|
||||
let cState = ClientState { _clientReg = userReg
|
||||
, _clientServer = sState
|
||||
, _clientHost = conn ^. hname
|
||||
, _clientConn = cid }
|
||||
, _clientHost = host
|
||||
, _clientConn = cid
|
||||
}
|
||||
|
||||
-- run the handler in the IrcMonad, returning new state and events
|
||||
let (_, newState, events) =
|
||||
runRWS (runIrc $ ircMessageHandler nextMsg) sConf cState
|
||||
runRWS (ircMessageHandler nextMsg) sConf cState
|
||||
|
||||
writeTVar (_ircState srv) $ _clientServer newState
|
||||
return (_clientReg newState, events)
|
||||
writeTVar (srv ^. ircState) $
|
||||
newState ^. clientServer
|
||||
|
||||
modifyTVar' (srv ^. ircConnections) $
|
||||
M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid
|
||||
|
||||
return (newState ^. clientReg, events)
|
||||
|
||||
-- handle resulting events
|
||||
aliveL <- liftIO $ forM events $ ircEventHandler srv
|
||||
|
||||
-- loop for the next command
|
||||
when (and aliveL) $ handle conn newReg
|
||||
when (and aliveL) $ handle host newReg
|
||||
|
||||
idlePinger :: ServerState -> Int -> IO ()
|
||||
idlePinger srv cid =
|
||||
let
|
||||
pingMsg = IrcMessage Nothing (Left PING)
|
||||
[":" `append` (srv ^. ircConfig . ircHostName)]
|
||||
oneMinute = 60 * 1000000 -- microseconds
|
||||
getLastCom = do conns <- readTVarIO (srv ^. ircConnections)
|
||||
return $ conns ! cid ^. lastCom
|
||||
resetPong = atomically $ modifyTVar' (srv ^. ircConnections) $
|
||||
M.adjust (gotPong .~ False) cid
|
||||
checkPong = do conns <- readTVarIO (srv ^. ircConnections)
|
||||
return $ conns ! cid ^. gotPong
|
||||
in
|
||||
forever $ do
|
||||
threadDelay oneMinute
|
||||
curTime <- getCurrentTime
|
||||
time <- getLastCom
|
||||
let diffTime = toRational . diffUTCTime curTime $ time
|
||||
if diffTime > 60
|
||||
then do
|
||||
resetPong
|
||||
atomically $ do
|
||||
conns <- readTVar (srv ^. ircConnections)
|
||||
PC.send (conns ! cid ^. out) pingMsg
|
||||
threadDelay oneMinute
|
||||
checkPong
|
||||
else return True
|
||||
|
||||
listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
|
||||
listenHandler srv (lsock, _) =
|
||||
|
|
@ -135,6 +159,7 @@ listenHandler srv (lsock, _) =
|
|||
(hName, _) <- getNameInfo [] True False caddr
|
||||
|
||||
(writeEnd, readEnd) <- spawn Unbounded
|
||||
curTime <- getCurrentTime
|
||||
|
||||
let client = IrcConnection
|
||||
{ _sock = csock
|
||||
|
|
@ -142,6 +167,8 @@ listenHandler srv (lsock, _) =
|
|||
, _hname = fmap BS.pack hName
|
||||
, _out = writeEnd
|
||||
, _reg = Unreg Nothing Nothing Nothing
|
||||
, _lastCom = curTime
|
||||
, _gotPong = False
|
||||
}
|
||||
|
||||
cid <- addIrcConnection srv client
|
||||
|
|
@ -152,11 +179,14 @@ listenHandler srv (lsock, _) =
|
|||
parseMessage sockReader >-> filterMsgs >-> handler
|
||||
link r
|
||||
|
||||
idle <- async $ idlePinger srv cid
|
||||
link idle
|
||||
|
||||
w <- async $ runEffect $
|
||||
fromInput readEnd >-> renderMessage >-> sockWriter
|
||||
link w
|
||||
|
||||
void $ waitEither r w
|
||||
void $ waitAnyCancel [r, w, idle]
|
||||
|
||||
delIrcConnection srv cid
|
||||
|
||||
|
|
|
|||
|
|
@ -32,3 +32,7 @@ ircEventHandler srv evt =
|
|||
let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest
|
||||
sendToMany _outMsg os
|
||||
return True
|
||||
Pong {..} -> do
|
||||
atomically $ modifyTVar' (srv ^. ircConnections) $
|
||||
M.adjust (gotPong .~ False) _pongConn
|
||||
return True
|
||||
|
|
|
|||
|
|
@ -0,0 +1,391 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Pipes.IRC.Server.IrcMonad
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.RWS
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes, fromJust, fromMaybe,
|
||||
isJust, isNothing)
|
||||
import qualified Data.Set as S
|
||||
import Pipes.IRC.Message.Types
|
||||
import Pipes.IRC.Server.Types
|
||||
|
||||
|
||||
-- | IrcUser management
|
||||
|
||||
mkUser :: IrcMonad IrcUser
|
||||
mkUser = do
|
||||
conn <- use clientConn
|
||||
srvname <- view ircHostName
|
||||
return $ newUser srvname conn
|
||||
|
||||
newUser :: ByteString -> Int -> IrcUser
|
||||
newUser srvname cid =
|
||||
IrcUser { _userServerName = srvname
|
||||
, _userModes = S.empty
|
||||
, _userChannels = S.empty
|
||||
, _userConn = cid
|
||||
, _userInvites = S.empty
|
||||
}
|
||||
|
||||
userAddChan, userDelChan :: ByteString -> IrcUser -> IrcUser
|
||||
userAddChan cn = userChannels %~ S.insert cn
|
||||
userDelChan cn = userChannels %~ S.delete cn
|
||||
|
||||
userAddMode, userDelMode :: IrcUserMode -> IrcUser -> IrcUser
|
||||
userAddMode um = userModes %~ S.insert um
|
||||
userDelMode um = userModes %~ S.delete um
|
||||
|
||||
userAddInvite, userDelInvite :: ByteString -> IrcUser -> IrcUser
|
||||
userAddInvite cn = userInvites %~ S.insert cn
|
||||
userDelInvite cn = userInvites %~ S.delete cn
|
||||
|
||||
userHasMode :: IrcUserMode -> IrcUser -> Bool
|
||||
userHasMode um usr = S.member um $ usr ^. userModes
|
||||
|
||||
userInChan :: ByteString -> IrcUser -> Bool
|
||||
userInChan cn usr = S.member cn $ usr ^. userChannels
|
||||
|
||||
-- | IrcChannel management
|
||||
|
||||
newChannel :: ByteString -> IrcChannel
|
||||
newChannel creator = IrcChannel { _chanTopic = Nothing
|
||||
, _chanKey = Nothing
|
||||
, _chanModeFlags = S.empty
|
||||
, _chanUsers = S.fromList [creator]
|
||||
, _chanOpers = S.fromList [creator]
|
||||
, _chanVoices = S.empty
|
||||
, _chanInvites = S.empty
|
||||
}
|
||||
|
||||
chanAddModeFlag, chanDelModeFlag :: IrcChanModeFlags -> IrcChannel -> IrcChannel
|
||||
chanAddModeFlag cm = chanModeFlags %~ S.insert cm
|
||||
chanDelModeFlag cm = chanModeFlags %~ S.delete cm
|
||||
|
||||
chanAddUser, chanDelUser :: ByteString -> IrcChannel -> IrcChannel
|
||||
chanAddUser un = chanUsers %~ S.insert un
|
||||
chanDelUser un = (chanUsers %~ S.delete un)
|
||||
. (chanOpers %~ S.delete un)
|
||||
. (chanVoices %~ S.delete un)
|
||||
|
||||
chanHasUser :: ByteString -> IrcChannel -> Bool
|
||||
chanHasUser un ch = S.member un $ ch ^. chanUsers
|
||||
|
||||
chanSetTopic :: ByteString -> IrcChannel -> IrcChannel
|
||||
chanSetTopic top = chanTopic .~ Just top
|
||||
|
||||
chanHasTopic :: IrcChannel -> Bool
|
||||
chanHasTopic ch = isJust $ ch ^. chanTopic
|
||||
|
||||
chanHasModeFlag :: IrcChanModeFlags -> IrcChannel -> Bool
|
||||
chanHasModeFlag cm ch = S.member cm $ ch ^. chanModeFlags
|
||||
|
||||
chanSigil :: IrcChannel -> ByteString
|
||||
chanSigil ch | chanHasModeFlag Secret ch = "@"
|
||||
| chanHasModeFlag Private ch = "*"
|
||||
| otherwise = "="
|
||||
|
||||
chanUserSigil :: ByteString -> IrcChannel -> ByteString
|
||||
chanUserSigil un ch | S.member un $ ch ^. chanOpers = "@"
|
||||
| S.member un $ ch ^. chanVoices = "+"
|
||||
| otherwise = ""
|
||||
|
||||
chanSetKey :: ByteString -> IrcChannel -> IrcChannel
|
||||
chanSetKey key = chanKey .~ Just key
|
||||
|
||||
chanHasKey :: IrcChannel -> Bool
|
||||
chanHasKey ch = isJust $ ch ^. chanKey
|
||||
|
||||
chanCheckKey :: ByteString -> IrcChannel -> Bool
|
||||
chanCheckKey key ch = case ch ^. chanKey of
|
||||
Just chKey -> key == chKey
|
||||
Nothing -> True
|
||||
|
||||
chanAddOper, chanDelOper :: ByteString -> IrcChannel -> IrcChannel
|
||||
chanAddOper un = chanOpers %~ S.insert un
|
||||
chanDelOper un = chanOpers %~ S.delete un
|
||||
|
||||
chanAddVoice, chanDelVoice :: ByteString -> IrcChannel -> IrcChannel
|
||||
chanAddVoice un = chanVoices %~ S.insert un
|
||||
chanDelVoice un = chanVoices %~ S.delete un
|
||||
|
||||
chanAddInvite, chanDelInvite :: ByteString -> IrcChannel -> IrcChannel
|
||||
chanAddInvite un = chanInvites %~ S.insert un
|
||||
chanDelInvite un = chanInvites %~ S.delete un
|
||||
|
||||
chanUserIsOper :: ByteString -> IrcChannel -> Bool
|
||||
chanUserIsOper un ch = S.member un $ ch ^. chanOpers
|
||||
|
||||
chanUserHasVoice :: ByteString -> IrcChannel -> Bool
|
||||
chanUserHasVoice un ch = S.member un $ ch ^. chanVoices
|
||||
|
||||
chanUserIsInvited :: ByteString -> IrcChannel -> Bool
|
||||
chanUserIsInvited un ch = S.member un $ ch ^. chanInvites
|
||||
|
||||
chanUserMaySpeak :: ByteString -> IrcChannel -> Bool
|
||||
chanUserMaySpeak un ch
|
||||
| (chanHasUser un ch || not (chanHasModeFlag NoOutsideMsgs ch))
|
||||
&& not (chanHasModeFlag Moderated ch) = True
|
||||
| chanUserIsOper un ch = True
|
||||
| chanUserHasVoice un ch = True
|
||||
| otherwise = False
|
||||
|
||||
chanUserMayJoin :: ByteString -> IrcChannel -> Bool
|
||||
chanUserMayJoin un ch | not $ chanHasModeFlag InviteOnly ch = True
|
||||
| chanUserIsInvited un ch = True
|
||||
| otherwise = False
|
||||
|
||||
chanUserMaySetTopic :: ByteString -> IrcChannel -> Bool
|
||||
chanUserMaySetTopic un ch
|
||||
| not (chanHasModeFlag TopicOperOnly ch) &&
|
||||
chanHasUser un ch = True
|
||||
| chanUserIsOper un ch = True
|
||||
| otherwise = False
|
||||
|
||||
-- | IrcServer management
|
||||
|
||||
ircAddUser :: ByteString -> IrcUser -> IrcServer -> IrcServer
|
||||
ircAddUser nn usr = ircUsers %~ M.insert nn usr
|
||||
|
||||
ircDelUser :: ByteString -> IrcServer -> IrcServer
|
||||
ircDelUser nn srv =
|
||||
srv & ircNicks %~ S.delete nn
|
||||
& if ircHasUser nn srv then let
|
||||
Just usr = M.lookup nn $ srv ^. ircUsers
|
||||
uchans = S.elems (usr ^. userChannels)
|
||||
ichans = S.elems (usr ^. userInvites)
|
||||
in
|
||||
(ircUsers %~ M.delete nn) .
|
||||
(ircChannels %~ \cs -> foldr (M.alter $ ircPartChan nn) cs uchans) .
|
||||
(ircChannels %~ \cs -> foldr (M.adjust $ chanDelInvite nn) cs ichans)
|
||||
else id
|
||||
|
||||
ircHasUser :: ByteString -> IrcServer -> Bool
|
||||
ircHasUser nn srv = isJust $ M.lookup nn (srv ^. ircUsers)
|
||||
|
||||
ircHasChan :: ByteString -> IrcServer -> Bool
|
||||
ircHasChan cn srv = isJust $ M.lookup cn (srv ^. ircChannels)
|
||||
|
||||
ircJoin :: ByteString -> ByteString -> IrcServer -> IrcServer
|
||||
ircJoin un cn = (ircChannels %~ M.alter alterChan cn)
|
||||
. (ircUsers %~ M.adjust (userAddChan cn) un)
|
||||
where
|
||||
alterChan mChan = Just $ chanAddUser un (fromMaybe (newChannel un) mChan)
|
||||
|
||||
ircPartChan :: ByteString -> Maybe IrcChannel -> Maybe IrcChannel
|
||||
ircPartChan un chan = case chanDelUser un (fromJust chan) of
|
||||
IrcChannel{ _chanUsers = us }
|
||||
| us == S.empty -> Nothing
|
||||
chan' -> Just chan'
|
||||
|
||||
ircPart :: ByteString -> ByteString -> IrcServer -> IrcServer
|
||||
ircPart un cn srv =
|
||||
srv & (ircChannels %~ (M.alter $ ircPartChan un) cn)
|
||||
& (ircUsers %~ \us -> foldr (M.adjust $ userDelInvite cn) us iusers)
|
||||
where
|
||||
chan = fromJust $ M.lookup cn (srv ^. ircChannels)
|
||||
iusers = S.elems $ chan ^. chanInvites
|
||||
|
||||
ircInvite :: ByteString -> ByteString -> IrcServer -> IrcServer
|
||||
ircInvite un cn = (ircChannels %~ M.adjust (chanAddInvite un) cn)
|
||||
. (ircUsers %~ M.adjust (userAddInvite cn) un)
|
||||
|
||||
ircInviteCheck :: ByteString -> IrcChannel -> Bool
|
||||
ircInviteCheck n chan =
|
||||
chanHasModeFlag InviteOnly chan && not (chanUserIsInvited n chan)
|
||||
|
||||
ircKeyCheck :: Maybe ByteString -> IrcChannel -> Bool
|
||||
ircKeyCheck k chan =
|
||||
chanHasKey chan && (isNothing k || not (chanCheckKey (fromJust k) chan))
|
||||
|
||||
-- | Misc
|
||||
|
||||
parseParamList :: ByteString -> [ByteString]
|
||||
parseParamList ps = filter (not . BS.null) $ BS.split ',' ps
|
||||
|
||||
zipParams :: [ByteString] -> [ByteString]
|
||||
-> [(ByteString, Maybe ByteString)]
|
||||
zipParams chans chkeys = zip chans (map Just chkeys ++ repeat Nothing)
|
||||
|
||||
-- | Pretty Printing
|
||||
|
||||
ppServiceName :: ServiceName -> ByteString
|
||||
ppServiceName = BS.pack
|
||||
|
||||
ppHostPreference :: HostPreference -> ByteString
|
||||
ppHostPreference hp = case hp of
|
||||
HostAny -> "*"
|
||||
HostIPv4 -> "*4"
|
||||
HostIPv6 -> "*6"
|
||||
Host hn -> BS.pack hn
|
||||
|
||||
-- | Monadic utilities
|
||||
|
||||
useChan :: ByteString -> IrcMonad (Maybe IrcChannel)
|
||||
useChan cname = fmap (M.lookup cname) $ use (clientServer . ircChannels)
|
||||
|
||||
useNick :: IrcMonad (Maybe ByteString)
|
||||
useNick = do
|
||||
regState <- use clientReg
|
||||
return $ case regState of
|
||||
Unreg _ (Just nn) _ -> Just nn
|
||||
RegUser (NickName nn _ _) -> Just nn
|
||||
_ -> Nothing
|
||||
|
||||
validateNick :: 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
|
||||
|
||||
channelTargets :: 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 :: ByteString -> IrcMonad (Maybe Int)
|
||||
userTarget uname = do
|
||||
srv <- use clientServer
|
||||
let umap = srv ^. ircUsers
|
||||
case M.lookup uname umap of
|
||||
Just u -> return . Just $ u ^. userConn
|
||||
_ -> do tellNumeric err_nosuchnick [uname, ":No such nick/channel"]
|
||||
return Nothing
|
||||
|
||||
findReceivers :: [ByteString] -> IrcMonad [([Int], 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], 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]
|
||||
|
||||
fwdMsgNoReplace :: IrcMessage -> [([Int], ByteString)] -> IrcMonad ()
|
||||
fwdMsgNoReplace msg rcvs = do
|
||||
m <- addUserPrefix msg
|
||||
forM_ rcvs $ \(cId, _) -> tell [Msg m cId]
|
||||
|
||||
|
||||
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 }
|
||||
|
||||
chanEcho :: [ByteString] -> IrcMessage -> IrcMonad ()
|
||||
chanEcho chans iMsg = do
|
||||
msg <- addUserPrefix iMsg
|
||||
findReceivers chans >>= fwdMsg msg
|
||||
|
||||
allChanEcho :: IrcMessage -> IrcMonad ()
|
||||
allChanEcho iMsg = do
|
||||
mNick <- useNick
|
||||
when (isJust mNick) $ do
|
||||
let nn = fromJust mNick
|
||||
mUser <- use $ clientServer . ircUsers . at nn
|
||||
when (isJust mUser) $ do
|
||||
let usr = fromJust mUser
|
||||
let chans = S.elems $ usr ^. userChannels
|
||||
chanEcho chans iMsg
|
||||
|
||||
-- | Adding responses to the Writer portion of the monad
|
||||
|
||||
tellYOURHOST :: 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 :: 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 :: ByteString -> IrcMonad ()
|
||||
tellWELCOME nickname = do
|
||||
srvname <- view ircHostName
|
||||
tellNumeric rpl_welcome [ nickname
|
||||
, BS.append ":Welcome to IRC on " srvname ]
|
||||
|
||||
tellTOPIC :: ByteString -> IrcMonad ()
|
||||
tellTOPIC cname = do
|
||||
chan <- use $ clientServer . ircChannels . at cname
|
||||
case chan of
|
||||
Just ch -> when (isJust $ ch ^. chanTopic) $
|
||||
tellNumeric rpl_topic [cname, fromJust $ ch ^. chanTopic]
|
||||
Nothing -> return ()
|
||||
|
||||
tellNAMES :: [ByteString] -> IrcMonad ()
|
||||
tellNAMES cnames = do
|
||||
Just nn <- useNick
|
||||
forM_ cnames $ \cname -> do
|
||||
mChan <- use $ clientServer . ircChannels . at cname
|
||||
case mChan of
|
||||
Just chan -> do
|
||||
let chanType = chanSigil chan
|
||||
nickL <- forM (S.elems $ chan ^. chanUsers) $ \uname ->
|
||||
return $ BS.append (chanUserSigil uname chan) uname
|
||||
let cUsers = BS.append ":" (BS.intercalate " " nickL)
|
||||
tellNumeric rpl_namreply [nn, chanType, cname, cUsers]
|
||||
tellNumeric rpl_endofnames [nn, head cnames, ":End of /NAMES list"]
|
||||
Nothing -> 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]]
|
||||
|
||||
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 ()
|
||||
|
|
@ -5,17 +5,18 @@ module Pipes.IRC.Server.MessageHandler
|
|||
( ircMessageHandler )
|
||||
where
|
||||
|
||||
import Control.Error
|
||||
import Control.Lens
|
||||
import Control.Monad.RWS
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Map as M
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Set as S
|
||||
import Data.Set as S
|
||||
import Pipes.IRC.Message.Types
|
||||
import Pipes.IRC.Server.IrcMonad
|
||||
import Pipes.IRC.Server.Types
|
||||
|
||||
|
||||
|
||||
ircMessageHandler :: IrcMessage -> IrcMonad ()
|
||||
ircMessageHandler msg =
|
||||
-- drop messages that have prefixes (until we have Server links)
|
||||
|
|
@ -32,26 +33,19 @@ unregHandler msg@IrcMessage{..} =
|
|||
Left PASS -> unregPASS msg
|
||||
Left NICK -> unregNICK msg
|
||||
Left USER -> unregUSER msg
|
||||
Left PONG -> handlePONG msg
|
||||
Left PING -> handlePING msg
|
||||
Left QUIT -> handleQUIT msg
|
||||
_ -> return ()
|
||||
|
||||
unregPASS :: IrcMessage -> IrcMonad ()
|
||||
unregPASS IrcMessage{..} =
|
||||
if length params < 1
|
||||
then tellNumeric err_needmoreparams [":Need more parameters"]
|
||||
then tellNumeric err_needmoreparams ["PASS", ":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
|
||||
|
|
@ -66,19 +60,11 @@ unregNICK IrcMessage{..} =
|
|||
unregUSER :: IrcMessage -> IrcMonad ()
|
||||
unregUSER IrcMessage{..} =
|
||||
if length params < 4
|
||||
then tellNumeric err_needmoreparams [":need more parameters"]
|
||||
then tellNumeric err_needmoreparams ["USER", ":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 ->
|
||||
|
|
@ -86,17 +72,18 @@ renderQuitMsg Nothing = useNick >>= \nickname ->
|
|||
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
|
||||
handlePING :: IrcMessage -> IrcMonad ()
|
||||
handlePING _ = do
|
||||
srvname <- view ircHostName
|
||||
tellCommand PONG [":" <> srvname]
|
||||
|
||||
handlePONG :: IrcMessage -> IrcMonad ()
|
||||
handlePONG _ = do
|
||||
cid <- use clientConn
|
||||
tell [Pong cid]
|
||||
|
||||
-- JOIN, MODE, KICK, PART, QUIT and of course PRIVMSG/NOTICE need to be
|
||||
-- echoed to channels that the user belongs to
|
||||
|
||||
doQuit :: IrcMessage -> Maybe BS.ByteString -> IrcMonad ()
|
||||
doQuit msg quitParamIn = do
|
||||
|
|
@ -107,7 +94,7 @@ doQuit msg quitParamIn = do
|
|||
let quitParam = BS.concat [ ":Closing Link: ", hoststr
|
||||
, " (", quitMsg, ")"]
|
||||
tellCommand ERROR [quitParam]
|
||||
chanEcho msg
|
||||
allChanEcho msg{params = [quitParam]}
|
||||
tell [Close connId]
|
||||
return ()
|
||||
|
||||
|
|
@ -117,16 +104,72 @@ handleQUIT msg@IrcMessage{..} =
|
|||
[] -> 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
|
||||
}
|
||||
handleJOIN :: IrcMessage -> IrcMonad ()
|
||||
handleJOIN msg@IrcMessage{..} =
|
||||
case params of
|
||||
[] -> tellNumeric err_needmoreparams ["JOIN", ":Not enough parameters"]
|
||||
["0"] -> do
|
||||
Just nn <- useNick
|
||||
cs <- use $ clientServer . ircUsers . at nn
|
||||
let Just chans = fmap (^. userChannels) cs
|
||||
doPart msg{command=Left PART} (S.elems chans) Nothing
|
||||
cs:[] -> doJoin msg $ zipParams (parseParamList cs) []
|
||||
cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
|
||||
|
||||
handlePART :: IrcMessage -> IrcMonad ()
|
||||
handlePART msg@IrcMessage{..} =
|
||||
case params of
|
||||
[] -> tellNumeric err_needmoreparams ["PART", ":Not enough parameters"]
|
||||
cs:[] -> doPart msg (parseParamList cs) Nothing
|
||||
cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)
|
||||
|
||||
tellErr :: IrcReply -> [IrcParam] -> IrcMonadErr ()
|
||||
tellErr r ps = lift (tellNumeric r ps) >> left []
|
||||
|
||||
checkRegistration :: IrcMonadErr BS.ByteString
|
||||
checkRegistration = do
|
||||
mNick <- lift useNick
|
||||
when (isNothing mNick) $
|
||||
tellErr err_notregistered [":You have not registered"]
|
||||
right $ fromJust mNick
|
||||
|
||||
doJoin :: IrcMessage -> [(BS.ByteString, Maybe BS.ByteString)] -> IrcMonad ()
|
||||
doJoin msg chans = forM_ chans $ \(c, k) -> runEitherT $ do
|
||||
nick <- checkRegistration
|
||||
mChan <- lift $ useChan c
|
||||
when (isJust mChan) $ do
|
||||
let chan = fromJust mChan
|
||||
|
||||
when (chanHasUser nick chan) $ left "already on channel"
|
||||
|
||||
when (ircInviteCheck nick chan) $
|
||||
tellErr err_inviteonlychan [c, ":Cannot join channel (+i)"]
|
||||
|
||||
when (ircKeyCheck k chan) $
|
||||
tellErr err_badchannelkey [c, ":Cannot join channel (+k)"]
|
||||
|
||||
lift $ do
|
||||
clientServer %= ircJoin nick c
|
||||
tellTOPIC c
|
||||
tellNAMES [c]
|
||||
chanEcho [c] msg
|
||||
|
||||
doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad ()
|
||||
doPart msg chans pmsg = forM_ chans $ \c -> runEitherT $ do
|
||||
nn <- checkRegistration
|
||||
mChan <- lift . use $ clientServer . ircChannels . at c
|
||||
when (isNothing mChan) $ tellErr err_nosuchchannel [c, ":No such channel"]
|
||||
let ch = fromJust mChan
|
||||
unless (chanHasUser nn ch) $ tellErr err_notonchannel [c, ":Not on channel"]
|
||||
|
||||
lift $ do
|
||||
let plist = case pmsg of
|
||||
Just bs -> [c, BS.append ":" bs]
|
||||
Nothing -> [c]
|
||||
let newMsg = msg{params = plist}
|
||||
chanEcho [c] newMsg
|
||||
findReceivers [nn] >>= fwdMsgNoReplace msg
|
||||
clientServer %= ircPart nn c
|
||||
|
||||
tryRegistration :: IrcMonad ()
|
||||
tryRegistration = do
|
||||
|
|
@ -136,30 +179,25 @@ tryRegistration = do
|
|||
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
|
||||
usr <- mkUser
|
||||
clientServer . ircUsers %= M.insert nickname usr
|
||||
|
||||
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 JOIN -> handleJOIN pMsg
|
||||
Left PART -> handlePART pMsg
|
||||
Left LIST -> return ()
|
||||
Left NICK -> return ()
|
||||
Left PING -> handlePING pMsg
|
||||
Left PONG -> handlePONG pMsg
|
||||
Left QUIT -> handleQUIT pMsg
|
||||
_ -> return ()
|
||||
|
||||
|
|
@ -168,109 +206,6 @@ handlePRIVMSG msg@IrcMessage{..} = do
|
|||
case params of
|
||||
[] -> tellNumeric err_norecipient []
|
||||
_:[] -> tellNumeric err_notexttosend []
|
||||
rsp:_:_ -> let rs = Prelude.filter (not . BS.null) $ BS.split ',' rsp
|
||||
rsp:_:_ -> let rs = parseParamList 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 ]
|
||||
|
|
|
|||
|
|
@ -8,12 +8,13 @@ module Pipes.IRC.Server.Types
|
|||
where
|
||||
|
||||
import Control.Concurrent.STM (TVar)
|
||||
import Control.Error
|
||||
import Control.Lens
|
||||
import Control.Monad.RWS (MonadReader, MonadState, MonadWriter,
|
||||
RWS)
|
||||
import Control.Monad.RWS (RWS)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Pipes.Concurrent (Output)
|
||||
import Pipes.IRC.Message.Types (IrcMessage, NickName)
|
||||
import Pipes.Network.TCP (HostPreference (..), ServiceName,
|
||||
|
|
@ -25,30 +26,35 @@ data IrcEvent = Msg { _outMsg :: !IrcMessage
|
|||
, _outDest :: ![Int]
|
||||
}
|
||||
| Close { _closeConn :: Int }
|
||||
| Pong { _pongConn :: Int }
|
||||
deriving (Show)
|
||||
makeLenses ''IrcEvent
|
||||
|
||||
data IrcUserMode = Away | Invisible | WallOps | Restricted
|
||||
| Oper | LocalOper | ServerNotices
|
||||
deriving (Show, Eq, Enum)
|
||||
deriving (Show, Eq, Enum, Ord)
|
||||
|
||||
data IrcUser =
|
||||
IrcUser { _userNick :: !NickName
|
||||
, _userServerName :: !ByteString
|
||||
IrcUser { _userServerName :: !ByteString
|
||||
, _userModes :: !(Set IrcUserMode)
|
||||
, _userChannels :: !(Set ByteString)
|
||||
, _userConn :: !Int
|
||||
, _userInvites :: !(Set ByteString)
|
||||
} deriving (Show, Eq)
|
||||
makeLenses ''IrcUser
|
||||
|
||||
data IrcChanMode = Anonymous | InviteOnly | Moderated | Quiet | Secret
|
||||
deriving (Show, Eq, Enum)
|
||||
data IrcChanModeFlags = Anonymous | InviteOnly | Moderated | NoOutsideMsgs
|
||||
| Quiet | Private | Secret | TopicOperOnly
|
||||
deriving (Show, Eq, Enum, Ord)
|
||||
|
||||
data IrcChannel =
|
||||
IrcChannel { _chanName :: !ByteString
|
||||
, _chanTopic :: !ByteString
|
||||
, _chanModes :: !(Set IrcChanMode)
|
||||
, _chanUsers :: !(Set ByteString)
|
||||
IrcChannel { _chanTopic :: !(Maybe ByteString)
|
||||
, _chanKey :: !(Maybe ByteString)
|
||||
, _chanModeFlags :: !(Set IrcChanModeFlags)
|
||||
, _chanUsers :: !(Set ByteString)
|
||||
, _chanOpers :: !(Set ByteString)
|
||||
, _chanVoices :: !(Set ByteString)
|
||||
, _chanInvites :: !(Set ByteString)
|
||||
} deriving (Show, Eq)
|
||||
makeLenses ''IrcChannel
|
||||
|
||||
|
|
@ -77,11 +83,13 @@ data RegState = Unreg { _rcvdPass :: !(Maybe ByteString)
|
|||
makeLenses ''RegState
|
||||
|
||||
data IrcConnection =
|
||||
IrcConnection { _sock :: !Socket
|
||||
, _addr :: !SockAddr
|
||||
, _hname :: !(Maybe ByteString)
|
||||
, _out :: !(Output IrcMessage)
|
||||
, _reg :: !RegState
|
||||
IrcConnection { _sock :: !Socket
|
||||
, _addr :: !SockAddr
|
||||
, _hname :: !(Maybe ByteString)
|
||||
, _out :: !(Output IrcMessage)
|
||||
, _reg :: !RegState
|
||||
, _lastCom :: !UTCTime
|
||||
, _gotPong :: !Bool
|
||||
}
|
||||
makeLenses ''IrcConnection
|
||||
|
||||
|
|
@ -101,10 +109,5 @@ data ClientState =
|
|||
} deriving (Show)
|
||||
makeLenses ''ClientState
|
||||
|
||||
newtype IrcMonad a =
|
||||
IrcMonad { runIrc :: RWS IrcConfig IrcEvents ClientState a }
|
||||
deriving ( Monad
|
||||
, Functor
|
||||
, MonadReader IrcConfig
|
||||
, MonadWriter IrcEvents
|
||||
, MonadState ClientState)
|
||||
type IrcMonad a = RWS IrcConfig IrcEvents ClientState a
|
||||
type IrcMonadErr a = EitherT String (RWS IrcConfig IrcEvents ClientState) a
|
||||
|
|
|
|||
Loading…
Reference in New Issue