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