author | Wuzzy <Wuzzy2@mail.ru> |
Sat, 25 Aug 2018 18:21:37 +0200 | |
changeset 13694 | 91fe09213abc |
parent 13693 | af208acaada6 |
child 13696 | d732ca5dcab9 |
permissions | -rw-r--r-- |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
1 |
{- |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
2 |
* Hedgewars, a free turn based strategy game |
11046 | 3 |
* Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
4 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
5 |
* This program is free software; you can redistribute it and/or modify |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
6 |
* it under the terms of the GNU General Public License as published by |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
7 |
* the Free Software Foundation; version 2 of the License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
8 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
9 |
* This program is distributed in the hope that it will be useful, |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
10 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
11 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
12 |
* GNU General Public License for more details. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
13 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
14 |
* You should have received a copy of the GNU General Public License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
15 |
* along with this program; if not, write to the Free Software |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
16 |
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
17 |
\-} |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10212
diff
changeset
|
18 |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
19 |
{-# LANGUAGE OverloadedStrings #-} |
1804 | 20 |
module HWProtoCore where |
21 |
||
4612 | 22 |
import Control.Monad.Reader |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
23 |
import Data.Maybe |
4612 | 24 |
import qualified Data.ByteString.Char8 as B |
1804 | 25 |
-------------------------------------- |
26 |
import CoreTypes |
|
27 |
import HWProtoNEState |
|
28 |
import HWProtoLobbyState |
|
29 |
import HWProtoInRoomState |
|
8479
8d71109b04d2
Some work on loading replay and interaction with checker
unc0rr
parents:
8478
diff
changeset
|
30 |
import HWProtoChecker |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
31 |
import HandlerUtils |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
32 |
import RoomsAndClients |
4612 | 33 |
import Utils |
1804 | 34 |
|
4989 | 35 |
handleCmd, handleCmd_loggedin :: CmdHandler |
1804 | 36 |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
37 |
|
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
38 |
handleCmd ["PING"] = answerClient ["PONG"] |
1804 | 39 |
|
40 |
||
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
41 |
handleCmd ("QUIT" : xs) = return [ByeClient msg] |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2706
diff
changeset
|
42 |
where |
13673
1aa5e884326a
Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents:
13516
diff
changeset
|
43 |
-- "User quit: " is a special string parsed by frontend, do not localize. |
1aa5e884326a
Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents:
13516
diff
changeset
|
44 |
-- It denotes when the /quit command has been used with message parameter. |
1aa5e884326a
Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents:
13516
diff
changeset
|
45 |
-- "bye" is also a special string. |
1aa5e884326a
Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents:
13516
diff
changeset
|
46 |
msg = if not $ null xs then "User quit: " `B.append` (head xs) else "bye" |
1804 | 47 |
|
4568 | 48 |
|
4612 | 49 |
handleCmd ["PONG"] = do |
50 |
cl <- thisClient |
|
51 |
if pingsQueue cl == 0 then |
|
8897
d6c310c65c91
- Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents:
8547
diff
changeset
|
52 |
return [ProtocolError "Protocol violation"] |
4612 | 53 |
else |
54 |
return [ModifyClient (\c -> c{pingsQueue = pingsQueue c - 1})] |
|
4568 | 55 |
|
11054
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
56 |
handleCmd cmd = do |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
57 |
(ci, irnc) <- ask |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
58 |
let cl = irnc `client` ci |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
59 |
if logonPassed cl then |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
60 |
if isChecker cl then |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
61 |
handleCmd_checker cmd |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
62 |
else |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
63 |
handleCmd_loggedin cmd |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
64 |
else |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
65 |
handleCmd_NotEntered cmd |
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
66 |
|
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
67 |
|
6e575b29881c
Check for CMD message a bit further down the control flow
unc0rr
parents:
11046
diff
changeset
|
68 |
handleCmd_loggedin ["CMD", parameters] = uncurry h $ extractParameters parameters |
8396 | 69 |
where |
9105 | 70 |
h "DELEGATE" n | not $ B.null n = handleCmd ["DELEGATE", n] |
10195 | 71 |
h "SAVEROOM" n | not $ B.null n = handleCmd ["SAVEROOM", n] |
72 |
h "LOADROOM" n | not $ B.null n = handleCmd ["LOADROOM", n] |
|
11575 | 73 |
h "SAVE" n | not $ B.null n = let (sn, ln) = B.break (== ' ') n in if B.null ln then return [] else handleCmd ["SAVE", sn, B.tail ln] |
10194 | 74 |
h "DELETE" n | not $ B.null n = handleCmd ["DELETE", n] |
9105 | 75 |
h "STATS" _ = handleCmd ["STATS"] |
76 |
h "PART" m | not $ B.null m = handleCmd ["PART", m] |
|
77 |
| otherwise = handleCmd ["PART"] |
|
78 |
h "QUIT" m | not $ B.null m = handleCmd ["QUIT", m] |
|
79 |
| otherwise = handleCmd ["QUIT"] |
|
80 |
h "RND" p = handleCmd ("RND" : B.words p) |
|
11467
f2c36df8c7b1
Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents:
11466
diff
changeset
|
81 |
h "GLOBAL" p = serverAdminOnly $ do |
8547
6898be8aa261
Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents:
8519
diff
changeset
|
82 |
rnc <- liftM snd ask |
6898be8aa261
Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents:
8519
diff
changeset
|
83 |
let chans = map (sendChan . client rnc) $ allClients rnc |
13692
70c8feb81d35
Make frontend translate server messages properly
Wuzzy <Wuzzy2@mail.ru>
parents:
13673
diff
changeset
|
84 |
-- parenthesis instead of square brackets used to avoid accidental translation by frontend |
70c8feb81d35
Make frontend translate server messages properly
Wuzzy <Wuzzy2@mail.ru>
parents:
13673
diff
changeset
|
85 |
return [AnswerClients chans ["CHAT", "(global notice)", p]] |
9448 | 86 |
h "WATCH" f = return [QueryReplay f] |
9753
9579596cf471
- Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents:
9448
diff
changeset
|
87 |
h "FIX" _ = handleCmd ["FIX"] |
9770 | 88 |
h "UNFIX" _ = handleCmd ["UNFIX"] |
10882
ed7717f659ae
- Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset
|
89 |
h "GREETING" msg | not $ B.null msg = handleCmd ["GREETING", msg] |
10039 | 90 |
h "CALLVOTE" msg | B.null msg = handleCmd ["CALLVOTE"] |
91 |
| otherwise = let (c, p) = extractParameters msg in |
|
92 |
if B.null p then handleCmd ["CALLVOTE", c] else handleCmd ["CALLVOTE", c, p] |
|
10882
ed7717f659ae
- Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset
|
93 |
h "VOTE" msg | not $ B.null msg = handleCmd ["VOTE", upperCase msg] |
13516
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
94 |
| otherwise = handleCmd ["VOTE", ""] |
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
95 |
h "FORCE" msg | not $ B.null msg = handleCmd ["VOTE", upperCase msg, "FORCE"] |
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
96 |
| otherwise = handleCmd ["VOTE", "", "FORCE"] |
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
97 |
h "VOTE" msg | not $ B.null msg = handleCmd ["VOTE", upperCase msg] |
10882
ed7717f659ae
- Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset
|
98 |
h "FORCE" msg | not $ B.null msg = handleCmd ["VOTE", upperCase msg, "FORCE"] |
ed7717f659ae
- Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset
|
99 |
h "MAXTEAMS" n | not $ B.null n = handleCmd ["MAXTEAMS", n] |
ed7717f659ae
- Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents:
10881
diff
changeset
|
100 |
h "INFO" n | not $ B.null n = handleCmd ["INFO", n] |
13514
da59012fbd7a
Add /help command for lobby and rooms too
Wuzzy <Wuzzy2@mail.ru>
parents:
11974
diff
changeset
|
101 |
h "HELP" _ = handleCmd ["HELP"] |
11033 | 102 |
h "RESTART_SERVER" "YES" = handleCmd ["RESTART_SERVER"] |
11467
f2c36df8c7b1
Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents:
11466
diff
changeset
|
103 |
h "REGISTERED_ONLY" _ = serverAdminOnly $ do |
11465
0ae2e4c13bd1
Allow toggling registration requirement on live server
unc0rr
parents:
11054
diff
changeset
|
104 |
cl <- thisClient |
11467
f2c36df8c7b1
Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents:
11466
diff
changeset
|
105 |
return |
11466
4b5c7a5c49fd
Defer kicking to the time when everything is in consistent state
unc0rr
parents:
11465
diff
changeset
|
106 |
[ModifyServerInfo(\s -> s{isRegisteredUsersOnly = not $ isRegisteredUsersOnly s}) |
13694
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
107 |
-- TODO: Say whether 'registered only' state is on or off |
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
108 |
, AnswerClients [sendChan cl] ["CHAT", "[server]", loc "'Registered only' state toggled."] |
11465
0ae2e4c13bd1
Allow toggling registration requirement on live server
unc0rr
parents:
11054
diff
changeset
|
109 |
] |
13694
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
110 |
h "SUPER_POWER" _ = serverAdminOnly $ do |
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
111 |
cl <- thisClient |
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
112 |
return |
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
113 |
[ModifyClient (\c -> c{hasSuperPower = True}) |
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
114 |
, AnswerClients [sendChan cl] ["CHAT", "[server]", loc "Super power activated."] |
91fe09213abc
Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents:
13693
diff
changeset
|
115 |
] |
13693
af208acaada6
Fix translatability of "unknown command" server message
Wuzzy <Wuzzy2@mail.ru>
parents:
13692
diff
changeset
|
116 |
h _ _ = return [Warning $ loc "Unknown command or invalid parameters. Say '/help' in chat for a list of commands." ] |
13516
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
117 |
|
8396 | 118 |
|
10039 | 119 |
extractParameters p = let (a, b) = B.break (== ' ') p in (upperCase a, B.dropWhile (== ' ') b) |
120 |
||
4612 | 121 |
handleCmd_loggedin ["INFO", asknick] = do |
122 |
(_, rnc) <- ask |
|
4614 | 123 |
maybeClientId <- clientByNick asknick |
5060
7d0f6e5b1c1c
Hide last two octets of IP address from usual users
unc0rr
parents:
5030
diff
changeset
|
124 |
isAdminAsking <- liftM isAdministrator thisClient |
4612 | 125 |
let noSuchClient = isNothing maybeClientId |
126 |
let clientId = fromJust maybeClientId |
|
127 |
let cl = rnc `client` fromJust maybeClientId |
|
128 |
let roomId = clientRoom rnc clientId |
|
129 |
let clRoom = room rnc roomId |
|
9061 | 130 |
let roomMasterSign = if isMaster cl then "+" else "" |
4612 | 131 |
let adminSign = if isAdministrator cl then "@" else "" |
13516
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
132 |
let rInfo = if roomId /= lobbyId then B.concat [adminSign, roomMasterSign, loc "room", " ", name clRoom] else adminSign `B.append` (loc "lobby") |
5996
2c72fe81dd37
Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents:
5060
diff
changeset
|
133 |
let roomStatus = if isJust $ gameInfo clRoom then |
13516
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
134 |
if teamsInGame cl > 0 then (loc "(playing)") else (loc "(spectating)") |
4612 | 135 |
else |
136 |
"" |
|
10061
b7161f00a6ca
hide complete IP of other users, when non-admin requests player info. showing the first two parts of the IP was kinda pointless to begin with (what for?) and has recently lead to increased abuse and lobby flooding due to bots collecting/posting IP tracking information
sheepluva
parents:
10039
diff
changeset
|
137 |
let hostStr = if isAdminAsking then host cl else B.empty |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2706
diff
changeset
|
138 |
if noSuchClient then |
13516
60bcc20e6ab0
Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents:
13514
diff
changeset
|
139 |
answerClient [ "CHAT", "[server]", loc "Player is not online." ] |
4612 | 140 |
else |
141 |
answerClient [ |
|
142 |
"INFO", |
|
143 |
nick cl, |
|
5060
7d0f6e5b1c1c
Hide last two octets of IP address from usual users
unc0rr
parents:
5030
diff
changeset
|
144 |
B.concat ["[", hostStr, "]"], |
4612 | 145 |
protoNumber2ver $ clientProto cl, |
7766 | 146 |
B.concat ["[", rInfo, "]", roomStatus] |
4612 | 147 |
] |
1862 | 148 |
|
149 |
||
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
150 |
handleCmd_loggedin cmd = do |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
151 |
(ci, rnc) <- ask |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
152 |
if clientRoom rnc ci == lobbyId then |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
153 |
handleCmd_lobby cmd |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
154 |
else |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
155 |
handleCmd_inRoom cmd |