--- a/gameServer/Actions.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/Actions.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,134 +1,171 @@
-{-# LANGUAGE OverloadedStrings #-}
module Actions where
-import Control.Concurrent
+import Control.Concurrent.STM
import Control.Concurrent.Chan
+import Data.IntMap
import qualified Data.IntSet as IntSet
-import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import System.Log.Logger
-import Control.Monad
+import Monad
import Data.Time
-import Data.Maybe
-import Control.Monad.Reader
-import Control.Monad.State.Strict
-import qualified Data.ByteString.Char8 as B
+import Maybe
-----------------------------
import CoreTypes
import Utils
-import ClientIO
-import ServerState
data Action =
- AnswerClients ![ClientChan] ![B.ByteString]
+ AnswerThisClient [String]
+ | AnswerAll [String]
+ | AnswerAllOthers [String]
+ | AnswerThisRoom [String]
+ | AnswerOthersInRoom [String]
+ | AnswerSameClan [String]
+ | AnswerLobby [String]
| SendServerMessage
| SendServerVars
- | MoveToRoom RoomIndex
- | MoveToLobby B.ByteString
- | RemoveTeam B.ByteString
+ | RoomAddThisClient Int -- roomID
+ | RoomRemoveThisClient String
+ | RemoveTeam String
| RemoveRoom
| UnreadyRoomClients
- | JoinLobby
- | ProtocolError B.ByteString
- | Warning B.ByteString
- | ByeClient B.ByteString
- | KickClient ClientIndex
- | KickRoomClient ClientIndex
- | BanClient B.ByteString -- nick
- | RemoveClientTeams ClientIndex
+ | MoveToLobby
+ | ProtocolError String
+ | Warning String
+ | ByeClient String
+ | KickClient Int -- clID
+ | KickRoomClient Int -- clID
+ | BanClient String -- nick
+ | RemoveClientTeams Int -- clID
| ModifyClient (ClientInfo -> ClientInfo)
- | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
+ | ModifyClient2 Int (ClientInfo -> ClientInfo)
| ModifyRoom (RoomInfo -> RoomInfo)
| ModifyServerInfo (ServerInfo -> ServerInfo)
- | AddRoom B.ByteString B.ByteString
+ | AddRoom String String
| CheckRegistered
| ClearAccountsCache
| ProcessAccountInfo AccountInfo
| Dump
| AddClient ClientInfo
- | DeleteClient ClientIndex
| PingAll
| StatsAction
-type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
+
+replaceID a (b, c, d, e) = (a, c, d, e)
+
+processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
+ writeChan (sendChan $ clients ! clID) msg
+ return (clID, serverInfo, clients, rooms)
-processAction :: Action -> StateT ServerState IO ()
+processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
+ mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)
+ return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do
+ mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $
+ Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients)
+ return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
+ mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
+ return (clID, serverInfo, clients, rooms)
+ where
+ roomClients = IntSet.elems $ playersIDs room
+ room = rooms ! rID
+ rID = roomID client
+ client = clients ! clID
-processAction (AnswerClients chans msg) = do
- liftIO $ map (flip seq ()) chans `seq` map (flip seq ()) msg `seq` mapM_ (flip writeChan msg) chans
+processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do
+ mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients
+ return (clID, serverInfo, clients, rooms)
+ where
+ roomClients = IntSet.elems $ playersIDs room
+ room = rooms ! rID
+ rID = roomID client
+ client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
+ mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
+ return (clID, serverInfo, clients, rooms)
+ where
+ roomClients = IntSet.elems $ playersIDs room
+ room = rooms ! 0
-processAction SendServerMessage = do
- chan <- client's sendChan
- protonum <- client's clientProto
- si <- liftM serverInfo get
- let message = if protonum < latestReleaseVersion si then
+processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do
+ mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec
+ return (clID, serverInfo, clients, rooms)
+ where
+ otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room)
+ sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators
+ spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients
+ sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients
+ thisClan = clientClan client
+ room = rooms ! rID
+ rID = roomID client
+ client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) SendServerMessage = do
+ writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
+ return (clID, serverInfo, clients, rooms)
+ where
+ client = clients ! clID
+ message si = if clientProto client < latestReleaseVersion si then
serverMessageForOldVersions si
else
serverMessage si
- processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
-{-
-processAction (clID, serverInfo, rnc) SendServerVars = do
+processAction (clID, serverInfo, clients, rooms) SendServerVars = do
writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
- return (clID, serverInfo, rnc)
+ return (clID, serverInfo, clients, rooms)
where
client = clients ! clID
vars = [
- "MOTD_NEW", serverMessage serverInfo,
- "MOTD_OLD", serverMessageForOldVersions serverInfo,
+ "MOTD_NEW", serverMessage serverInfo,
+ "MOTD_OLD", serverMessageForOldVersions serverInfo,
"LATEST_PROTO", show $ latestReleaseVersion serverInfo
]
--}
+processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
+ writeChan (sendChan $ clients ! clID) ["ERROR", msg]
+ return (clID, serverInfo, clients, rooms)
-processAction (ProtocolError msg) = do
- chan <- client's sendChan
- processAction $ AnswerClients [chan] ["ERROR", msg]
+
+processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
+ writeChan (sendChan $ clients ! clID) ["WARNING", msg]
+ return (clID, serverInfo, clients, rooms)
-processAction (Warning msg) = do
- chan <- client's sendChan
- processAction $ AnswerClients [chan] ["WARNING", msg]
-
-processAction (ByeClient msg) = do
- (Just ci) <- gets clientIndex
- rnc <- gets roomsClients
- ri <- clientRoomA
-
- chan <- client's sendChan
- ready <- client's isReady
+processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do
+ infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg)
+ (_, _, newClients, newRooms) <-
+ if roomID client /= 0 then
+ processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit"
+ else
+ return (clID, serverInfo, clients, rooms)
- when (ri /= lobbyId) $ do
- processAction $ MoveToLobby ("quit: " `B.append` msg)
- liftIO $ modifyRoom rnc (\r -> r{
- --playersIDs = IntSet.delete ci (playersIDs r)
- playersIn = (playersIn r) - 1,
- readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
- }) ri
- return ()
-
- liftIO $ do
- infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
-
- --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
-
- processAction $ AnswerClients [chan] ["BYE", msg]
-
- s <- get
- put $! s{removedClients = ci `Set.insert` removedClients s}
-
-processAction (DeleteClient ci) = do
- rnc <- gets roomsClients
- liftIO $ removeClient rnc ci
-
- s <- get
- put $! s{removedClients = ci `Set.delete` removedClients s}
-
-{-
+ mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom
+ writeChan (sendChan $ clients ! clID) ["BYE", msg]
+ return (
+ 0,
+ serverInfo,
+ delete clID newClients,
+ adjust (\r -> r{
+ playersIDs = IntSet.delete clID (playersIDs r),
+ playersIn = (playersIn r) - 1,
+ readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
+ }) (roomID $ newClients ! clID) newRooms
+ )
where
client = clients ! clID
clientNick = nick client
@@ -147,57 +184,46 @@
else
[AnswerAll ["LOBBY:LEFT", clientNick]]
else
- []
--}
+ []
+
+
+processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
+ return (clID, serverInfo, adjust func clID clients, rooms)
+
-processAction (ModifyClient f) = do
- (Just ci) <- gets clientIndex
- rnc <- gets roomsClients
- liftIO $ modifyClient rnc f ci
- return ()
+processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
+ return (clID, serverInfo, adjust func cl2ID clients, rooms)
+
-processAction (ModifyClient2 ci f) = do
- rnc <- gets roomsClients
- liftIO $ modifyClient rnc f ci
- return ()
+processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
+ return (clID, serverInfo, clients, adjust func rID rooms)
+ where
+ rID = roomID $ clients ! clID
-processAction (ModifyRoom f) = do
- rnc <- gets roomsClients
- ri <- clientRoomA
- liftIO $ modifyRoom rnc f ri
- return ()
+processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
+ return (clID, func serverInfo, clients, rooms)
-{-
-
-processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
- return (clID, func serverInfo, rnc)
-
--}
-processAction (MoveToRoom ri) = do
- (Just ci) <- gets clientIndex
- rnc <- gets roomsClients
- liftIO $ do
- modifyClient rnc (\cl -> cl{teamsInGame = 0}) ci
- modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri
-
- liftIO $ moveClientToRoom rnc ri ci
-
- chans <- liftM (map sendChan) $ roomClientsS ri
- clNick <- client's nick
+processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) =
+ processAction (
+ clID,
+ serverInfo,
+ adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
+ adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
+ adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
+ ) joinMsg
+ where
+ client = clients ! clID
+ joinMsg = if rID == 0 then
+ AnswerAllOthers ["LOBBY:JOINED", nick client]
+ else
+ AnswerThisRoom ["JOINED", nick client]
- processAction $ AnswerClients chans ["JOINED", clNick]
-processAction (MoveToLobby msg) = do
- (Just ci) <- gets clientIndex
- --ri <- clientRoomA
- rnc <- gets roomsClients
-
- liftIO $ moveClientToLobby rnc ci
-
-{-
+processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do
(_, _, newClients, newRooms) <-
+ if roomID client /= 0 then
if isMaster client then
if (gameinprogress room) && (playersIn room > 1) then
(changeMaster >>= (\state -> foldM processAction state
@@ -205,15 +231,16 @@
AnswerOthersInRoom ["WARNING", "Admin left the room"],
RemoveClientTeams clID]))
else -- not in game
- processAction (clID, serverInfo, rnc) RemoveRoom
+ processAction (clID, serverInfo, clients, rooms) RemoveRoom
else -- not master
foldM
processAction
- (clID, serverInfo, rnc)
+ (clID, serverInfo, clients, rooms)
[AnswerOthersInRoom ["LEFT", nick client, msg],
RemoveClientTeams clID]
-
-
+ else -- in lobby
+ return (clID, serverInfo, clients, rooms)
+
return (
clID,
serverInfo,
@@ -232,7 +259,7 @@
}
insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
changeMaster = do
- processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
+ processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
return (
clID,
serverInfo,
@@ -243,35 +270,34 @@
otherPlayersSet = IntSet.delete clID (playersIDs room)
newMasterId = IntSet.findMin otherPlayersSet
newMasterClient = clients ! newMasterId
--}
+
-processAction (AddRoom roomName roomPassword) = do
- Just clId <- gets clientIndex
- rnc <- gets roomsClients
- proto <- liftIO $ client'sM rnc clientProto clId
-
+processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
+ let newServerInfo = serverInfo {nextRoomID = newID}
let room = newRoom{
- masterID = clId,
+ roomUID = newID,
+ masterID = clID,
name = roomName,
password = roomPassword,
- roomProto = proto
+ roomProto = (clientProto client)
}
- rId <- liftIO $ addRoom rnc room
-
- processAction $ MoveToRoom rId
-
- chans <- liftM (map sendChan) $! roomClientsS lobbyId
+ processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
- mapM_ processAction [
- AnswerClients chans ["ROOM", "ADD", roomName]
- , ModifyClient (\cl -> cl{isMaster = True})
- ]
+ processAction (
+ clID,
+ newServerInfo,
+ adjust (\cl -> cl{isMaster = True}) clID clients,
+ insert newID room rooms
+ ) $ RoomAddThisClient newID
+ where
+ newID = (nextRoomID serverInfo) - 1
+ client = clients ! clID
-{-
-processAction (clID, serverInfo, rnc) (RemoveRoom) = do
- processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room]
- processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
+
+processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do
+ processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room]
+ processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
return (clID,
serverInfo,
Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
@@ -282,163 +308,139 @@
rID = roomID client
client = clients ! clID
--}
-processAction (UnreadyRoomClients) = do
- rnc <- gets roomsClients
- ri <- clientRoomA
- roomPlayers <- roomClientsS ri
- roomClIDs <- liftIO $ roomClientsIndicesM rnc ri
- processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
- liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
- processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
+
+processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do
+ processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
+ return (clID,
+ serverInfo,
+ Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
+ adjust (\r -> r{readyPlayers = 0}) rID rooms)
+ where
+ room = rooms ! rID
+ rID = roomID client
+ client = clients ! clID
+ roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
+ roomPlayersIDs = IntSet.elems $ playersIDs room
-processAction (RemoveTeam teamName) = do
- rnc <- gets roomsClients
- cl <- client's id
- ri <- clientRoomA
- inGame <- liftIO $ room'sM rnc gameinprogress ri
- chans <- liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
- if inGame then
- mapM_ processAction [
- AnswerClients chans ["REMOVE_TEAM", teamName],
- ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
- ]
+processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do
+ newRooms <- if not $ gameinprogress room then
+ do
+ processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
+ return $
+ adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
else
- mapM_ processAction [
- AnswerClients chans ["EM", rmTeamMsg],
- ModifyRoom (\r -> r{
- teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
- leftTeams = teamName : leftTeams r,
- roundMsgs = roundMsgs r Seq.|> rmTeamMsg
- })
- ]
+ do
+ processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg]
+ return $
+ adjust (\r -> r{
+ teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
+ leftTeams = teamName : leftTeams r,
+ roundMsgs = roundMsgs r Seq.|> rmTeamMsg
+ }) rID rooms
+ return (clID, serverInfo, clients, newRooms)
where
- rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
+ room = rooms ! rID
+ rID = roomID client
+ client = clients ! clID
+ rmTeamMsg = toEngineMsg $ 'F' : teamName
-processAction CheckRegistered = do
- (Just ci) <- gets clientIndex
- n <- client's nick
- h <- client's 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)
+processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do
+ writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
+ return (clID, serverInfo, clients, rooms)
where
client = clients ! clID
-processAction (clID, serverInfo, rnc) (Dump) = do
+processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do
+ writeChan (dbQueries serverInfo) ClearCache
+ return (clID, serverInfo, clients, rooms)
+ where
+ client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (Dump) = do
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
- return (clID, serverInfo, rnc)
--}
+ return (clID, serverInfo, clients, rooms)
-processAction (ProcessAccountInfo info) =
+
+processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
case info of
HasAccount passwd isAdmin -> do
- chan <- client's sendChan
- processAction $ AnswerClients [chan] ["ASKPASSWORD"]
+ infoM "Clients" $ show clID ++ " has account"
+ writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
+ return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms)
Guest -> do
- processAction JoinLobby
+ infoM "Clients" $ show clID ++ " is guest"
+ processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
Admin -> do
- mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
- chan <- client's sendChan
- processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
+ infoM "Clients" $ show clID ++ " is admin"
+ foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
-processAction JoinLobby = do
- chan <- client's sendChan
- clientNick <- client's nick
- (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS
- mapM_ processAction $
- (AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
- : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
- ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
+processAction (clID, serverInfo, clients, rooms) (MoveToLobby) =
+ foldM processAction (clID, serverInfo, clients, rooms) $
+ (RoomAddThisClient 0)
+ : answerLobbyNicks
+ ++ [SendServerMessage]
-{-
-processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
- processAction (
- clID,
- serverInfo,
- adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
- adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
- adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
- ) joinMsg
+ -- ++ (answerServerMessage client clients)
where
- client = clients ! clID
- joinMsg = if rID == 0 then
- AnswerAllOthers ["LOBBY:JOINED", nick client]
- else
- AnswerThisRoom ["JOINED", nick client]
-
-processAction (clID, serverInfo, rnc) (KickClient kickID) =
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked")
+ lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
+ answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
-processAction (clID, serverInfo, rnc) (BanClient banNick) =
- return (clID, serverInfo, rnc)
+processAction (clID, serverInfo, clients, rooms) (KickClient kickID) =
+ liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")
+
+
+processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
+ return (clID, serverInfo, clients, rooms)
-processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do
+processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do
writeChan (sendChan $ clients ! kickID) ["KICKED"]
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked")
+ liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")
-processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) =
+processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
liftM2 replaceID (return clID) $
- foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions
+ foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions
where
client = clients ! teamsClID
room = rooms ! (roomID client)
teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
--}
+
-processAction (AddClient client) = do
- rnc <- gets roomsClients
- si <- gets serverInfo
- liftIO $ do
- ci <- addClient rnc client
- forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci
- forkIO $ clientSendLoop (clientSocket client) (sendChan client) ci
+processAction (clID, serverInfo, clients, rooms) (AddClient client) = do
+ let updatedClients = insert (clientUID client) client clients
+ infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client))
+ writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
- infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client))
-
- processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
-{- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
+ let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
- if False && (isJust $ host client `Prelude.lookup` newLogins) then
- processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast"
- else
- return (ci, serverInfo)
--}
-
+ if isJust $ host client `Prelude.lookup` newLogins then
+ processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"
+ else
+ return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)
-processAction PingAll = do
- rnc <- gets roomsClients
- liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
- cis <- liftIO $ allClientsM rnc
- chans <- liftIO $ mapM (client'sM rnc sendChan) cis
- liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
- processAction $ AnswerClients chans ["PING"]
+processAction (clID, serverInfo, clients, rooms) PingAll = do
+ (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients
+ processAction (clID,
+ serverInfo,
+ Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
+ newRooms) $ AnswerAll ["PING"]
where
- kickTimeouted rnc ci = do
- pq <- liftIO $ client'sM rnc pingsQueue ci
- when (pq > 0) $
- withStateT (\as -> as{clientIndex = Just ci}) $
- processAction (ByeClient "Ping timeout")
+ kickTimeouted (clID, serverInfo, clients, rooms) client =
+ if pingsQueue client > 0 then
+ processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout"
+ else
+ return (clID, serverInfo, clients, rooms)
-processAction (StatsAction) = do
- rnc <- gets roomsClients
- si <- gets serverInfo
- (roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats
- liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
- where
- stats irnc = (length $ allRooms irnc, length $ allClients irnc)
-
+processAction (clID, serverInfo, clients, rooms) (StatsAction) = do
+ writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
+ return (clID, serverInfo, clients, rooms)
--- a/gameServer/CMakeLists.txt Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/CMakeLists.txt Fri Nov 12 09:49:46 2010 +0100
@@ -1,48 +1,43 @@
find_program(ghc_executable ghc)
if(NOT ghc_executable)
- message(FATAL_ERROR "Cannot find GHC")
+ message(FATAL_ERROR "Cannot find GHC")
endif(NOT ghc_executable)
set(hwserver_sources
- OfficialServer/DBInteraction.hs
- Actions.hs
- ClientIO.hs
- CoreTypes.hs
- HWProtoCore.hs
- HWProtoInRoomState.hs
- HWProtoLobbyState.hs
- HWProtoNEState.hs
- HandlerUtils.hs
- NetRoutines.hs
- Opts.hs
- RoomsAndClients.hs
- ServerCore.hs
- ServerState.hs
- Store.hs
- Utils.hs
- hedgewars-server.hs
- )
+ OfficialServer/DBInteraction.hs
+ Actions.hs
+ ClientIO.hs
+ CoreTypes.hs
+ HWProtoCore.hs
+ HWProtoInRoomState.hs
+ HWProtoLobbyState.hs
+ HWProtoNEState.hs
+ NetRoutines.hs
+ Opts.hs
+ ServerCore.hs
+ Utils.hs
+ hedgewars-server.hs
+ )
set(hwserv_main ${hedgewars_SOURCE_DIR}/gameServer/hedgewars-server.hs)
set(ghc_flags
- -Wall
- --make ${hwserv_main}
- -i${hedgewars_SOURCE_DIR}/gameServer
- -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}
- -odir ${CMAKE_CURRENT_BINARY_DIR}
- -hidir ${CMAKE_CURRENT_BINARY_DIR})
+ --make ${hwserv_main}
+ -i${hedgewars_SOURCE_DIR}/gameServer
+ -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}
+ -odir ${CMAKE_CURRENT_BINARY_DIR}
+ -hidir ${CMAKE_CURRENT_BINARY_DIR})
set(ghc_flags ${haskell_compiler_flags_cmn} ${ghc_flags})
add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}"
- COMMAND "${ghc_executable}"
- ARGS ${ghc_flags}
- MAIN_DEPENDENCY ${hwserv_main}
- DEPENDS ${hwserver_sources}
- )
+ COMMAND "${ghc_executable}"
+ ARGS ${ghc_flags}
+ MAIN_DEPENDENCY ${hwserv_main}
+ DEPENDS ${hwserver_sources}
+ )
add_custom_target(hedgewars-server ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}")
--- a/gameServer/ClientIO.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/ClientIO.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module ClientIO where
import qualified Control.Exception as Exception
@@ -6,71 +6,45 @@
import Control.Concurrent
import Control.Monad
import System.IO
-import Network
-import Network.Socket.ByteString
-import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.UTF8 as BUTF8
+import qualified Data.ByteString as B
----------------
import CoreTypes
-import RoomsAndClients
-import Utils
-
-pDelim :: B.ByteString
-pDelim = B.pack "\n\n"
-
-bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
-bs2Packets buf = unfoldrE extractPackets buf
- where
- extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString)
- extractPackets buf =
- let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in
- let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in
- if B.null bufTail then
- Left bsPacket
- else
- if B.null bsPacket then
- Left bufTail
- else
- Right (B.splitWith (== '\n') bsPacket, bufTail)
-
+listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
+listenLoop handle linesNumber buf chan clientID = do
+ str <- liftM BUTF8.toString $ B.hGetLine handle
+ if (linesNumber > 50) || (length str > 450) then
+ writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
+ else
+ if str == "" then do
+ writeChan chan $ ClientMessage (clientID, buf)
+ yield
+ listenLoop handle 0 [] chan clientID
+ else
+ listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
-listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
-listenLoop sock chan ci = recieveWithBufferLoop B.empty
- where
- recieveWithBufferLoop recvBuf = do
- recvBS <- recv sock 4096
--- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS)
- unless (B.null recvBS) $ do
- let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
- forM_ packets sendPacket
- recieveWithBufferLoop newrecvBuf
-
- sendPacket packet = writeChan chan $ ClientMessage (ci, packet)
-
+clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> 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
-clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
-clientRecvLoop s chan ci = do
- msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show)
- clientOff msg
- where
- clientOff msg = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci]
-
-
+clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
+clientSendLoop handle coreChan chan clientID = do
+ answer <- readChan chan
+ doClose <- Exception.handle
+ (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
+ B.hPutStrLn handle $ BUTF8.fromString $ unlines answer
+ hFlush handle
+ return $ isQuit answer
-clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO ()
-clientSendLoop s chan ci = do
- answer <- readChan chan
- Exception.handle
- (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
- sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n')
-
- if (isQuit answer) then
- Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
+ if doClose then
+ Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
else
- clientSendLoop s chan ci
+ clientSendLoop handle coreChan chan clientID
where
- --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
- sendQuit e = putStrLn $ show e
+ sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
isQuit ("BYE":xs) = True
isQuit _ = False
--- a/gameServer/CoreTypes.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/CoreTypes.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
module CoreTypes where
import System.IO
@@ -6,95 +5,102 @@
import Control.Concurrent.STM
import Data.Word
import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Sequence(Seq, empty)
import Data.Time
import Network
import Data.Function
-import Data.ByteString.Char8 as B
-import RoomsAndClients
-
-type ClientChan = Chan [B.ByteString]
data ClientInfo =
ClientInfo
{
- sendChan :: ClientChan,
- clientSocket :: Socket,
- host :: B.ByteString,
+ clientUID :: !Int,
+ sendChan :: Chan [String],
+ clientHandle :: Handle,
+ host :: String,
connectTime :: UTCTime,
- nick :: B.ByteString,
- webPassword :: B.ByteString,
+ nick :: String,
+ webPassword :: String,
logonPassed :: Bool,
clientProto :: !Word16,
- roomID :: RoomIndex,
+ roomID :: !Int,
pingsQueue :: !Word,
isMaster :: Bool,
- isReady :: !Bool,
+ isReady :: Bool,
isAdministrator :: Bool,
- clientClan :: B.ByteString,
+ clientClan :: String,
teamsInGame :: Word
}
instance Show ClientInfo where
- show ci = " nick: " ++ (unpack $ nick ci) ++ " host: " ++ (unpack $ host ci)
+ show ci = show (clientUID ci)
+ ++ " nick: " ++ (nick ci)
+ ++ " host: " ++ (host ci)
instance Eq ClientInfo where
- (==) = (==) `on` clientSocket
+ (==) = (==) `on` clientHandle
data HedgehogInfo =
- HedgehogInfo B.ByteString B.ByteString
+ HedgehogInfo String String
data TeamInfo =
TeamInfo
{
- teamownerId :: ClientIndex,
- teamowner :: B.ByteString,
- teamname :: B.ByteString,
- teamcolor :: B.ByteString,
- teamgrave :: B.ByteString,
- teamfort :: B.ByteString,
- teamvoicepack :: B.ByteString,
- teamflag :: B.ByteString,
+ teamownerId :: !Int,
+ teamowner :: String,
+ teamname :: String,
+ teamcolor :: String,
+ teamgrave :: String,
+ teamfort :: String,
+ teamvoicepack :: String,
+ teamflag :: String,
difficulty :: Int,
hhnum :: Int,
hedgehogs :: [HedgehogInfo]
}
instance Show TeamInfo where
- show ti = "owner: " ++ (unpack $ teamowner ti)
- ++ "name: " ++ (unpack $ teamname ti)
- ++ "color: " ++ (unpack $ teamcolor ti)
+ show ti = "owner: " ++ (teamowner ti)
+ ++ "name: " ++ (teamname ti)
+ ++ "color: " ++ (teamcolor ti)
data RoomInfo =
RoomInfo
{
- masterID :: ClientIndex,
- name :: B.ByteString,
- password :: B.ByteString,
+ roomUID :: !Int,
+ masterID :: !Int,
+ name :: String,
+ password :: String,
roomProto :: Word16,
teams :: [TeamInfo],
gameinprogress :: Bool,
playersIn :: !Int,
readyPlayers :: !Int,
+ playersIDs :: IntSet.IntSet,
isRestrictedJoins :: Bool,
isRestrictedTeams :: Bool,
- roundMsgs :: Seq B.ByteString,
- leftTeams :: [B.ByteString],
+ roundMsgs :: Seq String,
+ leftTeams :: [String],
teamsAtStart :: [TeamInfo],
- params :: Map.Map B.ByteString [B.ByteString]
+ params :: Map.Map String [String]
}
instance Show RoomInfo where
- show ri = ", players: " ++ show (playersIn ri)
+ show ri = show (roomUID ri)
+ ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri)
+ ++ ", players: " ++ show (playersIn ri)
++ ", ready: " ++ show (readyPlayers ri)
++ ", teams: " ++ show (teams ri)
-newRoom :: RoomInfo
+instance Eq RoomInfo where
+ (==) = (==) `on` roomUID
+
newRoom = (
RoomInfo
- undefined
+ 0
+ 0
""
""
0
@@ -102,6 +108,7 @@
False
0
0
+ IntSet.empty
False
False
Data.Sequence.empty
@@ -121,24 +128,23 @@
ServerInfo
{
isDedicated :: Bool,
- serverMessage :: B.ByteString,
- serverMessageForOldVersions :: B.ByteString,
+ serverMessage :: String,
+ serverMessageForOldVersions :: String,
latestReleaseVersion :: Word16,
listenPort :: PortNumber,
nextRoomID :: Int,
- dbHost :: B.ByteString,
- dbLogin :: B.ByteString,
- dbPassword :: B.ByteString,
- lastLogins :: [(B.ByteString, UTCTime)],
+ dbHost :: String,
+ dbLogin :: String,
+ dbPassword :: String,
+ lastLogins :: [(String, UTCTime)],
stats :: TMVar StatisticsInfo,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery
}
instance Show ServerInfo where
- show _ = "Server Info"
+ show si = "Server Info"
-newServerInfo :: TMVar StatisticsInfo -> Chan CoreMessage -> Chan DBQuery -> ServerInfo
newServerInfo = (
ServerInfo
True
@@ -154,31 +160,29 @@
)
data AccountInfo =
- HasAccount B.ByteString Bool
+ HasAccount String Bool
| Guest
| Admin
deriving (Show, Read)
data DBQuery =
- CheckAccount ClientIndex B.ByteString B.ByteString
+ CheckAccount Int String String
| ClearCache
| SendStats Int Int
deriving (Show, Read)
data CoreMessage =
Accept ClientInfo
- | ClientMessage (ClientIndex, [B.ByteString])
- | ClientAccountInfo (ClientIndex, AccountInfo)
+ | ClientMessage (Int, [String])
+ | ClientAccountInfo (Int, AccountInfo)
| TimerAction Int
- | Remove ClientIndex
+
+type Clients = IntMap.IntMap ClientInfo
+type Rooms = IntMap.IntMap RoomInfo
-instance Show CoreMessage where
- show (Accept _) = "Accept"
- show (ClientMessage _) = "ClientMessage"
- show (ClientAccountInfo _) = "ClientAccountInfo"
- show (TimerAction _) = "TimerAction"
- show (Remove _) = "Remove"
-
-type MRnC = MRoomsAndClients RoomInfo ClientInfo
-type IRnC = IRoomsAndClients RoomInfo ClientInfo
+--type ClientsTransform = [ClientInfo] -> [ClientInfo]
+--type RoomsTransform = [RoomInfo] -> [RoomInfo]
+--type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
+--type Answer = ServerInfo -> (HandlesSelector, [String])
+type ClientsSelector = Clients -> Rooms -> [Int]
--- a/gameServer/HWProtoCore.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/HWProtoCore.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,10 +1,8 @@
-{-# LANGUAGE OverloadedStrings #-}
module HWProtoCore where
import qualified Data.IntMap as IntMap
import Data.Foldable
-import Data.Maybe
-import Control.Monad.Reader
+import Maybe
--------------------------------------
import CoreTypes
import Actions
@@ -12,37 +10,35 @@
import HWProtoNEState
import HWProtoLobbyState
import HWProtoInRoomState
-import HandlerUtils
-import RoomsAndClients
handleCmd, handleCmd_loggedin :: CmdHandler
-
-handleCmd ["PING"] = answerClient ["PONG"]
+handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]]
-
-handleCmd ("QUIT" : xs) = return [ByeClient msg]
+handleCmd clID clients rooms ("QUIT" : xs) =
+ [ByeClient msg]
where
msg = if not $ null xs then head xs else ""
-{-
-handleCmd ["PONG"] =
+
+handleCmd clID clients _ ["PONG"] =
if pingsQueue client == 0 then
[ProtocolError "Protocol violation"]
else
[ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})]
where
client = clients IntMap.! clID
--}
+
-handleCmd cmd = do
- (ci, irnc) <- ask
- if logonPassed (irnc `client` ci) then
- handleCmd_loggedin cmd
- else
- handleCmd_NotEntered cmd
+handleCmd clID clients rooms cmd =
+ if not $ logonPassed client then
+ handleCmd_NotEntered clID clients rooms cmd
+ else
+ handleCmd_loggedin clID clients rooms cmd
+ where
+ client = clients IntMap.! clID
-{-
+
handleCmd_loggedin clID clients rooms ["INFO", asknick] =
if noSuchClient then
[]
@@ -66,12 +62,11 @@
then if teamsInGame client > 0 then "(playing)" else "(spectating)"
else ""
--}
-
-handleCmd_loggedin cmd = do
- (ci, rnc) <- ask
- if clientRoom rnc ci == lobbyId then
- handleCmd_lobby cmd
- else
- handleCmd_inRoom cmd
+handleCmd_loggedin clID clients rooms cmd =
+ if roomID client == 0 then
+ handleCmd_lobby clID clients rooms cmd
+ else
+ handleCmd_inRoom clID clients rooms cmd
+ where
+ client = clients IntMap.! clID
--- a/gameServer/HWProtoInRoomState.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/HWProtoInRoomState.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,240 +1,182 @@
-{-# LANGUAGE OverloadedStrings #-}
module HWProtoInRoomState where
import qualified Data.Foldable as Foldable
+import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.Sequence(Seq, (|>), (><), fromList, empty)
import Data.List
-import Data.Maybe
-import qualified Data.ByteString.Char8 as B
-import Control.Monad
-import Control.Monad.Reader
+import Maybe
--------------------------------------
import CoreTypes
import Actions
import Utils
-import HandlerUtils
-import RoomsAndClients
+
handleCmd_inRoom :: CmdHandler
-handleCmd_inRoom ["CHAT", msg] = do
- n <- clientNick
- s <- roomOthersChans
- return [AnswerClients s ["CHAT", n, msg]]
+handleCmd_inRoom clID clients _ ["CHAT", msg] =
+ [AnswerOthersInRoom ["CHAT", clientNick, msg]]
+ where
+ clientNick = nick $ clients IntMap.! clID
-handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
-handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
+handleCmd_inRoom clID clients rooms ["PART"] =
+ [RoomRemoveThisClient "part"]
+ where
+ client = clients IntMap.! clID
-handleCmd_inRoom ("CFG" : paramName : paramStrs)
- | null paramStrs = return [ProtocolError "Empty config entry"]
- | otherwise = do
- chans <- roomOthersChans
- cl <- thisClient
- if isMaster cl then
- return [
- ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
- AnswerClients chans ("CFG" : paramName : paramStrs)]
- else
- return [ProtocolError "Not room master"]
+handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs)
+ | null paramStrs = [ProtocolError "Empty config entry"]
+ | isMaster client =
+ [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
+ AnswerOthersInRoom ("CFG" : paramName : paramStrs)]
+ | otherwise = [ProtocolError "Not room master"]
+ where
+ client = clients IntMap.! clID
-handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
- | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"]
- | otherwise = do
- (ci, rnc) <- ask
- r <- thisRoom
- clNick <- clientNick
- clChan <- thisClientChans
- othersChans <- roomOthersChans
- return $
- if not . null . drop 5 $ teams r then
- [Warning "too many teams"]
- else if canAddNumber r <= 0 then
- [Warning "too many hedgehogs"]
- else if isJust $ findTeam r then
- [Warning "There's already a team with same name in the list"]
- else if gameinprogress r then
- [Warning "round in progress"]
- else if isRestrictedTeams r then
- [Warning "restricted"]
- else
- [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}),
- ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
- AnswerClients clChan ["TEAM_ACCEPTED", name],
- AnswerClients othersChans $ teamToNet $ newTeam ci clNick r,
- AnswerClients othersChans ["TEAM_COLOR", name, color]
- ]
- where
- canAddNumber r = 48 - (sum . map hhnum $ teams r)
- findTeam = find (\t -> name == teamname t) . teams
- newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo))
- difficulty = case B.readInt difStr of
- Just (i, t) | B.null t -> fromIntegral i
- otherwise -> 0
+handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
+ | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo)
+ | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"]
+ | length (teams room) == 6 = [Warning "too many teams"]
+ | canAddNumber <= 0 = [Warning "too many hedgehogs"]
+ | isJust findTeam = [Warning "There's already a team with same name in the list"]
+ | gameinprogress room = [Warning "round in progress"]
+ | isRestrictedTeams room = [Warning "restricted"]
+ | otherwise =
+ [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
+ ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
+ AnswerThisClient ["TEAM_ACCEPTED", name],
+ AnswerOthersInRoom $ teamToNet (clientProto client) newTeam,
+ AnswerOthersInRoom ["TEAM_COLOR", name, color]
+ ]
+ where
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ canAddNumber = 48 - (sum . map hhnum $ teams room)
+ findTeam = find (\t -> name == teamname t) $ teams room
+ newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo))
+ difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
hhsList [] = []
- hhsList [_] = error "Hedgehogs list with odd elements number"
hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
- newTeamHHNum r = min 4 (canAddNumber r)
-
-handleCmd_inRoom ["REMOVE_TEAM", name] = do
- (ci, rnc) <- ask
- r <- thisRoom
- clNick <- clientNick
-
- let maybeTeam = findTeam r
- let team = fromJust maybeTeam
+ newTeamHHNum = min 4 canAddNumber
- return $
- if isNothing $ findTeam r then
- [Warning "REMOVE_TEAM: no such team"]
- else if clNick /= teamowner team then
- [ProtocolError "Not team owner!"]
- else
- [RemoveTeam name,
- ModifyClient
- (\c -> c{
- teamsInGame = teamsInGame c - 1,
- clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r
- })
- ]
+handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName]
+ | noSuchTeam = [Warning "REMOVE_TEAM: no such team"]
+ | nick client /= teamowner team = [ProtocolError "Not team owner!"]
+ | otherwise =
+ [RemoveTeam teamName,
+ ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan})
+ ]
where
- anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
- findTeam = find (\t -> name == teamname t) . teams
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ noSuchTeam = isNothing findTeam
+ team = fromJust findTeam
+ findTeam = find (\t -> teamName == teamname t) $ teams room
+ anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room
-handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
- cl <- thisClient
- others <- roomOthersChans
- r <- thisRoom
-
- let maybeTeam = findTeam r
- let team = fromJust maybeTeam
-
- return $
- if not $ isMaster cl then
- [ProtocolError "Not room master"]
- else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then
- []
- else
- [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
- AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]]
+handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr]
+ | not $ isMaster client = [ProtocolError "Not room master"]
+ | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = []
+ | otherwise =
+ [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
+ AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]]
where
- hhNumber = case B.readInt numberStr of
- Just (i, t) | B.null t -> fromIntegral i
- otherwise -> 0
- findTeam = find (\t -> teamName == teamname t) . teams
- canAddNumber = (-) 48 . sum . map hhnum . teams
-
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
+ noSuchTeam = isNothing findTeam
+ team = fromJust findTeam
+ findTeam = find (\t -> teamName == teamname t) $ teams room
+ canAddNumber = 48 - (sum . map hhnum $ teams room)
-handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do
- cl <- thisClient
- others <- roomOthersChans
- r <- thisRoom
-
- let maybeTeam = findTeam r
- let team = fromJust maybeTeam
-
- return $
- if not $ isMaster cl then
- [ProtocolError "Not room master"]
- else if isNothing maybeTeam then
- []
- else
- [ModifyRoom $ modifyTeam team{teamcolor = newColor},
- AnswerClients others ["TEAM_COLOR", teamName, newColor],
+handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor]
+ | not $ isMaster client = [ProtocolError "Not room master"]
+ | noSuchTeam = []
+ | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor},
+ AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor],
ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
where
- findTeam = find (\t -> teamName == teamname t) . teams
+ noSuchTeam = isNothing findTeam
+ team = fromJust findTeam
+ findTeam = find (\t -> teamName == teamname t) $ teams room
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
-handleCmd_inRoom ["TOGGLE_READY"] = do
- cl <- thisClient
- chans <- roomClientsChans
- return [
- ModifyClient (\c -> c{isReady = not $ isReady cl}),
- ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}),
- AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl]
- ]
+handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] =
+ [ModifyClient (\c -> c{isReady = not $ isReady client}),
+ ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}),
+ AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]]
+ where
+ client = clients IntMap.! clID
-handleCmd_inRoom ["START_GAME"] = do
- cl <- thisClient
- r <- thisRoom
- chans <- roomClientsChans
- if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then
- if enoughClans r then
- return [
- ModifyRoom
+handleCmd_inRoom clID clients rooms ["START_GAME"] =
+ if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then
+ if enoughClans then
+ [ModifyRoom
(\r -> r{
gameinprogress = True,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = teams r}
),
- AnswerClients chans ["RUN_GAME"]
- ]
- else
- return [Warning "Less than two clans!"]
+ AnswerThisRoom ["RUN_GAME"]]
else
- return []
+ [Warning "Less than two clans!"]
+ else
+ []
where
- enoughClans = not . null . drop 1 . group . map teamcolor . teams
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
-handleCmd_inRoom ["EM", msg] = do
- cl <- thisClient
- r <- thisRoom
- chans <- roomOthersChans
-
- if (teamsInGame cl > 0) && isLegal then
- return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
- else
- return []
+handleCmd_inRoom clID clients rooms ["EM", msg] =
+ if (teamsInGame client > 0) && isLegal then
+ (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
+ else
+ []
where
+ client = clients IntMap.! clID
(isLegal, isKeepAlive) = checkNetCmd msg
-
-handleCmd_inRoom ["ROUNDFINISHED"] = do
- cl <- thisClient
- r <- thisRoom
- chans <- roomClientsChans
-
- if isMaster cl && (gameinprogress r) then
- return $ (ModifyRoom
+handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] =
+ if isMaster client then
+ [ModifyRoom
(\r -> r{
gameinprogress = False,
readyPlayers = 0,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = []}
- ))
- : UnreadyRoomClients
- : answerRemovedTeams chans r
- else
- return []
+ ),
+ UnreadyRoomClients
+ ] ++ answerRemovedTeams
+ else
+ []
where
- answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams
-
-handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
- cl <- thisClient
- return $
- if not $ isMaster cl then
- [ProtocolError "Not room master"]
- else
- [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
+ client = clients IntMap.! clID
+ room = rooms IntMap.! (roomID client)
+ answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
-handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do
- cl <- thisClient
- return $
- if not $ isMaster cl then
- [ProtocolError "Not room master"]
- else
- [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
+handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"]
+ | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
+ | otherwise = [ProtocolError "Not room master"]
+ where
+ client = clients IntMap.! clID
+
-{-
+handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"]
+ | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
+ | otherwise = [ProtocolError "Not room master"]
+ where
+ client = clients IntMap.! clID
+
handleCmd_inRoom clID clients rooms ["KICK", kickNick] =
[KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)]
where
@@ -250,5 +192,5 @@
where
client = clients IntMap.! clID
engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
--}
-handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]
+
+handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]
--- a/gameServer/HWProtoLobbyState.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/HWProtoLobbyState.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,102 +1,73 @@
-{-# LANGUAGE OverloadedStrings #-}
module HWProtoLobbyState where
import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Foldable as Foldable
-import Data.Maybe
+import Maybe
import Data.List
import Data.Word
-import Control.Monad.Reader
-import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import Actions
import Utils
-import HandlerUtils
-import RoomsAndClients
-{-answerAllTeams protocol teams = concatMap toAnswer teams
+answerAllTeams protocol teams = concatMap toAnswer teams
where
toAnswer team =
[AnswerThisClient $ teamToNet protocol team,
AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]
--}
+
handleCmd_lobby :: CmdHandler
-
-handleCmd_lobby ["LIST"] = do
- (ci, irnc) <- ask
- let cl = irnc `client` ci
- rooms <- allRoomInfos
- let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
- return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
+handleCmd_lobby clID clients rooms ["LIST"] =
+ [AnswerThisClient ("ROOMS" : roomsInfoList)]
where
- roomInfo irnc room = [
- showB $ gameinprogress room,
+ roomsInfoList = concatMap roomInfo sameProtoRooms
+ sameProtoRooms = filter (\r -> (roomProto r == protocol) && not (isRestrictedJoins r)) roomsList
+ roomsList = IntMap.elems rooms
+ protocol = clientProto client
+ client = clients IntMap.! clID
+ roomInfo room
+ | clientProto client < 28 = [
name room,
- showB $ playersIn room,
- showB $ length $ teams room,
- nick $ irnc `client` masterID room,
+ show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")",
+ show $ gameinprogress room
+ ]
+ | otherwise = [
+ show $ gameinprogress room,
+ name room,
+ show $ playersIn room,
+ show $ length $ teams room,
+ nick $ clients IntMap.! (masterID room),
head (Map.findWithDefault ["+gen+"] "MAP" (params room)),
head (Map.findWithDefault ["Default"] "SCHEME" (params room)),
head (Map.findWithDefault ["Default"] "AMMO" (params room))
]
-
-handleCmd_lobby ["CHAT", msg] = do
- n <- clientNick
- s <- roomOthersChans
- return [AnswerClients s ["CHAT", n, msg]]
-
-handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword]
- | illegalName newRoom = return [Warning "Illegal room name"]
- | otherwise = do
- rs <- allRoomInfos
- cl <- thisClient
- return $ if isJust $ find (\room -> newRoom == name room) rs then
- [Warning "Room exists"]
- else
- [
- AddRoom newRoom roomPassword,
- AnswerClients [sendChan cl] ["NOT_READY", nick cl]
- ]
-
-
-handleCmd_lobby ["CREATE_ROOM", newRoom] =
- handleCmd_lobby ["CREATE_ROOM", newRoom, ""]
+handleCmd_lobby clID clients _ ["CHAT", msg] =
+ [AnswerOthersInRoom ["CHAT", clientNick, msg]]
+ where
+ clientNick = nick $ clients IntMap.! clID
-handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
- (ci, irnc) <- ask
- let ris = allRooms irnc
- cl <- thisClient
- let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris
- let jRI = fromJust maybeRI
- let jRoom = irnc `room` jRI
- let jRoomClients = map (client irnc) $! roomClients irnc jRI -- no lazyness here!
- return $
- if isNothing maybeRI then
- [Warning "No such rooms"]
- else if isRestrictedJoins jRoom then
- [Warning "Joining restricted"]
- else if roomPassword /= password jRoom then
- [Warning "Wrong password"]
- else
- [
- MoveToRoom jRI,
- AnswerClients (map sendChan $ cl : jRoomClients) ["NOT_READY", nick cl]
- ]
- ++ [ AnswerClients [sendChan cl] $ "JOINED" : map nick jRoomClients | playersIn jRoom /= 0]
- ++ (map (readynessMessage cl) jRoomClients)
-
+handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, roomPassword]
+ | haveSameRoom = [Warning "Room exists"]
+ | illegalName newRoom = [Warning "Illegal room name"]
+ | otherwise =
+ [RoomRemoveThisClient "", -- leave lobby
+ AddRoom newRoom roomPassword,
+ AnswerThisClient ["NOT_READY", clientNick]
+ ]
where
- readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c]
+ clientNick = nick $ clients IntMap.! clID
+ haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms
+handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] =
+ handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""]
-{-
handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword]
| noSuchRoom = [Warning "No such room"]
@@ -112,6 +83,12 @@
++ answerTeams
++ watchRound
where
+ noSuchRoom = isNothing mbRoom
+ mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms
+ jRoom = fromJust mbRoom
+ rID = roomUID jRoom
+ client = clients IntMap.! clID
+ roomClientsIDs = IntSet.elems $ playersIDs jRoom
answerNicks =
[AnswerThisClient $ "JOINED" :
map (\clID -> nick $ clients IntMap.! clID) roomClientsIDs | playersIn jRoom /= 0]
@@ -123,7 +100,7 @@
roomClientsIDs
toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
-
+
answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart)
(leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom)
@@ -137,12 +114,12 @@
answerAllTeams (clientProto client) (teamsAtStart jRoom)
else
answerAllTeams (clientProto client) (teams jRoom)
--}
+
-handleCmd_lobby ["JOIN_ROOM", roomName] =
- handleCmd_lobby ["JOIN_ROOM", roomName, ""]
+handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] =
+ handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""]
+
-{-
handleCmd_lobby clID clients rooms ["FOLLOW", asknick] =
if noSuchClient || roomID followClient == 0 then
[]
@@ -203,7 +180,6 @@
[ClearAccountsCache | isAdministrator client]
where
client = clients IntMap.! clID
--}
-handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]
+handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]
--- a/gameServer/HWProtoNEState.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/HWProtoNEState.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,66 +1,54 @@
-{-# LANGUAGE OverloadedStrings #-}
module HWProtoNEState where
import qualified Data.IntMap as IntMap
-import Data.Maybe
+import Maybe
import Data.List
import Data.Word
-import Control.Monad.Reader
-import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import Actions
import Utils
-import RoomsAndClients
handleCmd_NotEntered :: CmdHandler
-handleCmd_NotEntered ["NICK", newNick] = do
- (ci, irnc) <- ask
- let cl = irnc `client` ci
- if not . B.null $ nick cl then return [ProtocolError "Nickname already chosen"]
- else
- if haveSameNick irnc (nick cl) 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]
+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]
where
- haveSameNick irnc clNick = isJust $ find (\cl -> newNick == clNick) $ map (client irnc) $ allClients irnc
-
-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", B.pack $ show parsedProto] :
- [CheckRegistered | not . B.null $ nick cl]
- where
- parsedProto = case B.readInt protoNum of
- Just (i, t) | B.null t -> fromIntegral i
- otherwise -> 0
+ client = clients IntMap.! clID
+ haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
-handleCmd_NotEntered ["PASSWORD", passwd] = do
- (ci, irnc) <- ask
- let cl = irnc `client` ci
+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)]
+ where
+ client = clients IntMap.! clID
+ parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
- if passwd == webPassword cl then
- return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl]
- else
- return [ByeClient "Authentication failed"]
-{-
+handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
+ if passwd == webPassword client then
+ [ModifyClient (\cl -> cl{logonPassed = True}),
+ MoveToLobby] ++ adminNotice
+ else
+ [ByeClient "Authentication failed"]
+ where
+ client = clients IntMap.! clID
+ adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] | isAdministrator client]
+
handleCmd_NotEntered clID clients _ ["DUMP"] =
if isAdministrator (clients IntMap.! clID) then [Dump] else []
--}
+
-handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]
+handleCmd_NotEntered clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"]
--- a/gameServer/HandlerUtils.hs Fri Nov 12 00:11:22 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,45 +0,0 @@
-module HandlerUtils where
-
-import Control.Monad.Reader
-import qualified Data.ByteString.Char8 as B
-
-import RoomsAndClients
-import CoreTypes
-import Actions
-
-thisClient :: Reader (ClientIndex, IRnC) ClientInfo
-thisClient = do
- (ci, rnc) <- ask
- return $ rnc `client` ci
-
-thisRoom :: Reader (ClientIndex, IRnC) RoomInfo
-thisRoom = do
- (ci, rnc) <- ask
- let ri = clientRoom rnc ci
- return $ rnc `room` ri
-
-clientNick :: Reader (ClientIndex, IRnC) B.ByteString
-clientNick = liftM nick thisClient
-
-roomOthersChans :: Reader (ClientIndex, IRnC) [ClientChan]
-roomOthersChans = do
- (ci, rnc) <- ask
- let ri = clientRoom rnc ci
- return $ map (sendChan . client rnc) $ filter (/= ci) (roomClients rnc ri)
-
-roomClientsChans :: Reader (ClientIndex, IRnC) [ClientChan]
-roomClientsChans = do
- (ci, rnc) <- ask
- let ri = clientRoom rnc ci
- return $ map (sendChan . client rnc) (roomClients rnc ri)
-
-thisClientChans :: Reader (ClientIndex, IRnC) [ClientChan]
-thisClientChans = do
- (ci, rnc) <- ask
- return $ [sendChan (rnc `client` ci)]
-
-answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
-answerClient msg = thisClientChans >>= return . (: []) . flip AnswerClients msg
-
-allRoomInfos :: Reader (a, IRnC) [RoomInfo]
-allRoomInfos = liftM ((\irnc -> map (room irnc) $ allRooms irnc) . snd) ask
--- a/gameServer/NetRoutines.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/NetRoutines.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,41 +1,46 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module NetRoutines where
+import Network
import Network.Socket
import System.IO
+import Control.Concurrent
import Control.Concurrent.Chan
+import Control.Concurrent.STM
import qualified Control.Exception as Exception
import Data.Time
-import Control.Monad
-----------------------------
import CoreTypes
+import ClientIO
import Utils
-import RoomsAndClients
-acceptLoop :: Socket -> Chan CoreMessage -> IO ()
-acceptLoop servSock chan = forever $ do
+acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO ()
+acceptLoop servSock coreChan clientCounter = do
Exception.handle
(\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
do
- (sock, sockAddr) <- Network.Socket.accept servSock
+ (socket, sockAddr) <- Network.Socket.accept servSock
+ cHandle <- socketToHandle socket ReadWriteMode
+ hSetBuffering cHandle LineBuffering
clientHost <- sockAddr2String sockAddr
currentTime <- getCurrentTime
-
- sendChan' <- newChan
+
+ sendChan <- newChan
let newClient =
(ClientInfo
- sendChan'
- sock
+ nextID
+ sendChan
+ cHandle
clientHost
currentTime
""
""
False
0
- lobbyId
+ 0
0
False
False
@@ -44,5 +49,12 @@
undefined
)
- writeChan chan $ Accept newClient
+ writeChan coreChan $ Accept newClient
+
+ forkIO $ clientRecvLoop cHandle coreChan nextID
+ forkIO $ clientSendLoop cHandle coreChan sendChan nextID
return ()
+
+ acceptLoop servSock coreChan nextID
+ where
+ nextID = clientCounter + 1
--- a/gameServer/OfficialServer/DBInteraction.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/OfficialServer/DBInteraction.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
module OfficialServer.DBInteraction
(
startDBConnection
@@ -11,7 +11,8 @@
import qualified Control.Exception as Exception
import Control.Monad
import qualified Data.Map as Map
-import Data.Maybe
+import Monad
+import Maybe
import System.Log.Logger
import Data.Time
------------------------
@@ -20,7 +21,7 @@
localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"]
-fakeDbConnection serverInfo = forever $ do
+fakeDbConnection serverInfo = do
q <- readChan $ dbQueries serverInfo
case q of
CheckAccount clUid _ clHost -> do
@@ -29,6 +30,8 @@
ClearCache -> return ()
SendStats {} -> return ()
+ fakeDbConnection serverInfo
+
#if defined(OFFICIAL_SERVER)
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache =
--- a/gameServer/OfficialServer/extdbinterface.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/OfficialServer/extdbinterface.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Main where
@@ -26,7 +26,7 @@
case q of
CheckAccount clUid clNick _ -> do
statement <- prepare dbConn dbQueryAccount
- execute statement [SqlByteString $ clNick]
+ execute statement [SqlString $ clNick]
passAndRole <- fetchRow statement
finish statement
let response =
@@ -47,7 +47,7 @@
dbConnectionLoop mySQLConnectionInfo =
- Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $
+ Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $
bracket
(connectMySQL mySQLConnectionInfo)
(disconnect)
--- a/gameServer/Opts.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/Opts.hs Fri Nov 12 09:49:46 2010 +0100
@@ -3,12 +3,10 @@
getOpts,
) where
-import System.Environment
+import System
import System.Console.GetOpt
import Network
import Data.Maybe ( fromMaybe )
-import qualified Data.ByteString.Char8 as B
-
import CoreTypes
import Utils
@@ -32,9 +30,9 @@
where
readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
-readDbLogin str opts = opts{dbLogin = B.pack str}
-readDbPassword str opts = opts{dbPassword = B.pack str}
-readDbHost str opts = opts{dbHost = B.pack str}
+readDbLogin str opts = opts{dbLogin = str}
+readDbPassword str opts = opts{dbPassword = str}
+readDbHost str opts = opts{dbHost = str}
getOpts :: ServerInfo -> IO ServerInfo
getOpts opts = do
--- a/gameServer/RoomsAndClients.hs Fri Nov 12 00:11:22 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,196 +0,0 @@
-module RoomsAndClients(
- RoomIndex(),
- ClientIndex(),
- MRoomsAndClients(),
- IRoomsAndClients(),
- newRoomsAndClients,
- addRoom,
- addClient,
- removeRoom,
- removeClient,
- modifyRoom,
- modifyClient,
- lobbyId,
- moveClientToLobby,
- moveClientToRoom,
- clientRoomM,
- clientExists,
- client,
- room,
- client'sM,
- room'sM,
- allClientsM,
- clientsM,
- roomClientsM,
- roomClientsIndicesM,
- withRoomsAndClients,
- allRooms,
- allClients,
- clientRoom,
- showRooms,
- roomClients
- ) where
-
-
-import Store
-import Control.Monad
-
-
-data Room r = Room {
- roomClients' :: [ClientIndex],
- room' :: r
- }
-
-
-data Client c = Client {
- clientRoom' :: RoomIndex,
- client' :: c
- }
-
-
-newtype RoomIndex = RoomIndex ElemIndex
- deriving (Eq)
-newtype ClientIndex = ClientIndex ElemIndex
- deriving (Eq, Show, Read, Ord)
-
-instance Show RoomIndex where
- show (RoomIndex i) = 'r' : show i
-
-unRoomIndex :: RoomIndex -> ElemIndex
-unRoomIndex (RoomIndex r) = r
-
-unClientIndex :: ClientIndex -> ElemIndex
-unClientIndex (ClientIndex c) = c
-
-
-newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c))
-newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c))
-
-
-lobbyId :: RoomIndex
-lobbyId = RoomIndex firstIndex
-
-
-newRoomsAndClients :: r -> IO (MRoomsAndClients r c)
-newRoomsAndClients r = do
- rooms <- newStore
- clients <- newStore
- let rnc = MRoomsAndClients (rooms, clients)
- ri <- addRoom rnc r
- when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index"
- return rnc
-
-
-roomAddClient :: ClientIndex -> Room r -> Room r
-roomAddClient cl room = let cls = cl : roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr
-
-roomRemoveClient :: ClientIndex -> Room r -> Room r
-roomRemoveClient cl room = let cls = filter (/= cl) $ roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr
-
-
-addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex
-addRoom (MRoomsAndClients (rooms, _)) room = do
- i <- addElem rooms (Room [] room)
- return $ RoomIndex i
-
-
-addClient :: MRoomsAndClients r c -> c -> IO ClientIndex
-addClient (MRoomsAndClients (rooms, clients)) client = do
- i <- addElem clients (Client lobbyId client)
- modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId)
- return $ ClientIndex i
-
-removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO ()
-removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri)
- | room == lobbyId = error "Cannot delete lobby"
- | otherwise = do
- clIds <- liftM roomClients' $ readElem rooms ri
- forM_ clIds (moveClientToLobby rnc)
- removeElem rooms ri
-
-
-removeClient :: MRoomsAndClients r c -> ClientIndex -> IO ()
-removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do
- RoomIndex ri <- liftM clientRoom' $ readElem clients ci
- modifyElem rooms (roomRemoveClient cl) ri
- removeElem clients ci
-
-
-modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO ()
-modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri
-
-modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO ()
-modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci
-
-moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO ()
-moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do
- modifyElem rooms (roomRemoveClient cl) riFrom
- modifyElem rooms (roomAddClient cl) riTo
- modifyElem clients (\c -> c{clientRoom' = rt}) ci
-
-
-moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO ()
-moveClientToLobby rnc ci = do
- room <- clientRoomM rnc ci
- moveClientInRooms rnc room lobbyId ci
-
-
-moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO ()
-moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci
-
-
-clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool
-clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci
-
-clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex
-clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci)
-
-client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a
-client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci)
-
-room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a
-room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri)
-
-allClientsM :: MRoomsAndClients r c -> IO [ClientIndex]
-allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients
-
-clientsM :: MRoomsAndClients r c -> IO [c]
-clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci)
-
-roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex]
-roomClientsIndicesM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri)
-
-roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c]
-roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients ci)
-
-withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a
-withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =
- withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c))
-
-----------------------------------------
------------ IRoomsAndClients -----------
-
-showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String
-showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc)
- where
- showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r)))
- showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c))
-
-
-allRooms :: IRoomsAndClients r c -> [RoomIndex]
-allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms
-
-allClients :: IRoomsAndClients r c -> [ClientIndex]
-allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients
-
-clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex
-clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci)
-
-client :: IRoomsAndClients r c -> ClientIndex -> c
-client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci)
-
-room :: IRoomsAndClients r c -> RoomIndex -> r
-room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri)
-
-roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex]
-roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri)
--- a/gameServer/ServerCore.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/ServerCore.hs Fri Nov 12 09:49:46 2010 +0100
@@ -2,75 +2,69 @@
import Network
import Control.Concurrent
+import Control.Concurrent.STM
import Control.Concurrent.Chan
import Control.Monad
import qualified Data.IntMap as IntMap
import System.Log.Logger
-import Control.Monad.Reader
-import Control.Monad.State.Strict
-import Data.Set as Set
-import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import NetRoutines
+import Utils
import HWProtoCore
import Actions
import OfficialServer.DBInteraction
-import ServerState
-
-
-timerLoop :: Int -> Chan CoreMessage -> IO ()
-timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-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 processAction
+timerLoop :: Int -> Chan CoreMessage -> IO()
+timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
+
+firstAway (_, a, b, c) = (a, b, c)
+
+reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
+reactCmd serverInfo clID cmd clients rooms =
+ liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
-mainLoop :: StateT ServerState IO ()
-mainLoop = forever $ do
- get >>= \s -> put $! s
-
- si <- gets serverInfo
- r <- liftIO $ readChan $ coreChan si
-
- case r of
- Accept ci -> processAction (AddClient ci)
-
- ClientMessage (ci, cmd) -> do
- liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
+mainLoop :: ServerInfo -> Clients -> Rooms -> IO ()
+mainLoop serverInfo clients rooms = do
+ r <- readChan $ coreChan serverInfo
+
+ (newServerInfo, mClients, mRooms) <-
+ case r of
+ Accept ci ->
+ liftM firstAway $ processAction
+ (clientUID ci, serverInfo, clients, rooms) (AddClient ci)
- removed <- gets removedClients
- when (not $ ci `Set.member` removed) $ do
- as <- get
- put $! as{clientIndex = Just ci}
- reactCmd cmd
-
- Remove ci -> do
- liftIO $ debugM "Clients" $ "DeleteClient: " ++ show ci
- processAction (DeleteClient ci)
+ ClientMessage (clID, cmd) -> do
+ debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
+ if clID `IntMap.member` clients then
+ reactCmd serverInfo clID cmd clients rooms
+ else
+ do
+ debugM "Clients" "Message from dead client"
+ return (serverInfo, clients, rooms)
- --else
- --do
- --debugM "Clients" "Message from dead client"
- --return (serverInfo, rnc)
+ ClientAccountInfo (clID, info) ->
+ if clID `IntMap.member` clients then
+ liftM firstAway $ processAction
+ (clID, serverInfo, clients, rooms)
+ (ProcessAccountInfo info)
+ else
+ do
+ debugM "Clients" "Got info for dead client"
+ return (serverInfo, clients, rooms)
- ClientAccountInfo (ci, info) -> do
- rnc <- gets roomsClients
- exists <- liftIO $ clientExists rnc ci
- when (exists) $ do
- as <- get
- put $! as{clientIndex = Just ci}
- processAction (ProcessAccountInfo info)
- return ()
+ TimerAction tick ->
+ liftM firstAway $
+ foldM processAction (0, serverInfo, clients, rooms) $
+ PingAll : [StatsAction | even tick]
+
- TimerAction tick ->
- mapM_ processAction $
- PingAll : [StatsAction | even tick]
+ {- let hadRooms = (not $ null rooms) && (null mrooms)
+ in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
+ mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
+ mainLoop newServerInfo mClients mRooms
startServer :: ServerInfo -> Socket -> IO ()
startServer serverInfo serverSocket = do
@@ -80,15 +74,14 @@
acceptLoop
serverSocket
(coreChan serverInfo)
+ 0
return ()
-
- --forkIO $ timerLoop 0 $ coreChan serverInfo
+
+ forkIO $ timerLoop 0 $ coreChan serverInfo
startDBConnection serverInfo
- rnc <- newRoomsAndClients newRoom
+ forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
- forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc)
-
- forever $ threadDelay (60 * 60 * 10^6)
+ forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
\ No newline at end of file
--- a/gameServer/ServerState.hs Fri Nov 12 00:11:22 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,43 +0,0 @@
-module ServerState
- (
- module RoomsAndClients,
- clientRoomA,
- ServerState(..),
- client's,
- allClientsS,
- roomClientsS
- ) where
-
-import Control.Monad.State.Strict
-import Data.Set as Set
-----------------------
-import RoomsAndClients
-import CoreTypes
-
-data ServerState = ServerState {
- clientIndex :: !(Maybe ClientIndex),
- serverInfo :: !ServerInfo,
- removedClients :: !(Set.Set ClientIndex),
- roomsClients :: !MRnC
- }
-
-
-clientRoomA :: StateT ServerState IO RoomIndex
-clientRoomA = do
- (Just ci) <- gets clientIndex
- rnc <- gets roomsClients
- liftIO $ clientRoomM rnc ci
-
-client's :: (ClientInfo -> a) -> StateT ServerState IO a
-client's f = do
- (Just ci) <- gets clientIndex
- rnc <- gets roomsClients
- liftIO $ client'sM rnc f ci
-
-allClientsS :: StateT ServerState IO [ClientInfo]
-allClientsS = gets roomsClients >>= liftIO . clientsM
-
-roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
-roomClientsS ri = do
- rnc <- gets roomsClients
- liftIO $ roomClientsM rnc ri
--- a/gameServer/Store.hs Fri Nov 12 00:11:22 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,145 +0,0 @@
-module Store(
- ElemIndex(),
- MStore(),
- IStore(),
- newStore,
- addElem,
- removeElem,
- readElem,
- writeElem,
- modifyElem,
- elemExists,
- firstIndex,
- indicesM,
- withIStore,
- withIStore2,
- (!),
- indices
- ) where
-
-import qualified Data.Array.IArray as IA
-import qualified Data.Array.IO as IOA
-import qualified Data.IntSet as IntSet
-import Data.IORef
-import Control.Monad
-
-
-newtype ElemIndex = ElemIndex Int
- deriving (Eq, Show, Read, Ord)
-newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
-newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
-
-
-firstIndex :: ElemIndex
-firstIndex = ElemIndex 0
-
--- MStore code
-initialSize :: Int
-initialSize = 10
-
-
-growFunc :: Int -> Int
-growFunc a = a * 3 `div` 2
-
-
-newStore :: IO (MStore e)
-newStore = do
- newar <- IOA.newArray_ (0, initialSize - 1)
- new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
- return (MStore new)
-
-
-growStore :: MStore e -> IO ()
-growStore (MStore ref) = do
- (busyElems, freeElems, arr) <- readIORef ref
- (_, m') <- IOA.getBounds arr
- let newM' = growFunc (m' + 1) - 1
- newArr <- IOA.newArray_ (0, newM')
- sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
- writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)
-
-
-growIfNeeded :: MStore e -> IO ()
-growIfNeeded m@(MStore ref) = do
- (_, freeElems, _) <- readIORef ref
- when (IntSet.null freeElems) $ growStore m
-
-
-addElem :: MStore e -> e -> IO ElemIndex
-addElem m@(MStore ref) element = do
- growIfNeeded m
- (busyElems, freeElems, arr) <- readIORef ref
- let (n, freeElems') = IntSet.deleteFindMin freeElems
- IOA.writeArray arr n element
- writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
- return $ ElemIndex n
-
-
-removeElem :: MStore e -> ElemIndex -> IO ()
-removeElem (MStore ref) (ElemIndex n) = do
- (busyElems, freeElems, arr) <- readIORef ref
- IOA.writeArray arr n (error $ "Store: no element " ++ show n)
- writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
-
-
-readElem :: MStore e -> ElemIndex -> IO e
-readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
-
-
-writeElem :: MStore e -> ElemIndex -> e -> IO ()
-writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
-
-
-modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
-modifyElem (MStore ref) f (ElemIndex n) = do
- (_, _, arr) <- readIORef ref
- IOA.readArray arr n >>= IOA.writeArray arr n . f
-
-elemExists :: MStore e -> ElemIndex -> IO Bool
-elemExists (MStore ref) (ElemIndex n) = do
- (_, free, _) <- readIORef ref
- return $ n `IntSet.notMember` free
-
-indicesM :: MStore e -> IO [ElemIndex]
-indicesM (MStore ref) = do
- (busy, _, _) <- readIORef ref
- return $ map ElemIndex $ IntSet.toList busy
-
-
--- A way to see MStore elements in pure code via IStore
-m2i :: MStore e -> IO (IStore e)
-m2i (MStore ref) = do
- (a, _, c') <- readIORef ref
- c <- IOA.unsafeFreeze c'
- return $ IStore (a, c)
-
-i2m :: (MStore e) -> IStore e -> IO ()
-i2m (MStore ref) (IStore (_, arr)) = do
- (b, e, _) <- readIORef ref
- a <- IOA.unsafeThaw arr
- writeIORef ref (b, e, a)
-
-withIStore :: MStore e -> (IStore e -> a) -> IO a
-withIStore m f = do
- i <- m2i m
- let res = f i
- res `seq` i2m m i
- return res
-
-
-withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
-withIStore2 m1 m2 f = do
- i1 <- m2i m1
- i2 <- m2i m2
- let res = f i1 i2
- res `seq` i2m m1 i1
- i2m m2 i2
- return res
-
-
--- IStore code
-(!) :: IStore e -> ElemIndex -> e
-(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
-
-indices :: IStore e -> [ElemIndex]
-indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy
--- a/gameServer/Utils.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/Utils.hs Fri Nov 12 09:49:46 2010 +0100
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
module Utils where
import Control.Concurrent
@@ -14,33 +13,36 @@
import System.IO
import qualified Data.List as List
import Control.Monad
-import Data.Maybe
+import Maybe
-------------------------------------------------
import qualified Codec.Binary.Base64 as Base64
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString as BW
+import qualified Data.ByteString.UTF8 as BUTF8
+import qualified Data.ByteString as B
import CoreTypes
-sockAddr2String :: SockAddr -> IO B.ByteString
-sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr
+sockAddr2String :: SockAddr -> IO String
+sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
- return $ B.pack $ (foldr1 (.)
+ return $ (foldr1 (.)
$ List.intersperse (\a -> ':':a)
$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
-toEngineMsg :: B.ByteString -> B.ByteString
-toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg))
+toEngineMsg :: String -> String
+toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg))
+ where
+ encodedMsg = BUTF8.fromString msg
-fromEngineMsg :: B.ByteString -> Maybe B.ByteString
-fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack
+fromEngineMsg :: String -> Maybe String
+fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength)
where
removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
removeLength _ = Nothing
-checkNetCmd :: B.ByteString -> (Bool, Bool)
-checkNetCmd = check . liftM B.unpack . fromEngineMsg
+checkNetCmd :: String -> (Bool, Bool)
+checkNetCmd msg = check decoded
where
+ decoded = fromEngineMsg msg
check Nothing = (False, False)
check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+')
check _ = (False, False)
@@ -52,17 +54,29 @@
[(x, rest)] | all isSpace rest -> Just x
_ -> Nothing
-teamToNet :: TeamInfo -> [B.ByteString]
-teamToNet team =
- "ADD_TEAM"
- : teamname team
- : teamgrave team
- : teamfort team
- : teamvoicepack team
- : teamflag team
- : teamowner team
- : (B.pack $ show $ difficulty team)
- : hhsInfo
+teamToNet :: Word16 -> TeamInfo -> [String]
+teamToNet protocol team
+ | protocol < 30 = [
+ "ADD_TEAM",
+ teamname team,
+ teamgrave team,
+ teamfort team,
+ teamvoicepack team,
+ teamowner team,
+ show $ difficulty team
+ ]
+ ++ hhsInfo
+ | otherwise = [
+ "ADD_TEAM",
+ teamname team,
+ teamgrave team,
+ teamfort team,
+ teamvoicepack team,
+ teamflag team,
+ teamowner team,
+ show $ difficulty team
+ ]
+ ++ hhsInfo
where
hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
@@ -76,10 +90,10 @@
else
t : replaceTeam team teams
-illegalName :: B.ByteString -> Bool
-illegalName = all isSpace . B.unpack
+illegalName :: String -> Bool
+illegalName = all isSpace
-protoNumber2ver :: Word16 -> B.ByteString
+protoNumber2ver :: Word16 -> String
protoNumber2ver 17 = "0.9.7-dev"
protoNumber2ver 19 = "0.9.7"
protoNumber2ver 20 = "0.9.8-dev"
@@ -102,13 +116,3 @@
putStr msg
hFlush stdout
getLine
-
-
-unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b)
-unfoldrE f b =
- case f b of
- Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b')
- Left new_b -> ([], new_b)
-
-showB :: Show a => a -> B.ByteString
-showB = B.pack .show
--- a/gameServer/hedgewars-server.cabal Fri Nov 12 00:11:22 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,32 +0,0 @@
-Name: hedgewars-server
-Version: 0.1
-Synopsis: hedgewars server
-Description: hedgewars server
-Homepage: http://www.hedgewars.org/
-License: GPL-2
-Author: unC0Rr
-Maintainer: unC0Rr@hedgewars.org
-Category: Game
-Build-type: Simple
-Cabal-version: >=1.2
-
-
-Executable hedgewars-server
- main-is: hedgewars-server.hs
-
- Build-depends:
- base >= 4,
- unix,
- containers,
- array,
- bytestring,
- network-bytestring,
- network,
- time,
- stm,
- mtl,
- dataenc,
- hslogger,
- process
-
- ghc-options: -O2
\ No newline at end of file
--- a/gameServer/hedgewars-server.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/hedgewars-server.hs Fri Nov 12 09:49:46 2010 +0100
@@ -2,15 +2,22 @@
module Main where
-import Network
+import Network.Socket
+import qualified Network
import Control.Concurrent.STM
import Control.Concurrent.Chan
+#if defined(NEW_EXCEPTIONS)
+import qualified Control.OldException as Exception
+#else
import qualified Control.Exception as Exception
+#endif
import System.Log.Logger
-----------------------------------
import Opts
import CoreTypes
+import OfficialServer.DBInteraction
import ServerCore
+import Utils
#if !defined(mingw32_HOST_OS)
@@ -18,12 +25,10 @@
#endif
-setupLoggers :: IO ()
setupLoggers =
updateGlobalLogger "Clients"
(setLevel INFO)
-main :: IO ()
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
installHandler sigPIPE Ignore Nothing;
@@ -32,11 +37,11 @@
setupLoggers
- stats' <- atomically $ newTMVar (StatisticsInfo 0 0)
+ stats <- atomically $ newTMVar (StatisticsInfo 0 0)
dbQueriesChan <- newChan
- coreChan' <- newChan
- serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan
-
+ coreChan <- newChan
+ serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan
+
#if defined(OFFICIAL_SERVER)
dbHost' <- askFromConsole "DB host: "
dbLogin' <- askFromConsole "login: "
--- a/gameServer/stresstest.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/stresstest.hs Fri Nov 12 09:49:46 2010 +0100
@@ -6,7 +6,7 @@
import System.IO
import Control.Concurrent
import Network
-import Control.OldException
+import Control.Exception
import Control.Monad
import System.Random
@@ -14,24 +14,24 @@
import System.Posix
#endif
-session1 nick room = ["NICK", nick, "", "PROTO", "32", "", "PING", "", "CHAT", "lobby 1", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""]
-session2 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROOM", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""]
-session3 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROON", room, "", "CHAT", "room 2", "", "QUIT", "quit", ""]
+session1 nick room = ["NICK", nick, "", "PROTO", "24", "", "CHAT", "lobby 1", "", "CREATE", room, "", "CHAT", "room 1", "", "QUIT", "bye-bye", ""]
+session2 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "bye-bye", ""]
+session3 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "QUIT", "bye-bye", ""]
emulateSession sock s = do
- mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (30000::Int, 59000) >>= threadDelay) s
+ mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (50000::Int, 90000) >>= threadDelay) s
hFlush sock
threadDelay 225000
-testing = Control.OldException.handle print $ do
+testing = Control.Exception.handle print $ do
putStrLn "Start"
sock <- connectTo "127.0.0.1" (PortNumber 46631)
num1 <- randomRIO (70000::Int, 70100)
num2 <- randomRIO (0::Int, 2)
num3 <- randomRIO (0::Int, 5)
- let nick1 = 'n' : show num1
- let room1 = 'r' : show num2
+ let nick1 = show num1
+ let room1 = show num2
case num2 of
0 -> emulateSession sock $ session1 nick1 room1
1 -> emulateSession sock $ session2 nick1 room1
@@ -40,7 +40,7 @@
putStrLn "Finish"
forks = forever $ do
- delay <- randomRIO (30000::Int, 59000)
+ delay <- randomRIO (10000::Int, 19000)
threadDelay delay
forkIO testing
--- a/gameServer/stresstest2.hs Fri Nov 12 00:11:22 2010 +0100
+++ b/gameServer/stresstest2.hs Fri Nov 12 09:49:46 2010 +0100
@@ -6,7 +6,7 @@
import System.IO
import Control.Concurrent
import Network
-import Control.OldException
+import Control.Exception
import Control.Monad
import System.Random
@@ -14,28 +14,22 @@
import System.Posix
#endif
-session1 nick room = ["NICK", nick, "", "PROTO", "32", ""]
-
-
-
-testing = Control.OldException.handle print $ do
- putStrLn "Start"
+testing = Control.Exception.handle print $ do
+ delay <- randomRIO (100::Int, 300)
+ threadDelay delay
sock <- connectTo "127.0.0.1" (PortNumber 46631)
+ hClose sock
- num1 <- randomRIO (70000::Int, 70100)
- num2 <- randomRIO (0::Int, 2)
- num3 <- randomRIO (0::Int, 5)
- let nick1 = 'n' : show num1
- let room1 = 'r' : show num2
- mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (300::Int, 590) >>= threadDelay) $ session1 nick1 room1
- mapM_ (\x -> hPutStrLn sock x >> hFlush sock) $ concatMap (\x -> ["CHAT_MSG", show x, ""]) [1..]
- hClose sock
- putStrLn "Finish"
-
-forks = testing
+forks i = do
+ delay <- randomRIO (50::Int, 190)
+ if i `mod` 10 == 0 then putStr (show i) else putStr "."
+ hFlush stdout
+ threadDelay delay
+ forkIO testing
+ forks (i + 1)
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
installHandler sigPIPE Ignore Nothing;
#endif
- forks
+ forks 1
--- a/gameServer/stresstest3.hs Fri Nov 12 00:11:22 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,75 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Main where
-
-import IO
-import System.IO
-import Control.Concurrent
-import Network
-import Control.OldException
-import Control.Monad
-import System.Random
-import Control.Monad.State
-import Data.List
-
-#if !defined(mingw32_HOST_OS)
-import System.Posix
-#endif
-
-type SState = Handle
-io = liftIO
-
-readPacket :: StateT SState IO [String]
-readPacket = do
- h <- get
- p <- io $ hGetPacket h []
- return p
- where
- hGetPacket h buf = do
- l <- hGetLine h
- if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf
-
-waitPacket :: String -> StateT SState IO Bool
-waitPacket s = do
- p <- readPacket
- return $ head p == s
-
-sendPacket :: [String] -> StateT SState IO ()
-sendPacket s = do
- h <- get
- io $ do
- mapM_ (hPutStrLn h) s
- hPutStrLn h ""
- hFlush h
-
-emulateSession :: StateT SState IO ()
-emulateSession = do
- n <- io $ randomRIO (100000::Int, 100100)
- waitPacket "CONNECTED"
- sendPacket ["NICK", "test" ++ (show n)]
- waitPacket "NICK"
- sendPacket ["PROTO", "31"]
- waitPacket "PROTO"
- b <- waitPacket "LOBBY:JOINED"
- --io $ print b
- sendPacket ["QUIT", "BYE"]
- return ()
-
-testing = Control.OldException.handle print $ do
- putStr "+"
- sock <- connectTo "127.0.0.1" (PortNumber 46631)
- evalStateT emulateSession sock
- --hClose sock
- putStr "-"
- hFlush stdout
-
-forks = forM_ [1..100] $ const $ do
- delay <- randomRIO (10000::Int, 30000)
- threadDelay delay
- forkIO testing
-
-main = withSocketsDo $ do
-#if !defined(mingw32_HOST_OS)
- installHandler sigPIPE Ignore Nothing;
-#endif
- forks
