102 reactCmd ["QUIT", "Kicked"] (fromJust quitClient) clientsIn mrooms |
102 reactCmd ["QUIT", "Kicked"] (fromJust quitClient) clientsIn mrooms |
103 else |
103 else |
104 return (clientsIn, mrooms) |
104 return (clientsIn, mrooms) |
105 |
105 |
106 |
106 |
107 mainLoop :: Socket -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
107 mainLoop :: TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
108 mainLoop servSock acceptChan messagesChan clients rooms = do |
108 mainLoop acceptChan messagesChan clients rooms = do |
109 r <- atomically $ |
109 r <- atomically $ |
110 (Accept `fmap` readTChan acceptChan) `orElse` |
110 (Accept `fmap` readTChan acceptChan) `orElse` |
111 (ClientMessage `fmap` tselect clients) `orElse` |
111 (ClientMessage `fmap` tselect clients) `orElse` |
112 (CoreMessage `fmap` readTChan messagesChan) |
112 (CoreMessage `fmap` readTChan messagesChan) |
113 case r of |
113 case r of |
115 let sameHostClients = filter (\cl -> host ci == host cl) clients |
115 let sameHostClients = filter (\cl -> host ci == host cl) clients |
116 let haveJustConnected = not $ null $ filter (\cl -> diffUTCTime (connectTime ci) (connectTime cl) <= 5) sameHostClients |
116 let haveJustConnected = not $ null $ filter (\cl -> diffUTCTime (connectTime ci) (connectTime cl) <= 5) sameHostClients |
117 |
117 |
118 when haveJustConnected $ do |
118 when haveJustConnected $ do |
119 atomically $ writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
119 atomically $ writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
120 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
120 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
121 |
121 |
122 mainLoop servSock acceptChan messagesChan (clients ++ [ci]) rooms |
122 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
123 ClientMessage (cmd, client) -> do |
123 ClientMessage (cmd, client) -> do |
124 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
124 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
125 |
125 |
126 let hadRooms = (not $ null rooms) && (null mrooms) |
126 let hadRooms = (not $ null rooms) && (null mrooms) |
127 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
127 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
128 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
128 mainLoop acceptChan messagesChan clientsIn mrooms |
129 CoreMessage msg -> |
129 CoreMessage msg -> |
130 if not $ null $ clients then |
130 if not $ null $ clients then |
131 do |
131 do |
132 let client = head clients -- don't care |
132 let client = head clients -- don't care |
133 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
133 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
134 mainLoop servSock acceptChan messagesChan clientsIn mrooms |
134 mainLoop acceptChan messagesChan clientsIn mrooms |
135 else |
135 else |
136 mainLoop servSock acceptChan messagesChan clients rooms |
136 mainLoop acceptChan messagesChan clients rooms |
137 |
137 |
138 |
138 startServer :: Socket -> IO() |
139 startServer serverSocket = do |
139 startServer serverSocket = do |
140 acceptChan <- atomically newTChan |
140 acceptChan <- atomically newTChan |
141 forkIO $ acceptLoop serverSocket acceptChan |
141 forkIO $ acceptLoop serverSocket acceptChan |
142 |
142 |
143 messagesChan <- atomically newTChan |
143 messagesChan <- atomically newTChan |
144 forkIO $ messagesLoop messagesChan |
144 forkIO $ messagesLoop messagesChan |
145 |
145 |
146 mainLoop serverSocket acceptChan messagesChan [] [] |
146 mainLoop acceptChan messagesChan [] [] |
147 |
147 |
148 |
148 |
149 main = withSocketsDo $ do |
149 main = withSocketsDo $ do |
150 #if !defined(mingw32_HOST_OS) |
150 #if !defined(mingw32_HOST_OS) |
151 installHandler sigPIPE Ignore Nothing; |
151 installHandler sigPIPE Ignore Nothing; |