- Fix problem when clouds number is 0
- Swap two sounds used when hedgehog get damage due to fall
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