27 messagesLoop messagesChan = forever $ do |
27 messagesLoop messagesChan = forever $ do |
28 threadDelay (30 * 10^6) -- 30 seconds |
28 threadDelay (30 * 10^6) -- 30 seconds |
29 atomically $ writeTChan messagesChan ["PING"] |
29 atomically $ writeTChan messagesChan ["PING"] |
30 |
30 |
31 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
31 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
32 acceptLoop servSock acceptChan = Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ do |
32 acceptLoop servSock acceptChan = |
|
33 Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
|
34 do |
33 (cHandle, host, _) <- accept servSock |
35 (cHandle, host, _) <- accept servSock |
|
36 |
34 currentTime <- getCurrentTime |
37 currentTime <- getCurrentTime |
35 putStrLn $ (show currentTime) ++ " new client: " ++ host |
38 putStrLn $ (show currentTime) ++ " new client: " ++ host |
|
39 |
36 cChan <- atomically newTChan |
40 cChan <- atomically newTChan |
37 forkIO $ clientLoop cHandle cChan |
41 forkIO $ clientLoop cHandle cChan |
38 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime"" 0 "" False False False) |
42 |
|
43 atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime "" 0 "" False False False) |
39 atomically $ writeTChan cChan ["ASKME"] |
44 atomically $ writeTChan cChan ["ASKME"] |
40 acceptLoop servSock acceptChan |
45 acceptLoop servSock acceptChan |
41 |
46 |
42 |
47 |
43 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
48 listenLoop :: Handle -> [String] -> TChan [String] -> IO () |
94 let mrooms = roomsFunc rooms |
99 let mrooms = roomsFunc rooms |
95 let mclients = (clientsFunc clients) |
100 let mclients = (clientsFunc clients) |
96 let mclient = fromMaybe client $ find (== client) mclients |
101 let mclient = fromMaybe client $ find (== client) mclients |
97 |
102 |
98 clientsIn <- sendAnswers answers mclient mclients mrooms |
103 clientsIn <- sendAnswers answers mclient mclients mrooms |
99 let quitClient = find forceQuit $ clientsIn |
104 mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn |
100 |
105 |
101 if isJust quitClient then |
106 return (clientsIn, mrooms) |
102 reactCmd ["QUIT", "Kicked"] (fromJust quitClient) clientsIn mrooms |
|
103 else |
|
104 return (clientsIn, mrooms) |
|
105 |
107 |
106 |
108 |
107 mainLoop :: TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
109 mainLoop :: TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
108 mainLoop acceptChan messagesChan clients rooms = do |
110 mainLoop acceptChan messagesChan clients rooms = do |
109 r <- atomically $ |
111 r <- atomically $ |
111 (ClientMessage `fmap` tselect clients) `orElse` |
113 (ClientMessage `fmap` tselect clients) `orElse` |
112 (CoreMessage `fmap` readTChan messagesChan) |
114 (CoreMessage `fmap` readTChan messagesChan) |
113 case r of |
115 case r of |
114 Accept ci -> do |
116 Accept ci -> do |
115 let sameHostClients = filter (\cl -> host ci == host cl) clients |
117 let sameHostClients = filter (\cl -> host ci == host cl) clients |
116 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 5) sameHostClients |
118 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
117 |
119 |
118 when haveJustConnected $ do |
120 when haveJustConnected $ do |
119 atomically $ writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
121 atomically $ do |
120 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
122 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
|
123 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
121 |
124 |
122 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
125 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
123 ClientMessage (cmd, client) -> do |
126 ClientMessage (cmd, client) -> do |
124 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
127 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
125 |
128 |