--- 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
--- 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])
--- 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
--- 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