27 threadDelay (30 * 10^6) -- 30 seconds |
28 threadDelay (30 * 10^6) -- 30 seconds |
28 atomically $ writeTChan messagesChan ["PING"] |
29 atomically $ writeTChan messagesChan ["PING"] |
29 |
30 |
30 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
31 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
31 acceptLoop servSock acceptChan = Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ do |
32 acceptLoop servSock acceptChan = Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ do |
32 (cHandle, host, port) <- accept servSock |
33 (cHandle, host, _) <- accept servSock |
33 putStrLn "new client" |
34 putStrLn $ "new client: " ++ host |
|
35 currentTime <- getCurrentTime |
34 cChan <- atomically newTChan |
36 cChan <- atomically newTChan |
35 forkIO $ clientLoop cHandle cChan |
37 forkIO $ clientLoop cHandle cChan |
36 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle "" 0 "" False False False) |
38 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime"" 0 "" False False False) |
37 atomically $ writeTChan cChan ["ASKME"] |
39 atomically $ writeTChan cChan ["ASKME"] |
38 acceptLoop servSock acceptChan |
40 acceptLoop servSock acceptChan |
39 |
41 |
40 |
42 |
41 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
43 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
49 |
51 |
50 |
52 |
51 clientLoop :: Handle -> TChan [String] -> IO () |
53 clientLoop :: Handle -> TChan [String] -> IO () |
52 clientLoop handle chan = |
54 clientLoop handle chan = |
53 listenLoop handle [] chan |
55 listenLoop handle [] chan |
54 `catch` (const $ clientOff >> return ()) |
56 `catch` (\e -> (clientOff $ show e) >> return ()) |
55 where clientOff = atomically $ writeTChan chan ["QUIT"] -- if the client disconnects, we perform as if it sent QUIT message |
57 where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message |
56 |
58 |
57 |
59 |
58 sendAnswers [] _ clients _ = return clients |
60 sendAnswers [] _ clients _ = return clients |
59 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
61 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
60 let recipients = handlesFunc client clients rooms |
62 let recipients = handlesFunc client clients rooms |
61 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
63 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
|
64 when (head answer == "NICK") $ putStrLn (show answer) |
62 |
65 |
63 clHandles' <- forM recipients $ |
66 clHandles' <- forM recipients $ |
64 \ch -> Control.Exception.handle |
67 \ch -> Control.Exception.handle |
65 (\e -> putStrLn ("handle exception: " ++ show e) >> |
68 (\e -> if head answer == "BYE" then |
66 if head answer == "BYE" then |
|
67 return [ch] |
69 return [ch] |
68 else |
70 else |
69 atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT"] >> return [] -- cannot just remove |
71 atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT", show e] >> return [] -- cannot just remove |
70 ) $ |
72 ) $ |
71 do |
73 do |
72 forM_ answer (\str -> hPutStrLn ch str) |
74 forM_ answer (\str -> hPutStrLn ch str) |
73 hPutStrLn ch "" |
75 hPutStrLn ch "" |
74 hFlush ch |
76 hFlush ch |
75 if head answer == "BYE" then return [ch] else return [] |
77 if head answer == "BYE" then return [ch] else return [] |
76 |
78 |
77 let outHandles = concat clHandles' |
79 let outHandles = concat clHandles' |
78 unless (null outHandles) $ putStrLn ("bye: " ++ (show $ length outHandles) ++ "/" ++ (show $ length clients) ++ " clients") |
80 unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer)) |
79 mapM_ (\ch -> Control.Exception.handle (const $ putStrLn "error on hClose") (hClose ch)) outHandles |
81 mapM_ (\ch -> Control.Exception.handle (const $ putStrLn "error on hClose") (hClose ch)) outHandles |
80 let mclients = remove clients outHandles |
82 let mclients = remove clients outHandles |
81 |
83 |
82 sendAnswers answers client mclients rooms |
84 sendAnswers answers client mclients rooms |
83 where |
85 where |
95 |
97 |
96 clientsIn <- sendAnswers answers mclient mclients mrooms |
98 clientsIn <- sendAnswers answers mclient mclients mrooms |
97 let quitClient = find forceQuit $ clientsIn |
99 let quitClient = find forceQuit $ clientsIn |
98 |
100 |
99 if isJust quitClient then |
101 if isJust quitClient then |
100 reactCmd ["QUIT"] (fromJust quitClient) clientsIn mrooms |
102 reactCmd ["QUIT", "Kicked"] (fromJust quitClient) clientsIn mrooms |
101 else |
103 else |
102 return (clientsIn, mrooms) |
104 return (clientsIn, mrooms) |
103 |
105 |
104 |
106 |
105 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
107 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
107 r <- atomically $ |
109 r <- atomically $ |
108 (Accept `fmap` readTChan acceptChan) `orElse` |
110 (Accept `fmap` readTChan acceptChan) `orElse` |
109 (ClientMessage `fmap` tselect clients) `orElse` |
111 (ClientMessage `fmap` tselect clients) `orElse` |
110 (CoreMessage `fmap` readTChan messagesChan) |
112 (CoreMessage `fmap` readTChan messagesChan) |
111 case r of |
113 case r of |
112 Accept ci -> |
114 Accept ci -> do |
|
115 let sameHostClients = filter (\cl -> host ci == host cl) clients |
|
116 let haveJustConnected = not $ null $ filter (\cl -> diffUTCTime (connectTime ci) (connectTime cl) <= 5) sameHostClients |
|
117 |
|
118 when haveJustConnected $ do |
|
119 atomically $ writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
|
120 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
|
121 |
113 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
122 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
114 ClientMessage (cmd, client) -> do |
123 ClientMessage (cmd, client) -> do |
115 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
124 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
116 |
125 |
117 let hadRooms = (not $ null rooms) && (null mrooms) |
126 let hadRooms = (not $ null rooms) && (null mrooms) |