diff -r 9b2abea1071f -r 3bf9dc791f45 netserver/newhwserv.hs --- a/netserver/newhwserv.hs Sun Apr 27 16:51:28 2008 +0000 +++ b/netserver/newhwserv.hs Wed Apr 30 16:50:28 2008 +0000 @@ -9,14 +9,12 @@ import Control.Monad (forM, filterM, liftM) import Miscutils -type Client = (TChan String, Handle) - -acceptLoop :: Socket -> TChan Client -> IO () +acceptLoop :: Socket -> TChan ClientInfo -> IO () acceptLoop servSock acceptChan = do (cHandle, host, port) <- accept servSock cChan <- atomically newTChan forkIO $ clientLoop cHandle cChan - atomically $ writeTChan acceptChan (cChan, cHandle) + atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" "" False) acceptLoop servSock acceptChan listenLoop :: Handle -> TChan String -> IO () @@ -32,28 +30,26 @@ `finally` hClose handle where clientOff = atomically $ writeTChan chan "QUIT" -mainLoop :: Socket -> TChan Client -> [Client] -> IO () -mainLoop servSock acceptChan clients = do +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 (ch, h) -> do - mainLoop servSock acceptChan $ (ch, h):clients - Right (line, handle) -> do + Left ci -> do + mainLoop servSock acceptChan (ci:clients) rooms + Right (line, clhandle) -> do + --handleCmd handle line clients' <- forM clients $ - \(ch, h) -> do - hPutStrLn h line - hFlush h - return [(ch,h)] - `catch` const (hClose h >> return []) - mainLoop servSock acceptChan $ concat clients' - -tselect :: [(TChan a, t)] -> STM (a, t) -tselect = foldl orElse retry . map (\(ch, ty) -> (flip (,) ty) `fmap` readTChan ch) + \ci -> do + hPutStrLn (handle ci) line + hFlush (handle ci) + return [ci] + `catch` const (hClose (handle ci) >> return []) + mainLoop servSock acceptChan (concat clients') rooms startServer serverSocket = do acceptChan <- atomically newTChan forkIO $ acceptLoop serverSocket acceptChan - mainLoop serverSocket acceptChan [] + mainLoop serverSocket acceptChan [] [] main = withSocketsDo $ do serverSocket <- listenOn $ Service "hedgewars"