7 import Control.Concurrent.STM |
7 import Control.Concurrent.STM |
8 import Control.Exception (finally) |
8 import Control.Exception (finally) |
9 import Control.Monad (forM, filterM, liftM) |
9 import Control.Monad (forM, filterM, liftM) |
10 import Miscutils |
10 import Miscutils |
11 |
11 |
12 type Client = (TChan String, Handle) |
12 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
13 |
|
14 acceptLoop :: Socket -> TChan Client -> IO () |
|
15 acceptLoop servSock acceptChan = do |
13 acceptLoop servSock acceptChan = do |
16 (cHandle, host, port) <- accept servSock |
14 (cHandle, host, port) <- accept servSock |
17 cChan <- atomically newTChan |
15 cChan <- atomically newTChan |
18 forkIO $ clientLoop cHandle cChan |
16 forkIO $ clientLoop cHandle cChan |
19 atomically $ writeTChan acceptChan (cChan, cHandle) |
17 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" "" False) |
20 acceptLoop servSock acceptChan |
18 acceptLoop servSock acceptChan |
21 |
19 |
22 listenLoop :: Handle -> TChan String -> IO () |
20 listenLoop :: Handle -> TChan String -> IO () |
23 listenLoop handle chan = do |
21 listenLoop handle chan = do |
24 str <- hGetLine handle |
22 str <- hGetLine handle |
30 listenLoop handle chan |
28 listenLoop handle chan |
31 `catch` (const $ clientOff >> return ()) |
29 `catch` (const $ clientOff >> return ()) |
32 `finally` hClose handle |
30 `finally` hClose handle |
33 where clientOff = atomically $ writeTChan chan "QUIT" |
31 where clientOff = atomically $ writeTChan chan "QUIT" |
34 |
32 |
35 mainLoop :: Socket -> TChan Client -> [Client] -> IO () |
33 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
36 mainLoop servSock acceptChan clients = do |
34 mainLoop servSock acceptChan clients rooms = do |
37 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
35 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
38 case r of |
36 case r of |
39 Left (ch, h) -> do |
37 Left ci -> do |
40 mainLoop servSock acceptChan $ (ch, h):clients |
38 mainLoop servSock acceptChan (ci:clients) rooms |
41 Right (line, handle) -> do |
39 Right (line, clhandle) -> do |
|
40 --handleCmd handle line |
42 clients' <- forM clients $ |
41 clients' <- forM clients $ |
43 \(ch, h) -> do |
42 \ci -> do |
44 hPutStrLn h line |
43 hPutStrLn (handle ci) line |
45 hFlush h |
44 hFlush (handle ci) |
46 return [(ch,h)] |
45 return [ci] |
47 `catch` const (hClose h >> return []) |
46 `catch` const (hClose (handle ci) >> return []) |
48 mainLoop servSock acceptChan $ concat clients' |
47 mainLoop servSock acceptChan (concat clients') rooms |
49 |
|
50 tselect :: [(TChan a, t)] -> STM (a, t) |
|
51 tselect = foldl orElse retry . map (\(ch, ty) -> (flip (,) ty) `fmap` readTChan ch) |
|
52 |
48 |
53 startServer serverSocket = do |
49 startServer serverSocket = do |
54 acceptChan <- atomically newTChan |
50 acceptChan <- atomically newTChan |
55 forkIO $ acceptLoop serverSocket acceptChan |
51 forkIO $ acceptLoop serverSocket acceptChan |
56 mainLoop serverSocket acceptChan [] |
52 mainLoop serverSocket acceptChan [] [] |
57 |
53 |
58 main = withSocketsDo $ do |
54 main = withSocketsDo $ do |
59 serverSocket <- listenOn $ Service "hedgewars" |
55 serverSocket <- listenOn $ Service "hedgewars" |
60 startServer serverSocket `finally` sClose serverSocket |
56 startServer serverSocket `finally` sClose serverSocket |