4 import IO |
4 import IO |
5 import System.IO |
5 import System.IO |
6 import Control.Concurrent |
6 import Control.Concurrent |
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, forM_, filterM, liftM) |
|
10 import Data.List |
10 import Miscutils |
11 import Miscutils |
|
12 import HWProto |
11 |
13 |
12 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
14 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
13 acceptLoop servSock acceptChan = do |
15 acceptLoop servSock acceptChan = do |
14 (cHandle, host, port) <- accept servSock |
16 (cHandle, host, port) <- accept servSock |
15 cChan <- atomically newTChan |
17 cChan <- atomically newTChan |
34 mainLoop servSock acceptChan clients rooms = do |
36 mainLoop servSock acceptChan clients rooms = do |
35 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
37 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
36 case r of |
38 case r of |
37 Left ci -> do |
39 Left ci -> do |
38 mainLoop servSock acceptChan (ci:clients) rooms |
40 mainLoop servSock acceptChan (ci:clients) rooms |
39 Right (line, clhandle) -> do |
41 Right (line, client) -> do |
40 --handleCmd handle line |
42 let (doQuit, toMe, strs) = handleCmd client sameRoom rooms line |
41 clients' <- forM clients $ |
43 |
|
44 clients' <- forM sameRoom $ |
42 \ci -> do |
45 \ci -> do |
43 hPutStrLn (handle ci) line |
46 if (handle ci /= handle client) || toMe then do |
44 hFlush (handle ci) |
47 forM_ strs (\str -> hPutStrLn (handle ci) str) |
45 return [ci] |
48 hFlush (handle ci) |
46 `catch` const (hClose (handle ci) >> return []) |
49 return [] |
47 mainLoop servSock acceptChan (concat clients') rooms |
50 else if doQuit then return [ci] else return [] |
|
51 `catch` const (hClose (handle ci) >> return [ci]) |
|
52 |
|
53 mainLoop servSock acceptChan (deleteFirstsBy (\ a b -> handle a == handle b) clients (concat clients')) rooms |
|
54 where |
|
55 sameRoom = filter (\cl -> room cl == room client) clients |
48 |
56 |
49 startServer serverSocket = do |
57 startServer serverSocket = do |
50 acceptChan <- atomically newTChan |
58 acceptChan <- atomically newTChan |
51 forkIO $ acceptLoop serverSocket acceptChan |
59 forkIO $ acceptLoop serverSocket acceptChan |
52 mainLoop serverSocket acceptChan [] [] |
60 mainLoop serverSocket acceptChan [] [] |