33 clientLoop handle chan = |
33 clientLoop handle chan = |
34 listenLoop handle [] chan |
34 listenLoop handle [] chan |
35 `catch` (const $ clientOff >> return ()) |
35 `catch` (const $ clientOff >> return ()) |
36 where clientOff = atomically $ writeTChan chan ["QUIT"] -- если клиент отключается, то делаем вид, что от него пришла команда QUIT |
36 where clientOff = atomically $ writeTChan chan ["QUIT"] -- если клиент отключается, то делаем вид, что от него пришла команда QUIT |
37 |
37 |
|
38 sendAnswers [] _ clients _ = return clients |
|
39 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
|
40 putStrLn ("< " ++ show answer) |
|
41 |
|
42 let recipients = handlesFunc client clients rooms |
|
43 |
|
44 clHandles' <- forM recipients $ |
|
45 \ch -> do |
|
46 forM_ answer (\str -> hPutStrLn ch str) |
|
47 hPutStrLn ch "" |
|
48 hFlush ch |
|
49 if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] |
|
50 `catch` const (hClose ch >> return [ch]) |
|
51 |
|
52 let mclients = remove clients $ concat clHandles' |
|
53 |
|
54 sendAnswers answers client mclients rooms |
|
55 where |
|
56 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
|
57 |
|
58 |
38 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
59 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
39 mainLoop servSock acceptChan clients rooms = do |
60 mainLoop servSock acceptChan clients rooms = do |
40 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
61 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
41 case r of |
62 case r of |
42 Left ci -> do |
63 Left ci -> do |
46 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
67 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
47 |
68 |
48 let mclients = clientsFunc clients |
69 let mclients = clientsFunc clients |
49 let mrooms = roomsFunc rooms |
70 let mrooms = roomsFunc rooms |
50 |
71 |
51 clHandles' <- forM answers $ |
72 mclients <- sendAnswers answers client clients rooms |
52 \(handlesFunc, answer) -> do |
73 |
53 putStrLn ("< " ++ show answer) |
74 mainLoop servSock acceptChan mclients mrooms |
54 let recipients = handlesFunc client mclients mrooms |
|
55 forM recipients $ |
|
56 \ch -> do |
|
57 forM_ answer (\str -> hPutStrLn ch str) |
|
58 hPutStrLn ch "" |
|
59 hFlush ch |
|
60 if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] |
|
61 `catch` const (hClose ch >> return [ch]) |
|
62 |
|
63 mainLoop servSock acceptChan (remove mclients (concat $ concat clHandles')) mrooms |
|
64 where |
|
65 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
|
66 |
75 |
67 startServer serverSocket = do |
76 startServer serverSocket = do |
68 acceptChan <- atomically newTChan |
77 acceptChan <- atomically newTChan |
69 forkIO $ acceptLoop serverSocket acceptChan |
78 forkIO $ acceptLoop serverSocket acceptChan |
70 mainLoop serverSocket acceptChan [] [] |
79 mainLoop serverSocket acceptChan [] [] |