326 lines
10 KiB
Haskell
326 lines
10 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Pipes.IRC.Server.IrcMonad
|
|
where
|
|
|
|
import Control.Applicative ((<$>))
|
|
import Control.Error
|
|
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 (fromJust)
|
|
import qualified Data.Set as S
|
|
|
|
import Pipes.IRC.Message.Types
|
|
import Pipes.IRC.Server.Channel
|
|
import Pipes.IRC.Server.Server
|
|
import Pipes.IRC.Server.Types
|
|
import Pipes.IRC.Server.User
|
|
|
|
-- * IrcUser management
|
|
|
|
mkUser :: IrcMonad IrcUser
|
|
mkUser = do
|
|
conn <- use clientConn
|
|
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
|
|
ppServiceName = BS.pack
|
|
|
|
ppHostPreference :: HostPreference -> ByteString
|
|
ppHostPreference hp = case hp of
|
|
HostAny -> "*"
|
|
HostIPv4 -> "*4"
|
|
HostIPv6 -> "*6"
|
|
Host hn -> BS.pack hn
|
|
|
|
-- * Monadic utilities
|
|
|
|
useChan :: ChanKey -> IrcMonad (Maybe IrcChannel)
|
|
useChan cname = use $ clientServer . ircChannels . at cname
|
|
|
|
useUserChans :: NickKey -> IrcMonad (S.Set ChanKey)
|
|
useUserChans nn =
|
|
use (clientServer . ircUsers . at nn . traverse . userChannels)
|
|
|
|
useNick :: IrcMonad (Maybe NickKey)
|
|
useNick = do
|
|
regState <- use clientReg
|
|
return $ case regState of
|
|
Unreg _ (Just nn) _ -> Just nn
|
|
RegUser (NickName nn _ _) -> Just nn
|
|
_ -> Nothing
|
|
|
|
channelTargets :: ChanKey -> 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 -> catMaybes <$> forM (cUsers chan) userTarget
|
|
_ -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"]
|
|
return []
|
|
|
|
userTarget :: NickKey -> 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 :: [ChanKey] -> IrcMessage -> IrcMonad ()
|
|
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
|
|
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])
|
|
type IrcMonadErr = ExceptT ErrParam IrcMonad
|
|
|
|
tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad ()
|
|
tellErr (Left (r, ps)) = void $ tellNumeric r ps
|
|
tellErr _ = return ()
|
|
|
|
runValidation :: IrcMonadErr () -> IrcMonad ()
|
|
runValidation = tellErr <=< runExceptT
|
|
|
|
ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr ()
|
|
ensure p r ps = unless p $ throwE (r, ps)
|
|
|
|
ensureUse :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a
|
|
ensureUse u e = lift u >>= hoistEither . note e
|
|
|
|
checkParamLength :: BS.ByteString -> [IrcParam] -> Int -> IrcMonadErr ()
|
|
checkParamLength cmd ps n =
|
|
ensure (length ps >= n)
|
|
err_needmoreparams [cmd, ":Need more parameters"]
|
|
|
|
checkSuppliedNickname :: [IrcParam] -> IrcMonadErr NickKey
|
|
checkSuppliedNickname ps = do
|
|
ensure (not $ null ps) err_nonicknamegiven [":must supply a nickname"]
|
|
return (head ps)
|
|
|
|
checkRegistration :: IrcMonadErr NickKey
|
|
checkRegistration =
|
|
ensureUse useNick (err_notregistered, [":You have not registered"])
|
|
|
|
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"]
|
|
|
|
checkInvitation :: NickKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
|
|
checkInvitation nn c ch = ensure (ircInviteCheck nn ch)
|
|
err_inviteonlychan [c, ":Cannot join channel (+i)"]
|
|
|
|
checkPassKey :: Maybe PassKey -> ChanKey -> IrcChannel -> IrcMonadErr ()
|
|
checkPassKey k c chan = ensure (ircPassCheck k chan)
|
|
err_badchannelkey [c, ":Cannot join channel (+k)"]
|
|
|
|
checkNickFree :: NickKey -> IrcMonadErr ()
|
|
checkNickFree nickname = do
|
|
nickSet <- lift (use $ clientServer . ircNicks)
|
|
ensure (not $ S.member nickname nickSet)
|
|
err_nicknameinuse [nickname, ":Nickname is already in use."]
|
|
|
|
-- * Adding responses to the Writer portion of the monad
|
|
|
|
renderQuitMsg :: Maybe BS.ByteString -> IrcMonad BS.ByteString
|
|
renderQuitMsg (Just msg) = return $ BS.append "Quit: " msg
|
|
renderQuitMsg Nothing = useNick >>= \nickname ->
|
|
return $ case nickname of
|
|
Just n -> BS.append "Quit: " n
|
|
Nothing -> ""
|
|
|
|
tellYOURHOST :: NickKey -> 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 :: NickKey -> 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 :: NickKey -> IrcMonad ()
|
|
tellWELCOME nickname = do
|
|
srvname <- view ircHostName
|
|
tellNumeric rpl_welcome [ nickname
|
|
, BS.append ":Welcome to IRC on " srvname ]
|
|
|
|
tellTOPIC :: ChanKey -> 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 :: [ChanKey] -> 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 ()
|