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 (recipients, strs) = handleCmd client sameRoom rooms $ words line |
42 let (mclient, mrooms, recipients, strs) = handleCmd client clients rooms $ words line |
43 |
43 |
44 clients' <- forM recipients $ |
44 clients' <- forM recipients $ |
45 \ci -> do |
45 \ci -> do |
46 forM_ strs (\str -> hPutStrLn (handle ci) str) |
46 forM_ strs (\str -> hPutStrLn (handle ci) str) |
47 hFlush (handle ci) |
47 hFlush (handle ci) |
48 return [] |
48 return [] |
49 `catch` const (hClose (handle ci) >> return [ci]) |
49 `catch` const (hClose (handle ci) >> return [ci]) |
50 |
50 |
51 client' <- if head strs == "QUIT" then hClose (handle client) >> return [client] else return [] |
51 client' <- if head strs == "QUIT" then hClose (handle client) >> return [client] else return [] |
52 |
52 |
53 mainLoop servSock acceptChan (remove (remove clients (concat clients')) client') rooms |
53 mainLoop servSock acceptChan (remove (remove (mclient : filter (\cl -> handle cl /= handle client) clients) (concat clients')) client') mrooms |
54 where |
54 where |
55 sameRoom = filter (\cl -> room cl == room client) clients |
|
56 remove list rmClients = deleteFirstsBy (\ a b -> handle a == handle b) list rmClients |
55 remove list rmClients = deleteFirstsBy (\ a b -> handle a == handle b) list rmClients |
57 |
56 |
58 startServer serverSocket = do |
57 startServer serverSocket = do |
59 acceptChan <- atomically newTChan |
58 acceptChan <- atomically newTChan |
60 forkIO $ acceptLoop serverSocket acceptChan |
59 forkIO $ acceptLoop serverSocket acceptChan |