41 case r of |
41 case r of |
42 Left ci -> do |
42 Left ci -> do |
43 mainLoop servSock acceptChan (ci:clients) rooms |
43 mainLoop servSock acceptChan (ci:clients) rooms |
44 Right (cmd, client) -> do |
44 Right (cmd, client) -> do |
45 putStrLn ("> " ++ show cmd) |
45 putStrLn ("> " ++ show cmd) |
46 let (clientsFunc, roomsFunc, handlesFunc, answer) = handleCmd client clients rooms $ cmd |
46 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
47 putStrLn ("< " ++ show answer) |
|
48 |
47 |
49 let mclients = clientsFunc clients |
48 let mclients = clientsFunc clients |
50 let mrooms = roomsFunc rooms |
49 let mrooms = roomsFunc rooms |
51 let recipients = handlesFunc client mclients mrooms |
50 |
52 |
51 clHandles' <- forM answers $ |
53 clHandles' <- forM recipients $ |
52 \(handlesFunc, answer) -> do |
54 \ch -> do |
53 putStrLn ("< " ++ show answer) |
|
54 let recipients = handlesFunc client mclients mrooms |
|
55 forM recipients $ |
|
56 \ch -> do |
55 forM_ answer (\str -> hPutStrLn ch str) |
57 forM_ answer (\str -> hPutStrLn ch str) |
56 hPutStrLn ch "" |
58 hPutStrLn ch "" |
57 hFlush ch |
59 hFlush ch |
58 if (not $ null answer) && (head answer == "ROOMABANDONED") then hClose ch >> return [ch] else return [] |
60 if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] |
59 `catch` const (hClose ch >> return [ch]) |
61 `catch` const (hClose ch >> return [ch]) |
60 |
62 |
61 clHandle' <- if (not $ null answer) && (head answer == "QUIT") then hClose (handle client) >> return [handle client] else return [] |
63 mainLoop servSock acceptChan (remove mclients (concat $ concat clHandles')) mrooms |
62 |
|
63 mainLoop servSock acceptChan (remove (remove mclients (concat clHandles')) clHandle') mrooms |
|
64 where |
64 where |
65 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
65 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
66 |
66 |
67 startServer serverSocket = do |
67 startServer serverSocket = do |
68 acceptChan <- atomically newTChan |
68 acceptChan <- atomically newTChan |