110 mainLoop acceptChan messagesChan clients rooms = do |
110 mainLoop acceptChan messagesChan clients rooms = do |
111 r <- atomically $ |
111 r <- atomically $ |
112 (Accept `fmap` readTChan acceptChan) `orElse` |
112 (Accept `fmap` readTChan acceptChan) `orElse` |
113 (ClientMessage `fmap` tselect clients) `orElse` |
113 (ClientMessage `fmap` tselect clients) `orElse` |
114 (CoreMessage `fmap` readTChan messagesChan) |
114 (CoreMessage `fmap` readTChan messagesChan) |
|
115 |
115 case r of |
116 case r of |
116 Accept ci -> do |
117 Accept ci -> do |
117 let sameHostClients = filter (\cl -> host ci == host cl) clients |
118 let sameHostClients = filter (\cl -> host ci == host cl) clients |
118 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
119 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
119 |
120 |
121 atomically $ do |
122 atomically $ do |
122 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
123 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
123 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
124 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
124 |
125 |
125 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
126 mainLoop acceptChan messagesChan (clients ++ [ci]) rooms |
|
127 |
126 ClientMessage (cmd, client) -> do |
128 ClientMessage (cmd, client) -> do |
127 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
129 (clientsIn, mrooms) <- reactCmd cmd client clients rooms |
128 |
130 |
129 let hadRooms = (not $ null rooms) && (null mrooms) |
131 let hadRooms = (not $ null rooms) && (null mrooms) |
130 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
132 in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $ |
131 mainLoop acceptChan messagesChan clientsIn mrooms |
133 mainLoop acceptChan messagesChan clientsIn mrooms |
|
134 |
132 CoreMessage msg -> |
135 CoreMessage msg -> |
133 if not $ null $ clients then |
136 if not $ null $ clients then |
134 do |
137 do |
135 let client = head clients -- don't care |
138 let client = head clients -- don't care |
136 (clientsIn, mrooms) <- reactCmd msg client clients rooms |
139 (clientsIn, mrooms) <- reactCmd msg client clients rooms |