hedgewars: comparison gameServer/Actions.hs

equal deleted inserted replaced

-:8054d9d775fd
+:2759212a27de
 import Control.Arrow
 import Control.Exception as E
 import System.Process
 import Network.Socket
 import System.Random
+import qualified Data.Traversable as DT
 -----------------------------
 #if defined(OFFICIAL_SERVER)
 import OfficialServer.GameReplayStore
 #endif
 import CoreTypes
 processAction (MoveToLobby msg) = do
 (Just ci) <- gets clientIndex
 ri <- clientRoomA
 rnc <- gets roomsClients
 playersNum <- io $ room'sM rnc playersIn ri
+specialRoom <- io $ room'sM rnc isSpecial ri
 master <- client's isMaster
 --    client <- client's id
 clNick <- client's nick
 chans <- othersChans
 if master then
-if playersNum > 1 then
+if (playersNum > 1) || specialRoom then
 mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
 else
 processAction RemoveRoom
 else
 mapM_ processAction [RemoveClientTeams, AnswerClients chans ["LEFT", clNick, msg]]
 allClientsChans <- liftM (Prelude.map sendChan . Prelude.filter isVisible) $! allClientsS
 processAction $ AnswerClients allClientsChans ["CLIENT_FLAGS", "-i", clNick]
 -- when not removing room
 ready <- client's isReady
-when (not master || playersNum > 1) . io $ do
+when (not master || playersNum > 1 || specialRoom) . io $ do
 modifyRoom rnc (\r -> r{
 playersIn = playersIn r - 1,
 readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
 }) ri
 moveClientToLobby rnc ci
 processAction (ChangeMaster delegateId)= do
 (Just ci) <- gets clientIndex
 proto <- client's clientProto
 ri <- clientRoomA
 rnc <- gets roomsClients
-newMasterId <- liftM (\ids -> fromMaybe (last . filter (/= ci) $ ids) delegateId) . io $ roomClientsIndicesM rnc ri
+specialRoom <- io $ room'sM rnc isSpecial ri
-newMaster <- io $ client'sM rnc id newMasterId
+newMasterId <- liftM (\ids -> fromMaybe (listToMaybe . reverse . filter (/= ci) $ ids) $ liftM Just delegateId) . io $ roomClientsIndicesM rnc ri
+newMaster <- io $ client'sM rnc id `DT.mapM` newMasterId
 oldMasterId <- io $ room'sM rnc masterID ri
-oldMaster <- io $ client'sM rnc id oldMasterId
 oldRoomName <- io $ room'sM rnc name ri
 kicked <- client's isKickedFromServer
 thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
-let newRoomName = if (proto < 42) || kicked then nick newMaster else oldRoomName
+let newRoomName = if ((proto < 42) || kicked) && (not specialRoom) then maybeNick newMaster else oldRoomName
-mapM_ processAction [
+when (isJust oldMasterId) $ do
+oldMasterNick <- io $ client'sM rnc nick (fromJust oldMasterId)
+mapM_ processAction [
+ModifyClient2 (fromJust oldMasterId) (\c -> c{isMaster = False})
+, AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMasterNick]
+]
+when (isJust newMasterId) $
+mapM_ processAction [
+ModifyClient2 (fromJust newMasterId) (\c -> c{isMaster = True})
+, AnswerClients [sendChan $ fromJust newMaster] ["ROOM_CONTROL_ACCESS", "1"]
+, AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick $ fromJust newMaster]
+]
+processAction $
 ModifyRoom (\r -> r{masterID = newMasterId
 , name = newRoomName
 , isRestrictedJoins = False
 , isRestrictedTeams = False
-, isRegisteredOnly = False}
+, isRegisteredOnly = isSpecial r}
 )
-, ModifyClient2 newMasterId (\c -> c{isMaster = True})
-, ModifyClient2 oldMasterId (\c -> c{isMaster = False})
-, AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
-, AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", nick oldMaster]
-, AnswerClients thisRoomChans ["CLIENT_FLAGS", "+h", nick newMaster]
-]
 newRoom' <- io $ room'sM rnc id ri
 chans <- liftM (map sendChan) $! sameProtoClientsS proto
-processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo (nick newMaster) newRoom')
+processAction $ AnswerClients chans ("ROOM" : "UPD" : oldRoomName : roomInfo proto (maybeNick newMaster) newRoom')
 processAction (AddRoom roomName roomPassword) = do
 Just clId <- gets clientIndex
 rnc <- gets roomsClients
 proto <- client's clientProto
 n <- client's nick
 let rm = newRoom{
-masterID = clId,
+masterID = Just clId,
 name = roomName,
 password = roomPassword,
 roomProto = proto
 }
 processAction $ MoveToRoom rId
 chans <- liftM (map sendChan) $! sameProtoClientsS proto
 mapM_ processAction [
-AnswerClients chans ("ROOM" : "ADD" : roomInfo n rm{playersIn = 1})
+AnswerClients chans ("ROOM" : "ADD" : roomInfo proto n rm{playersIn = 1})
 ]
 processAction RemoveRoom = do
 Just clId <- gets clientIndex
 Just clId <- gets clientIndex
 proto <- client's clientProto
 rnc <- gets roomsClients
 ri <- io $ clientRoomM rnc clId
 rm <- io $ room'sM rnc id ri
-n <- io $ client'sM rnc nick (masterID rm)
+masterCl <- io $ client'sM rnc id `DT.mapM` (masterID rm)
 chans <- liftM (map sendChan) $! sameProtoClientsS proto
-processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo n rm)
+processAction $ AnswerClients chans ("ROOM" : "UPD" : name rm : roomInfo proto (maybeNick masterCl) rm)
 processAction UnreadyRoomClients = do
 ri <- clientRoomA
 roomPlayers <- roomClientsS ri
 when (not b) $
 if c then
 checkerLogin "" False False
 else
 processAction JoinLobby
-Admin -> do
+Admin ->
 mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
-chan <- client's sendChan
-processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
 ReplayName fn -> processAction $ ShowReplay fn
 where
 isBanned = do
 processAction $ CheckBanned False
 liftM B.null $ client's nick
 , ModifyClient (\c -> c{webPassword = p, isAdministrator = a, isContributor = contr})
 ]
 processAction JoinLobby = do
 chan <- client's sendChan
+rnc <- gets roomsClients
 clientNick <- client's nick
 isAuthenticated <- liftM (not . B.null) $ client's webPassword
 isAdmin <- client's isAdministrator
 isContr <- client's isContributor
 loggedInClients <- liftM (Prelude.filter isVisible) $! allClientsS
 let (lobbyNicks, clientsChans) = unzip . L.map (nick &&& sendChan) $ loggedInClients
 let authenticatedNicks = L.map nick . L.filter (not . B.null . webPassword) $ loggedInClients
 let adminsNicks = L.map nick . L.filter isAdministrator $ loggedInClients
 let contrNicks = L.map nick . L.filter isContributor $ loggedInClients
+inRoomNicks <- io $
+allClientsM rnc
+>>= filterM (liftM ((/=) lobbyId) . clientRoomM rnc)
+>>= mapM (client'sM rnc nick)
 let clFlags = B.concat . L.concat $ [["u" | isAuthenticated], ["a" | isAdmin], ["c" | isContr]]
 mapM_ processAction . concat $ [
 [AnswerClients clientsChans ["LOBBY:JOINED", clientNick]]
 , [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
 , [AnswerClients [chan] ("CLIENT_FLAGS" : "+u" : authenticatedNicks) | not $ null authenticatedNicks]
 , [AnswerClients [chan] ("CLIENT_FLAGS" : "+a" : adminsNicks) | not $ null adminsNicks]
 , [AnswerClients [chan] ("CLIENT_FLAGS" : "+c" : contrNicks) | not $ null contrNicks]
+, [AnswerClients [chan] ("CLIENT_FLAGS" : "+i" : inRoomNicks) | not $ null inRoomNicks]
 , [AnswerClients (chan : clientsChans) ["CLIENT_FLAGS",  B.concat["+" , clFlags], clientNick] | not $ B.null clFlags]
 , [ModifyClient (\cl -> cl{logonPassed = True, isVisible = True})]
 , [SendServerMessage]
 ]
 processAction CheckRecord = do
 p <- client's clientProto
 c <- client's sendChan
-(cinfo, l) <- io $ loadReplay (fromIntegral p)
+ri <- clientRoomA
+rnc <- gets roomsClients
+blackList <- liftM (map (recordFileName . fromJust . checkInfo) . filter (isJust . checkInfo)) allClientsS
+readyCheckersIds <- io $ do
+allci <- allClientsM rnc
+filterM (client'sM rnc (isJust . checkInfo)) allci
+(cinfo, l) <- io $ loadReplay (fromIntegral p) blackList
 when (not . null $ l) $
 mapM_ processAction [
 AnswerClients [c] ("REPLAY" : l)
 , ModifyClient $ \c -> c{checkInfo = cinfo, isReady = False}
 ]
 io $ moveFailedRecord fileName
 processAction (CheckSuccess info) = do
 Just (CheckInfo fileName teams) <- client's checkInfo
+p <- client's clientProto
 si <- gets serverInfo
-io $ writeChan (dbQueries si) $ StoreAchievements (B.pack fileName) (map toPair teams) info
+io $ writeChan (dbQueries si) $ StoreAchievements p (B.pack fileName) (map toPair teams) info
 io $ moveCheckedRecord fileName
 where
 toPair t = (teamname t, teamowner t)
-processAction (QueryReplay name) = do
+processAction (QueryReplay rname) = do
 (Just ci) <- gets clientIndex
 si <- gets serverInfo
 uid <- client's clUID
-io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) name
+io $ writeChan (dbQueries si) $ GetReplayName ci (hashUnique uid) rname
 #else
 processAction SaveReplay = return ()
 processAction CheckRecord = return ()
 processAction (CheckFailed _) = return ()
 processAction (CheckSuccess _) = return ()
 processAction (QueryReplay _) = return ()
 #endif
-processAction (ShowReplay name) = do
+processAction (ShowReplay rname) = do
 c <- client's sendChan
 cl <- client's id
-let fileName = B.concat ["checked/", if B.isPrefixOf "replays/" name then B.drop 8 name else name]
+let fileName = B.concat ["checked/", if B.isPrefixOf "replays/" rname then B.drop 8 rname else rname]
-checkInfo <- liftIO $ E.handle (\(e :: SomeException) ->
+cInfo <- liftIO $ E.handle (\(e :: SomeException) ->
 warningM "REPLAYS" (B.unpack $ B.concat ["Problems reading ", fileName, ": ", B.pack $ show e]) >> return Nothing) $ do
 (t, p1, p2, msgs) <- liftM read $ readFile (B.unpack fileName)
 return $ Just (t, Map.fromList p1, Map.fromList p2, reverse msgs)
-let (teams, params1, params2, roundMsgs) = fromJust checkInfo
+let (teams', params1, params2, roundMsgs') = fromJust cInfo
-when (isJust checkInfo) $ do
+when (isJust cInfo) $ do
 mapM_ processAction $ concat [
 [AnswerClients [c] ["JOINED", nick cl]]
 , answerFullConfigParams cl params1 params2
-, answerAllTeams cl teams
+, answerAllTeams cl teams'
 , [AnswerClients [c]  ["RUN_GAME"]]
-, [AnswerClients [c] $ "EM" : roundMsgs]
+, [AnswerClients [c] $ "EM" : roundMsgs']
 , [AnswerClients [c] ["KICKED"]]
 ]

branch	webgl
changeset 9950	2759212a27de
parent 9521	8054d9d775fd
parent 9868	53d1b92db6ce
child 10015	4feced261c68