# HG changeset patch
# User unc0rr
# Date 1226332679 0
# Node ID 2da1fe033f2300e4bea761c8afb13c00033f8bb0
# Parent  0b1f44751509e310c150818fa62154a625d14205
Finish refactoring

diff -r 0b1f44751509 -r 2da1fe033f23 netserver/HWProto.hs
--- a/netserver/HWProto.hs	Mon Nov 10 15:50:46 2008 +0000
+++ b/netserver/HWProto.hs	Mon Nov 10 15:57:59 2008 +0000
@@ -16,7 +16,7 @@
 		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
 
 makeAnswer :: HandlesSelector -> [String] -> [Answer]
-makeAnswer func msg = [(func, msg)]-- [\_ -> (func, msg)]
+makeAnswer func msg = [\_ -> (func, msg)]
 answerClientOnly, answerOthersRoom, answerSameRoom :: [String] -> [Answer]
 answerClientOnly  = makeAnswer clientOnly
 answerOthersRoom  = makeAnswer othersInRoom
@@ -72,12 +72,18 @@
 			(answerClientOnly ["TEAM_COLOR", teamname team, teamcolor team]) ++
 			(answerClientOnly ["HH_NUM", teamname team, show $ hhnum team])
 
-answerServerMessage clients = answerClientOnly $ "SERVER_MESSAGE" : [mainbody ++ clientsIn]
+answerServerMessage clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" : [(mainbody serverInfo) ++ clientsIn])]
 	where
-		mainbody = serverMessage globalOptions ++ if isDedicated globalOptions then "<p align=center>Dedicated server</p>" else "<p align=center>Private server</p>"
+		mainbody serverInfo = serverMessage serverInfo ++
+			if isDedicated serverInfo then
+				"<p align=center>Dedicated server</p>"
+				else
+				"<p align=center>Private server</p>"
+		
 		clientsIn = "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>"
 		clientslist = if not $ null nicks then foldr1 (\a b -> a  ++ ", " ++ b) nicks else ""
 		nicks = filter (not . null) $ map nick clients
+
 answerPing = makeAnswer allClients ["PING"]
 
 
@@ -157,13 +163,10 @@
 			sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms
 
 handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
-	if (not $ isDedicated globalOptions) && (not $ null rooms) then
-		(noChangeClients, noChangeRooms, answerCannotCreateRoom)
+	if haveSameRoom then
+		(noChangeClients, noChangeRooms, answerRoomExists)
 	else
-		if haveSameRoom then
-			(noChangeClients, noChangeRooms, answerRoomExists)
-		else
-			(modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client))
+		(modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client))
 	where
 		haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms
 
diff -r 0b1f44751509 -r 2da1fe033f23 netserver/Miscutils.hs
--- a/netserver/Miscutils.hs	Mon Nov 10 15:50:46 2008 +0000
+++ b/netserver/Miscutils.hs	Mon Nov 10 15:57:59 2008 +0000
@@ -8,6 +8,7 @@
 import Maybe (fromJust)
 import qualified Data.Map as Map
 import Data.Time
+import Network
 
 data ClientInfo =
  ClientInfo
@@ -58,18 +59,39 @@
 		isRestrictedTeams :: Bool,
 		params :: Map.Map String [String]
 	}
-createRoom = (RoomInfo "" "" 0 [] "+rnd+" False 1 0 False False Map.empty)
+createRoom = (
+	RoomInfo
+		""
+		""
+		0
+		[]
+		"+rnd+"
+		False
+		1
+		0
+		False
+		False
+		Map.empty
+	)
 
 data ServerInfo =
 	ServerInfo
 	{
-		message :: String
+		isDedicated :: Bool,
+		serverMessage :: String,
+		listenPort :: PortNumber
 	}
+newServerInfo = (
+	ServerInfo
+		True
+		"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
+		46631
+	)
 
 type ClientsTransform = [ClientInfo] -> [ClientInfo]
 type RoomsTransform = [RoomInfo] -> [RoomInfo]
 type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [Handle]
-type Answer = (HandlesSelector, [String])
+type Answer = ServerInfo -> (HandlesSelector, [String])
 type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [Answer])
 
 
diff -r 0b1f44751509 -r 2da1fe033f23 netserver/Opts.hs
--- a/netserver/Opts.hs	Mon Nov 10 15:50:46 2008 +0000
+++ b/netserver/Opts.hs	Mon Nov 10 15:57:59 2008 +0000
@@ -1,7 +1,6 @@
 module Opts
 (
-	GlobalOptions(..),
-	globalOptions
+	getOpts,
 ) where
 
 import System
@@ -11,23 +10,14 @@
 import Miscutils
 import System.IO.Unsafe
 
-data GlobalOptions =
-	GlobalOptions
-	{
-		isDedicated :: Bool,
-		serverMessage :: String,
-		listenPort :: PortNumber
-	}
-defaultMessage = "<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
-defaultOptions = (GlobalOptions True defaultMessage 46631)
 
-options :: [OptDescr (GlobalOptions -> GlobalOptions)]
+options :: [OptDescr (ServerInfo -> ServerInfo)]
 options = [
 	Option ['p'] ["port"] (ReqArg readListenPort "PORT") "listen on PORT",
 	Option ['d'] ["dedicated"] (ReqArg readDedicated "BOOL") "start as dedicated (True or False)"
 	]
 
-readListenPort, readDedicated :: String -> GlobalOptions -> GlobalOptions
+readListenPort, readDedicated :: String -> ServerInfo -> ServerInfo
 readListenPort str opts = opts{listenPort = readPort}
 	where
 		readPort = fromInteger $ fromMaybe 46631 (maybeRead str :: Maybe Integer)
@@ -36,13 +26,10 @@
 	where
 		readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
 
-opts :: IO GlobalOptions
-opts = do
+getOpts :: ServerInfo -> IO ServerInfo
+getOpts opts = do
 	args <- getArgs
 	case getOpt Permute options args of
-		(o, [], []) -> return $ foldr ($) defaultOptions o
+		(o, [], []) -> return $ foldr ($) opts o
 		(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
 	where header = "Usage: newhwserv [OPTION...]"
-
-{-# NOINLINE globalOptions #-}
-globalOptions = unsafePerformIO opts
diff -r 0b1f44751509 -r 2da1fe033f23 netserver/hedgewars-server.hs
--- a/netserver/hedgewars-server.hs	Mon Nov 10 15:50:46 2008 +0000
+++ b/netserver/hedgewars-server.hs	Mon Nov 10 15:57:59 2008 +0000
@@ -91,14 +91,15 @@
 		remove list rmClHandles = deleteFirstsBy2t (\ a b -> (Miscutils.handle a) == b) list rmClHandles
 
 
-reactCmd :: [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
-reactCmd 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, answers) = handleCmd client clients rooms $ cmd
+	let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd
 	let mrooms = roomsFunc rooms
 	let mclients = (clientsFunc clients)
 	let mclient = fromMaybe client $ find (== client) mclients
+	let answers = map (\x -> x serverInfo) answerFuncs
 
 	clientsIn <- sendAnswers answers mclient mclients mrooms
 	mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn
@@ -106,8 +107,8 @@
 	return (clientsIn, mrooms)
 
 
-mainLoop :: TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
-mainLoop acceptChan messagesChan 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`
@@ -123,39 +124,42 @@
 					--writeTChan (chan ci) ["ERROR", "Reconnected too fast"]
 					writeTChan (chan ci) ["QUIT", "Reconnected too fast"]
 				
-			mainLoop acceptChan messagesChan (clients ++ [ci]) rooms
+			mainLoop serverInfo acceptChan messagesChan (clients ++ [ci]) rooms
 			
 		ClientMessage (cmd, client) -> do
-			(clientsIn, mrooms) <- reactCmd cmd client clients rooms
+			(clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
 			
 			let hadRooms = (not $ null rooms) && (null mrooms)
-				in unless ((not $ isDedicated globalOptions) && ((null clientsIn) || hadRooms)) $
-					mainLoop acceptChan messagesChan clientsIn mrooms
+				in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
+					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
 		
 		CoreMessage msg ->
 			if not $ null $ clients then
 				do
 				let client = head clients -- don't care
-				(clientsIn, mrooms) <- reactCmd msg client clients rooms
-				mainLoop acceptChan messagesChan clientsIn mrooms
+				(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
+				mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
 			else
-				mainLoop acceptChan messagesChan clients rooms
+				mainLoop serverInfo acceptChan messagesChan clients rooms
 
-startServer :: Socket -> IO()
-startServer serverSocket = do
+startServer :: ServerInfo -> Socket -> IO()
+startServer serverInfo serverSocket = do
 	acceptChan <- atomically newTChan
 	forkIO $ acceptLoop serverSocket acceptChan
 	
 	messagesChan <- atomically newTChan
 	forkIO $ messagesLoop messagesChan
-	
-	mainLoop acceptChan messagesChan [] []
+
+	mainLoop serverInfo acceptChan messagesChan [] []
 
 
 main = withSocketsDo $ do
 #if !defined(mingw32_HOST_OS)
 	installHandler sigPIPE Ignore Nothing;
 #endif
-	putStrLn $ "Listening on port " ++ show (listenPort globalOptions)
-	serverSocket <- listenOn $ PortNumber (listenPort globalOptions)
-	startServer serverSocket `finally` sClose serverSocket
+	serverInfo <- getOpts newServerInfo
+	
+	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+	
+	serverSocket <- listenOn $ PortNumber (listenPort serverInfo)
+	startServer serverInfo serverSocket `finally` sClose serverSocket