gameServer/Actions.hs
author nemo
Wed, 24 Feb 2010 13:46:02 +0000
changeset 2858 4c5c4bc0ae35
parent 2662 12dc696f1c81
child 2867 9be6693c78cb
permissions -rw-r--r--
Add nil check to shotgun shell

module Actions where

import Control.Concurrent.STM
import Control.Concurrent.Chan
import Data.IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Sequence as Seq
import System.Log.Logger
import Monad
import Data.Time
import Maybe
-----------------------------
import CoreTypes
import Utils

data Action =
	AnswerThisClient [String]
	| AnswerAll [String]
	| AnswerAllOthers [String]
	| AnswerThisRoom [String]
	| AnswerOthersInRoom [String]
	| AnswerSameClan [String]
	| AnswerLobby [String]
	| SendServerMessage
	| RoomAddThisClient Int -- roomID
	| RoomRemoveThisClient String
	| RemoveTeam String
	| RemoveRoom
	| UnreadyRoomClients
	| MoveToLobby
	| ProtocolError String
	| Warning String
	| ByeClient String
	| KickClient Int -- clID
	| KickRoomClient Int -- clID
	| BanClient String -- nick
	| RemoveClientTeams Int -- clID
	| ModifyClient (ClientInfo -> ClientInfo)
	| ModifyClient2 Int (ClientInfo -> ClientInfo)
	| ModifyRoom (RoomInfo -> RoomInfo)
	| ModifyServerInfo (ServerInfo -> ServerInfo)
	| AddRoom String String
	| CheckRegistered
	| ClearAccountsCache
	| ProcessAccountInfo AccountInfo
	| Dump
	| AddClient ClientInfo
	| PingAll
	| StatsAction

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 (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 (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 (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 = if clientProto client < 29 then
			serverMessageForOldVersions
			else
			serverMessage


processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
	writeChan (sendChan $ clients ! clID) ["ERROR", msg]
	return (clID, serverInfo, clients, rooms)


processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
	writeChan (sendChan $ clients ! clID) ["WARNING", msg]
	return (clID, serverInfo, clients, rooms)


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)

	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
		answerInformRoom =
			if roomID client /= 0 then
				if not $ Prelude.null msg then
					[AnswerThisRoom ["LEFT", clientNick, msg]]
				else
					[AnswerThisRoom ["LEFT", clientNick]]
			else
				[]
		answerOthersQuit =
			if logonPassed client then
				if not $ Prelude.null msg then
					[AnswerAll ["LOBBY:LEFT", clientNick, msg]]
				else
					[AnswerAll ["LOBBY:LEFT", clientNick]]
			else
				[]


processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
	return (clID, serverInfo, adjust func clID clients, rooms)


processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
	return (clID, serverInfo, adjust func cl2ID clients, rooms)


processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
	return (clID, serverInfo, clients, adjust func rID rooms)
	where
		rID = roomID $ clients ! clID


processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
	return (clID, func serverInfo, clients, rooms)


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 (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
						[AnswerOthersInRoom ["LEFT", nick client, msg],
						AnswerOthersInRoom ["WARNING", "Admin left the room"],
						RemoveClientTeams clID]))
				else -- not in game
					processAction (clID, serverInfo, clients, rooms) RemoveRoom
			else -- not master
				foldM
					processAction
						(clID, serverInfo, clients, rooms)
						[AnswerOthersInRoom ["LEFT", nick client, msg],
						RemoveClientTeams clID]
		else -- in lobby
			return (clID, serverInfo, clients, rooms)
	
	return (
		clID,
		serverInfo,
		adjust resetClientFlags clID newClients,
		adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
		)
	where
		rID = roomID client
		client = clients ! clID
		room = rooms ! rID
		resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
		removeClientFromRoom r = r{
				playersIDs = otherPlayersSet,
				playersIn = (playersIn r) - 1,
				readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
				}
		insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
		changeMaster = do
			processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
			return (
				clID,
				serverInfo,
				adjust (\cl -> cl{isMaster = True}) newMasterId clients,
				adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
				)
		newRoomName = nick newMasterClient
		otherPlayersSet = IntSet.delete clID (playersIDs room)
		newMasterId = IntSet.findMin otherPlayersSet
		newMasterClient = clients ! newMasterId


processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
	let newServerInfo = serverInfo {nextRoomID = newID}
	let room = newRoom{
			roomUID = newID,
			masterID = clID,
			name = roomName,
			password = roomPassword,
			roomProto = (clientProto client)
			}

	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]

	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, 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,
		delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
		)
	where
		room = rooms ! rID
		rID = roomID client
		client = clients ! clID


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 (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
			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
		room = rooms ! rID
		rID = roomID client
		client = clients ! clID
		rmTeamMsg = toEngineMsg $ 'F' : teamName


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, 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, clients, rooms)


processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
	case info of
		HasAccount passwd isAdmin -> do
			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
			infoM "Clients" $ show clID ++ " is guest"
			processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
		Admin -> do
			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 (clID, serverInfo, clients, rooms) (MoveToLobby) =
	foldM processAction (clID, serverInfo, clients, rooms) $
		(RoomAddThisClient 0)
		: answerLobbyNicks
		++ [SendServerMessage]

		-- ++ (answerServerMessage client clients)
	where
		lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
		answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]


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, clients, rooms) (KickRoomClient kickID) = do
	writeChan (sendChan $ clients ! kickID) ["KICKED"]
	liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")


processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
	liftM2 replaceID (return clID) $
		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 (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/"]

	let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins 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 (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 (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 (clID, serverInfo, clients, rooms) (StatsAction) = do
	writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
	return (clID, serverInfo, clients, rooms)