On restart command close server socket and spawn new server, keep running until last client quits
--- a/gameServer/Actions.hs Thu May 12 23:29:31 2011 +0200
+++ b/gameServer/Actions.hs Sun May 15 18:10:01 2011 +0400
@@ -18,6 +18,8 @@
import Control.Arrow
import Control.Exception
import OfficialServer.GameReplayStore
+import System.Process
+import Network.Socket
-----------------------------
import CoreTypes
import Utils
@@ -57,7 +59,7 @@
| DeleteClient ClientIndex
| PingAll
| StatsAction
- | RestartServer Bool
+ | RestartServer
| AddNick2Bans B.ByteString B.ByteString UTCTime
| AddIP2Bans B.ByteString B.ByteString UTCTime
| CheckBanned
@@ -153,6 +155,10 @@
s <- get
put $! s{removedClients = ci `Set.delete` removedClients s}
+
+ sp <- gets (shutdownPending . serverInfo)
+ cls <- allClientsS
+ io $ when (sp && null cls) $ throwIO ShutdownException
processAction (ModifyClient f) = do
(Just ci) <- gets clientIndex
@@ -467,11 +473,15 @@
where
st irnc = (length $ allRooms irnc, length $ allClients irnc)
-processAction (RestartServer force) = do
- if force then do
- throw RestartException
- else
- processAction $ ModifyServerInfo (\s -> s{restartPending=True})
+processAction RestartServer = do
+ sock <- gets (fromJust . serverSocket . serverInfo)
+ io $ do
+ noticeM "Core" "Closing listening socket"
+ sClose sock
+ noticeM "Core" "Spawning new server"
+ _ <- createProcess (proc "./hedgewars-server" [])
+ return ()
+ processAction $ ModifyServerInfo (\s -> s{shutdownPending=True})
processAction SaveReplay = do
ri <- clientRoomA
--- a/gameServer/CoreTypes.hs Thu May 12 23:29:31 2011 +0200
+++ b/gameServer/CoreTypes.hs Sun May 15 18:10:01 2011 +0400
@@ -128,14 +128,15 @@
dbLogin :: B.ByteString,
dbPassword :: B.ByteString,
bans :: [BanInfo],
- restartPending :: Bool,
+ shutdownPending :: Bool,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery,
+ serverSocket :: Maybe Socket,
serverConfig :: Maybe Conf
}
-newServerInfo :: Chan CoreMessage -> Chan DBQuery -> Maybe Conf -> ServerInfo
+newServerInfo :: Chan CoreMessage -> Chan DBQuery -> Maybe Socket -> Maybe Conf -> ServerInfo
newServerInfo =
ServerInfo
True
@@ -181,7 +182,6 @@
data ShutdownException =
ShutdownException
- | RestartException
deriving (Show, Typeable)
instance Exception ShutdownException
--- a/gameServer/HWProtoLobbyState.hs Thu May 12 23:29:31 2011 +0200
+++ b/gameServer/HWProtoLobbyState.hs Sun May 15 18:10:01 2011 +0400
@@ -178,9 +178,9 @@
cl <- thisClient
return [ClearAccountsCache | isAdministrator cl]
-handleCmd_lobby ["RESTART_SERVER", restartType] = do
+handleCmd_lobby ["RESTART_SERVER"] = do
cl <- thisClient
- return [RestartServer f | let f = restartType == "FORCE", isAdministrator cl]
+ return [RestartServer]
handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]
--- a/gameServer/NetRoutines.hs Thu May 12 23:29:31 2011 +0200
+++ b/gameServer/NetRoutines.hs Sun May 15 18:10:01 2011 +0400
@@ -14,8 +14,6 @@
acceptLoop :: Socket -> Chan CoreMessage -> IO ()
acceptLoop servSock chan = forever $
- Exception.handle
- (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
do
(sock, sockAddr) <- Network.Socket.accept servSock
--- a/gameServer/ServerCore.hs Thu May 12 23:29:31 2011 +0200
+++ b/gameServer/ServerCore.hs Sun May 15 18:10:01 2011 +0400
@@ -10,6 +10,7 @@
import qualified Data.ByteString.Char8 as B
import Control.DeepSeq
import Data.Unique
+import Data.Maybe
--------------------------------------
import CoreTypes
import NetRoutines
@@ -65,13 +66,13 @@
PingAll : [StatsAction | even tick]
-startServer :: ServerInfo -> Socket -> IO ()
-startServer si serverSocket = do
- putStrLn $ "Listening on port " ++ show (listenPort si)
+startServer :: ServerInfo -> IO ()
+startServer si = do
+ noticeM "Core" $ "Listening on port " ++ show (listenPort si)
_ <- forkIO $
acceptLoop
- serverSocket
+ (fromJust $ serverSocket si)
(coreChan si)
return ()
--- a/gameServer/hedgewars-server.hs Thu May 12 23:29:31 2011 +0200
+++ b/gameServer/hedgewars-server.hs Sun May 15 18:10:01 2011 +0400
@@ -7,7 +7,6 @@
import Control.Concurrent.Chan
import qualified Control.Exception as E
import System.Log.Logger
-import System.Process
-----------------------------------
import Opts
import CoreTypes
@@ -22,9 +21,9 @@
setupLoggers :: IO ()
-setupLoggers =
- updateGlobalLogger "Clients"
- (setLevel NOTICE)
+setupLoggers = do
+ updateGlobalLogger "Clients" (setLevel NOTICE)
+ updateGlobalLogger "Core" (setLevel NOTICE)
server :: ServerInfo -> IO ()
@@ -37,13 +36,12 @@
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrInet (listenPort si) iNADDR_ANY)
listen sock maxListenQueue
- startServer si sock
+ startServer si{serverSocket = Just sock}
)
handleRestart :: ShutdownException -> IO ()
-handleRestart ShutdownException = return ()
-handleRestart RestartException = do
- _ <- createProcess (proc "./hedgewars-server" [])
+handleRestart ShutdownException = do
+ noticeM "Core" "Shutting down"
return ()
main :: IO ()
@@ -57,7 +55,7 @@
dbQueriesChan <- newChan
coreChan' <- newChan
- serverInfo' <- getOpts $ newServerInfo coreChan' dbQueriesChan Nothing
+ serverInfo' <- getOpts $ newServerInfo coreChan' dbQueriesChan Nothing Nothing
#if defined(OFFICIAL_SERVER)
si <- readServerConfig serverInfo'