1 module Miscutils where |
|
2 |
|
3 import IO |
|
4 import Control.Concurrent.STM |
|
5 import Data.Word |
|
6 import Data.Char |
|
7 import Data.List(find) |
|
8 import Maybe (fromJust) |
|
9 import qualified Data.Map as Map |
|
10 import Data.Time |
|
11 import Data.Sequence(Seq, empty) |
|
12 import Network |
|
13 import qualified Codec.Binary.Base64 as Base64 |
|
14 import qualified Codec.Binary.UTF8.String as UTF8 |
|
15 |
|
16 data ClientInfo = |
|
17 ClientInfo |
|
18 { |
|
19 chan :: TChan [String], |
|
20 sendChan :: TChan [String], |
|
21 handle :: Handle, |
|
22 host :: String, |
|
23 connectTime :: UTCTime, |
|
24 nick :: String, |
|
25 protocol :: Word16, |
|
26 room :: String, |
|
27 isMaster :: Bool, |
|
28 isReady :: Bool, |
|
29 forceQuit :: Bool, |
|
30 partRoom :: Bool |
|
31 } |
|
32 |
|
33 instance Eq ClientInfo where |
|
34 a1 == a2 = handle a1 == handle a2 |
|
35 |
|
36 data HedgehogInfo = |
|
37 HedgehogInfo String String |
|
38 |
|
39 data TeamInfo = |
|
40 TeamInfo |
|
41 { |
|
42 teamowner :: String, |
|
43 teamname :: String, |
|
44 teamcolor :: String, |
|
45 teamgrave :: String, |
|
46 teamfort :: String, |
|
47 teamvoicepack :: String, |
|
48 difficulty :: Int, |
|
49 hhnum :: Int, |
|
50 hedgehogs :: [HedgehogInfo] |
|
51 } |
|
52 |
|
53 data RoomInfo = |
|
54 RoomInfo |
|
55 { |
|
56 name :: String, |
|
57 password :: String, |
|
58 roomProto :: Word16, |
|
59 teams :: [TeamInfo], |
|
60 gamemap :: String, |
|
61 gameinprogress :: Bool, |
|
62 playersIn :: Int, |
|
63 readyPlayers :: Int, |
|
64 isRestrictedJoins :: Bool, |
|
65 isRestrictedTeams :: Bool, |
|
66 roundMsgs :: Seq String, |
|
67 leftTeams :: [String], |
|
68 teamsAtStart :: [TeamInfo], |
|
69 params :: Map.Map String [String] |
|
70 } |
|
71 |
|
72 createRoom = ( |
|
73 RoomInfo |
|
74 "" |
|
75 "" |
|
76 0 |
|
77 [] |
|
78 "+rnd+" |
|
79 False |
|
80 1 |
|
81 0 |
|
82 False |
|
83 False |
|
84 Data.Sequence.empty |
|
85 [] |
|
86 [] |
|
87 Map.empty |
|
88 ) |
|
89 |
|
90 data StatisticsInfo = |
|
91 StatisticsInfo |
|
92 { |
|
93 playersNumber :: Int, |
|
94 roomsNumber :: Int |
|
95 } |
|
96 |
|
97 data ServerInfo = |
|
98 ServerInfo |
|
99 { |
|
100 isDedicated :: Bool, |
|
101 serverMessage :: String, |
|
102 adminPassword :: String, |
|
103 listenPort :: PortNumber, |
|
104 loginsNumber :: Int, |
|
105 lastHourUsers :: [UTCTime], |
|
106 stats :: TMVar StatisticsInfo |
|
107 } |
|
108 |
|
109 newServerInfo = ( |
|
110 ServerInfo |
|
111 True |
|
112 "<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>" |
|
113 "" |
|
114 46631 |
|
115 0 |
|
116 [] |
|
117 ) |
|
118 |
|
119 type ClientsTransform = [ClientInfo] -> [ClientInfo] |
|
120 type RoomsTransform = [RoomInfo] -> [RoomInfo] |
|
121 type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo] |
|
122 type Answer = ServerInfo -> (HandlesSelector, [String]) |
|
123 type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [Answer]) |
|
124 |
|
125 |
|
126 roomByName :: String -> [RoomInfo] -> RoomInfo |
|
127 roomByName roomName rooms = fromJust $ find (\room -> roomName == name room) rooms |
|
128 |
|
129 tselect :: [ClientInfo] -> STM ([String], ClientInfo) |
|
130 tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci)) |
|
131 |
|
132 maybeRead :: Read a => String -> Maybe a |
|
133 maybeRead s = case reads s of |
|
134 [(x, rest)] | all isSpace rest -> Just x |
|
135 _ -> Nothing |
|
136 |
|
137 deleteBy2t :: (a -> b -> Bool) -> b -> [a] -> [a] |
|
138 deleteBy2t _ _ [] = [] |
|
139 deleteBy2t eq x (y:ys) = if y `eq` x then ys else y : deleteBy2t eq x ys |
|
140 |
|
141 deleteFirstsBy2t :: (a -> b -> Bool) -> [a] -> [b] -> [a] |
|
142 deleteFirstsBy2t eq = foldl (flip (deleteBy2t eq)) |
|
143 |
|
144 --clientByHandle :: Handle -> [ClientInfo] -> Maybe ClientInfo |
|
145 --clientByHandle chandle clients = find (\c -> handle c == chandle) clients |
|
146 |
|
147 sameRoom :: HandlesSelector |
|
148 sameRoom client clients rooms = filter (\ci -> room ci == room client) clients |
|
149 |
|
150 sameProtoLobbyClients :: HandlesSelector |
|
151 sameProtoLobbyClients client clients rooms = filter (\ci -> room ci == [] && protocol ci == protocol client) clients |
|
152 |
|
153 otherLobbyClients :: HandlesSelector |
|
154 otherLobbyClients client clients rooms = filter (\ci -> room ci == []) clients |
|
155 |
|
156 noRoomSameProto :: HandlesSelector |
|
157 noRoomSameProto client clients _ = filter (null . room) $ filter (\ci -> protocol client == protocol ci) clients |
|
158 |
|
159 othersInRoom :: HandlesSelector |
|
160 othersInRoom client clients rooms = filter (client /=) $ filter (\ci -> room ci == room client) clients |
|
161 |
|
162 fromRoom :: String -> HandlesSelector |
|
163 fromRoom roomName _ clients _ = filter (\ci -> room ci == roomName) clients |
|
164 |
|
165 allClients :: HandlesSelector |
|
166 allClients _ clients _ = clients |
|
167 |
|
168 clientOnly :: HandlesSelector |
|
169 clientOnly client _ _ = [client] |
|
170 |
|
171 noChangeClients :: ClientsTransform |
|
172 noChangeClients a = a |
|
173 |
|
174 modifyClient :: ClientInfo -> ClientsTransform |
|
175 modifyClient _ [] = error "modifyClient: no such client" |
|
176 modifyClient client (cl:cls) = |
|
177 if cl == client then |
|
178 client : cls |
|
179 else |
|
180 cl : (modifyClient client cls) |
|
181 |
|
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 |
|
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 |
|
193 |
|
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 |
|
199 else |
|
200 rm : modifyRoom room rms |
|
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 |
|
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" |
|
216 proto2ver 21 = "0.9.8" |
|
217 proto2ver 22 = "0.9.9-dev" |
|
218 proto2ver 23 = "0.9.9" |
|
219 proto2ver 24 = "0.9.10-dev" |
|
220 proto2ver _ = "Unknown" |
|
221 |
|
222 toEngineMsg :: String -> String |
|
223 toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg)) |
|