- Write server config into .ini file on change
- Import Data.TConfig into project, make it export Conf constructor, remove all workarounds for missing constructor in server.
--- a/gameServer/Actions.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/Actions.hs Sun Mar 06 21:54:37 2011 +0300
@@ -21,8 +21,9 @@
import ClientIO
import ServerState
import Consts
+import ConfigFile
-data Action c =
+data Action =
AnswerClients ![ClientChan] ![B.ByteString]
| SendServerMessage
| SendServerVars
@@ -44,7 +45,7 @@
| ModifyClient (ClientInfo -> ClientInfo)
| ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
| ModifyRoom (RoomInfo -> RoomInfo)
- | ModifyServerInfo (ServerInfo c -> ServerInfo c)
+ | ModifyServerInfo (ServerInfo -> ServerInfo)
| AddRoom B.ByteString B.ByteString
| CheckRegistered
| ClearAccountsCache
@@ -56,9 +57,9 @@
| RestartServer Bool
-type CmdHandler c = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action c]
+type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
-instance NFData (Action c) where
+instance NFData Action where
rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
rnf a = a `seq` ()
@@ -66,13 +67,13 @@
instance NFData (Chan a)
-othersChans :: StateT (ServerState c) IO [ClientChan]
+othersChans :: StateT ServerState IO [ClientChan]
othersChans = do
cl <- client's id
ri <- clientRoomA
liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
-processAction :: Action c -> StateT (ServerState c) IO ()
+processAction :: Action -> StateT ServerState IO ()
processAction (AnswerClients chans msg) =
@@ -162,8 +163,10 @@
return ()
-processAction (ModifyServerInfo f) =
+processAction (ModifyServerInfo f) = do
modify (\s -> s{serverInfo = f $ serverInfo s})
+ si <- gets serverInfo
+ io $ writeServerConfig si
processAction (MoveToRoom ri) = do
--- a/gameServer/ConfigFile.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/ConfigFile.hs Sun Mar 06 21:54:37 2011 +0300
@@ -7,8 +7,10 @@
-------------------
import CoreTypes
+cfgFileName = "hedgewars-server.ini"
+
readServerConfig serverInfo' = do
- cfg <- readConfig "hedgewars-server.ini"
+ cfg <- readConfig cfgFileName
let si = serverInfo'{
dbHost = value "dbHost" cfg
, dbName = value "dbName" cfg
@@ -25,5 +27,26 @@
fromJust2 n Nothing = error $ "Missing config entry " ++ n
fromJust2 _ (Just a) = a
-writeServerConfig :: ServerInfo c -> IO ()
-writeServerConfig = undefined
+
+writeServerConfig ServerInfo{serverConfig = Nothing} = return ()
+writeServerConfig ServerInfo{
+ dbHost = dh,
+ dbName = dn,
+ dbLogin = dl,
+ dbPassword = dp,
+ serverMessage = sm,
+ serverMessageForOldVersions = smo,
+ latestReleaseVersion = ver,
+ serverConfig = Just cfg}
+ = do
+ let newCfg = foldl (\c (n, v) -> repConfig n (B.unpack v) c) cfg entries
+ writeConfig cfgFileName newCfg
+ where
+ entries = [
+ ("dbHost", dh)
+ , ("dbName", dn)
+ , ("dbLogin", dl)
+ , ("dbPassword", dp)
+ , ("sv_message", sm)
+ , ("sv_messageOld", smo)
+ ]
--- a/gameServer/CoreTypes.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/CoreTypes.hs Sun Mar 06 21:54:37 2011 +0300
@@ -12,6 +12,7 @@
import Data.Unique
import Control.Exception
import Data.Typeable
+import Data.TConfig
-----------------------
import RoomsAndClients
@@ -123,7 +124,7 @@
roomsNumber :: Int
}
-data ServerInfo c =
+data ServerInfo =
ServerInfo
{
isDedicated :: Bool,
@@ -141,13 +142,13 @@
restartPending :: Bool,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery,
- serverConfig :: Maybe c
+ serverConfig :: Maybe Conf
}
-instance Show (ServerInfo c) where
+instance Show ServerInfo where
show _ = "Server Info"
-newServerInfo :: Chan CoreMessage -> Chan DBQuery -> Maybe c -> ServerInfo c
+newServerInfo :: Chan CoreMessage -> Chan DBQuery -> Maybe Conf -> ServerInfo
newServerInfo =
ServerInfo
True
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Data/TConfig.hs Sun Mar 06 21:54:37 2011 +0300
@@ -0,0 +1,116 @@
+-- Module : Data.TConfig
+-- Copyright : (c) Anthony Simpson 2009
+-- License : BSD3
+--
+-- Maintainer : DiscipleRayne@gmail.com
+-- Stability : relatively stable
+-- Portability : portable
+---------------------------------------------------
+{-|
+ A small and simple text file configuration
+ library written in Haskell. It is similar
+ to the INI file format, but lacks a few of
+ it's features, such as sections. It is
+ suitable for simple games that need to
+ keep track of certain information between
+ plays.
+-}
+module Data.TConfig
+ (
+ getValue
+ , repConfig
+ , readConfig
+ , writeConfig
+ , remKey
+ , addKey
+ , Conf ()
+ ) where
+
+import Data.Char
+import qualified Data.Map as M
+
+type Key = String
+type Value = String
+type Conf = M.Map Key Value
+
+-- |Adds a key and value to the end of the configuration.
+addKey :: Key -> Value -> Conf -> Conf
+addKey k v conf = M.insert k (addQuotes v) conf
+
+-- |Utility Function. Checks for the existence
+-- of a key.
+checkKey :: Key -> Conf -> Bool
+checkKey k conf = M.member k conf
+
+-- |Utility function.
+-- Removes a key and it's value from the configuration.
+remKey :: Key -> Conf -> Conf
+remKey k conf = M.delete k conf
+
+-- |Utility function. Searches a configuration for a
+-- key, and returns it's value.
+getValue :: Key -> Conf -> Maybe Value
+getValue k conf = case M.lookup k conf of
+ Just val -> Just $ stripQuotes val
+ Nothing -> Nothing
+
+stripQuotes :: String -> String
+stripQuotes x | any isSpace x = filter (/= '\"') x
+ | otherwise = x
+
+-- |Returns a String wrapped in quotes if it
+-- contains spaces, otherwise returns the string
+-- untouched.
+addQuotes :: String -> String
+addQuotes x | any isSpace x = "\"" ++ x ++ "\""
+ | otherwise = x
+
+-- |Utility function. Replaces the value
+-- associated with a key in a configuration.
+repConfig :: Key -> Value -> Conf -> Conf
+repConfig k rv conf = let f _ = Just rv
+ in M.alter f k conf
+
+-- |Reads a file and parses to a Map String String.
+readConfig :: FilePath -> IO Conf
+readConfig path = readFile path >>= return . parseConfig
+
+-- |Parses a parsed configuration back to a file.
+writeConfig :: FilePath -> Conf -> IO ()
+writeConfig path con = writeFile path $ putTogether con
+
+-- |Turns a list of configuration types back into a String
+-- to write to a file.
+putTogether :: Conf -> String
+putTogether = concat . putTogether' . backToString
+ where putTogether' (x:y:xs) = x : " = " : y : "\n" : putTogether' xs
+ putTogether' _ = []
+
+-- |Turns a list of configuration types into a list of Strings
+backToString :: Conf -> [String]
+backToString conf = backToString' $ M.toList conf
+ where backToString' ((x,y):xs) = x : y : backToString' xs
+ backToString' _ = []
+
+-- |Parses a string into a list of Configuration types.
+parseConfig :: String -> Conf
+parseConfig = listConfig . popString . parse
+
+parse :: String -> [String]
+parse = words . filter (/= '=')
+
+-- |Turns a list of key value key value etc... pairs into
+-- A list of Configuration types.
+listConfig :: [String] -> Conf
+listConfig = M.fromList . helper
+ where helper (x:y:xs) = (x,y) : helper xs
+ helper _ = []
+
+-- |Parses strings from the parseConfig'd file.
+popString :: [String] -> [String]
+popString [] = []
+popString (x:xs)
+ | head x == '\"' = findClose $ break (('\"' ==) . last) xs
+ | otherwise = x : popString xs
+ where findClose (y,ys) =
+ [unwords $ x : y ++ [head ys]] ++ popString (tail ys)
--- a/gameServer/HWProtoCore.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/HWProtoCore.hs Sun Mar 06 21:54:37 2011 +0300
@@ -14,7 +14,7 @@
import RoomsAndClients
import Utils
-handleCmd, handleCmd_loggedin :: CmdHandler c
+handleCmd, handleCmd_loggedin :: CmdHandler
handleCmd ["PING"] = answerClient ["PONG"]
--- a/gameServer/HWProtoInRoomState.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/HWProtoInRoomState.hs Sun Mar 06 21:54:37 2011 +0300
@@ -15,7 +15,7 @@
import HandlerUtils
import RoomsAndClients
-handleCmd_inRoom :: CmdHandler c
+handleCmd_inRoom :: CmdHandler
handleCmd_inRoom ["CHAT", msg] = do
n <- clientNick
@@ -99,8 +99,8 @@
ModifyClient
(\c -> c{
teamsInGame = teamsInGame c - 1,
- clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci r
- })
+ clientClan = if teamsInGame c == 1 then Nothing else Just $ anotherTeamClan ci r
+ })
]
where
anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
--- a/gameServer/HWProtoLobbyState.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/HWProtoLobbyState.hs Sun Mar 06 21:54:37 2011 +0300
@@ -15,7 +15,7 @@
import RoomsAndClients
-answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action c]
+answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
answerAllTeams cl = concatMap toAnswer
where
clChan = sendChan cl
@@ -24,7 +24,7 @@
AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]]
-handleCmd_lobby :: CmdHandler c
+handleCmd_lobby :: CmdHandler
handleCmd_lobby ["LIST"] = do
--- a/gameServer/HWProtoNEState.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/HWProtoNEState.hs Sun Mar 06 21:54:37 2011 +0300
@@ -11,7 +11,7 @@
import Utils
import RoomsAndClients
-handleCmd_NotEntered :: CmdHandler c
+handleCmd_NotEntered :: CmdHandler
handleCmd_NotEntered ["NICK", newNick] = do
(ci, irnc) <- ask
--- a/gameServer/HandlerUtils.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/HandlerUtils.hs Sun Mar 06 21:54:37 2011 +0300
@@ -48,7 +48,7 @@
(ci, rnc) <- ask
return [sendChan (rnc `client` ci)]
-answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action c]
+answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
answerClient msg = liftM ((: []) . flip AnswerClients msg) thisClientChans
allRoomInfos :: Reader (a, IRnC) [RoomInfo]
--- a/gameServer/OfficialServer/DBInteraction.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/OfficialServer/DBInteraction.hs Sun Mar 06 21:54:37 2011 +0300
@@ -27,7 +27,7 @@
localAddressList :: [B.ByteString]
localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"]
-fakeDbConnection :: forall b c. ServerInfo c -> IO b
+fakeDbConnection :: forall b. ServerInfo -> IO b
fakeDbConnection si = forever $ do
q <- readChan $ dbQueries si
case q of
@@ -38,7 +38,7 @@
--dbConnectionLoop :: forall b. (ServerInfo c) -> IO b
#if defined(OFFICIAL_SERVER)
-flushRequests :: (ServerInfo c) -> IO ()
+flushRequests :: ServerInfo -> IO ()
flushRequests si = do
e <- isEmptyChan $ dbQueries si
unless e $ do
@@ -89,10 +89,10 @@
maybeException (Just a) = return a
maybeException Nothing = ioError (userError "Can't read")
-pipeDbConnection :: forall a c b.
+pipeDbConnection :: forall a b.
(Num a, Ord a) =>
Map.Map ByteString (UTCTime, AccountInfo)
- -> ServerInfo c
+ -> ServerInfo
-> a
-> IO b
@@ -116,7 +116,7 @@
threadDelay (3000000)
pipeDbConnection updatedCache si newErrNum
-dbConnectionLoop :: forall c b. ServerInfo c -> IO b
+dbConnectionLoop :: forall b. ServerInfo -> IO b
dbConnectionLoop si =
if (not . B.null $ dbHost si) then
pipeDbConnection Map.empty si 0
@@ -126,6 +126,6 @@
dbConnectionLoop = fakeDbConnection
#endif
-startDBConnection :: (ServerInfo c) -> IO ()
+startDBConnection :: ServerInfo -> IO ()
startDBConnection serverInfo =
forkIO (dbConnectionLoop serverInfo) >> return ()
--- a/gameServer/Opts.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/Opts.hs Sun Mar 06 21:54:37 2011 +0300
@@ -11,7 +11,7 @@
import CoreTypes
import Utils
-options :: [OptDescr (ServerInfo c -> ServerInfo c)]
+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)"
@@ -19,7 +19,7 @@
readListenPort
, readDedicated
- :: String -> ServerInfo c -> ServerInfo c
+ :: String -> ServerInfo -> ServerInfo
readListenPort str opts = opts{listenPort = readPort}
@@ -30,7 +30,7 @@
where
readDed = fromMaybe True (maybeRead str :: Maybe Bool)
-getOpts :: ServerInfo c -> IO (ServerInfo c)
+getOpts :: ServerInfo -> IO ServerInfo
getOpts opts = do
args <- getArgs
case getOpt Permute options args of
--- a/gameServer/ServerCore.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/ServerCore.hs Sun Mar 06 21:54:37 2011 +0300
@@ -23,14 +23,14 @@
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-reactCmd :: [B.ByteString] -> StateT (ServerState c) IO ()
+reactCmd :: [B.ByteString] -> StateT ServerState IO ()
reactCmd cmd = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
forM_ (actions `deepseq` actions) processAction
-mainLoop :: StateT (ServerState c) IO ()
+mainLoop :: StateT ServerState IO ()
mainLoop = forever $ do
-- get >>= \s -> put $! s
@@ -68,7 +68,7 @@
PingAll : [StatsAction | even tick]
-startServer :: ServerInfo c -> Socket -> IO ()
+startServer :: ServerInfo -> Socket -> IO ()
startServer si serverSocket = do
putStrLn $ "Listening on port " ++ show (listenPort si)
--- a/gameServer/ServerState.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/ServerState.hs Sun Mar 06 21:54:37 2011 +0300
@@ -15,33 +15,33 @@
import RoomsAndClients
import CoreTypes
-data ServerState c = ServerState {
+data ServerState = ServerState {
clientIndex :: !(Maybe ClientIndex),
- serverInfo :: !(ServerInfo c),
+ serverInfo :: !ServerInfo,
removedClients :: !(Set.Set ClientIndex),
roomsClients :: !MRnC
}
-clientRoomA :: StateT (ServerState c) IO RoomIndex
+clientRoomA :: StateT ServerState IO RoomIndex
clientRoomA = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
io $ clientRoomM rnc ci
-client's :: (ClientInfo -> a) -> StateT (ServerState c) IO a
+client's :: (ClientInfo -> a) -> StateT ServerState IO a
client's f = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
io $ client'sM rnc f ci
-allClientsS :: StateT (ServerState c) IO [ClientInfo]
+allClientsS :: StateT ServerState IO [ClientInfo]
allClientsS = gets roomsClients >>= liftIO . clientsM
-roomClientsS :: RoomIndex -> StateT (ServerState c) IO [ClientInfo]
+roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
roomClientsS ri = do
rnc <- gets roomsClients
io $ roomClientsM rnc ri
-io :: IO a -> StateT (ServerState c) IO a
+io :: IO a -> StateT ServerState IO a
io = liftIO
--- a/gameServer/hedgewars-server.hs Sat Mar 05 22:39:26 2011 +0300
+++ b/gameServer/hedgewars-server.hs Sun Mar 06 21:54:37 2011 +0300
@@ -25,7 +25,7 @@
(setLevel INFO)
-server :: ServerInfo c -> IO ()
+server :: ServerInfo -> IO ()
server si = do
proto <- getProtocolNumber "tcp"
E.bracket