18 forkIO $ clientLoop cHandle cChan |
18 forkIO $ clientLoop cHandle cChan |
19 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
19 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False) |
20 hPutStrLn cHandle "CONNECTED\n" |
20 hPutStrLn cHandle "CONNECTED\n" |
21 acceptLoop servSock acceptChan |
21 acceptLoop servSock acceptChan |
22 |
22 |
|
23 |
23 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
24 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
24 listenLoop handle buf chan = do |
25 listenLoop handle buf chan = do |
25 str <- hGetLine handle |
26 str <- hGetLine handle |
26 if str == "" then do |
27 if str == "" then do |
27 atomically $ writeTChan chan buf |
28 atomically $ writeTChan chan buf |
28 listenLoop handle [] chan |
29 listenLoop handle [] chan |
29 else |
30 else |
30 listenLoop handle (buf ++ [str]) chan |
31 listenLoop handle (buf ++ [str]) chan |
31 |
32 |
|
33 |
32 clientLoop :: Handle -> TChan [String] -> IO () |
34 clientLoop :: Handle -> TChan [String] -> IO () |
33 clientLoop handle chan = |
35 clientLoop handle chan = |
34 listenLoop handle [] chan |
36 listenLoop handle [] chan |
35 `catch` (const $ clientOff >> return ()) |
37 `catch` (const $ clientOff >> return ()) |
36 where clientOff = atomically $ writeTChan chan ["QUIT"] -- если клиент отключается, то делаем вид, что от него пришла команда QUIT |
38 where clientOff = atomically $ writeTChan chan ["QUIT"] -- если клиент отключается, то делаем вид, что от него пришла команда QUIT |
37 |
39 |
|
40 |
38 sendAnswers [] _ clients _ = return clients |
41 sendAnswers [] _ clients _ = return clients |
39 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
42 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
40 putStrLn ("< " ++ show answer) |
|
41 |
|
42 let recipients = handlesFunc client clients rooms |
43 let recipients = handlesFunc client clients rooms |
|
44 putStrLn ("< " ++ (show answer) ++ " (" ++ (show $ length recipients) ++ " recipients)") |
43 |
45 |
44 clHandles' <- forM recipients $ |
46 clHandles' <- forM recipients $ |
45 \ch -> do |
47 \ch -> Control.Exception.handle (\e -> putStrLn (show e) >> hClose ch >> return [ch]) $ |
|
48 do |
46 forM_ answer (\str -> hPutStrLn ch str) |
49 forM_ answer (\str -> hPutStrLn ch str) |
47 hPutStrLn ch "" |
50 hPutStrLn ch "" |
48 hFlush ch |
51 hFlush ch |
49 if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] |
52 if (not $ null answer) && (head answer == "BYE") then hClose ch >> return [ch] else return [] |
50 `catch` const (hClose ch >> return [ch]) |
|
51 |
53 |
52 let mclients = remove clients $ concat clHandles' |
54 let mclients = remove clients $ concat clHandles' |
53 |
55 |
54 sendAnswers answers client mclients rooms |
56 sendAnswers answers client mclients rooms |
55 where |
57 where |
56 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (handle a) == b) list rmClHandles |
58 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
57 |
59 |
58 |
60 |
59 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
61 mainLoop :: Socket -> TChan ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO () |
60 mainLoop servSock acceptChan clients rooms = do |
62 mainLoop servSock acceptChan clients rooms = do |
61 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
63 r <- atomically $ (Left `fmap` readTChan acceptChan) `orElse` (Right `fmap` tselect clients) |
62 case r of |
64 case r of |
63 Left ci -> do |
65 Left ci -> do |
64 mainLoop servSock acceptChan (ci:clients) rooms |
66 mainLoop servSock acceptChan (ci:clients) rooms |
65 Right (cmd, client) -> do |
67 Right (cmd, client) -> do |
66 putStrLn ("> " ++ show cmd) |
68 putStrLn ("> " ++ show cmd) |
|
69 |
67 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
70 let (clientsFunc, roomsFunc, answers) = handleCmd client clients rooms $ cmd |
68 |
|
69 let mclients = clientsFunc clients |
|
70 let mrooms = roomsFunc rooms |
71 let mrooms = roomsFunc rooms |
71 |
72 |
72 mclients <- sendAnswers answers client clients rooms |
73 clientsIn <- sendAnswers answers client (clientsFunc clients) mrooms |
73 |
74 |
74 mainLoop servSock acceptChan mclients mrooms |
75 mainLoop servSock acceptChan clientsIn mrooms |
|
76 |
75 |
77 |
76 startServer serverSocket = do |
78 startServer serverSocket = do |
77 acceptChan <- atomically newTChan |
79 acceptChan <- atomically newTChan |
78 forkIO $ acceptLoop serverSocket acceptChan |
80 forkIO $ acceptLoop serverSocket acceptChan |
79 mainLoop serverSocket acceptChan [] [] |
81 mainLoop serverSocket acceptChan [] [] |
80 |
82 |
|
83 |
81 main = withSocketsDo $ do |
84 main = withSocketsDo $ do |
82 serverSocket <- listenOn $ Service "hedgewars" |
85 serverSocket <- listenOn $ Service "hedgewars" |
83 startServer serverSocket `finally` sClose serverSocket |
86 startServer serverSocket `finally` sClose serverSocket |