--- a/gameServer/Actions.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/Actions.hs Mon May 10 17:48:06 2010 +0000
@@ -1,3 +1,4 @@
+
module Actions where
import Control.Concurrent
@@ -15,13 +16,13 @@
import CoreTypes
import Utils
import ClientIO
-import RoomsAndClients
+import ServerState
data Action =
AnswerClients [ClientChan] [String]
| SendServerMessage
| SendServerVars
- | RoomAddThisClient Int -- roomID
+ | RoomAddThisClient RoomIndex -- roomID
| RoomRemoveThisClient String
| RemoveTeam String
| RemoveRoom
@@ -30,12 +31,12 @@
| ProtocolError String
| Warning String
| ByeClient String
- | KickClient Int -- clID
- | KickRoomClient Int -- clID
+ | KickClient ClientIndex -- clID
+ | KickRoomClient ClientIndex -- clID
| BanClient String -- nick
- | RemoveClientTeams Int -- clID
+ | RemoveClientTeams ClientIndex -- clID
| ModifyClient (ClientInfo -> ClientInfo)
- | ModifyClient2 Int (ClientInfo -> ClientInfo)
+ | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
| ModifyRoom (RoomInfo -> RoomInfo)
| ModifyServerInfo (ServerInfo -> ServerInfo)
| AddRoom String String
@@ -49,21 +50,8 @@
type CmdHandler = [String] -> Reader (ClientIndex, IRnC) [Action]
-data ActionsState = ActionsState {
- clientIndex :: Maybe ClientIndex,
- serverInfo :: ServerInfo,
- roomsClients :: MRnC
- }
-
-clientRoomA :: StateT ActionsState IO RoomIndex
-clientRoomA = do
- (Just ci) <- gets clientIndex
- rnc <- gets roomsClients
- liftIO $ clientRoomM rnc ci
-replaceID a (b, c, d, e) = (a, c, d, e)
-
-processAction :: Action -> StateT ActionsState IO ()
+processAction :: Action -> StateT ServerState IO ()
processAction (AnswerClients chans msg) =
@@ -111,11 +99,12 @@
processAction $ RoomRemoveThisClient ("quit: " ++ msg)
return ()
+ chan <- clients sendChan
+
liftIO $ do
infoM "Clients" (show ci ++ " quits: " ++ msg)
- chan <- withRoomsAndClients rnc (getChan ci)
-
+
--mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
writeChan chan ["BYE", msg]
modifyRoom rnc (\r -> r{
@@ -123,10 +112,6 @@
playersIn = (playersIn r) - 1
--readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
}) ri
- removeClient rnc ci
- where
- getChan ci irnc = let cl = irnc `client` ci in (sendChan cl)
-
{-
where
@@ -149,21 +134,21 @@
else
[]
-}
-{-
-processAction (clID, serverInfo, rnc) (ModifyClient func) =
- return (clID, serverInfo, adjust func clID rnc)
-
+processAction (ModifyClient f) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ liftIO $ modifyClient rnc f ci
+ return ()
+
-processAction (clID, serverInfo, rnc) (ModifyClient2 cl2ID func) =
- return (clID, serverInfo, adjust func cl2ID rnc)
-
+processAction (ModifyRoom f) = do
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+ liftIO $ modifyRoom rnc f ri
+ return ()
-processAction (clID, serverInfo, rnc) (ModifyRoom func) =
- return (clID, serverInfo, clients, adjust func rID rooms)
- where
- rID = roomID $ clients ! clID
-
+{-
processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
return (clID, func serverInfo, rnc)
@@ -308,15 +293,17 @@
rID = roomID client
client = clients ! clID
rmTeamMsg = toEngineMsg $ 'F' : teamName
-
+-}
-processAction (clID, serverInfo, rnc) (CheckRegistered) = do
- writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
- return (clID, serverInfo, rnc)
- where
- client = clients ! clID
+processAction CheckRegistered = do
+ (Just ci) <- gets clientIndex
+ n <- clients nick
+ h <- clients host
+ db <- gets (dbQueries . serverInfo)
+ liftIO $ writeChan db $ CheckAccount ci n h
+ return ()
-
+{-
processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do
writeChan (dbQueries serverInfo) ClearCache
return (clID, serverInfo, rnc)
@@ -397,7 +384,7 @@
return (ci, serverInfo)
-}
-
+
{-
--- a/gameServer/CMakeLists.txt Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/CMakeLists.txt Mon May 10 17:48:06 2010 +0000
@@ -18,13 +18,15 @@
Opts.hs
ServerCore.hs
Utils.hs
+ RoomsAndClients.hs
+ ServerState.hs
+ Store.hs
hedgewars-server.hs
)
set(hwserv_main ${hedgewars_SOURCE_DIR}/gameServer/hedgewars-server.hs)
set(ghc_flags
- -O2
--make ${hwserv_main}
-i${hedgewars_SOURCE_DIR}/gameServer
-o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}
--- a/gameServer/ClientIO.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/ClientIO.hs Mon May 10 17:48:06 2010 +0000
@@ -14,22 +14,29 @@
listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> ClientIndex -> IO ()
listenLoop handle linesNumber buf chan clientID = do
+ putStrLn $ show handle ++ show buf ++ show clientID
str <- liftM BUTF8.toString $ B.hGetLine handle
if (linesNumber > 50) || (length str > 450) then
- writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
+ protocolViolationMsg >> freeClient
else
if str == "" then do
- writeChan chan $ ClientMessage (clientID, buf)
+ writeChan chan $ ClientMessage (clientID, reverse buf)
yield
listenLoop handle 0 [] chan clientID
else
- listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
+ listenLoop handle (linesNumber + 1) (str : buf) chan clientID
+ where
+ protocolViolationMsg = writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
+ freeClient = writeChan chan $ FreeClient clientID
+
clientRecvLoop :: Handle -> Chan CoreMessage -> ClientIndex -> IO ()
clientRecvLoop handle chan clientID =
listenLoop handle 0 [] chan clientID
- `catch` (\e -> clientOff (show e) >> return ())
- where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
+ `catch` (\e -> clientOff (show e) >> freeClient >> return ())
+ where
+ clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
+ freeClient = writeChan chan $ FreeClient clientID
clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> ClientIndex -> IO()
clientSendLoop handle coreChan chan clientID = do
--- a/gameServer/CoreTypes.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/CoreTypes.hs Mon May 10 17:48:06 2010 +0000
@@ -171,6 +171,7 @@
| ClientMessage (ClientIndex, [String])
| ClientAccountInfo (ClientIndex, AccountInfo)
| TimerAction Int
+ | FreeClient ClientIndex
type MRnC = MRoomsAndClients RoomInfo ClientInfo
type IRnC = IRoomsAndClients RoomInfo ClientInfo
--- a/gameServer/HWProtoCore.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/HWProtoCore.hs Mon May 10 17:48:06 2010 +0000
@@ -25,7 +25,7 @@
msg = if not $ null xs then head xs else ""
{-
-handleCmd clID clients _ ["PONG"] =
+handleCmd ["PONG"] =
if pingsQueue client == 0 then
[ProtocolError "Protocol violation"]
else
@@ -37,9 +37,9 @@
handleCmd cmd = do
(ci, irnc) <- ask
if logonPassed (irnc `client` ci) then
- handleCmd_NotEntered cmd
+ handleCmd_loggedin cmd
else
- handleCmd_loggedin cmd
+ handleCmd_NotEntered cmd
{-
handleCmd_loggedin clID clients rooms ["INFO", asknick] =
--- a/gameServer/HWProtoNEState.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/HWProtoNEState.hs Mon May 10 17:48:06 2010 +0000
@@ -4,38 +4,46 @@
import Maybe
import Data.List
import Data.Word
+import Control.Monad.Reader
--------------------------------------
import CoreTypes
import Actions
import Utils
+import RoomsAndClients
handleCmd_NotEntered :: CmdHandler
-{-
-handleCmd_NotEntered clID clients _ ["NICK", newNick]
- | not . null $ nick client = [ProtocolError "Nickname already chosen"]
- | haveSameNick = [AnswerThisClient ["WARNING", "Nickname already in use"], ByeClient ""]
- | illegalName newNick = [ByeClient "Illegal nickname"]
- | otherwise =
- ModifyClient (\c -> c{nick = newNick}) :
- AnswerThisClient ["NICK", newNick] :
- [CheckRegistered | clientProto client /= 0]
+handleCmd_NotEntered ["NICK", newNick] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ if not . null $ nick cl then return [ProtocolError "Nickname already chosen"]
+ else
+ if haveSameNick irnc then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""]
+ else
+ if illegalName newNick then return [ByeClient "Illegal nickname"]
+ else
+ return $
+ ModifyClient (\c -> c{nick = newNick}) :
+ AnswerClients [sendChan cl] ["NICK", newNick] :
+ [CheckRegistered | clientProto cl /= 0]
where
- client = clients IntMap.! clID
- haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
-
+ haveSameNick irnc = False --isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
-handleCmd_NotEntered clID clients _ ["PROTO", protoNum]
- | clientProto client > 0 = [ProtocolError "Protocol already known"]
- | parsedProto == 0 = [ProtocolError "Bad number"]
- | otherwise =
- ModifyClient (\c -> c{clientProto = parsedProto}) :
- AnswerThisClient ["PROTO", show parsedProto] :
- [CheckRegistered | (not . null) (nick client)]
+handleCmd_NotEntered ["PROTO", protoNum] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
+ else
+ if parsedProto == 0 then return [ProtocolError "Bad number"]
+ else
+ return $
+ ModifyClient (\c -> c{clientProto = parsedProto}) :
+ AnswerClients [sendChan cl] ["PROTO", show parsedProto] :
+ [CheckRegistered | (not . null) (nick cl)]
where
- client = clients IntMap.! clID
parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
+{-
handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
if passwd == webPassword client then
--- a/gameServer/RoomsAndClients.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/RoomsAndClients.hs Mon May 10 17:48:06 2010 +0000
@@ -16,6 +16,7 @@
clientRoom,
clientRoomM,
client,
+ clientsM,
allClients,
withRoomsAndClients,
showRooms,
@@ -135,6 +136,9 @@
clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex
clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci)
+clientsM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a
+clientsM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci)
+
withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a
withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =
--- a/gameServer/ServerCore.hs Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/ServerCore.hs Mon May 10 17:48:06 2010 +0000
@@ -14,21 +14,21 @@
import HWProtoCore
import Actions
import OfficialServer.DBInteraction
-import RoomsAndClients
+import ServerState
timerLoop :: Int -> Chan CoreMessage -> IO()
timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-reactCmd :: [String] -> StateT ActionsState IO ()
+reactCmd :: [String] -> 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 processAction
-mainLoop :: StateT ActionsState IO ()
+mainLoop :: StateT ServerState IO ()
mainLoop = forever $ do
si <- gets serverInfo
r <- liftIO $ readChan $ coreChan si
@@ -64,6 +64,11 @@
-- foldM processAction (0, serverInfo, rnc) $
-- PingAll : [StatsAction | even tick]
+ FreeClient ci -> do
+ rnc <- gets roomsClients
+ liftIO $ removeClient rnc ci
+
+
startServer :: ServerInfo -> Socket -> IO ()
startServer serverInfo serverSocket = do
putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
@@ -81,6 +86,6 @@
rnc <- newRoomsAndClients newRoom
- forkIO $ evalStateT mainLoop (ActionsState Nothing serverInfo rnc)
+ forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc)
forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ServerState.hs Mon May 10 17:48:06 2010 +0000
@@ -0,0 +1,32 @@
+module ServerState
+ (
+ module RoomsAndClients,
+ clientRoomA,
+ ServerState(..),
+ clients
+ ) where
+
+import Control.Monad.State
+----------------------
+import RoomsAndClients
+import CoreTypes
+
+data ServerState = ServerState {
+ clientIndex :: Maybe ClientIndex,
+ serverInfo :: ServerInfo,
+ roomsClients :: MRnC
+ }
+
+
+clientRoomA :: StateT ServerState IO RoomIndex
+clientRoomA = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ liftIO $ clientRoomM rnc ci
+
+clients :: (ClientInfo -> a) -> StateT ServerState IO a
+clients f = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ liftIO $ clientsM rnc f ci
+
\ No newline at end of file