gameServer/Actions.hs
author unc0rr
Wed, 09 Sep 2009 14:04:06 +0000
changeset 2362 ef4abaf2d5cc
parent 2352 7eaf82cf0890
child 2403 6c5d504af2ba
permissions -rw-r--r--
- Implement low quality rope - Sometimes doesn't render - to be fixed
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module Actions where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Data.IntMap
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import qualified Data.IntSet as IntSet
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
     7
import qualified Data.Sequence as Seq
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
     8
import System.Log.Logger
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Monad
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
    10
import Data.Time
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
    11
import Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
    14
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
data Action =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
	AnswerThisClient [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
	| AnswerAll [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
	| AnswerAllOthers [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
	| AnswerThisRoom [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
	| AnswerOthersInRoom [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
	| AnswerLobby [String]
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
    23
	| SendServerMessage
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
	| RoomAddThisClient Int -- roomID
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2118
diff changeset
    25
	| RoomRemoveThisClient String
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
    26
	| RemoveTeam String
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
	| RemoveRoom
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
    28
	| UnreadyRoomClients
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    29
	| MoveToLobby
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
	| ProtocolError String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
	| Warning String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
	| ByeClient String
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1847
diff changeset
    33
	| KickClient Int -- clID
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
    34
	| KickRoomClient Int -- clID
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
    35
	| BanClient String -- nick
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
    36
	| RemoveClientTeams Int -- clID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
	| ModifyClient (ClientInfo -> ClientInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
	| ModifyRoom (RoomInfo -> RoomInfo)
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
    39
	| ModifyServerInfo (ServerInfo -> ServerInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
	| AddRoom String String
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
    41
	| CheckRegistered
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
    42
	| ClearAccountsCache
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    43
	| ProcessAccountInfo AccountInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
	| Dump
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
    45
	| AddClient ClientInfo
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    46
	| PingAll
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
    47
	| StatsAction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1847
diff changeset
    51
replaceID a (b, c, d, e) = (a, c, d, e)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
	writeChan (sendChan $ clients ! clID) msg
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    62
	mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
    67
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
    68
		Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    76
		roomClients = IntSet.elems $ playersIDs room
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    77
		room = rooms ! rID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    81
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) roomClients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    85
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
		roomClients = IntSet.elems $ playersIDs room
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    87
		room = rooms ! rID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    88
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    89
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    90
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    92
processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    93
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    94
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    95
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
		roomClients = IntSet.elems $ playersIDs room
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    97
		room = rooms ! 0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    98
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    99
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
   100
processAction (clID, serverInfo, clients, rooms) SendServerMessage = do
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   101
	writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
   102
	return (clID, serverInfo, clients, rooms)
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1931
diff changeset
   103
	where
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1931
diff changeset
   104
		client = clients ! clID
2104
b2c50a7480ea Update server's message
unc0rr
parents: 2001
diff changeset
   105
		message = if clientProto client < 27 then
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1931
diff changeset
   106
			serverMessageForOldVersions
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1931
diff changeset
   107
			else
1994
990f341a2332 Fix message being sent to users of 0.9.10
unc0rr
parents: 1977
diff changeset
   108
			serverMessage
1923
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
   109
956b6b3529bc Send server message on join
unc0rr
parents: 1921
diff changeset
   110
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   111
processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   112
	writeChan (sendChan $ clients ! clID) ["ERROR", msg]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   113
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   114
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   115
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   116
processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   117
	writeChan (sendChan $ clients ! clID) ["WARNING", msg]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   118
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   119
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   120
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   121
processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   122
	infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg)
1929
7e6cc8da1c58 - Fix bug with kicking players
unc0rr
parents: 1928
diff changeset
   123
	(_, _, newClients, newRooms) <-
1930
e71c24f11483 Fix server crash (properly follow client's state)
unc0rr
parents: 1929
diff changeset
   124
			if roomID client /= 0 then
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   125
				processAction  (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit"
1930
e71c24f11483 Fix server crash (properly follow client's state)
unc0rr
parents: 1929
diff changeset
   126
				else
e71c24f11483 Fix server crash (properly follow client's state)
unc0rr
parents: 1929
diff changeset
   127
					return (clID, serverInfo, clients, rooms)
1929
7e6cc8da1c58 - Fix bug with kicking players
unc0rr
parents: 1928
diff changeset
   128
7e6cc8da1c58 - Fix bug with kicking players
unc0rr
parents: 1928
diff changeset
   129
	mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   130
	writeChan (sendChan $ clients ! clID) ["BYE", msg]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   131
	return (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   132
			0,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   133
			serverInfo,
1929
7e6cc8da1c58 - Fix bug with kicking players
unc0rr
parents: 1928
diff changeset
   134
			delete clID newClients,
1823
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   135
			adjust (\r -> r{
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   136
					playersIDs = IntSet.delete clID (playersIDs r),
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   137
					playersIn = (playersIn r) - 1,
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   138
					readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
1930
e71c24f11483 Fix server crash (properly follow client's state)
unc0rr
parents: 1929
diff changeset
   139
					}) (roomID $ newClients ! clID) newRooms
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   140
			)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   141
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   142
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   143
		clientNick = nick client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   144
		answerInformRoom =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   145
			if roomID client /= 0 then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   146
				if not $ Prelude.null msg then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   147
					[AnswerThisRoom ["LEFT", clientNick, msg]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   148
				else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   149
					[AnswerThisRoom ["LEFT", clientNick]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   150
			else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   151
				[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   152
		answerOthersQuit =
1846
24d0074d4eed Small optimization in net server
unc0rr
parents: 1841
diff changeset
   153
			if logonPassed client then
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   154
				if not $ Prelude.null msg then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   155
					[AnswerAll ["LOBBY:LEFT", clientNick, msg]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   156
				else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   157
					[AnswerAll ["LOBBY:LEFT", clientNick]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   158
			else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   159
				[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   160
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   161
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   162
processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   163
	return (clID, serverInfo, adjust func clID clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   164
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   165
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   166
processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   167
	return (clID, serverInfo, clients, adjust func rID rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   168
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   169
		rID = roomID $ clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   170
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   171
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   172
processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
1925
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
   173
	return (clID, func serverInfo, clients, rooms)
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
   174
ec923e56c444 Allow admin to set server's motd
unc0rr
parents: 1923
diff changeset
   175
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   176
processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) =
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   177
	processAction (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   178
		clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   179
		serverInfo,
2245
c011aecc95e5 unc0rr's patch from issue #144 - prevent spectators from ruining the game
nemo
parents: 2172
diff changeset
   180
		adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   181
		adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   182
			adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   183
		) joinMsg
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   184
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   185
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   186
		joinMsg = if rID == 0 then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   187
				AnswerAllOthers ["LOBBY:JOINED", nick client]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   188
			else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   189
				AnswerThisRoom ["JOINED", nick client]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   190
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   191
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2118
diff changeset
   192
processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do
1977
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   193
	(_, _, newClients, newRooms) <-
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   194
		if roomID client /= 0 then
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   195
			if isMaster client then
2341
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   196
				if (gameinprogress room) && (playersIn room > 1) then
2343
3ab763dc14a3 Send leaving message and remove room admin's teams when he exits
unc0rr
parents: 2341
diff changeset
   197
					(changeMaster >>= (\state -> foldM processAction state
3ab763dc14a3 Send leaving message and remove room admin's teams when he exits
unc0rr
parents: 2341
diff changeset
   198
						[AnswerOthersInRoom ["LEFT", nick client, msg],
2346
f07fd1ac2c48 Warn players in room when admin lefts room
unc0rr
parents: 2345
diff changeset
   199
						AnswerOthersInRoom ["WARNING", "Admin left the room"],
2343
3ab763dc14a3 Send leaving message and remove room admin's teams when he exits
unc0rr
parents: 2341
diff changeset
   200
						RemoveClientTeams clID]))
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   201
				else -- not in game
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   202
					processAction (clID, serverInfo, clients, rooms) RemoveRoom
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   203
			else -- not master
1977
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   204
				foldM
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   205
					processAction
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   206
						(clID, serverInfo, clients, rooms)
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2118
diff changeset
   207
						[AnswerOthersInRoom ["LEFT", nick client, msg],
1977
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   208
						RemoveClientTeams clID]
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   209
		else -- in lobby
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   210
			return (clID, serverInfo, clients, rooms)
1977
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   211
	
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   212
	return (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   213
		clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   214
		serverInfo,
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   215
		adjust resetClientFlags clID newClients,
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   216
		adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   217
		)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   218
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   219
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   220
		client = clients ! clID
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   221
		room = rooms ! rID
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   222
		resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   223
		removeClientFromRoom r = r{
2341
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   224
				playersIDs = otherPlayersSet,
2337
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   225
				playersIn = (playersIn r) - 1,
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   226
				readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   227
				}
723f1cbe2ef3 Some preparation for room control delegation support
unc0rr
parents: 2245
diff changeset
   228
		insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
2341
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   229
		changeMaster = do
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   230
			processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   231
			return (
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   232
				clID,
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   233
				serverInfo,
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   234
				adjust (\cl -> cl{isMaster = True}) newMasterId clients,
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   235
				adjust (\r -> r{name = newRoomName}) rID rooms
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   236
				)
2345
daf1785f2337 - Frontend: reorganize code controlling widgets state, fix problems getting room admin status
unc0rr
parents: 2343
diff changeset
   237
		newRoomName = nick newMasterClient
2341
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   238
		otherPlayersSet = IntSet.delete clID (playersIDs room)
408edb2f254c Implement room delegation (not tested, only one predefined name to rename room)
unc0rr
parents: 2337
diff changeset
   239
		newMasterId = IntSet.findMin otherPlayersSet
2345
daf1785f2337 - Frontend: reorganize code controlling widgets state, fix problems getting room admin status
unc0rr
parents: 2343
diff changeset
   240
		newMasterClient = clients ! newMasterId
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   241
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   242
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   243
processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   244
	let newServerInfo = serverInfo {nextRoomID = newID}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   245
	let room = newRoom{
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   246
			roomUID = newID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   247
			name = roomName,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   248
			password = roomPassword,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   249
			roomProto = (clientProto client)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   250
			}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   251
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   252
	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   253
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   254
	processAction (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   255
		clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   256
		newServerInfo,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   257
		adjust (\cl -> cl{isMaster = True}) clID clients,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   258
		insert newID room rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   259
		) $ RoomAddThisClient newID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   260
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   261
		newID = (nextRoomID serverInfo) - 1
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   262
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   263
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   264
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   265
processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   266
	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room]
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   267
	processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   268
	return (clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   269
		serverInfo,
2245
c011aecc95e5 unc0rr's patch from issue #144 - prevent spectators from ruining the game
nemo
parents: 2172
diff changeset
   270
		Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   271
		delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   272
		)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   273
	where
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   274
		room = rooms ! rID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   275
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   276
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   277
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   278
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   279
processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   280
	processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   281
	return (clID,
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   282
		serverInfo,
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   283
		Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
1827
3bb5e22b7f9a Fix ready players number after a round
unc0rr
parents: 1823
diff changeset
   284
		adjust (\r -> r{readyPlayers = 0}) rID rooms)
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   285
	where
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   286
		room = rooms ! rID
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   287
		rID = roomID client
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   288
		client = clients ! clID
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   289
		roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   290
		roomPlayersIDs = IntSet.elems $ playersIDs room
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   291
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   292
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   293
processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   294
	newRooms <-	if not $ gameinprogress room then
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   295
			do
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   296
			processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   297
			return $
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   298
				adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   299
		else
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   300
			do
1866
36aa0ca6e8af Cut the length of most used net packet
unc0rr
parents: 1862
diff changeset
   301
			processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg]
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   302
			return $
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   303
				adjust (\r -> r{
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   304
				teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   305
				leftTeams = teamName : leftTeams r,
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   306
				roundMsgs = roundMsgs r Seq.|> rmTeamMsg
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   307
				}) rID rooms
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   308
	return (clID, serverInfo, clients, newRooms)
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   309
	where
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   310
		room = rooms ! rID
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   311
		rID = roomID client
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   312
		client = clients ! clID
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   313
		rmTeamMsg = toEngineMsg $ 'F' : teamName
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   314
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   315
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   316
processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   317
	writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   318
	return (clID, serverInfo, clients, rooms)
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   319
	where
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   320
		client = clients ! clID
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   321
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   322
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   323
processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   324
	writeChan (dbQueries serverInfo) ClearCache
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   325
	return (clID, serverInfo, clients, rooms)
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   326
	where
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   327
		client = clients ! clID
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   328
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2126
diff changeset
   329
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   330
processAction (clID, serverInfo, clients, rooms) (Dump) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   331
	writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   332
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   333
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   334
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   335
processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   336
	case info of
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1846
diff changeset
   337
		HasAccount passwd isAdmin -> do
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   338
			infoM "Clients" $ show clID ++ " has account"
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   339
			writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1846
diff changeset
   340
			return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   341
		Guest -> do
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   342
			infoM "Clients" $ show clID ++ " is guest"
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   343
			processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   344
		Admin -> do
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   345
			infoM "Clients" $ show clID ++ " is admin"
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   346
			foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   347
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   348
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   349
processAction (clID, serverInfo, clients, rooms) (MoveToLobby) =
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   350
	foldM processAction (clID, serverInfo, clients, rooms) $
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   351
		(RoomAddThisClient 0)
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   352
		: answerLobbyNicks
2118
0ebcc98ebc1a Send server message after nicks info (more chance for it to be seen)
unc0rr
parents: 2116
diff changeset
   353
		++ [SendServerMessage]
0ebcc98ebc1a Send server message after nicks info (more chance for it to be seen)
unc0rr
parents: 2116
diff changeset
   354
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   355
		-- ++ (answerServerMessage client clients)
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   356
	where
1846
24d0074d4eed Small optimization in net server
unc0rr
parents: 1841
diff changeset
   357
		lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   358
		answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   359
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   360
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   361
processAction (clID, serverInfo, clients, rooms) (KickClient kickID) =
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   362
	liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked")
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   363
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   364
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   365
processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   366
	return (clID, serverInfo, clients, rooms)
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1879
diff changeset
   367
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   368
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   369
processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   370
	writeChan (sendChan $ clients ! kickID) ["KICKED"]
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2118
diff changeset
   371
	liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   372
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   373
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   374
processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   375
	liftM2 replaceID (return clID) $
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   376
		foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   377
	where
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   378
		client = clients ! teamsClID
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   379
		room = rooms ! (roomID client)
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   380
		teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
bb114339eb4e Implement kick from room
unc0rr
parents: 1866
diff changeset
   381
		removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   382
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   383
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   384
processAction (clID, serverInfo, clients, rooms) (AddClient client) = do
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   385
	let updatedClients = insert (clientUID client) client clients
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   386
	infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client))
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2346
diff changeset
   387
	writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   388
1977
2284d7fefe4f Some polishing
unc0rr
parents: 1972
diff changeset
   389
	let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1925
diff changeset
   390
1931
ffe420e9e61a Ooops.. enable back DoS protection
unc0rr
parents: 1930
diff changeset
   391
	if isJust $ host client `Prelude.lookup` newLogins then
ffe420e9e61a Ooops.. enable back DoS protection
unc0rr
parents: 1930
diff changeset
   392
		processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast"
ffe420e9e61a Ooops.. enable back DoS protection
unc0rr
parents: 1930
diff changeset
   393
		else
ffe420e9e61a Ooops.. enable back DoS protection
unc0rr
parents: 1930
diff changeset
   394
		return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms)
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   395
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   396
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   397
processAction (clID, serverInfo, clients, rooms) PingAll = do
1928
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   398
	(_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   399
	processAction (clID,
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
   400
		serverInfo,
1928
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   401
		Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   402
		newRooms) $ AnswerAll ["PING"]
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   403
	where
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   404
		kickTimeouted (clID, serverInfo, clients, rooms) client =
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   405
			if pingsQueue client > 0 then
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   406
				processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout"
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   407
				else
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1927
diff changeset
   408
				return (clID, serverInfo, clients, rooms)
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   409
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   410
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   411
processAction (clID, serverInfo, clients, rooms) (StatsAction) = do
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   412
	writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   413
	return (clID, serverInfo, clients, rooms)