gameServer/CoreTypes.hs
author nemo
Sat, 17 Oct 2009 04:57:05 +0000
changeset 2516 effafd586a4e
parent 2408 41ebdb5f1e6e
child 2551 01eb81cd3198
permissions -rw-r--r--
pass in sdli
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module CoreTypes where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Data.Word
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import qualified Data.Map as Map
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import qualified Data.IntMap as IntMap
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import qualified Data.IntSet as IntSet
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Data.Sequence(Seq, empty)
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1921
diff changeset
    11
import Data.Time
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import Network
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    13
import Data.Function
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1832
diff changeset
    15
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
data ClientInfo =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
 ClientInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
	{
2004
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    19
		clientUID :: !Int,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
		sendChan :: Chan [String],
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
		clientHandle :: Handle,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
		host :: String,
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1921
diff changeset
    23
		connectTime :: UTCTime,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
		nick :: String,
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    25
		webPassword :: String,
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    26
		logonPassed :: Bool,
2004
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    27
		clientProto :: !Word16,
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    28
		roomID :: !Int,
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    29
		pingsQueue :: !Word,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
		isMaster :: Bool,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
		isReady :: Bool,
2245
c011aecc95e5 unc0rr's patch from issue #144 - prevent spectators from ruining the game
nemo
parents: 2173
diff changeset
    32
		isAdministrator :: Bool,
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2352
diff changeset
    33
		clientClan :: String,
2245
c011aecc95e5 unc0rr's patch from issue #144 - prevent spectators from ruining the game
nemo
parents: 2173
diff changeset
    34
		teamsInGame :: Word
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
	}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
instance Show ClientInfo where
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    38
	show ci = show (clientUID ci)
2004
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    39
			++ " nick: " ++ (nick ci)
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    40
			++ " host: " ++ (host ci)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
instance Eq ClientInfo where
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    43
	(==) = (==) `on` clientHandle
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
data HedgehogInfo =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
	HedgehogInfo String String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
data TeamInfo =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
	TeamInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
	{
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2352
diff changeset
    51
		teamownerId :: !Int,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
		teamowner :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
		teamname :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
		teamcolor :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
		teamgrave :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
		teamfort :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
		teamvoicepack :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
		difficulty :: Int,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
		hhnum :: Int,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
		hedgehogs :: [HedgehogInfo]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
	}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
data RoomInfo =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
	RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
	{
2004
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    66
		roomUID :: !Int,
2408
41ebdb5f1e6e Server provides more info in rooms list
unc0rr
parents: 2403
diff changeset
    67
		masterID :: !Int,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
		name :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
		password :: String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
		roomProto :: Word16,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
		teams :: [TeamInfo],
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
		gameinprogress :: Bool,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
		playersIn :: !Int,
2004
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
    74
		readyPlayers :: !Int,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
		playersIDs :: IntSet.IntSet,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    76
		isRestrictedJoins :: Bool,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    77
		isRestrictedTeams :: Bool,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
		roundMsgs :: Seq String,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
		leftTeams :: [String],
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
		teamsAtStart :: [TeamInfo],
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    81
		params :: Map.Map String [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
	}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
instance Show RoomInfo where
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    85
	show ri = show (roomUID ri)
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    86
			++ ", players ids: " ++ show (IntSet.size $ playersIDs ri)
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    87
			++ ", players: " ++ show (playersIn ri)
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    88
			++ ", ready: " ++ show (readyPlayers ri)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    89
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    90
instance Eq RoomInfo where
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2245
diff changeset
    91
	(==) = (==) `on` roomUID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    92
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    93
newRoom = (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    94
	RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    95
		0
2408
41ebdb5f1e6e Server provides more info in rooms list
unc0rr
parents: 2403
diff changeset
    96
		0
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    97
		""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    98
		""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    99
		0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   100
		[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
		False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   102
		0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   103
		0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   104
		IntSet.empty
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   105
		False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   106
		False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   107
		Data.Sequence.empty
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   108
		[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   109
		[]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   110
		(Map.singleton "MAP" ["+rnd+"])
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   111
	)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   112
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   113
data StatisticsInfo =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   114
	StatisticsInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   115
	{
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   116
		playersNumber :: Int,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   117
		roomsNumber :: Int
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   118
	}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   119
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   120
data ServerInfo =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   121
	ServerInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   122
	{
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   123
		isDedicated :: Bool,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   124
		serverMessage :: String,
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1927
diff changeset
   125
		serverMessageForOldVersions :: String,
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   126
		listenPort :: PortNumber,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   127
		nextRoomID :: Int,
1832
1fb61a53a2c2 Add options for database access
unc0rr
parents: 1824
diff changeset
   128
		dbHost :: String,
1fb61a53a2c2 Add options for database access
unc0rr
parents: 1824
diff changeset
   129
		dbLogin :: String,
1fb61a53a2c2 Add options for database access
unc0rr
parents: 1824
diff changeset
   130
		dbPassword :: String,
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1921
diff changeset
   131
		lastLogins :: [(String, UTCTime)],
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1832
diff changeset
   132
		stats :: TMVar StatisticsInfo,
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
   133
		coreChan :: Chan CoreMessage,
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1832
diff changeset
   134
		dbQueries :: Chan DBQuery
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   135
	}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   136
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   137
instance Show ServerInfo where
2004
f7944d5adc5f Some work to try prevent stack memory leak
unc0rr
parents: 1986
diff changeset
   138
	show si = "Server Info"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   139
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   140
newServerInfo = (
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   141
	ServerInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   142
		True
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   143
		"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
2104
b2c50a7480ea Update server's message
unc0rr
parents: 2004
diff changeset
   144
		"<font color=yellow><h3>Hedgewars 0.9.11 is out! Please, update.</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></p><h4>New features are:</h4><ul><li>Speech bubbles</li><li>New game modes</li><li>Sniper rifle</li><li>...</li></ul></font>"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   145
		46631
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   146
		0
1832
1fb61a53a2c2 Add options for database access
unc0rr
parents: 1824
diff changeset
   147
		""
1fb61a53a2c2 Add options for database access
unc0rr
parents: 1824
diff changeset
   148
		""
1fb61a53a2c2 Add options for database access
unc0rr
parents: 1824
diff changeset
   149
		""
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1921
diff changeset
   150
		[]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   151
	)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   152
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
   153
data AccountInfo =
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
   154
	HasAccount String Bool
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
   155
	| Guest
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1847
diff changeset
   156
	| Admin
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   157
	deriving (Show, Read)
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   158
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   159
data DBQuery =
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   160
	CheckAccount Int String String
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2116
diff changeset
   161
	| ClearCache
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2155
diff changeset
   162
	| SendStats Int Int
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   163
	deriving (Show, Read)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
   164
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   165
data CoreMessage =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   166
	Accept ClientInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   167
	| ClientMessage (Int, [String])
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 2104
diff changeset
   168
	| ClientAccountInfo (Int, AccountInfo)
2173
98cde8645e21 Send stats every minute
unc0rr
parents: 2172
diff changeset
   169
	| TimerAction Int
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   170
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   171
type Clients = IntMap.IntMap ClientInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   172
type Rooms = IntMap.IntMap RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   173
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   174
--type ClientsTransform = [ClientInfo] -> [ClientInfo]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   175
--type RoomsTransform = [RoomInfo] -> [RoomInfo]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   176
--type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   177
--type Answer = ServerInfo -> (HandlesSelector, [String])
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   178
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   179
type ClientsSelector = Clients -> Rooms -> [Int]