37 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
37 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
38 case r of |
38 case r of |
39 Left ci -> do |
39 Left ci -> do |
40 mainLoop servSock acceptChan (ci:clients) rooms |
40 mainLoop servSock acceptChan (ci:clients) rooms |
41 Right (line, client) -> do |
41 Right (line, client) -> do |
42 let (doQuit, toMe, strs) = handleCmd client sameRoom rooms line |
42 let (doQuit, recipients, strs) = handleCmd client sameRoom rooms $ words line |
43 |
43 |
44 clients' <- forM sameRoom $ |
44 clients' <- forM recipients $ |
45 \ci -> do |
45 \ci -> do |
46 if (handle ci /= handle client) || toMe then do |
|
47 forM_ strs (\str -> hPutStrLn (handle ci) str) |
46 forM_ strs (\str -> hPutStrLn (handle ci) str) |
48 hFlush (handle ci) |
47 hFlush (handle ci) |
49 return [] |
48 return [] |
50 else if doQuit then return [ci] else return [] |
|
51 `catch` const (hClose (handle ci) >> return [ci]) |
49 `catch` const (hClose (handle ci) >> return [ci]) |
52 |
50 |
53 mainLoop servSock acceptChan (deleteFirstsBy (\ a b -> handle a == handle b) clients (concat clients')) rooms |
51 client' <- if doQuit then hClose (handle client) >> return [client] else return [] |
|
52 |
|
53 mainLoop servSock acceptChan (remove (remove clients (concat clients')) client') rooms |
54 where |
54 where |
55 sameRoom = filter (\cl -> room cl == room client) clients |
55 sameRoom = filter (\cl -> room cl == room client) clients |
|
56 remove list rmClients = deleteFirstsBy (\ a b -> handle a == handle b) list rmClients |
56 |
57 |
57 startServer serverSocket = do |
58 startServer serverSocket = do |
58 acceptChan <- atomically newTChan |
59 acceptChan <- atomically newTChan |
59 forkIO $ acceptLoop serverSocket acceptChan |
60 forkIO $ acceptLoop serverSocket acceptChan |
60 mainLoop serverSocket acceptChan [] [] |
61 mainLoop serverSocket acceptChan [] [] |