netserver/Miscutils.hs
author unc0rr
Sun, 25 Jan 2009 18:35:27 +0000
changeset 1755 cfb442f6a149
parent 1748 27dd2967fc65
child 1757 3aa7d21baca1
permissions -rw-r--r--
Impement stats on UDP 46632 port
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     1
module Miscutils where
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     2
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     3
import IO
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     4
import Control.Concurrent.STM
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
     5
import Data.Word
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
     6
import Data.Char
1646
19b3784ac9d2 Optimize net server perfomance by substituting List by Data.Sequence for storing spectators data
unc0rr
parents: 1618
diff changeset
     7
import Data.List(find)
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
     8
import Maybe (fromJust)
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
     9
import qualified Data.Map as Map
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1466
diff changeset
    10
import Data.Time
1646
19b3784ac9d2 Optimize net server perfomance by substituting List by Data.Sequence for storing spectators data
unc0rr
parents: 1618
diff changeset
    11
import Data.Sequence(Seq, empty)
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    12
import Network
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
    13
import qualified Codec.Binary.Base64 as Base64
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
    14
import qualified Codec.Binary.UTF8.String as UTF8
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    15
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    16
data ClientInfo =
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    17
 ClientInfo
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    18
	{
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    19
		chan :: TChan [String],
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
    20
		sendChan :: TChan [String],
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    21
		handle :: Handle,
1478
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1466
diff changeset
    22
		host :: String,
8bfb417d165e Add simple DoS protection
unc0rr
parents: 1466
diff changeset
    23
		connectTime :: UTCTime,
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    24
		nick :: String,
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    25
		protocol :: Word16,
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    26
		room :: String,
1391
735f6d43780b Implement kick
unc0rr
parents: 1383
diff changeset
    27
		isMaster :: Bool,
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    28
		isReady :: Bool,
1598
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1591
diff changeset
    29
		forceQuit :: Bool,
c853e02ed663 - Fix bugs in net server
unc0rr
parents: 1591
diff changeset
    30
		partRoom :: Bool
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    31
	}
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    32
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    33
instance Eq ClientInfo where
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    34
	a1 == a2 = handle a1 == handle a2
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    35
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    36
data HedgehogInfo =
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    37
	HedgehogInfo String String
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    38
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    39
data TeamInfo =
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    40
	TeamInfo
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    41
	{
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1327
diff changeset
    42
		teamowner :: String,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    43
		teamname :: String,
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    44
		teamcolor :: String,
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    45
		teamgrave :: String,
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    46
		teamfort :: String,
1662
cefb9d0f816f Support voicepack info in net server
unc0rr
parents: 1646
diff changeset
    47
		teamvoicepack :: String,
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    48
		difficulty :: Int,
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
    49
		hhnum :: Int,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    50
		hedgehogs :: [HedgehogInfo]
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    51
	}
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    52
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    53
data RoomInfo =
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    54
	RoomInfo
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    55
	{
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    56
		name :: String,
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    57
		password :: String,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    58
		roomProto :: Word16,
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    59
		teams :: [TeamInfo],
1333
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1329
diff changeset
    60
		gamemap :: String,
1350
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1333
diff changeset
    61
		gameinprogress :: Bool,
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1391
diff changeset
    62
		playersIn :: Int,
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    63
		readyPlayers :: Int,
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    64
		isRestrictedJoins :: Bool,
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    65
		isRestrictedTeams :: Bool,
1646
19b3784ac9d2 Optimize net server perfomance by substituting List by Data.Sequence for storing spectators data
unc0rr
parents: 1618
diff changeset
    66
		roundMsgs :: Seq String,
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
    67
		leftTeams :: [String],
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
    68
		teamsAtStart :: [TeamInfo],
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    69
		params :: Map.Map String [String]
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    70
	}
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
    71
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    72
createRoom = (
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    73
	RoomInfo
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    74
		""
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    75
		""
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    76
		0
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    77
		[]
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    78
		"+rnd+"
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    79
		False
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    80
		1
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    81
		0
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    82
		False
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    83
		False
1646
19b3784ac9d2 Optimize net server perfomance by substituting List by Data.Sequence for storing spectators data
unc0rr
parents: 1618
diff changeset
    84
		Data.Sequence.empty
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
    85
		[]
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
    86
		[]
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    87
		Map.empty
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
    88
	)
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    89
1755
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    90
data StatisticsInfo =
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    91
	StatisticsInfo
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    92
	{
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    93
		playersNumber :: Int,
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    94
		roomsNumber :: Int
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    95
	}
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
    96
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1484
diff changeset
    97
data ServerInfo =
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1484
diff changeset
    98
	ServerInfo
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1484
diff changeset
    99
	{
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   100
		isDedicated :: Bool,
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   101
		serverMessage :: String,
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   102
		listenPort :: PortNumber,
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   103
		loginsNumber :: Int,
1755
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
   104
		lastHourUsers :: [UTCTime],
cfb442f6a149 Impement stats on UDP 46632 port
unc0rr
parents: 1748
diff changeset
   105
		stats :: TMVar StatisticsInfo
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1484
diff changeset
   106
	}
1748
27dd2967fc65 Some support for spectating when some teams removed
unc0rr
parents: 1742
diff changeset
   107
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   108
newServerInfo = (
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   109
	ServerInfo
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   110
		True
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   111
		"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   112
		46631
1493
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   113
		0
1e422bc5d863 Show last hour logins number
unc0rr
parents: 1492
diff changeset
   114
		[]
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   115
	)
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1484
diff changeset
   116
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   117
type ClientsTransform = [ClientInfo] -> [ClientInfo]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   118
type RoomsTransform = [RoomInfo] -> [RoomInfo]
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   119
type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
1492
2da1fe033f23 Finish refactoring
unc0rr
parents: 1491
diff changeset
   120
type Answer = ServerInfo -> (HandlesSelector, [String])
1491
0b1f44751509 Make answers creation more abstract, in prepare for a conversion
unc0rr
parents: 1484
diff changeset
   121
type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [Answer])
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   122
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   123
902
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
   124
roomByName :: String -> [RoomInfo] -> RoomInfo
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
   125
roomByName roomName rooms = fromJust $ find (\room -> roomName == name room) rooms
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
   126
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   127
tselect :: [ClientInfo] -> STM ([String], ClientInfo)
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   128
tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci))
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 852
diff changeset
   129
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
   130
maybeRead :: Read a => String -> Maybe a
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
   131
maybeRead s = case reads s of
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
   132
	[(x, rest)] | all isSpace rest -> Just x
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
   133
	_         -> Nothing
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   134
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   135
deleteBy2t :: (a -> b -> Bool) -> b -> [a] -> [a]
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   136
deleteBy2t _  _ [] = []
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   137
deleteBy2t eq x (y:ys) = if y `eq` x then ys else y : deleteBy2t eq x ys
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   138
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   139
deleteFirstsBy2t :: (a -> b -> Bool) -> [a] -> [b] -> [a]
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
   140
deleteFirstsBy2t eq =  foldl (flip (deleteBy2t eq))
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   141
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   142
--clientByHandle :: Handle -> [ClientInfo] -> Maybe ClientInfo
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   143
--clientByHandle chandle clients = find (\c -> handle c == chandle) clients
1466
c68b0a0969d3 It seems, I finally got the solution
unc0rr
parents: 1461
diff changeset
   144
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   145
sameRoom :: HandlesSelector
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   146
sameRoom client clients rooms = filter (\ci -> room ci == room client) clients
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   147
1591
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1578
diff changeset
   148
sameProtoLobbyClients :: HandlesSelector
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1578
diff changeset
   149
sameProtoLobbyClients client clients rooms = filter (\ci -> room ci == [] && protocol ci == protocol client) clients
1db9b654f880 Notify lobby when a room is created or deleted
unc0rr
parents: 1578
diff changeset
   150
1618
2b9cadc232ab Fix server bugs:
unc0rr
parents: 1617
diff changeset
   151
otherLobbyClients :: HandlesSelector
2b9cadc232ab Fix server bugs:
unc0rr
parents: 1617
diff changeset
   152
otherLobbyClients client clients rooms = filter (\ci -> room ci == []) clients
2b9cadc232ab Fix server bugs:
unc0rr
parents: 1617
diff changeset
   153
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1478
diff changeset
   154
noRoomSameProto :: HandlesSelector
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   155
noRoomSameProto client clients _ = filter (null . room) $ filter (\ci -> protocol client == protocol ci) clients
1484
c01512115c12 - Add es and sv translations to hedgewars.pro
unc0rr
parents: 1478
diff changeset
   156
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   157
othersInRoom :: HandlesSelector
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   158
othersInRoom client clients rooms = filter (client /=) $ filter (\ci -> room ci == room client) clients
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   159
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   160
fromRoom :: String -> HandlesSelector
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   161
fromRoom roomName _ clients _ = filter (\ci -> room ci == roomName) clients
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   162
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1411
diff changeset
   163
allClients :: HandlesSelector
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   164
allClients _ clients _ = clients
1461
87e5a6c3882c Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents: 1411
diff changeset
   165
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   166
clientOnly :: HandlesSelector
1513
a35c90263e27 Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents: 1493
diff changeset
   167
clientOnly client _ _ = [client]
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   168
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   169
noChangeClients :: ClientsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   170
noChangeClients a = a
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   171
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   172
modifyClient :: ClientInfo -> ClientsTransform
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   173
modifyClient _ [] = error "modifyClient: no such client"
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   174
modifyClient client (cl:cls) =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   175
	if cl == client then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   176
		client : cls
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   177
	else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   178
		cl : (modifyClient client cls)
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   179
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1403
diff changeset
   180
modifyRoomClients :: RoomInfo -> (ClientInfo -> ClientInfo) -> ClientsTransform
fab171a17968 Unset ready status after round
unc0rr
parents: 1403
diff changeset
   181
modifyRoomClients clientsroom clientMod clients = map (\c -> if name clientsroom == room c then clientMod c else c) clients
fab171a17968 Unset ready status after round
unc0rr
parents: 1403
diff changeset
   182
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   183
noChangeRooms :: RoomsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   184
noChangeRooms a = a
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   185
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   186
addRoom :: RoomInfo -> RoomsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   187
addRoom room rooms = room:rooms
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   188
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   189
removeRoom :: String -> RoomsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   190
removeRoom roomname rooms = filter (\rm -> roomname /= name rm) rooms
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
   191
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   192
modifyRoom :: RoomInfo -> RoomsTransform
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   193
modifyRoom _ [] = error "changeRoomConfig: no such room"
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   194
modifyRoom room (rm:rms) =
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   195
	if name room == name rm then
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   196
		room : rms
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
   197
	else
1402
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1396
diff changeset
   198
		rm : modifyRoom room rms
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   199
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   200
modifyTeam :: RoomInfo -> TeamInfo -> RoomInfo
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   201
modifyTeam room team = room{teams = replaceTeam team $ teams room}
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   202
	where
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   203
	replaceTeam _ [] = error "modifyTeam: no such team"
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   204
	replaceTeam team (t:teams) =
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   205
		if teamname team == teamname t then
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   206
			team : teams
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   207
		else
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   208
			t : replaceTeam team teams
1577
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1558
diff changeset
   209
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1558
diff changeset
   210
proto2ver :: Word16 -> String
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1558
diff changeset
   211
proto2ver 17 = "0.9.7-dev"
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1558
diff changeset
   212
proto2ver 19 = "0.9.7"
e3e37c730dc0 - Decrease font size in chat
unc0rr
parents: 1558
diff changeset
   213
proto2ver 20 = "0.9.8-dev"
1617
30170c63a9dd Make net server know that 21 protocol is 0.9.8
unc0rr
parents: 1598
diff changeset
   214
proto2ver 21 = "0.9.8"
30170c63a9dd Make net server know that 21 protocol is 0.9.8
unc0rr
parents: 1598
diff changeset
   215
proto2ver 22 = "0.9.9-dev"
1683
af34da5726aa Show team owner in tooltip
unc0rr
parents: 1662
diff changeset
   216
proto2ver 23 = "0.9.9"
af34da5726aa Show team owner in tooltip
unc0rr
parents: 1662
diff changeset
   217
proto2ver 24 = "0.9.10-dev"
1578
f02806f66e00 Show also client host info
unc0rr
parents: 1577
diff changeset
   218
proto2ver _ = "Unknown"
1742
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
   219
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
   220
toEngineMsg :: String -> String
cf97d1eecb12 Start fixing spectating bug (implement some routines)
unc0rr
parents: 1683
diff changeset
   221
toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg))