--- 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"