Prevent AI to damage a teammate when trying to dig with firepunch (patch not tested)
module Main where
import Network
import IO
import System.IO
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (finally)
import Control.Monad (forM, forM_, filterM, liftM)
import Data.List
import Miscutils
import HWProto
acceptLoop :: Socket -> TChan ClientInfo -> IO ()
acceptLoop servSock acceptChan = do
(cHandle, host, port) <- accept servSock
cChan <- atomically newTChan
forkIO $ clientLoop cHandle cChan
atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False)
hPutStrLn cHandle "CONNECTED\n"
acceptLoop servSock acceptChan
listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
listenLoop handle buf chan = do
str <- hGetLine handle
if str == "" then do
atomically $ writeTChan chan buf
listenLoop handle [] chan
else
listenLoop handle (buf ++ [str]) chan
clientLoop :: Handle -> TChan [String] -> IO ()
clientLoop handle chan =
listenLoop handle [] chan
`catch` (const $ clientOff >> return ())
where clientOff = atomically $ writeTChan chan ["QUIT"]
mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ()
mainLoop servSock acceptChan clients rooms = do
r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients)
case r of
Left ci -> do
mainLoop servSock acceptChan (ci:clients) rooms
Right (cmd, client) -> do
print ("> " ++ show cmd)
let (clientsFunc, roomsFunc, handlesFunc, answer) = handleCmd client clients rooms $ cmd
print ("< " ++ show answer)
let mclients = clientsFunc clients
let mrooms = roomsFunc rooms
let recipients = handlesFunc client clients rooms
clHandles' <- forM recipients $
\ch -> do
forM_ answer (\str -> hPutStrLn ch str)
hPutStrLn ch ""
hFlush ch
if (not $ null answer) && (head answer == "ROOMABANDONED") then hClose ch >> return [ch] else return []
`catch` const (hClose ch >> return [ch])
clHandle' <- if (not $ null answer) && (head answer == "QUIT") then hClose (handle client) >> return [handle client] else return []
mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms
where
remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles
startServer serverSocket = do
acceptChan <- atomically newTChan
forkIO $ acceptLoop serverSocket acceptChan
mainLoop serverSocket acceptChan [] []
main = withSocketsDo $ do
serverSocket <- listenOn $ Service "hedgewars"
startServer serverSocket `finally` sClose serverSocket