netserver/newhwserv.hs
changeset 889 3bf9dc791f45
parent 878 45bff6dadfce
child 890 1d8c4a5ec622
--- 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"