142 lines
4.3 KiB
Haskell
142 lines
4.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Pipes.IRC.Server
|
|
( mkIrcServer
|
|
, startIrcServer
|
|
, listenHandler
|
|
, module Pipes.IRC.Server.Types
|
|
)
|
|
where
|
|
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import Data.ByteString.Char8 as BS
|
|
import Data.ByteString.Lazy as LB
|
|
import Data.ByteString.Lazy.Builder (toLazyByteString)
|
|
import Data.List as L
|
|
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.Server.Types
|
|
import Pipes.Lift (runStateP)
|
|
import Pipes.Network.TCP
|
|
import Pipes.Parse as PP
|
|
|
|
sendToMany :: a -> [Output a] -> IO ()
|
|
sendToMany msg outs = do
|
|
resL <- forM outs $ \o ->
|
|
async $ atomically $ PC.send o msg
|
|
mapM_ wait resL
|
|
|
|
publishStream :: TVar [IrcConnection a] -> Consumer a IO ()
|
|
publishStream clients = forever $ do
|
|
msg <- await
|
|
cs <- lift $ atomically $ readTVar clients
|
|
let os = L.map out cs
|
|
lift $ sendToMany msg os
|
|
|
|
spawnEcho :: TVar [IrcConnection a] -> IO (Output a)
|
|
spawnEcho clients = do
|
|
(writeEnd, readEnd) <- spawn Unbounded
|
|
_ <- async $ forever $
|
|
runEffect $ fromInput readEnd >-> publishStream clients
|
|
return writeEnd
|
|
|
|
logMsg :: IrcMessage -> IO ()
|
|
logMsg msg = BS.putStr $ BS.concat
|
|
["LOG: ", toStrict $ toLazyByteString (renderIrcMessage msg)]
|
|
|
|
cmdHandler :: Output IrcMessage -> Consumer IrcMessage IO ()
|
|
cmdHandler echoSrv = toOutput echoSrv
|
|
|
|
filterMsgs :: Pipe (Either BS.ByteString IrcMessage) IrcMessage IO ()
|
|
filterMsgs = forever $ do
|
|
cmd <- await
|
|
case cmd of
|
|
Left bs -> lift $ BS.putStr $ BS.concat ["BAD COMMAND: ", bs]
|
|
Right c -> do lift $ logMsg c
|
|
yield c
|
|
|
|
addIrcConnection :: IrcConnection IrcMessage -> IrcServer -> IO ()
|
|
addIrcConnection client server = do
|
|
let clients = ircConnections server
|
|
atomically $ modifyTVar clients $ \cs -> client : cs
|
|
|
|
delIrcConnection :: IrcConnection IrcMessage -> IrcServer -> IO ()
|
|
delIrcConnection client server = do
|
|
let clients = ircConnections server
|
|
atomically $ modifyTVar clients $ delete client
|
|
|
|
parseMessage :: Producer BS.ByteString IO ()
|
|
-> Producer (Either BS.ByteString IrcMessage) IO ()
|
|
parseMessage prod = do
|
|
(me, src') <- runStateP prod go
|
|
case me of
|
|
Left e -> lift . print . show $ e
|
|
Right r -> return r
|
|
where
|
|
go = do
|
|
eof <- lift isEndOfParserInput
|
|
if eof
|
|
then do
|
|
liftIO $ BS.putStrLn "EOF Reached"
|
|
ra <- lift PP.draw
|
|
case ra of
|
|
Left r -> return (Right r)
|
|
Right _ -> error "parseMessage: impossible!!"
|
|
else do
|
|
eb <- lift (parse parseMsgOrLine)
|
|
case eb of
|
|
Left e -> return (Left e)
|
|
Right (_, b) -> yield b >> go
|
|
|
|
renderMessage :: Pipe IrcMessage BS.ByteString IO ()
|
|
renderMessage = forever $ do
|
|
msg <- await
|
|
let output = toIrcMessage msg
|
|
yield output
|
|
where
|
|
toIrcMessage = toStrict . toLazyByteString . renderIrcMessage
|
|
|
|
listenHandler :: IrcServer -> IrcHandler
|
|
listenHandler server (lsock, _) =
|
|
forever $ acceptFork lsock $ \(csock, caddr) ->
|
|
let
|
|
sockWriter = toSocket csock
|
|
sockReader = fromSocket csock 4096
|
|
handler = ircHandler server
|
|
in do
|
|
(writeEnd, readEnd) <- spawn Unbounded
|
|
let client = IrcConnection csock caddr writeEnd
|
|
|
|
addIrcConnection client server
|
|
|
|
r <- async $ runEffect $
|
|
parseMessage sockReader >-> filterMsgs >-> handler
|
|
|
|
w <- async $ runEffect $
|
|
fromInput readEnd >-> renderMessage >-> sockWriter
|
|
|
|
mapM_ wait [r,w]
|
|
|
|
delIrcConnection client server
|
|
|
|
mkIrcServer :: IrcConfig -> IO IrcServer
|
|
mkIrcServer config = do
|
|
conns <- atomically $ newTVar []
|
|
users <- atomically $ newTVar []
|
|
chans <- atomically $ newTVar []
|
|
echoEnd <- spawnEcho conns
|
|
return $ IrcServer config conns users chans (cmdHandler echoEnd)
|
|
|
|
startIrcServer :: IrcServer -> IrcHandler -> IO (Async ())
|
|
startIrcServer server handler =
|
|
async $ listen sHost sPort handler
|
|
where
|
|
sHost = ircHost . ircConfig $ server
|
|
sPort = ircPort . ircConfig $ server
|