33 timerLoop :: TChan [String] -> IO() |
33 timerLoop :: TChan [String] -> IO() |
34 timerLoop messagesChan = forever $ do |
34 timerLoop messagesChan = forever $ do |
35 threadDelay (60 * 10^6) -- 60 seconds |
35 threadDelay (60 * 10^6) -- 60 seconds |
36 atomically $ writeTChan messagesChan ["MINUTELY"] |
36 atomically $ writeTChan messagesChan ["MINUTELY"] |
37 |
37 |
|
38 socketCloseLoop :: TChan Handle -> IO() |
|
39 socketCloseLoop closingChan = forever $ do |
|
40 h <- atomically $ readTChan closingChan |
|
41 Control.Exception.handle (const $ putStrLn "error on hClose") $ hClose h |
|
42 |
38 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
43 acceptLoop :: Socket -> TChan ClientInfo -> IO () |
39 acceptLoop servSock acceptChan = |
44 acceptLoop servSock acceptChan = |
40 Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
45 Control.Exception.handle (const $ putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $ |
41 do |
46 do |
42 (cHandle, host, _) <- accept servSock |
47 (cHandle, host, _) <- accept servSock |
67 listenLoop handle [] chan |
72 listenLoop handle [] chan |
68 `catch` (\e -> (clientOff $ show e) >> return ()) |
73 `catch` (\e -> (clientOff $ show e) >> return ()) |
69 where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message |
74 where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message |
70 |
75 |
71 |
76 |
72 sendAnswers [] _ clients _ = return clients |
77 sendAnswers _ [] _ clients _ = return clients |
73 sendAnswers ((handlesFunc, answer):answers) client clients rooms = do |
78 sendAnswers closingChan ((handlesFunc, answer):answers) client clients rooms = do |
74 let recipients = handlesFunc client clients rooms |
79 let recipients = handlesFunc client clients rooms |
75 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
80 --unless (null recipients) $ putStrLn ("< " ++ (show answer)) |
76 when (head answer == "NICK") $ putStrLn (show answer) |
81 when (head answer == "NICK") $ putStrLn (show answer) |
77 |
82 |
78 clHandles' <- forM recipients $ |
83 clHandles' <- forM recipients $ |
90 |
95 |
91 let outHandles = concat clHandles' |
96 let outHandles = concat clHandles' |
92 unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer)) |
97 unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer)) |
93 |
98 |
94 -- strange, but this seems to be a bad idea to manually close these handles as it causes hangs |
99 -- strange, but this seems to be a bad idea to manually close these handles as it causes hangs |
95 --mapM_ (\ch -> Control.Exception.handle (const $ putStrLn "error on hClose") (hClose ch)) outHandles |
100 mapM_ (\ch -> atomically $ writeTChan closingChan ch) outHandles |
96 let mclients = remove clients outHandles |
101 let mclients = remove clients outHandles |
97 |
102 |
98 sendAnswers answers client mclients rooms |
103 sendAnswers closingChan answers client mclients rooms |
99 where |
104 where |
100 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
105 remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles |
101 |
106 |
102 |
107 |
103 reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
108 reactCmd :: ServerInfo -> TChan Handle -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo]) |
104 reactCmd serverInfo cmd client clients rooms = do |
109 reactCmd serverInfo closingChan cmd client clients rooms = do |
105 --putStrLn ("> " ++ show cmd) |
110 --putStrLn ("> " ++ show cmd) |
106 |
111 |
107 let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd |
112 let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd |
108 let mrooms = roomsFunc rooms |
113 let mrooms = roomsFunc rooms |
109 let mclients = (clientsFunc clients) |
114 let mclients = (clientsFunc clients) |
110 let mclient = fromMaybe client $ find (== client) mclients |
115 let mclient = fromMaybe client $ find (== client) mclients |
111 let answers = map (\x -> x serverInfo) answerFuncs |
116 let answers = map (\x -> x serverInfo) answerFuncs |
112 |
117 |
113 clientsIn <- sendAnswers answers mclient mclients mrooms |
118 clientsIn <- sendAnswers closingChan answers mclient mclients mrooms |
114 mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn |
119 mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn |
115 |
120 |
116 return (clientsIn, mrooms) |
121 return (clientsIn, mrooms) |
117 |
122 |
118 |
123 |
119 mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO () |
124 mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> TChan Handle -> [ClientInfo] -> [RoomInfo] -> IO () |
120 mainLoop serverInfo acceptChan messagesChan clients rooms = do |
125 mainLoop serverInfo acceptChan messagesChan closingChan clients rooms = do |
121 r <- atomically $ |
126 r <- atomically $ |
122 (Accept `fmap` readTChan acceptChan) `orElse` |
127 (Accept `fmap` readTChan acceptChan) `orElse` |
123 (ClientMessage `fmap` tselect clients) `orElse` |
128 (ClientMessage `fmap` tselect clients) `orElse` |
124 (CoreMessage `fmap` readTChan messagesChan) |
129 (CoreMessage `fmap` readTChan messagesChan) |
125 |
130 |
126 case r of |
131 case r of |
127 Accept ci -> do |
132 Accept ci -> do |
128 let sameHostClients = filter (\cl -> host ci == host cl) clients |
133 let sameHostClients = filter (\cl -> host ci == host cl) clients |
129 let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
134 let haveJustConnected = False--not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients |
130 |
135 |
131 when haveJustConnected $ do |
136 when haveJustConnected $ do |
132 atomically $ do |
137 atomically $ do |
133 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
138 --writeTChan (chan ci) ["ERROR", "Reconnected too fast"] |
134 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
139 writeTChan (chan ci) ["QUIT", "Reconnected too fast"] |
136 currentTime <- getCurrentTime |
141 currentTime <- getCurrentTime |
137 let newServerInfo = serverInfo{ |
142 let newServerInfo = serverInfo{ |
138 loginsNumber = loginsNumber serverInfo + 1, |
143 loginsNumber = loginsNumber serverInfo + 1, |
139 lastHourUsers = currentTime : lastHourUsers serverInfo |
144 lastHourUsers = currentTime : lastHourUsers serverInfo |
140 } |
145 } |
141 mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms |
146 mainLoop newServerInfo acceptChan messagesChan closingChan (clients ++ [ci]) rooms |
142 |
147 |
143 ClientMessage (cmd, client) -> do |
148 ClientMessage (cmd, client) -> do |
144 (clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms |
149 (clientsIn, mrooms) <- reactCmd serverInfo closingChan cmd client clients rooms |
145 |
150 |
146 let hadRooms = (not $ null rooms) && (null mrooms) |
151 let hadRooms = (not $ null rooms) && (null mrooms) |
147 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
152 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
148 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
153 mainLoop serverInfo acceptChan messagesChan closingChan clientsIn mrooms |
149 |
154 |
150 CoreMessage msg -> case msg of |
155 CoreMessage msg -> case msg of |
151 ["PING"] -> |
156 ["PING"] -> |
152 if not $ null $ clients then |
157 if not $ null $ clients then |
153 do |
158 do |
154 let client = head clients -- don't care |
159 let client = head clients -- don't care |
155 (clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms |
160 (clientsIn, mrooms) <- reactCmd serverInfo closingChan msg client clients rooms |
156 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms |
161 mainLoop serverInfo acceptChan messagesChan closingChan clientsIn mrooms |
157 else |
162 else |
158 mainLoop serverInfo acceptChan messagesChan clients rooms |
163 mainLoop serverInfo acceptChan messagesChan closingChan clients rooms |
159 ["MINUTELY"] -> do |
164 ["MINUTELY"] -> do |
160 currentTime <- getCurrentTime |
165 currentTime <- getCurrentTime |
161 let newServerInfo = serverInfo{ |
166 let newServerInfo = serverInfo{ |
162 lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo |
167 lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo |
163 } |
168 } |
164 mainLoop newServerInfo acceptChan messagesChan clients rooms |
169 mainLoop newServerInfo acceptChan messagesChan closingChan clients rooms |
165 |
170 |
166 startServer :: ServerInfo -> Socket -> IO() |
171 startServer :: ServerInfo -> Socket -> IO() |
167 startServer serverInfo serverSocket = do |
172 startServer serverInfo serverSocket = do |
168 acceptChan <- atomically newTChan |
173 acceptChan <- atomically newTChan |
169 forkIO $ acceptLoop serverSocket acceptChan |
174 forkIO $ acceptLoop serverSocket acceptChan |
170 |
175 |
171 messagesChan <- atomically newTChan |
176 messagesChan <- atomically newTChan |
172 forkIO $ messagesLoop messagesChan |
177 forkIO $ messagesLoop messagesChan |
173 forkIO $ timerLoop messagesChan |
178 forkIO $ timerLoop messagesChan |
174 |
179 |
175 mainLoop serverInfo acceptChan messagesChan [] [] |
180 closingChan <- atomically newTChan |
|
181 forkIO $ socketCloseLoop closingChan |
|
182 |
|
183 mainLoop serverInfo acceptChan messagesChan closingChan [] [] |
176 |
184 |
177 |
185 |
178 main = withSocketsDo $ do |
186 main = withSocketsDo $ do |
179 #if !defined(mingw32_HOST_OS) |
187 #if !defined(mingw32_HOST_OS) |
180 installHandler sigPIPE Ignore Nothing; |
188 installHandler sigPIPE Ignore Nothing; |