Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
authorunc0rr
Thu, 03 Mar 2011 22:15:13 +0300
changeset 4975 31da8979e5b1
parent 4974 078cd026a7b1
child 4980 3b40c80c0fe3
Use Data.TConfig to read and store server config in hedgewars.ini (a little bit of hate to the author for not exporting Conf type)
gameServer/Actions.hs
gameServer/ConfigFile.hs
gameServer/CoreTypes.hs
gameServer/HWProtoCore.hs
gameServer/HWProtoInRoomState.hs
gameServer/HWProtoLobbyState.hs
gameServer/HWProtoNEState.hs
gameServer/HandlerUtils.hs
gameServer/OfficialServer/DBInteraction.hs
gameServer/Opts.hs
gameServer/ServerCore.hs
gameServer/ServerState.hs
gameServer/Utils.hs
gameServer/hedgewars-server.hs
--- a/gameServer/Actions.hs	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/Actions.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/ConfigFile.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/CoreTypes.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/HWProtoCore.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/HWProtoInRoomState.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/HWProtoLobbyState.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/HWProtoNEState.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/HandlerUtils.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/OfficialServer/DBInteraction.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/Opts.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/ServerCore.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/ServerState.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/Utils.hs	Thu Mar 03 22:15:13 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	Mon Feb 28 22:28:43 2011 +0300
+++ b/gameServer/hedgewars-server.hs	Thu Mar 03 22:15:13 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