diff -r 914fa66aec05 -r 735f6d43780b netserver/hedgewars-server.hs --- a/netserver/hedgewars-server.hs Tue Oct 21 13:39:34 2008 +0000 +++ b/netserver/hedgewars-server.hs Tue Oct 21 16:53:34 2008 +0000 @@ -7,7 +7,7 @@ import Control.Concurrent.STM import Control.Exception (setUncaughtExceptionHandler, handle, finally) import Control.Monad (forM, forM_, filterM, liftM, when, unless) -import Maybe (fromMaybe) +import Maybe (fromMaybe, isJust, fromJust) import Data.List import Miscutils import HWProto @@ -20,7 +20,7 @@ hFlush cHandle cChan <- atomically newTChan forkIO $ clientLoop cHandle cChan - atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) + atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False) acceptLoop servSock acceptChan @@ -61,6 +61,20 @@ remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles +reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) +reactCmd cmd client clients rooms = do + putStrLn ("> " ++ show cmd) + + let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd + let mrooms = roomsFunc rooms + let mclients = (clientsFunc clients) + let mclient = fromMaybe client $ find (== client) mclients + + clientsIn <- sendAnswers answers mclient mclients mrooms + let quitClient = find forceQuit $ clientsIn + if isJust quitClient then reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms else return (clientsIn, mrooms) + + mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () mainLoop servSock acceptChan clients rooms = do r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) @@ -68,14 +82,7 @@ Left ci -> do mainLoop servSock acceptChan (clients ++ [ci]) rooms Right (cmd, client) -> do - putStrLn ("> " ++ show cmd) - - let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd - let mrooms = roomsFunc rooms - let mclients = (clientsFunc clients) - let mclient = fromMaybe client $ find (== client) mclients - - clientsIn <- sendAnswers answers mclient mclients mrooms + (clientsIn, mrooms) <- reactCmd cmd client clients rooms let hadRooms = (not $ null rooms) && (null mrooms) in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $