author | unc0rr |
Fri, 10 Apr 2009 18:44:36 +0000 | |
changeset 1951 | 47f38d84ac72 |
parent 1757 | 3aa7d21baca1 |
permissions | -rw-r--r-- |
849 | 1 |
module Miscutils where |
2 |
||
3 |
import IO |
|
4 |
import Control.Concurrent.STM |
|
894 | 5 |
import Data.Word |
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 | 9 |
import qualified Data.Map as Map |
1478 | 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 | 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 | 15 |
|
851 | 16 |
data ClientInfo = |
1082 | 17 |
ClientInfo |
851 | 18 |
{ |
1082 | 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 | 21 |
handle :: Handle, |
1478 | 22 |
host :: String, |
23 |
connectTime :: UTCTime, |
|
851 | 24 |
nick :: String, |
894 | 25 |
protocol :: Word16, |
851 | 26 |
room :: String, |
1391 | 27 |
isMaster :: Bool, |
1403 | 28 |
isReady :: Bool, |
1598 | 29 |
forceQuit :: Bool, |
30 |
partRoom :: Bool |
|
851 | 31 |
} |
32 |
||
1082 | 33 |
instance Eq ClientInfo where |
34 |
a1 == a2 = handle a1 == handle a2 |
|
35 |
||
1317 | 36 |
data HedgehogInfo = |
37 |
HedgehogInfo String String |
|
38 |
||
1083 | 39 |
data TeamInfo = |
40 |
TeamInfo |
|
41 |
{ |
|
1329 | 42 |
teamowner :: String, |
1317 | 43 |
teamname :: String, |
1321 | 44 |
teamcolor :: String, |
45 |
teamgrave :: String, |
|
46 |
teamfort :: String, |
|
1662 | 47 |
teamvoicepack :: String, |
1321 | 48 |
difficulty :: Int, |
1327 | 49 |
hhnum :: Int, |
1317 | 50 |
hedgehogs :: [HedgehogInfo] |
1083 | 51 |
} |
52 |
||
851 | 53 |
data RoomInfo = |
54 |
RoomInfo |
|
55 |
{ |
|
56 |
name :: String, |
|
1083 | 57 |
password :: String, |
1317 | 58 |
roomProto :: Word16, |
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 | 61 |
gameinprogress :: Bool, |
1396 | 62 |
playersIn :: Int, |
1403 | 63 |
readyPlayers :: Int, |
1411 | 64 |
isRestrictedJoins :: Bool, |
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 | 69 |
params :: Map.Map String [String] |
851 | 70 |
} |
1748
27dd2967fc65
Some support for spectating when some teams removed
unc0rr
parents:
1742
diff
changeset
|
71 |
|
1492 | 72 |
createRoom = ( |
73 |
RoomInfo |
|
74 |
"" |
|
75 |
"" |
|
76 |
0 |
|
77 |
[] |
|
78 |
"+rnd+" |
|
79 |
False |
|
80 |
1 |
|
81 |
0 |
|
82 |
False |
|
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 | 87 |
Map.empty |
88 |
) |
|
851 | 89 |
|
1755 | 90 |
data StatisticsInfo = |
91 |
StatisticsInfo |
|
92 |
{ |
|
93 |
playersNumber :: Int, |
|
94 |
roomsNumber :: Int |
|
95 |
} |
|
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 | 100 |
isDedicated :: Bool, |
101 |
serverMessage :: String, |
|
1757
3aa7d21baca1
Add an ability for global messages when server started with password option set
unc0rr
parents:
1755
diff
changeset
|
102 |
adminPassword :: String, |
1493 | 103 |
listenPort :: PortNumber, |
104 |
loginsNumber :: Int, |
|
1755 | 105 |
lastHourUsers :: [UTCTime], |
106 |
stats :: TMVar StatisticsInfo |
|
1491
0b1f44751509
Make answers creation more abstract, in prepare for a conversion
unc0rr
parents:
1484
diff
changeset
|
107 |
} |
1748
27dd2967fc65
Some support for spectating when some teams removed
unc0rr
parents:
1742
diff
changeset
|
108 |
|
1492 | 109 |
newServerInfo = ( |
110 |
ServerInfo |
|
111 |
True |
|
112 |
"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>" |
|
1757
3aa7d21baca1
Add an ability for global messages when server started with password option set
unc0rr
parents:
1755
diff
changeset
|
113 |
"" |
1492 | 114 |
46631 |
1493 | 115 |
0 |
116 |
[] |
|
1492 | 117 |
) |
1491
0b1f44751509
Make answers creation more abstract, in prepare for a conversion
unc0rr
parents:
1484
diff
changeset
|
118 |
|
1082 | 119 |
type ClientsTransform = [ClientInfo] -> [ClientInfo] |
120 |
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
|
121 |
type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo] |
1492 | 122 |
type Answer = ServerInfo -> (HandlesSelector, [String]) |
1491
0b1f44751509
Make answers creation more abstract, in prepare for a conversion
unc0rr
parents:
1484
diff
changeset
|
123 |
type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [Answer]) |
1082 | 124 |
|
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
125 |
|
902 | 126 |
roomByName :: String -> [RoomInfo] -> RoomInfo |
127 |
roomByName roomName rooms = fromJust $ find (\room -> roomName == name room) rooms |
|
128 |
||
1082 | 129 |
tselect :: [ClientInfo] -> STM ([String], ClientInfo) |
130 |
tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci)) |
|
889 | 131 |
|
894 | 132 |
maybeRead :: Read a => String -> Maybe a |
133 |
maybeRead s = case reads s of |
|
134 |
[(x, rest)] | all isSpace rest -> Just x |
|
135 |
_ -> Nothing |
|
901
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
136 |
|
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
137 |
deleteBy2t :: (a -> b -> Bool) -> b -> [a] -> [a] |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
138 |
deleteBy2t _ _ [] = [] |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
139 |
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
|
140 |
|
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
141 |
deleteFirstsBy2t :: (a -> b -> Bool) -> [a] -> [b] -> [a] |
2f5ce9a584f9
Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents:
895
diff
changeset
|
142 |
deleteFirstsBy2t eq = foldl (flip (deleteBy2t eq)) |
1082 | 143 |
|
1513
a35c90263e27
Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents:
1493
diff
changeset
|
144 |
--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
|
145 |
--clientByHandle chandle clients = find (\c -> handle c == chandle) clients |
1466 | 146 |
|
1082 | 147 |
sameRoom :: HandlesSelector |
1513
a35c90263e27
Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents:
1493
diff
changeset
|
148 |
sameRoom client clients rooms = filter (\ci -> room ci == room client) clients |
1082 | 149 |
|
1591 | 150 |
sameProtoLobbyClients :: HandlesSelector |
151 |
sameProtoLobbyClients client clients rooms = filter (\ci -> room ci == [] && protocol ci == protocol client) clients |
|
152 |
||
1618 | 153 |
otherLobbyClients :: HandlesSelector |
154 |
otherLobbyClients client clients rooms = filter (\ci -> room ci == []) clients |
|
155 |
||
1484 | 156 |
noRoomSameProto :: HandlesSelector |
1513
a35c90263e27
Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents:
1493
diff
changeset
|
157 |
noRoomSameProto client clients _ = filter (null . room) $ filter (\ci -> protocol client == protocol ci) clients |
1484 | 158 |
|
1082 | 159 |
othersInRoom :: HandlesSelector |
1513
a35c90263e27
Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents:
1493
diff
changeset
|
160 |
othersInRoom client clients rooms = filter (client /=) $ filter (\ci -> room ci == room client) clients |
1082 | 161 |
|
162 |
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
|
163 |
fromRoom roomName _ clients _ = filter (\ci -> room ci == roomName) clients |
1082 | 164 |
|
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1411
diff
changeset
|
165 |
allClients :: HandlesSelector |
1513
a35c90263e27
Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents:
1493
diff
changeset
|
166 |
allClients _ clients _ = clients |
1461
87e5a6c3882c
Ping clients every 30 seconds, should help with ghosts on server
unc0rr
parents:
1411
diff
changeset
|
167 |
|
1082 | 168 |
clientOnly :: HandlesSelector |
1513
a35c90263e27
Refactor server a bit, now all socket operations are in own threads, two per client
unc0rr
parents:
1493
diff
changeset
|
169 |
clientOnly client _ _ = [client] |
1082 | 170 |
|
171 |
noChangeClients :: ClientsTransform |
|
172 |
noChangeClients a = a |
|
173 |
||
174 |
modifyClient :: ClientInfo -> ClientsTransform |
|
1321 | 175 |
modifyClient _ [] = error "modifyClient: no such client" |
1082 | 176 |
modifyClient client (cl:cls) = |
177 |
if cl == client then |
|
178 |
client : cls |
|
179 |
else |
|
180 |
cl : (modifyClient client cls) |
|
181 |
||
1408 | 182 |
modifyRoomClients :: RoomInfo -> (ClientInfo -> ClientInfo) -> ClientsTransform |
183 |
modifyRoomClients clientsroom clientMod clients = map (\c -> if name clientsroom == room c then clientMod c else c) clients |
|
184 |
||
1082 | 185 |
noChangeRooms :: RoomsTransform |
186 |
noChangeRooms a = a |
|
187 |
||
188 |
addRoom :: RoomInfo -> RoomsTransform |
|
189 |
addRoom room rooms = room:rooms |
|
190 |
||
191 |
removeRoom :: String -> RoomsTransform |
|
192 |
removeRoom roomname rooms = filter (\rm -> roomname /= name rm) rooms |
|
1317 | 193 |
|
1321 | 194 |
modifyRoom :: RoomInfo -> RoomsTransform |
195 |
modifyRoom _ [] = error "changeRoomConfig: no such room" |
|
196 |
modifyRoom room (rm:rms) = |
|
197 |
if name room == name rm then |
|
198 |
room : rms |
|
1317 | 199 |
else |
1402 | 200 |
rm : modifyRoom room rms |
1327 | 201 |
|
202 |
modifyTeam :: RoomInfo -> TeamInfo -> RoomInfo |
|
203 |
modifyTeam room team = room{teams = replaceTeam team $ teams room} |
|
204 |
where |
|
205 |
replaceTeam _ [] = error "modifyTeam: no such team" |
|
206 |
replaceTeam team (t:teams) = |
|
207 |
if teamname team == teamname t then |
|
208 |
team : teams |
|
209 |
else |
|
210 |
t : replaceTeam team teams |
|
1577 | 211 |
|
212 |
proto2ver :: Word16 -> String |
|
213 |
proto2ver 17 = "0.9.7-dev" |
|
214 |
proto2ver 19 = "0.9.7" |
|
215 |
proto2ver 20 = "0.9.8-dev" |
|
1617 | 216 |
proto2ver 21 = "0.9.8" |
217 |
proto2ver 22 = "0.9.9-dev" |
|
1683 | 218 |
proto2ver 23 = "0.9.9" |
219 |
proto2ver 24 = "0.9.10-dev" |
|
1578 | 220 |
proto2ver _ = "Unknown" |
1742
cf97d1eecb12
Start fixing spectating bug (implement some routines)
unc0rr
parents:
1683
diff
changeset
|
221 |
|
cf97d1eecb12
Start fixing spectating bug (implement some routines)
unc0rr
parents:
1683
diff
changeset
|
222 |
toEngineMsg :: String -> String |
cf97d1eecb12
Start fixing spectating bug (implement some routines)
unc0rr
parents:
1683
diff
changeset
|
223 |
toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg)) |