--- a/gameServer/Actions.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/Actions.hs Thu Mar 03 22:15:42 2011 +0300
@@ -22,7 +22,7 @@
import ServerState
import Consts
-data Action =
+data Action c =
AnswerClients ![ClientChan] ![B.ByteString]
| SendServerMessage
| SendServerVars
@@ -44,7 +44,7 @@
| ModifyClient (ClientInfo -> ClientInfo)
| ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
| ModifyRoom (RoomInfo -> RoomInfo)
- | ModifyServerInfo (ServerInfo -> ServerInfo)
+ | ModifyServerInfo (ServerInfo c -> ServerInfo c)
| AddRoom B.ByteString B.ByteString
| CheckRegistered
| ClearAccountsCache
@@ -56,9 +56,9 @@
| RestartServer Bool
-type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+type CmdHandler c = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action c]
-instance NFData Action where
+instance NFData (Action c) where
rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
rnf a = a `seq` ()
@@ -66,13 +66,13 @@
instance NFData (Chan a)
-othersChans :: StateT ServerState IO [ClientChan]
+othersChans :: StateT (ServerState c) IO [ClientChan]
othersChans = do
cl <- client's id
ri <- clientRoomA
liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
-processAction :: Action -> StateT ServerState IO ()
+processAction :: Action c -> StateT (ServerState c) IO ()
processAction (AnswerClients chans msg) =
--- a/gameServer/ConfigFile.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/ConfigFile.hs Thu Mar 03 22:15:42 2011 +0300
@@ -1,11 +1,23 @@
+{-# LANGUAGE RankNTypes #-}
module ConfigFile where
+import Data.Maybe
import Data.TConfig
+import qualified Data.ByteString.Char8 as B
-------------------
import CoreTypes
-readServerConfig :: ServerInfo -> IO ServerInfo
-readServerConfig = undefined
+readServerConfig serverInfo' = do
+ cfg <- readConfig "hedgewars-server.ini"
+ let si = serverInfo'{
+ dbHost = value "dbHost" cfg
+ , dbLogin = value "dbLogin" cfg
+ , dbPassword = value "dbPassword" cfg
+ , serverConfig = Just cfg
+ }
+ return si
+ where
+ value n c = B.pack . fromJust $ getValue n c
-writeServerConfig :: ServerInfo -> IO
+writeServerConfig :: ServerInfo c -> IO ()
writeServerConfig = undefined
--- a/gameServer/CoreTypes.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/CoreTypes.hs Thu Mar 03 22:15:42 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 =
+data ServerInfo c =
ServerInfo
{
isDedicated :: Bool,
@@ -138,13 +139,14 @@
lastLogins :: [(B.ByteString, (UTCTime, B.ByteString))],
restartPending :: Bool,
coreChan :: Chan CoreMessage,
- dbQueries :: Chan DBQuery
+ dbQueries :: Chan DBQuery,
+ serverConfig :: Maybe c
}
-instance Show ServerInfo where
+instance Show (ServerInfo c) where
show _ = "Server Info"
-newServerInfo :: Chan CoreMessage -> Chan DBQuery -> ServerInfo
+newServerInfo :: Chan CoreMessage -> Chan DBQuery -> Maybe c -> ServerInfo c
newServerInfo =
ServerInfo
True
--- a/gameServer/HWProtoCore.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/HWProtoCore.hs Thu Mar 03 22:15:42 2011 +0300
@@ -14,7 +14,7 @@
import RoomsAndClients
import Utils
-handleCmd, handleCmd_loggedin :: CmdHandler
+handleCmd, handleCmd_loggedin :: CmdHandler c
handleCmd ["PING"] = answerClient ["PONG"]
--- a/gameServer/HWProtoInRoomState.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/HWProtoInRoomState.hs Thu Mar 03 22:15:42 2011 +0300
@@ -15,7 +15,7 @@
import HandlerUtils
import RoomsAndClients
-handleCmd_inRoom :: CmdHandler
+handleCmd_inRoom :: CmdHandler c
handleCmd_inRoom ["CHAT", msg] = do
n <- clientNick
--- a/gameServer/HWProtoLobbyState.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/HWProtoLobbyState.hs Thu Mar 03 22:15:42 2011 +0300
@@ -15,7 +15,7 @@
import RoomsAndClients
-answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action]
+answerAllTeams :: ClientInfo -> [TeamInfo] -> [Action c]
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
+handleCmd_lobby :: CmdHandler c
handleCmd_lobby ["LIST"] = do
--- a/gameServer/HWProtoNEState.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/HWProtoNEState.hs Thu Mar 03 22:15:42 2011 +0300
@@ -11,7 +11,7 @@
import Utils
import RoomsAndClients
-handleCmd_NotEntered :: CmdHandler
+handleCmd_NotEntered :: CmdHandler c
handleCmd_NotEntered ["NICK", newNick] = do
(ci, irnc) <- ask
--- a/gameServer/HandlerUtils.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/HandlerUtils.hs Thu Mar 03 22:15:42 2011 +0300
@@ -51,7 +51,7 @@
(ci, rnc) <- ask
return [sendChan (rnc `client` ci)]
-answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action c]
answerClient msg = liftM ((: []) . flip AnswerClients msg) thisClientChans
allRoomInfos :: Reader (a, IRnC) [RoomInfo]
--- a/gameServer/OfficialServer/DBInteraction.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/OfficialServer/DBInteraction.hs Thu Mar 03 22:15:42 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. ServerInfo -> IO b
+--fakeDbConnection :: forall b. (ServerInfo c)-> IO b
fakeDbConnection si = forever $ do
q <- readChan $ dbQueries si
case q of
@@ -36,9 +36,9 @@
ClearCache -> return ()
SendStats {} -> return ()
-dbConnectionLoop :: forall b. ServerInfo -> IO b
+--dbConnectionLoop :: forall b. (ServerInfo c) -> IO b
#if defined(OFFICIAL_SERVER)
-flushRequests :: ServerInfo -> IO ()
+flushRequests :: (ServerInfo c) -> IO ()
flushRequests si = do
e <- isEmptyChan $ dbQueries si
unless e $ do
@@ -89,7 +89,7 @@
maybeException (Just a) = return a
maybeException Nothing = ioError (userError "Can't read")
-pipeDbConnection :: forall b. Map.Map ByteString (UTCTime, AccountInfo) -> ServerInfo -> Int -> IO b
+--pipeDbConnection :: forall b. Map.Map ByteString (UTCTime, AccountInfo) -> (ServerInfo c) -> Int -> IO b
pipeDbConnection accountsCache si errNum = do
(updatedCache, newErrNum) <-
Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, errNum + 1)) $ do
@@ -118,6 +118,6 @@
dbConnectionLoop = fakeDbConnection
#endif
-startDBConnection :: ServerInfo -> IO ()
+startDBConnection :: (ServerInfo c) -> IO ()
startDBConnection serverInfo =
forkIO (dbConnectionLoop serverInfo) >> return ()
--- a/gameServer/Opts.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/Opts.hs Thu Mar 03 22:15:42 2011 +0300
@@ -11,7 +11,7 @@
import CoreTypes
import Utils
-options :: [OptDescr (ServerInfo -> ServerInfo)]
+options :: [OptDescr (ServerInfo c -> ServerInfo c)]
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 -> ServerInfo
+ :: String -> ServerInfo c -> ServerInfo c
readListenPort str opts = opts{listenPort = readPort}
@@ -30,7 +30,7 @@
where
readDed = fromMaybe True (maybeRead str :: Maybe Bool)
-getOpts :: ServerInfo -> IO ServerInfo
+getOpts :: ServerInfo c -> IO (ServerInfo c)
getOpts opts = do
args <- getArgs
case getOpt Permute options args of
--- a/gameServer/ServerCore.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/ServerCore.hs Thu Mar 03 22:15:42 2011 +0300
@@ -23,14 +23,14 @@
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-reactCmd :: [B.ByteString] -> StateT ServerState IO ()
+reactCmd :: [B.ByteString] -> StateT (ServerState c) 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 IO ()
+mainLoop :: StateT (ServerState c) IO ()
mainLoop = forever $ do
-- get >>= \s -> put $! s
@@ -68,7 +68,7 @@
PingAll : [StatsAction | even tick]
-startServer :: ServerInfo -> Socket -> IO ()
+startServer :: ServerInfo c -> Socket -> IO ()
startServer si serverSocket = do
putStrLn $ "Listening on port " ++ show (listenPort si)
--- a/gameServer/ServerState.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/ServerState.hs Thu Mar 03 22:15:42 2011 +0300
@@ -15,33 +15,33 @@
import RoomsAndClients
import CoreTypes
-data ServerState = ServerState {
+data ServerState c = ServerState {
clientIndex :: !(Maybe ClientIndex),
- serverInfo :: !ServerInfo,
+ serverInfo :: !(ServerInfo c),
removedClients :: !(Set.Set ClientIndex),
roomsClients :: !MRnC
}
-clientRoomA :: StateT ServerState IO RoomIndex
+clientRoomA :: StateT (ServerState c) IO RoomIndex
clientRoomA = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
io $ clientRoomM rnc ci
-client's :: (ClientInfo -> a) -> StateT ServerState IO a
+client's :: (ClientInfo -> a) -> StateT (ServerState c) IO a
client's f = do
(Just ci) <- gets clientIndex
rnc <- gets roomsClients
io $ client'sM rnc f ci
-allClientsS :: StateT ServerState IO [ClientInfo]
+allClientsS :: StateT (ServerState c) IO [ClientInfo]
allClientsS = gets roomsClients >>= liftIO . clientsM
-roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
+roomClientsS :: RoomIndex -> StateT (ServerState c) IO [ClientInfo]
roomClientsS ri = do
rnc <- gets roomsClients
io $ roomClientsM rnc ri
-io :: IO a -> StateT ServerState IO a
+io :: IO a -> StateT (ServerState c) IO a
io = liftIO
--- a/gameServer/Utils.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/Utils.hs Thu Mar 03 22:15:42 2011 +0300
@@ -10,10 +10,10 @@
import System.IO
import qualified Data.List as List
import Control.Monad
--------------------------------------------------
import qualified Codec.Binary.Base64 as Base64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BW
+-------------------------------------------------
import CoreTypes
--- a/gameServer/hedgewars-server.hs Wed Mar 02 15:57:44 2011 -0500
+++ b/gameServer/hedgewars-server.hs Thu Mar 03 22:15:42 2011 +0300
@@ -8,6 +8,8 @@
import qualified Control.Exception as E
import System.Log.Logger
import System.Process
+import Data.TConfig
+import Data.Maybe
#if defined(OFFICIAL_SERVER)
import Control.Monad
#endif
@@ -28,7 +30,7 @@
(setLevel INFO)
-server :: ServerInfo -> IO ()
+server :: ServerInfo c -> IO ()
server si = do
proto <- getProtocolNumber "tcp"
E.bracket
@@ -58,11 +60,10 @@
dbQueriesChan <- newChan
coreChan' <- newChan
- serverInfo' <- getOpts $ newServerInfo coreChan' dbQueriesChan
+ serverInfo' <- getOpts $ newServerInfo coreChan' dbQueriesChan Nothing
#if defined(OFFICIAL_SERVER)
- [dbHost', dbLogin', dbPassword'] <- liftM read $ readFile "hedgewars-server.ini"
- let si = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
+ si <- readServerConfig serverInfo'
#else
let si = serverInfo'
#endif