# HG changeset patch
# User unc0rr
# Date 1227796492 0
# Node ID a35c90263e272eedf3b332a1d43926fdbb633a08
# Parent  43742041c211a37aea7c3b5a65e5fce100e6e063
Refactor server a bit, now all socket operations are in own threads, two per client

diff -r 43742041c211 -r a35c90263e27 netserver/Miscutils.hs
--- a/netserver/Miscutils.hs	Tue Nov 25 15:43:10 2008 +0000
+++ b/netserver/Miscutils.hs	Thu Nov 27 14:34:52 2008 +0000
@@ -14,6 +14,7 @@
  ClientInfo
 	{
 		chan :: TChan [String],
+		sendChan :: TChan [String],
 		handle :: Handle,
 		host :: String,
 		connectTime :: UTCTime,
@@ -94,7 +95,7 @@
 
 type ClientsTransform = [ClientInfo] -> [ClientInfo]
 type RoomsTransform = [RoomInfo] -> [RoomInfo]
-type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [Handle]
+type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
 type Answer = ServerInfo -> (HandlesSelector, [String])
 type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [Answer])
 
@@ -117,26 +118,26 @@
 deleteFirstsBy2t :: (a -> b -> Bool) -> [a] -> [b] -> [a]
 deleteFirstsBy2t eq =  foldl (flip (deleteBy2t eq))
 
-clientByHandle :: Handle -> [ClientInfo] -> Maybe ClientInfo
-clientByHandle chandle clients = find (\c -> handle c == chandle) clients
+--clientByHandle :: Handle -> [ClientInfo] -> Maybe ClientInfo
+--clientByHandle chandle clients = find (\c -> handle c == chandle) clients
 
 sameRoom :: HandlesSelector
-sameRoom client clients rooms = map handle $ filter (\ci -> room ci == room client) clients
+sameRoom client clients rooms = filter (\ci -> room ci == room client) clients
 
 noRoomSameProto :: HandlesSelector
-noRoomSameProto client clients _ = map handle $ filter (null . room) $ filter (\ci -> protocol client == protocol ci) clients
+noRoomSameProto client clients _ = filter (null . room) $ filter (\ci -> protocol client == protocol ci) clients
 
 othersInRoom :: HandlesSelector
-othersInRoom client clients rooms = map handle $ filter (client /=) $ filter (\ci -> room ci == room client) clients
+othersInRoom client clients rooms = filter (client /=) $ filter (\ci -> room ci == room client) clients
 
 fromRoom :: String -> HandlesSelector
-fromRoom roomName _ clients _ = map handle $ filter (\ci -> room ci == roomName) clients
+fromRoom roomName _ clients _ = filter (\ci -> room ci == roomName) clients
 
 allClients :: HandlesSelector
-allClients _ clients _ = map handle $ clients
+allClients _ clients _ = clients
 
 clientOnly :: HandlesSelector
-clientOnly client _ _ = [handle client]
+clientOnly client _ _ = [client]
 
 noChangeClients :: ClientsTransform
 noChangeClients a = a
diff -r 43742041c211 -r a35c90263e27 netserver/hedgewars-server.hs
--- a/netserver/hedgewars-server.hs	Tue Nov 25 15:43:10 2008 +0000
+++ b/netserver/hedgewars-server.hs	Thu Nov 27 14:34:52 2008 +0000
@@ -20,6 +20,8 @@
 import System.Posix
 #endif
 
+#define IOException Exception
+
 data Messages =
 	Accept ClientInfo
 	| ClientMessage ([String], ClientInfo)
@@ -36,11 +38,6 @@
 	threadDelay (60 * 10^6) -- 60 seconds
 	atomically $ writeTChan messagesChan ["MINUTELY"]
 
-socketCloseLoop :: TChan Handle -> IO()
-socketCloseLoop closingChan = forever $ do
-	h <- atomically $ readTChan closingChan
-	Control.Exception.handle (\(_ :: IOException) -> putStrLn "error on hClose") $ hClose h
-
 acceptLoop :: Socket -> TChan ClientInfo -> IO ()
 acceptLoop servSock acceptChan =
 	Control.Exception.handle (\(_ :: IOException) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $
@@ -51,9 +48,11 @@
 	putStrLn $ (show currentTime) ++ " new client: " ++ host
 	
 	cChan <- atomically newTChan
-	forkIO $ clientLoop cHandle cChan
+	sendChan <- atomically newTChan
+	forkIO $ clientRecvLoop cHandle cChan
+	forkIO $ clientSendLoop cHandle cChan sendChan
 	
-	atomically $ writeTChan acceptChan (ClientInfo cChan cHandle host currentTime "" 0 "" False False False)
+	atomically $ writeTChan acceptChan (ClientInfo cChan sendChan cHandle host currentTime "" 0 "" False False False)
 	atomically $ writeTChan cChan ["ASKME"]
 	acceptLoop servSock acceptChan
 
@@ -68,46 +67,54 @@
 		listenLoop handle (buf ++ [str]) chan
 
 
-clientLoop :: Handle -> TChan [String] -> IO ()
-clientLoop handle chan =
+clientRecvLoop :: Handle -> TChan [String] -> IO ()
+clientRecvLoop handle chan =
 	listenLoop handle [] chan
 		`catch` (\e -> (clientOff $ show e) >> return ())
 	where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message
 
+clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO()
+clientSendLoop handle clChan chan = do
+	answer <- atomically $ readTChan chan
+	doClose <- Control.Exception.handle
+		(\(e :: IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
+		forM_ answer (\str -> hPutStrLn handle str)
+		hPutStrLn handle ""
+		hFlush handle
+		return $ isQuit answer
 
-sendAnswers _ [] _ clients _ = return clients
-sendAnswers closingChan ((handlesFunc, answer):answers) client clients rooms = do
+	if doClose then
+		Control.Exception.handle (\(_ :: IOException) -> putStrLn "error on hClose") $ hClose handle
+		else
+		clientSendLoop handle clChan chan
+
+	where
+		sendQuit e = atomically $ writeTChan clChan ["QUIT", show e]
+		isQuit answer = head answer == "BYE"
+
+sendAnswers  [] _ clients _ = return clients
+sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
 	let recipients = handlesFunc client clients rooms
 	--unless (null recipients) $ putStrLn ("< " ++ (show answer))
 	when (head answer == "NICK") $ putStrLn (show answer)
 
 	clHandles' <- forM recipients $
-		\ch -> Control.Exception.handle
-			(\(e :: IOException) -> if head answer == "BYE" then
-					return [ch]
-				else
-					atomically $ writeTChan (chan $ fromJust $ clientByHandle ch clients) ["QUIT", show e] >> return []  -- cannot just remove
-			) $
+		\ch ->
 			do
-			forM_ answer (\str -> hPutStrLn ch str)
-			hPutStrLn ch ""
-			hFlush ch
+			atomically $ writeTChan (sendChan ch) answer
 			if head answer == "BYE" then return [ch] else return []
 
 	let outHandles = concat clHandles'
 	unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer))
 
 	-- strange, but this seems to be a bad idea to manually close these handles as it causes hangs
-	mapM_ (\ch -> atomically $ writeTChan closingChan ch) outHandles
-	let mclients = remove clients outHandles
+	let mclients = deleteFirstsBy (==) clients outHandles
 
-	sendAnswers closingChan answers client mclients rooms
-	where
-		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
+	sendAnswers answers client mclients rooms
 
 
-reactCmd :: ServerInfo -> TChan Handle -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
-reactCmd serverInfo closingChan cmd client clients rooms = do
+reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
+reactCmd serverInfo cmd client clients rooms = do
 	--putStrLn ("> " ++ show cmd)
 
 	let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd
@@ -116,14 +123,14 @@
 	let mclient = fromMaybe client $ find (== client) mclients
 	let answers = map (\x -> x serverInfo) answerFuncs
 
-	clientsIn <- sendAnswers closingChan answers mclient mclients mrooms
+	clientsIn <- sendAnswers answers mclient mclients mrooms
 	mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn
 	
 	return (clientsIn, mrooms)
 
 
-mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> TChan Handle -> [ClientInfo] -> [RoomInfo] -> IO ()
-mainLoop serverInfo acceptChan messagesChan closingChan clients rooms = do
+mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
+mainLoop serverInfo acceptChan messagesChan clients rooms = do
 	r <- atomically $
 		(Accept `fmap` readTChan acceptChan) `orElse`
 		(ClientMessage `fmap` tselect clients) `orElse`
@@ -132,7 +139,7 @@
 	case r of
 		Accept ci -> do
 			let sameHostClients = filter (\cl -> host ci == host cl) clients
-			let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients
+			let haveJustConnected = False--not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients
 			
 			when haveJustConnected $ do
 				atomically $ do
@@ -143,30 +150,30 @@
 					loginsNumber = loginsNumber serverInfo + 1,
 					lastHourUsers = currentTime : lastHourUsers serverInfo
 					}
-			mainLoop newServerInfo acceptChan messagesChan closingChan (clients ++ [ci]) rooms
+			mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms
 			
 		ClientMessage (cmd, client) -> do
-			(clientsIn, mrooms) <- reactCmd serverInfo closingChan cmd client clients rooms
+			(clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
 			
 			let hadRooms = (not $ null rooms) && (null mrooms)
 				in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
-					mainLoop serverInfo acceptChan messagesChan closingChan clientsIn mrooms
+					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
 		
 		CoreMessage msg -> case msg of
 			["PING"] ->
 				if not $ null $ clients then
 					do
 					let client = head clients -- don't care
-					(clientsIn, mrooms) <- reactCmd serverInfo closingChan msg client clients rooms
-					mainLoop serverInfo acceptChan messagesChan closingChan clientsIn mrooms
+					(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
+					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
 				else
-					mainLoop serverInfo acceptChan messagesChan closingChan clients rooms
+					mainLoop serverInfo acceptChan messagesChan clients rooms
 			["MINUTELY"] -> do
 				currentTime <- getCurrentTime
 				let newServerInfo = serverInfo{
 						lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo
 						}
-				mainLoop newServerInfo acceptChan messagesChan closingChan clients rooms
+				mainLoop newServerInfo acceptChan messagesChan clients rooms
 
 startServer :: ServerInfo -> Socket -> IO()
 startServer serverInfo serverSocket = do
@@ -177,10 +184,7 @@
 	forkIO $ messagesLoop messagesChan
 	forkIO $ timerLoop messagesChan
 
-	closingChan <- atomically newTChan
-	forkIO $ socketCloseLoop closingChan
-
-	mainLoop serverInfo acceptChan messagesChan closingChan [] []
+	mainLoop serverInfo acceptChan messagesChan [] []
 
 
 main = withSocketsDo $ do