gameServer/Actions.hs
author unc0rr
Thu, 26 Feb 2009 14:58:06 +0000
changeset 1845 1d4a5280887d
parent 1841 fba7210b438b
child 1846 24d0074d4eed
permissions -rw-r--r--
Fix pages mess when password is refused
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
    12
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
data Action =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
	AnswerThisClient [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
	| AnswerAll [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
	| AnswerAllOthers [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
	| AnswerThisRoom [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
	| AnswerOthersInRoom [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
	| AnswerLobby [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
	| RoomAddThisClient Int -- roomID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
	| RoomRemoveThisClient
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
    23
	| RemoveTeam String
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
	| RemoveRoom
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
    25
	| UnreadyRoomClients
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    26
	| MoveToLobby
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
	| ProtocolError String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
	| Warning String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
	| ByeClient String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
	| ModifyClient (ClientInfo -> ClientInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
	| ModifyRoom (RoomInfo -> RoomInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
	| AddRoom String String
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
    33
	| CheckRegistered
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    34
	| ProcessAccountInfo AccountInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
	| Dump
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
	writeChan (sendChan $ clients ! clID) msg
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) (keys clients)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) (keys clients)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
		roomClients = IntSet.elems $ playersIDs room
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
		room = rooms ! rID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) roomClients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
		roomClients = IntSet.elems $ playersIDs room
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
		room = rooms ! rID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    76
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    77
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    81
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
		roomClients = IntSet.elems $ playersIDs room
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
		room = rooms ! 0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    85
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    87
	writeChan (sendChan $ clients ! clID) ["ERROR", msg]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    88
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    89
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    90
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    92
	writeChan (sendChan $ clients ! clID) ["WARNING", msg]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    93
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    94
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    95
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    97
	mapM_ (processAction (clID, serverInfo, clients, rooms)) $ answerOthersQuit ++ answerInformRoom
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    98
	writeChan (sendChan $ clients ! clID) ["BYE"]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    99
	return (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   100
			0,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
			serverInfo,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   102
			delete clID clients,
1823
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   103
			adjust (\r -> r{
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   104
					playersIDs = IntSet.delete clID (playersIDs r),
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   105
					playersIn = (playersIn r) - 1,
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   106
					readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   107
					}) rID rooms
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   108
			)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   109
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   110
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   111
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   112
		clientNick = nick client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   113
		answerInformRoom =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   114
			if roomID client /= 0 then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   115
				if not $ Prelude.null msg then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   116
					[AnswerThisRoom ["LEFT", clientNick, msg]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   117
				else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   118
					[AnswerThisRoom ["LEFT", clientNick]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   119
			else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   120
				[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   121
		answerOthersQuit =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   122
			if not $ Prelude.null clientNick then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   123
				if not $ Prelude.null msg then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   124
					[AnswerAll ["LOBBY:LEFT", clientNick, msg]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   125
				else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   126
					[AnswerAll ["LOBBY:LEFT", clientNick]]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   127
			else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   128
				[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   129
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   130
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   131
processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   132
	return (clID, serverInfo, adjust func clID clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   133
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   134
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   135
processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   136
	return (clID, serverInfo, clients, adjust func rID rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   137
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   138
		rID = roomID $ clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   139
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   140
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   141
processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   142
	processAction (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   143
		clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   144
		serverInfo,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   145
		adjust (\cl -> cl{roomID = rID}) clID clients,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   146
		adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   147
			adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   148
		) joinMsg
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   149
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   150
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   151
		joinMsg = if rID == 0 then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   152
				AnswerAllOthers ["LOBBY:JOINED", nick client]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   153
			else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   154
				AnswerThisRoom ["JOINED", nick client]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   155
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   156
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   157
processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   158
	when (rID /= 0) $ (processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["LEFT", nick client, "part"]) >> return ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   159
	return (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   160
		clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   161
		serverInfo,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   162
		adjust (\cl -> cl{roomID = 0}) clID clients,
1823
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   163
		adjust (\r -> r{
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   164
				playersIDs = IntSet.delete clID (playersIDs r),
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   165
				playersIn = (playersIn r) - 1,
1827
3bb5e22b7f9a Fix ready players number after a round
unc0rr
parents: 1823
diff changeset
   166
				readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
1823
1938ef375350 Fix ready players accounting
unc0rr
parents: 1813
diff changeset
   167
				}) rID $
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   168
			adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r)}) 0 rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   169
		)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   170
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   171
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   172
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   173
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   174
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   175
processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   176
	let newServerInfo = serverInfo {nextRoomID = newID}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   177
	let room = newRoom{
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   178
			roomUID = newID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   179
			name = roomName,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   180
			password = roomPassword,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   181
			roomProto = (clientProto client)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   182
			}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   183
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   184
	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   185
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   186
	processAction (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   187
		clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   188
		newServerInfo,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   189
		adjust (\cl -> cl{isMaster = True}) clID clients,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   190
		insert newID room rooms
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   191
		) $ RoomAddThisClient newID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   192
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   193
		newID = (nextRoomID serverInfo) - 1
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   194
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   195
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   196
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   197
processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   198
	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room]
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   199
	processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   200
	return (clID,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   201
		serverInfo,
1827
3bb5e22b7f9a Fix ready players number after a round
unc0rr
parents: 1823
diff changeset
   202
		Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False} else cl) clients,
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   203
		delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   204
		)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   205
	where
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   206
		room = rooms ! rID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   207
		rID = roomID client
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   208
		client = clients ! clID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   209
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   210
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   211
processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   212
	processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   213
	return (clID,
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   214
		serverInfo,
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   215
		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
   216
		adjust (\r -> r{readyPlayers = 0}) rID rooms)
1811
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   217
	where
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   218
		room = rooms ! rID
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   219
		rID = roomID client
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   220
		client = clients ! clID
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   221
		roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   222
		roomPlayersIDs = IntSet.elems $ playersIDs room
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   223
1b9e33623b7e Implement 'roundfinished' cmd on net server
unc0rr
parents: 1804
diff changeset
   224
1813
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   225
processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   226
	newRooms <-	if not $ gameinprogress room then
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   227
			do
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   228
			processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   229
			return $
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   230
				adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   231
		else
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   232
			do
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   233
			processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["GAMEMSG", rmTeamMsg]
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   234
			return $
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   235
				adjust (\r -> r{
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   236
				teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   237
				leftTeams = teamName : leftTeams r,
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   238
				roundMsgs = roundMsgs r Seq.|> rmTeamMsg
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   239
				}) rID rooms
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   240
	return (clID, serverInfo, clients, newRooms)
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   241
	where
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   242
		room = rooms ! rID
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   243
		rID = roomID client
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   244
		client = clients ! clID
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   245
		rmTeamMsg = toEngineMsg $ 'F' : teamName
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   246
cfe1481e0247 Removeteam action
unc0rr
parents: 1811
diff changeset
   247
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   248
processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   249
	writeChan (dbQueries serverInfo) $ CheckAccount clID (nick client)
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   250
	return (clID, serverInfo, clients, rooms)
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   251
	where
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   252
		client = clients ! clID
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1827
diff changeset
   253
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   254
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   255
processAction (clID, serverInfo, clients, rooms) (Dump) = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   256
	writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   257
	return (clID, serverInfo, clients, rooms)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   258
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   259
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   260
processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = do
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   261
	case info of
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   262
		HasAccount passwd -> do
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   263
			infoM "Clients" $ show clID ++ " has account"
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   264
			writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   265
			return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd}) clID clients, rooms)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   266
		Guest -> do
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
   267
			infoM "Clients" $ show clID ++ " is guest"
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   268
			processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   269
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   270
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   271
processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = do
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   272
	foldM processAction (clID, serverInfo, clients, rooms) $
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   273
		(RoomAddThisClient 0)
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   274
		: answerLobbyNicks
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   275
		-- ++ (answerServerMessage client clients)
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   276
	where
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   277
		lobbyNicks = Prelude.filter (\n -> (not (Prelude.null n))) $ Prelude.map nick $ elems clients
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   278
		answerLobbyNicks = if not $ Prelude.null lobbyNicks then
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   279
					[AnswerThisClient (["LOBBY:JOINED"] ++ lobbyNicks)]
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   280
				else
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   281
					[]
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   282
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
   283