137 lines
4.2 KiB
Haskell
137 lines
4.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Pipes.IRC.Server
|
|
( startIrcServer
|
|
, module Pipes.IRC.Server.Types
|
|
)
|
|
where
|
|
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import Control.Monad.RWS
|
|
import Data.ByteString.Char8 as BS
|
|
import Data.Map as M
|
|
import Data.Set as S
|
|
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.Server.EventHandler
|
|
import Pipes.IRC.Server.Log
|
|
import Pipes.IRC.Server.MessageHandler
|
|
import Pipes.IRC.Server.Types
|
|
import Pipes.Network.TCP as PN
|
|
|
|
parseMessage :: Producer BS.ByteString IO ()
|
|
-> Producer (Either BS.ByteString IrcMessage) IO ()
|
|
parseMessage prod = do
|
|
void $ for (parseMany parseMsgOrLine prod) $ \res ->
|
|
case res of
|
|
(_, Left _) -> yield $ Left "ERROR Bad Parse"
|
|
(_, Right val) -> yield $ Right val
|
|
return ()
|
|
|
|
renderMessage :: Pipe IrcMessage BS.ByteString IO ()
|
|
renderMessage = forever $ do
|
|
msg <- await
|
|
let output = renderIrcMessage msg
|
|
yield output
|
|
|
|
filterMsgs :: Pipe (Either BS.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
|
|
|
|
addIrcConnection :: ServerState -> IrcConnection -> IO Int
|
|
addIrcConnection srv client = do
|
|
let clients = ircConnections srv
|
|
ids = ircConnIds srv
|
|
cid <- atomically $ do
|
|
lastId <- readTVar ids
|
|
let newId = lastId + 1
|
|
writeTVar ids newId
|
|
return newId
|
|
atomically $ modifyTVar' clients $ M.insert cid client
|
|
return cid
|
|
|
|
delIrcConnection :: ServerState -> Int -> IO ()
|
|
delIrcConnection srv cid = do
|
|
let clients = ircConnections srv
|
|
atomically $ modifyTVar' clients $ M.delete cid
|
|
|
|
cmdHandler :: ServerState -> Int -> Consumer IrcMessage IO ()
|
|
cmdHandler srv cid =
|
|
let cReg = Unreg Nothing Nothing Nothing
|
|
in handle cReg
|
|
where
|
|
handle 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 }
|
|
|
|
-- 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)
|
|
|
|
-- handle resulting events
|
|
liftIO $ forM_ events $ ircEventHandler srv
|
|
|
|
-- loop for the next command
|
|
handle newReg
|
|
|
|
listenHandler :: ServerState -> (Socket, SockAddr) -> IO ()
|
|
listenHandler srv (lsock, _) =
|
|
forever $ acceptFork lsock $ \(csock, caddr) -> do
|
|
let sockWriter = toSocket csock
|
|
sockReader = fromSocket csock 4096
|
|
(writeEnd, readEnd) <- spawn Unbounded
|
|
let client = IrcConnection csock caddr writeEnd
|
|
|
|
cid <- addIrcConnection srv client
|
|
let handler = cmdHandler srv cid
|
|
|
|
r <- async $ runEffect $
|
|
parseMessage sockReader >-> filterMsgs >-> handler
|
|
|
|
w <- async $ runEffect $
|
|
fromInput readEnd >-> renderMessage >-> sockWriter
|
|
|
|
mapM_ wait [r,w]
|
|
|
|
delIrcConnection srv cid
|
|
|
|
mkIrcServer :: IrcConfig -> IO ServerState
|
|
mkIrcServer config = do
|
|
let nks = S.empty
|
|
urs = M.empty
|
|
chs = M.empty
|
|
srv = IrcServer nks urs chs
|
|
tvState <- newTVarIO srv
|
|
tvCns <- newTVarIO M.empty
|
|
tvRef <- newTVarIO 0
|
|
return $ ServerState tvState config tvCns tvRef
|
|
|
|
startIrcServer :: IrcConfig -> IO (Async ())
|
|
startIrcServer config = do
|
|
srv <- mkIrcServer config
|
|
let sHost = (ircHost . ircConfig) srv
|
|
sPort = (ircPort . ircConfig) srv
|
|
async $ PN.listen sHost sPort (listenHandler srv)
|