--- a/gameServer/Actions.hs Sat Feb 26 15:56:11 2011 +0100
+++ b/gameServer/Actions.hs Sun Feb 27 19:32:44 2011 +0300
@@ -14,6 +14,7 @@
import Control.DeepSeq
import Data.Unique
import Control.Arrow
+import Control.Exception
-----------------------------
import CoreTypes
import Utils
@@ -53,6 +54,7 @@
| StatsAction
| RestartServer Bool
+
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
instance NFData Action where
@@ -412,5 +414,8 @@
where
st irnc = (length $ allRooms irnc, length $ allClients irnc)
-processAction (RestartServer _) =
- return ()
\ No newline at end of file
+processAction (RestartServer force) = do
+ if force then do
+ throw ShutdownException
+ else
+ processAction $ ModifyServerInfo (\s -> s{restartPending=True})
--- a/gameServer/CoreTypes.hs Sat Feb 26 15:56:11 2011 +0100
+++ b/gameServer/CoreTypes.hs Sun Feb 27 19:32:44 2011 +0300
@@ -1,8 +1,7 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
module CoreTypes where
import Control.Concurrent
-import Control.Concurrent.STM
import Data.Word
import qualified Data.Map as Map
import Data.Sequence(Seq, empty)
@@ -11,7 +10,9 @@
import Data.Function
import Data.ByteString.Char8 as B
import Data.Unique
-
+import Control.Exception
+import Data.Typeable
+-----------------------
import RoomsAndClients
type ClientChan = Chan [B.ByteString]
@@ -135,7 +136,7 @@
dbLogin :: B.ByteString,
dbPassword :: B.ByteString,
lastLogins :: [(B.ByteString, (UTCTime, B.ByteString))],
- stats :: TMVar StatisticsInfo,
+ restartPending :: Bool,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery
}
@@ -143,7 +144,7 @@
instance Show ServerInfo where
show _ = "Server Info"
-newServerInfo :: TMVar StatisticsInfo -> Chan CoreMessage -> Chan DBQuery -> ServerInfo
+newServerInfo :: Chan CoreMessage -> Chan DBQuery -> ServerInfo
newServerInfo =
ServerInfo
True
@@ -156,6 +157,7 @@
""
""
[]
+ False
data AccountInfo =
HasAccount B.ByteString Bool
@@ -189,4 +191,11 @@
data Notice =
NickAlreadyInUse
| AdminLeft
- deriving Enum
\ No newline at end of file
+ deriving Enum
+
+data ShutdownException =
+ ShutdownException
+ | RestartException
+ deriving (Show, Typeable)
+
+instance Exception ShutdownException
--- a/gameServer/Opts.hs Sat Feb 26 15:56:11 2011 +0100
+++ b/gameServer/Opts.hs Sun Feb 27 19:32:44 2011 +0300
@@ -7,10 +7,6 @@
import System.Environment
import System.Console.GetOpt
import Data.Maybe ( fromMaybe )
-#if defined(OFFICIAL_SERVER)
-import qualified Data.ByteString.Char8 as B
-import Network
-#endif
-------------------
import CoreTypes
import Utils
@@ -23,11 +19,6 @@
readListenPort
, readDedicated
-#if defined(OFFICIAL_SERVER)
- , readDbLogin
- , readDbPassword
- readDbHost
-#endif
:: String -> ServerInfo -> ServerInfo
@@ -39,12 +30,6 @@
where
readDed = fromMaybe True (maybeRead str :: Maybe Bool)
-#if defined(OFFICIAL_SERVER)
-readDbLogin str opts = opts{dbLogin = B.pack str}
-readDbPassword str opts = opts{dbPassword = B.pack str}
-readDbHost str opts = opts{dbHost = B.pack str}
-#endif
-
getOpts :: ServerInfo -> IO ServerInfo
getOpts opts = do
args <- getArgs
--- a/gameServer/ServerCore.hs Sat Feb 26 15:56:11 2011 +0100
+++ b/gameServer/ServerCore.hs Sun Feb 27 19:32:44 2011 +0300
@@ -32,7 +32,7 @@
mainLoop :: StateT ServerState IO ()
mainLoop = forever $ do
- get >>= \s -> put $! s
+ -- get >>= \s -> put $! s
si <- gets serverInfo
r <- liftIO $ readChan $ coreChan si
@@ -53,11 +53,6 @@
liftIO $ debugM "Clients" $ "DeleteClient: " ++ show ci
processAction (DeleteClient ci)
- --else
- --do
- --debugM "Clients" "Message from dead client"
- --return (serverInfo, rnc)
-
ClientAccountInfo ci uid info -> do
rnc <- gets roomsClients
exists <- liftIO $ clientExists rnc ci
@@ -90,6 +85,4 @@
rnc <- newRoomsAndClients newRoom
- _ <- forkIO $ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)
-
- forever $ threadDelay 3600000000 -- one hour
+ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)
--- a/gameServer/hedgewars-server.hs Sat Feb 26 15:56:11 2011 +0100
+++ b/gameServer/hedgewars-server.hs Sun Feb 27 19:32:44 2011 +0300
@@ -4,9 +4,8 @@
import Network.Socket
import Network.BSD
-import Control.Concurrent.STM
import Control.Concurrent.Chan
-import qualified Control.Exception as Exception
+import qualified Control.Exception as E
import System.Log.Logger
-----------------------------------
import Opts
@@ -27,6 +26,26 @@
updateGlobalLogger "Clients"
(setLevel INFO)
+
+server :: ServerInfo -> IO ()
+server si = do
+ proto <- getProtocolNumber "tcp"
+ E.bracket
+ (socket AF_INET Stream proto)
+ sClose
+ (\sock -> do
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock (SockAddrInet (listenPort si) iNADDR_ANY)
+ listen sock maxListenQueue
+ startServer si sock
+ )
+
+handleRestart :: ShutdownException -> IO ()
+handleRestart ShutdownException = return ()
+handleRestart RestartException = do
+
+ return ()
+
main :: IO ()
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
@@ -36,28 +55,17 @@
setupLoggers
- stats' <- atomically $ newTMVar (StatisticsInfo 0 0)
dbQueriesChan <- newChan
coreChan' <- newChan
- serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan
+ serverInfo' <- getOpts $ newServerInfo coreChan' dbQueriesChan
#if defined(OFFICIAL_SERVER)
dbHost' <- askFromConsole "DB host: "
dbLogin' <- askFromConsole "login: "
dbPassword' <- askFromConsole "password: "
- let serverInfo = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
+ let si = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
#else
- let serverInfo = serverInfo'
+ let si = serverInfo'
#endif
-
- proto <- getProtocolNumber "tcp"
- Exception.bracket
- (socket AF_INET Stream proto)
- sClose
- (\sock -> do
- setSocketOption sock ReuseAddr 1
- bindSocket sock (SockAddrInet (listenPort serverInfo) iNADDR_ANY)
- listen sock maxListenQueue
- startServer serverInfo sock
- )
+ (server si) `E.catch` handleRestart