Various refactorings and bugfixes
Levi Pearson
parent
8f5e224a8f
commit
91fcf5f78c
|
|
@ -1,8 +1,11 @@
|
|||
module Pipes.IRC.Message
|
||||
( parseMsgOrLine
|
||||
, parseIrcMessage
|
||||
, renderIrcMessage
|
||||
, renderIrcMessageNoNL
|
||||
, module Pipes.IRC.Message.Types
|
||||
) where
|
||||
|
||||
import Pipes.IRC.Message.Parse
|
||||
import Pipes.IRC.Message.Render
|
||||
import Pipes.IRC.Message.Types
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
|
||||
module Pipes.IRC.Message.Render
|
||||
( renderIrcMessage
|
||||
, renderIrcMessageNoNL
|
||||
, renderNickName )
|
||||
where
|
||||
|
||||
|
|
@ -15,17 +16,20 @@ import Data.Monoid
|
|||
import Pipes.IRC.Message.Types
|
||||
|
||||
renderIrcMessage :: IrcMessage -> C8.ByteString
|
||||
renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage
|
||||
renderIrcMessage = toStrict . toLazyByteString . buildIrcMessage True
|
||||
|
||||
renderIrcMessageNoNL :: IrcMessage -> ByteString
|
||||
renderIrcMessageNoNL = toStrict . toLazyByteString . buildIrcMessage False
|
||||
|
||||
renderNickName :: NickName -> C8.ByteString
|
||||
renderNickName = toStrict . toLazyByteString . buildNickName
|
||||
|
||||
buildIrcMessage :: IrcMessage -> Builder
|
||||
buildIrcMessage IrcMessage {..} =
|
||||
buildIrcMessage :: Bool -> IrcMessage -> Builder
|
||||
buildIrcMessage nl IrcMessage {..} =
|
||||
buildMsgPrefix prefix
|
||||
<> buildMsgCommand command
|
||||
<> buildIrcParams params
|
||||
<> byteString "\r\n"
|
||||
<> if nl then byteString "\r\n" else mempty
|
||||
|
||||
buildMsgPrefix :: Maybe MsgPrefix -> Builder
|
||||
buildMsgPrefix Nothing = mempty
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
module Pipes.IRC.Message.Types where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Monoid
|
||||
|
||||
data IrcMessage =
|
||||
IrcMessage { prefix :: Maybe MsgPrefix
|
||||
|
|
@ -71,6 +72,10 @@ data IrcReply = IrcReply
|
|||
, replyName :: !B.ByteString
|
||||
} deriving (Show)
|
||||
|
||||
instance Monoid IrcReply where
|
||||
mempty = mkIrcReply 400 "UNKNOWN ERROR"
|
||||
_ `mappend` b = b
|
||||
|
||||
instance Eq IrcReply where
|
||||
IrcReply { replyCode = a } == IrcReply { replyCode = b } = a == b
|
||||
|
||||
|
|
|
|||
|
|
@ -13,27 +13,27 @@ import Control.Monad
|
|||
import Control.Monad.RWS
|
||||
import Data.ByteString.Char8 as BS
|
||||
import Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Set as S
|
||||
import Data.Time.Clock
|
||||
import Network.Socket as NS
|
||||
import Pipes
|
||||
import Pipes.Attoparsec
|
||||
import Pipes.Concurrent as PC
|
||||
import Pipes.IRC.Message.Parse
|
||||
import Pipes.IRC.Message.Render
|
||||
import Pipes.IRC.Message.Types
|
||||
import Pipes.IRC.Message
|
||||
import Pipes.IRC.Server.EventHandler
|
||||
import Pipes.IRC.Server.IrcMonad
|
||||
import Pipes.IRC.Server.Log
|
||||
import Pipes.IRC.Server.MessageHandler
|
||||
import Pipes.IRC.Server.Server
|
||||
import Pipes.IRC.Server.Types
|
||||
import Pipes.Network.TCP as PN
|
||||
|
||||
version :: BS.ByteString
|
||||
version :: ByteString
|
||||
version = "0.1a"
|
||||
|
||||
parseMessage :: Producer BS.ByteString IO ()
|
||||
-> Producer (Either BS.ByteString IrcMessage) IO ()
|
||||
parseMessage :: Producer ByteString IO ()
|
||||
-> Producer (Either ByteString IrcMessage) IO ()
|
||||
parseMessage prod = do
|
||||
void $ for (parseMany parseMsgOrLine prod) $ \res ->
|
||||
case res of
|
||||
|
|
@ -41,19 +41,18 @@ parseMessage prod = do
|
|||
(_, Right val) -> yield $ Right val
|
||||
return ()
|
||||
|
||||
renderMessage :: Pipe IrcMessage BS.ByteString IO ()
|
||||
renderMessage :: Pipe IrcMessage ByteString IO ()
|
||||
renderMessage = forever $ do
|
||||
msg <- await
|
||||
let output = renderIrcMessage msg
|
||||
yield output
|
||||
|
||||
filterMsgs :: Pipe (Either BS.ByteString IrcMessage) IrcMessage IO ()
|
||||
filterMsgs :: Pipe (Either ByteString IrcMessage) IrcMessage IO ()
|
||||
filterMsgs = forever $ do
|
||||
cmd <- await
|
||||
case cmd of
|
||||
Left bs -> liftIO $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs]
|
||||
Right c -> do lift $ logMsg c
|
||||
yield c
|
||||
Left bs -> liftIO $ logLine $ BS.concat ["BAD COMMAND: ", bs]
|
||||
Right c -> yield c
|
||||
|
||||
addIrcConnection :: ServerState -> IrcConnection -> IO Int
|
||||
addIrcConnection srv client = do
|
||||
|
|
@ -80,6 +79,32 @@ delIrcConnection srv cid = atomically $ do
|
|||
_ -> return ()
|
||||
modifyTVar' (srv ^. ircConnections) $ M.delete cid
|
||||
|
||||
ircMonadTransaction :: ServerState -> Int -> RegState -> IrcMonad ()
|
||||
-> IO (RegState, [IrcEvent])
|
||||
ircMonadTransaction srv cid userReg action = do
|
||||
cmap <- readTVarIO $ srv ^. ircConnections
|
||||
let hostname = view (at cid . traverse . hname) cmap
|
||||
curTime <- getCurrentTime
|
||||
atomically $ do
|
||||
sState <- readTVar $ srv ^. ircState
|
||||
let sConf = srv ^. ircConfig
|
||||
let cState = ClientState { _clientReg = userReg
|
||||
, _clientServer = sState
|
||||
, _clientHost = hostname
|
||||
, _clientConn = cid }
|
||||
let (_, newState, events) = runRWS action sConf cState
|
||||
writeTVar (srv ^. ircState) (newState ^. clientServer)
|
||||
modifyTVar' (srv ^. ircConnections) $
|
||||
M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid
|
||||
return (newState ^. clientReg, events)
|
||||
|
||||
runIrcMonad :: ServerState -> Int -> IrcMonad () -> IO ()
|
||||
runIrcMonad srv cid action = do
|
||||
cs <- readTVarIO (srv ^. ircConnections)
|
||||
let cReg = maybe (Unreg Nothing Nothing Nothing) (view reg) (cs ^. at cid)
|
||||
(_, events) <- ircMonadTransaction srv cid cReg action
|
||||
forM_ events $ ircEventHandler srv
|
||||
|
||||
cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
|
||||
cmdHandler srv cid =
|
||||
let cReg = Unreg Nothing Nothing Nothing
|
||||
|
|
@ -89,38 +114,24 @@ cmdHandler srv cid =
|
|||
Just c -> handle (c ^. hname) cReg
|
||||
Nothing -> return ()
|
||||
where
|
||||
handle host userReg = do
|
||||
handle h userReg = do
|
||||
-- wait for the next command
|
||||
nextMsg <- await
|
||||
curTime <- liftIO getCurrentTime
|
||||
|
||||
liftIO $ logMsg nextMsg (fromMaybe "unknown" h) userReg
|
||||
|
||||
-- run the handler in a transaction
|
||||
(newReg, events) <- liftIO $ atomically $ do
|
||||
sState <- readTVar $ srv ^. ircState
|
||||
let sConf = srv ^. ircConfig
|
||||
let cState = ClientState { _clientReg = userReg
|
||||
, _clientServer = sState
|
||||
, _clientHost = host
|
||||
, _clientConn = cid
|
||||
}
|
||||
|
||||
-- run the handler in the IrcMonad, returning new state and events
|
||||
let (_, newState, events) =
|
||||
runRWS (ircMessageHandler nextMsg) sConf cState
|
||||
|
||||
writeTVar (srv ^. ircState) $
|
||||
newState ^. clientServer
|
||||
|
||||
modifyTVar' (srv ^. ircConnections) $
|
||||
M.adjust ((reg .~ newState ^. clientReg).(lastCom .~ curTime)) cid
|
||||
|
||||
return (newState ^. clientReg, events)
|
||||
(newReg, events) <-
|
||||
liftIO $ ircMonadTransaction srv cid userReg (ircMessageHandler nextMsg)
|
||||
|
||||
-- handle resulting events
|
||||
aliveL <- liftIO $ forM events $ ircEventHandler srv
|
||||
|
||||
{- -- debug
|
||||
sState <- liftIO $ readTVarIO $ srv ^. ircState
|
||||
liftIO $ BS.putStrLn $ BS.pack (show sState)
|
||||
-}
|
||||
-- loop for the next command
|
||||
when (and aliveL) $ handle host newReg
|
||||
when (and aliveL) $ handle h newReg
|
||||
|
||||
idlePinger :: ServerState -> Int -> IO ()
|
||||
idlePinger srv cid =
|
||||
|
|
@ -134,21 +145,28 @@ idlePinger srv cid =
|
|||
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
|
||||
timeoutLoop b = when b $ 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 >>= timeoutLoop
|
||||
else timeoutLoop True
|
||||
in do
|
||||
-- timeoutLoop will call itself repeatedly until a timeout occurs
|
||||
timeoutLoop True
|
||||
-- Then we need to send a timeout message
|
||||
runIrcMonad srv cid $ doQuit (Just "Ping timeout")
|
||||
|
||||
listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
|
||||
listenHandler srv (lsock, _) =
|
||||
|
|
@ -161,6 +179,9 @@ listenHandler srv (lsock, _) =
|
|||
(writeEnd, readEnd) <- spawn Unbounded
|
||||
curTime <- getCurrentTime
|
||||
|
||||
logLine $ BS.pack $
|
||||
"Accepted connection from " ++ fromMaybe "unknown" hName
|
||||
|
||||
let client = IrcConnection
|
||||
{ _sock = csock
|
||||
, _addr = caddr
|
||||
|
|
@ -188,6 +209,9 @@ listenHandler srv (lsock, _) =
|
|||
|
||||
void $ waitAnyCancel [r, w, idle]
|
||||
|
||||
logLine $ BS.pack $
|
||||
"Connection from " ++ fromMaybe "unknown" hName ++ " terminated"
|
||||
|
||||
delIrcConnection srv cid
|
||||
|
||||
mkIrcServer :: IrcConfig -> IO ServerState
|
||||
|
|
@ -206,4 +230,6 @@ startIrcServer config = do
|
|||
srv <- mkIrcServer config
|
||||
let sHost = srv ^. ircConfig . ircHost
|
||||
sPort = srv ^. ircConfig . ircPort
|
||||
logLine $ BS.pack $
|
||||
mconcat ["Starting server on ", show sHost, " ", show sPort]
|
||||
async $ PN.listen sHost sPort (listenHandler srv)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import Control.Monad
|
|||
import Data.Map as M
|
||||
import Data.Maybe as DM
|
||||
import Pipes.Concurrent as PC
|
||||
import Pipes.IRC.Server.Log
|
||||
import Pipes.IRC.Server.Types
|
||||
|
||||
sendToMany :: a -> [Output a] -> IO ()
|
||||
|
|
@ -31,8 +32,9 @@ ircEventHandler srv evt =
|
|||
outConns <- readTVarIO $ srv ^. ircConnections
|
||||
let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest
|
||||
sendToMany _outMsg os
|
||||
logOutMsg _outMsg _outDest
|
||||
return True
|
||||
Pong {..} -> do
|
||||
atomically $ modifyTVar' (srv ^. ircConnections) $
|
||||
M.adjust (gotPong .~ False) _pongConn
|
||||
M.adjust (gotPong .~ True) _pongConn
|
||||
return True
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
module Pipes.IRC.Server.IrcMonad
|
||||
where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Error
|
||||
import Control.Lens
|
||||
import Control.Monad.RWS
|
||||
|
|
@ -26,6 +27,40 @@ mkUser = do
|
|||
srvname <- view ircHostName
|
||||
return $ newUser srvname conn
|
||||
|
||||
-- * User registration management
|
||||
|
||||
storePassKey :: PassKey -> IrcMonad ()
|
||||
storePassKey k = clientReg . rcvdPass ?= k
|
||||
|
||||
storeNickKey :: NickKey -> IrcMonad ()
|
||||
storeNickKey nn = clientReg . rcvdNick ?= nn
|
||||
|
||||
storeUserName :: ByteString -> IrcMonad ()
|
||||
storeUserName n = clientReg . rcvdName ?= n
|
||||
|
||||
registerUser :: RegState -> IrcMonad ()
|
||||
registerUser rs = clientReg .= rs
|
||||
|
||||
-- * IrcServer management
|
||||
|
||||
joinNickToChan :: NickKey -> ChanKey -> IrcMonad ()
|
||||
joinNickToChan nn c = clientServer %= ircJoin nn c
|
||||
|
||||
partNickFromChan :: NickKey -> ChanKey -> IrcMonad ()
|
||||
partNickFromChan nn c = clientServer %= ircPart nn c
|
||||
|
||||
reserveNick :: NickKey -> IrcMonad ()
|
||||
reserveNick nn = clientServer . ircNicks . contains nn .= True
|
||||
|
||||
changeNick :: NickKey -> NickKey -> IrcMonad ()
|
||||
changeNick oldN newN = do
|
||||
clientServer %= ircChangeNick oldN newN
|
||||
clientReg . regdNick %= (\n -> n{nick = newN})
|
||||
|
||||
associateUserWithNick :: IrcUser -> NickKey -> IrcMonad ()
|
||||
associateUserWithNick usr nn = clientServer . ircUsers . at nn ?= usr
|
||||
|
||||
|
||||
-- * Pretty Printing
|
||||
|
||||
ppServiceName :: ServiceName -> ByteString
|
||||
|
|
@ -114,22 +149,36 @@ chanEcho chans iMsg = do
|
|||
msg <- addUserPrefix iMsg
|
||||
findReceivers chans >>= fwdMsg msg
|
||||
|
||||
allChans :: IrcMonad [ChanKey]
|
||||
allChans = do
|
||||
cs <- runMaybeT $ do
|
||||
nn <- lift useNick >>= hoistMaybe
|
||||
usrs <- lift (use $ clientServer . ircUsers)
|
||||
usr <- hoistMaybe $ M.lookup nn usrs
|
||||
let chans = S.elems $ usr ^. userChannels
|
||||
return chans
|
||||
return $ fromMaybe [] cs
|
||||
|
||||
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
|
||||
cs <- allChans
|
||||
chanEcho cs iMsg
|
||||
|
||||
disconnectUser :: Int -> IrcMessage -> IrcMonad ()
|
||||
disconnectUser cid msg = do
|
||||
allChanEcho msg
|
||||
tell [Close cid]
|
||||
|
||||
doQuit :: Maybe ByteString -> IrcMonad ()
|
||||
doQuit qmsg = do
|
||||
connId <- use clientConn
|
||||
hostname <- fromMaybe "unknown hostname" <$> use clientHost
|
||||
quitMsg <- renderQuitMsg qmsg
|
||||
let quitParam = mconcat [":Closing Link: ", hostname, " (", quitMsg, ")"]
|
||||
let msg = IrcMessage Nothing (Left QUIT) [quitParam]
|
||||
tellCommand ERROR [quitParam]
|
||||
disconnectUser connId msg
|
||||
|
||||
-- * Command validation utilities
|
||||
|
||||
type ErrParam = (IrcReply, [IrcParam])
|
||||
|
|
@ -143,7 +192,7 @@ runValidation :: IrcMonadErr () -> IrcMonad ()
|
|||
runValidation = tellErr <=< runEitherT
|
||||
|
||||
ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr ()
|
||||
ensure p r ps = when p $ left (r, ps)
|
||||
ensure p r ps = unless p $ left (r, ps)
|
||||
|
||||
ensureUse :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a
|
||||
ensureUse u e = lift u >>= hoistEither . note e
|
||||
|
|
@ -155,7 +204,7 @@ checkParamLength cmd ps n =
|
|||
|
||||
checkSuppliedNickname :: [IrcParam] -> IrcMonadErr NickKey
|
||||
checkSuppliedNickname ps = do
|
||||
ensure (not . null $ ps) err_nonicknamegiven [":must supply a nickname"]
|
||||
ensure (not $ null ps) err_nonicknamegiven [":must supply a nickname"]
|
||||
return (head ps)
|
||||
|
||||
checkRegistration :: IrcMonadErr NickKey
|
||||
|
|
@ -166,13 +215,18 @@ checkChannelPresence :: ChanKey -> IrcMonadErr IrcChannel
|
|||
checkChannelPresence ckey =
|
||||
ensureUse (useChan ckey) (err_badchannelkey, [ckey, ":No such channel"])
|
||||
|
||||
checkChannelAbsence :: ChanKey -> IrcMonadErr ()
|
||||
checkChannelAbsence ckey = do
|
||||
ch <- lift $ useChan ckey
|
||||
ensure (isNothing ch) mempty mempty
|
||||
|
||||
checkUserOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
|
||||
checkUserOnChan nn c ch =
|
||||
ensure (chanHasUser nn ch) err_notonchannel [c, ":Not on channel"]
|
||||
|
||||
checkUserNotOnChan :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
|
||||
checkUserNotOnChan nn c ch =
|
||||
ensure (not . chanHasUser nn $ ch) err_notonchannel [c, ":Already on channel"]
|
||||
ensure (not $ chanHasUser nn ch) err_notonchannel [c, ":Already on channel"]
|
||||
|
||||
checkInvitation :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
|
||||
checkInvitation nn c ch = ensure (ircInviteCheck nn ch)
|
||||
|
|
@ -185,7 +239,7 @@ checkPassKey k c chan = ensure (ircPassCheck k chan)
|
|||
checkNickFree :: NickKey -> IrcMonadErr ()
|
||||
checkNickFree nickname = do
|
||||
nickSet <- lift (use $ clientServer . ircNicks)
|
||||
ensure (S.member nickname nickSet)
|
||||
ensure (not $ S.member nickname nickSet)
|
||||
err_nicknameinuse [nickname, ":Nickname is already in use."]
|
||||
|
||||
-- * Adding responses to the Writer portion of the monad
|
||||
|
|
|
|||
|
|
@ -1,12 +1,41 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Pipes.IRC.Server.Log
|
||||
( logMsg )
|
||||
( logMsg
|
||||
, logLine
|
||||
, logOutMsg
|
||||
)
|
||||
where
|
||||
|
||||
import Data.ByteString as BS
|
||||
import Pipes.IRC.Message.Render
|
||||
import Pipes.IRC.Message.Types
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Time
|
||||
import Pipes.IRC.Message
|
||||
import Pipes.IRC.Server.Types
|
||||
|
||||
logMsg :: IrcMessage -> IO ()
|
||||
logMsg msg = BS.putStr $ BS.concat ["LOG: ", renderIrcMessage msg]
|
||||
logMsg :: IrcMessage -> ByteString -> RegState -> IO ()
|
||||
logMsg msg h userReg =
|
||||
putLog $ BS.concat ["MSG:", hStr, uStr, renderIrcMessageNoNL msg]
|
||||
where
|
||||
hStr = BS.concat [" ", h, " "]
|
||||
uStr = BS.concat $ case userReg of
|
||||
Unreg _ (Just nn) Nothing -> [" ", nn, " ? "]
|
||||
Unreg _ Nothing (Just name) -> [" ? ", name, " "]
|
||||
Unreg _ (Just nn) (Just name) -> [" ", nn," ", name, " "]
|
||||
RegUser (NickName nn (Just name) _) -> [" ", nn," ", name, " "]
|
||||
_ -> [" ? ? "]
|
||||
|
||||
logOutMsg :: IrcMessage -> [Int] -> IO ()
|
||||
logOutMsg msg os =
|
||||
putLog $ BS.concat [ "OutMSG: "
|
||||
, BS.intercalate "," $ map (BS.pack . show) os
|
||||
, ": "
|
||||
, renderIrcMessageNoNL msg ]
|
||||
|
||||
logLine :: ByteString -> IO ()
|
||||
logLine = putLog
|
||||
|
||||
putLog :: ByteString -> IO ()
|
||||
putLog l = do
|
||||
now <- getCurrentTime
|
||||
BS.putStrLn $ BS.concat [BS.pack (show now), " : ", l]
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ module Pipes.IRC.Server.MessageHandler
|
|||
( ircMessageHandler )
|
||||
where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative (pure, (<$>), (<|>))
|
||||
import Control.Error
|
||||
import Control.Lens
|
||||
import Control.Monad.RWS
|
||||
|
|
@ -14,7 +14,6 @@ import Data.Set as S
|
|||
|
||||
import Pipes.IRC.Message.Types
|
||||
import Pipes.IRC.Server.IrcMonad
|
||||
import Pipes.IRC.Server.Server
|
||||
import Pipes.IRC.Server.Types
|
||||
import Pipes.IRC.Server.Util
|
||||
|
||||
|
|
@ -43,14 +42,25 @@ regHandler :: IrcMessage -> IrcMonad ()
|
|||
regHandler msg@IrcMessage{..} = do
|
||||
pMsg <- addUserPrefix msg
|
||||
case command of
|
||||
Left PRIVMSG -> handlePRIVMSG pMsg
|
||||
Left AWAY -> return ()
|
||||
Left INVITE -> return ()
|
||||
Left JOIN -> handleJOIN pMsg
|
||||
Left PART -> handlePART pMsg
|
||||
Left KICK -> return ()
|
||||
Left KILL -> return ()
|
||||
Left LIST -> return ()
|
||||
Left NICK -> return ()
|
||||
Left MODE -> return ()
|
||||
Left NAMES -> return ()
|
||||
Left NICK -> handleNICK pMsg
|
||||
Left NOTICE -> return ()
|
||||
Left PART -> handlePART pMsg
|
||||
Left PING -> handlePING pMsg
|
||||
Left PONG -> handlePONG pMsg
|
||||
Left PRIVMSG -> handlePRIVMSG pMsg
|
||||
Left TOPIC -> return ()
|
||||
Left QUIT -> handleQUIT pMsg
|
||||
Left WHO -> return ()
|
||||
Left WHOIS -> return ()
|
||||
Left WHOWAS -> return ()
|
||||
_ -> return ()
|
||||
|
||||
-- * Handlers for messages coming from unregistered users
|
||||
|
|
@ -58,22 +68,22 @@ regHandler msg@IrcMessage{..} = do
|
|||
unregPASS :: IrcMessage -> IrcMonad ()
|
||||
unregPASS IrcMessage{..} = runValidation $ do
|
||||
checkParamLength "PASS" params 1
|
||||
lift $ clientReg . rcvdPass ?= head params
|
||||
lift $ storePassKey (head params)
|
||||
|
||||
unregNICK :: IrcMessage -> IrcMonad ()
|
||||
unregNICK IrcMessage{..} = runValidation $ do
|
||||
nickname <- checkSuppliedNickname params
|
||||
checkNickFree nickname
|
||||
lift $ do
|
||||
clientReg . rcvdNick ?= nickname
|
||||
clientServer . ircNicks . contains nickname .= True
|
||||
storeNickKey nickname
|
||||
reserveNick nickname
|
||||
tryRegistration
|
||||
|
||||
unregUSER :: IrcMessage -> IrcMonad ()
|
||||
unregUSER IrcMessage{..} = runValidation $ do
|
||||
checkParamLength "USER" params 4
|
||||
lift $ do
|
||||
clientReg . rcvdName ?= head params
|
||||
storeUserName (head params)
|
||||
tryRegistration
|
||||
|
||||
tryRegistration :: IrcMonad ()
|
||||
|
|
@ -83,8 +93,8 @@ tryRegistration = do
|
|||
case regState of
|
||||
Unreg _ (Just nickname) (Just name) -> do
|
||||
usr <- mkUser
|
||||
clientReg .= (RegUser $ NickName nickname (Just name) hostname)
|
||||
clientServer . ircUsers . at nickname ?= usr
|
||||
registerUser (RegUser $ NickName nickname (Just name) hostname)
|
||||
associateUserWithNick usr nickname
|
||||
|
||||
tellWELCOME nickname
|
||||
tellYOURHOST nickname
|
||||
|
|
@ -107,22 +117,19 @@ handlePONG _ = do
|
|||
-- echoed to channels that the user belongs to
|
||||
|
||||
handleQUIT :: IrcMessage -> IrcMonad ()
|
||||
handleQUIT msg@IrcMessage{..} = do
|
||||
connId <- use clientConn
|
||||
hostname <- fromMaybe "unknown hostname" <$> use clientHost
|
||||
quitMsg <- renderQuitMsg (headMay params)
|
||||
let quitParam = mconcat [":Closing Link: ", hostname, " (", quitMsg, ")"]
|
||||
tellCommand ERROR [quitParam]
|
||||
disconnectUser connId msg{params = [quitParam]}
|
||||
handleQUIT IrcMessage{..} = doQuit (headMay params)
|
||||
|
||||
handleJOIN :: IrcMessage -> IrcMonad ()
|
||||
handleJOIN msg@IrcMessage{..} = runValidation $ do
|
||||
checkParamLength "JOIN" params 1
|
||||
nn <- checkRegistration
|
||||
lift $ case params of
|
||||
-- Joining channel "0" really means to PART all channels
|
||||
["0"] -> do cs <- useUserChans nn
|
||||
doPart msg{command=Left PART} (S.elems cs) Nothing
|
||||
-- No passwords were supplied
|
||||
cs:[] -> doJoin msg $ zipParams (parseParamList cs) []
|
||||
-- Some number of passwords were supplied
|
||||
cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
|
||||
|
||||
handlePART :: IrcMessage -> IrcMonad ()
|
||||
|
|
@ -135,16 +142,20 @@ handlePART msg@IrcMessage{..} = runValidation $ do
|
|||
doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
|
||||
doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do
|
||||
nick <- checkRegistration
|
||||
chan <- checkChannelPresence c
|
||||
checkUserNotOnChan nick c chan
|
||||
checkInvitation nick c chan
|
||||
checkPassKey k c chan
|
||||
-- If the channel is absent, joining it will create it
|
||||
checkChannelAbsence c
|
||||
-- If it already exists, do some sanity checks first
|
||||
<|> do chan <- checkChannelPresence c
|
||||
checkUserNotOnChan nick c chan
|
||||
checkInvitation nick c chan
|
||||
checkPassKey k c chan
|
||||
|
||||
lift $ do
|
||||
clientServer %= ircJoin nick c
|
||||
joinNickToChan nick c
|
||||
tellTOPIC c
|
||||
tellNAMES [c]
|
||||
chanEcho [c] msg
|
||||
findReceivers [nick] >>= fwdMsgNoReplace msg
|
||||
|
||||
doPart :: IrcMessage -> [BS.ByteString] -> Maybe BS.ByteString -> IrcMonad ()
|
||||
doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do
|
||||
|
|
@ -155,9 +166,8 @@ doPart msg chans pmsg = forM_ chans $ \c -> runValidation $ do
|
|||
|
||||
lift $ do
|
||||
chanEcho [c] newMsg
|
||||
rs <- findReceivers [nn]
|
||||
fwdMsgNoReplace msg rs
|
||||
clientServer %= ircPart nn c
|
||||
findReceivers [nn] >>= fwdMsgNoReplace msg
|
||||
partNickFromChan nn c
|
||||
|
||||
handlePRIVMSG :: IrcMessage -> IrcMonad ()
|
||||
handlePRIVMSG msg@IrcMessage{..} = do
|
||||
|
|
@ -167,3 +177,13 @@ handlePRIVMSG msg@IrcMessage{..} = do
|
|||
rsp:_:_ -> let rs = parseParamList rsp
|
||||
in findReceivers rs >>= fwdMsg msg
|
||||
return ()
|
||||
|
||||
handleNICK :: IrcMessage -> IrcMonad ()
|
||||
handleNICK msg@IrcMessage{..} = runValidation $ do
|
||||
nn <- checkRegistration
|
||||
newNick <- checkSuppliedNickname params
|
||||
checkNickFree newNick
|
||||
lift $ do
|
||||
cs <- allChans
|
||||
findReceivers (cs <> [nn]) >>= fwdMsgNoReplace msg
|
||||
changeNick nn newNick
|
||||
|
|
|
|||
|
|
@ -9,7 +9,6 @@ module Pipes.IRC.Server.Server
|
|||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
|
|
@ -112,7 +111,7 @@ ircInviteCheck :: NickKey -- ^ nickname of possibly invited user
|
|||
-> IrcChannel -- ^ name of channel to check
|
||||
-> Bool -- ^ may the user join?
|
||||
ircInviteCheck n chan =
|
||||
chanHasModeFlag InviteOnly chan && not (chanUserIsInvited n chan)
|
||||
not (chanHasModeFlag InviteOnly chan) || chanUserIsInvited n chan
|
||||
|
||||
-- | Determine whether the given channel will disallow joining due to
|
||||
-- a missing or incorrect password. A 'True' value indicates that
|
||||
|
|
@ -121,7 +120,7 @@ ircPassCheck :: Maybe PassKey -- ^ password supplied by user
|
|||
-> IrcChannel -- ^ channel to check
|
||||
-> Bool -- ^ may the user join?
|
||||
ircPassCheck k chan =
|
||||
chanHasPass chan && (isNothing k || not (chanCheckPass (fromJust k) chan))
|
||||
not (chanHasPass chan) || (isJust k && chanCheckPass (fromJust k) chan)
|
||||
|
||||
-- | Change the nickname of a user from 'old' to 'new', updating the
|
||||
-- necessary 'IrcServer' structures. No nick collision check is
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ module Pipes.IRC.Server.Types
|
|||
where
|
||||
|
||||
import Control.Concurrent.STM (TVar)
|
||||
import Control.Error
|
||||
import Control.Lens
|
||||
import Control.Monad.RWS (RWS)
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
|
|||
Loading…
Reference in New Issue