35 mainLoop servSock acceptChan clients rooms = do |
35 mainLoop servSock acceptChan clients rooms = do |
36 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
36 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
37 case r of |
37 case r of |
38 Left ci -> do |
38 Left ci -> do |
39 mainLoop servSock acceptChan (ci:clients) rooms |
39 mainLoop servSock acceptChan (ci:clients) rooms |
40 Right (line, client) -> do |
40 Right (line, clhandle) -> do |
41 let (mclient, mrooms, recipients, strs) = handleCmd client clients rooms $ words line |
41 let (mclients, mrooms, recipients, strs) = handleCmd clhandle clients rooms $ words line |
42 |
42 |
43 clients' <- forM recipients $ |
43 clHandles' <- forM recipients $ |
44 \ci -> do |
44 \ch -> do |
45 forM_ strs (\str -> hPutStrLn (handle ci) str) |
45 forM_ strs (\str -> hPutStrLn ch str) |
46 hFlush (handle ci) |
46 hFlush ch |
47 if (not $ null strs) && (head strs == "ROOMABANDONED") then hClose (handle ci) >> return [ci] else return [] |
47 if (not $ null strs) && (head strs == "ROOMABANDONED") then hClose ch >> return [ch] else return [] |
48 `catch` const (hClose (handle ci) >> return [ci]) |
48 `catch` const (hClose ch >> return [ch]) |
49 |
49 |
50 client' <- if (not $ null strs) && (head strs == "QUIT") then hClose (handle client) >> return [client] else return [] |
50 clHandle' <- if (not $ null strs) && (head strs == "QUIT") then hClose clhandle >> return [clhandle] else return [] |
51 |
51 |
52 mainLoop servSock acceptChan (remove (remove (mclient : filter (\cl -> handle cl /= handle client) clients) (concat clients')) client') mrooms |
52 mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms |
53 where |
53 where |
54 remove list rmClients = deleteFirstsBy (\ a b -> handle a == handle b) list rmClients |
54 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
55 |
55 |
56 startServer serverSocket = do |
56 startServer serverSocket = do |
57 acceptChan <- atomically newTChan |
57 acceptChan <- atomically newTChan |
58 forkIO $ acceptLoop serverSocket acceptChan |
58 forkIO $ acceptLoop serverSocket acceptChan |
59 mainLoop serverSocket acceptChan [] [] |
59 mainLoop serverSocket acceptChan [] [] |