_cl_rate: we can do up to 60k now, given that sys_ticrate got reduced
[divverent/nexuiz.git] / server / rcon.pl
1 #!/usr/bin/perl
2
3 # Copyright (c) 2008 Rudolf "divVerent" Polzer
4
5 # Permission is hereby granted, free of charge, to any person
6 # obtaining a copy of this software and associated documentation
7 # files (the "Software"), to deal in the Software without
8 # restriction, including without limitation the rights to use,
9 # copy, modify, merge, publish, distribute, sublicense, and/or sell
10 # copies of the Software, and to permit persons to whom the
11 # Software is furnished to do so, subject to the following
12 # conditions:
13
14 # The above copyright notice and this permission notice shall be
15 # included in all copies or substantial portions of the Software.
16
17 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
18 # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
19 # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
20 # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
21 # HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
22 # WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
23 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
24 # OTHER DEALINGS IN THE SOFTWARE.
25
26 # parts copied from rcon2irc
27 # MISC STRING UTILITY ROUTINES to convert between DarkPlaces and IRC conventions
28
29 # convert mIRC color codes to DP color codes
30 our @color_irc2dp_table = (7, 0, 4, 2, 1, 1, 6, 1, 3, 2, 5, 5, 4, 6, 7, 7);
31 our @color_dp2irc_table = (-1, 4, 9, 8, 12, 11, 13, -1, -1, -1); # not accurate, but legible
32 our @color_dp2ansi_table = ("m", "1;31m", "1;32m", "1;33m", "1;34m", "1;36m", "1;35m", "m", "1m", "1m"); # not accurate, but legible
33 our %color_team2dp_table = (5 => 1, 14 => 4, 13 => 3, 10 => 6);
34 our %color_team2irc_table = (5 => 4, 14 => 12, 13 => 8, 10 => 13);
35 sub color_irc2dp($)
36 {
37         my ($message) = @_;
38         $message =~ s/\^/^^/g;
39         my $color = 7;
40         $message =~ s{\003(\d\d?)(?:,(\d?\d?))?|(\017)}{
41                 # $1 is FG, $2 is BG, but let's ignore BG
42                 my $oldcolor = $color;
43                 if($3)
44                 {
45                         $color = 7;
46                 }
47                 else
48                 {
49                         $color = $color_irc2dp_table[$1];
50                         $color = $oldcolor if not defined $color;
51                 }
52                 ($color == $oldcolor) ? '' : '^' . $color;
53         }esg;
54         $message =~ s{[\000-\037]}{}gs; # kill bold etc. for now
55         return $message;
56 }
57
58 our @text_qfont_table = ( # ripped from DP console.c qfont_table
59     "\0", '#',  '#',  '#',  '#',  '.',  '#',  '#',
60     '#',  9,    10,   '#',  ' ',  13,   '.',  '.',
61     '[',  ']',  '0',  '1',  '2',  '3',  '4',  '5',
62     '6',  '7',  '8',  '9',  '.',  '<',  '=',  '>',
63     ' ',  '!',  '"',  '#',  '$',  '%',  '&',  '\'',
64     '(',  ')',  '*',  '+',  ',',  '-',  '.',  '/',
65     '0',  '1',  '2',  '3',  '4',  '5',  '6',  '7',
66     '8',  '9',  ':',  ';',  '<',  '=',  '>',  '?',
67     '@',  'A',  'B',  'C',  'D',  'E',  'F',  'G',
68     'H',  'I',  'J',  'K',  'L',  'M',  'N',  'O',
69     'P',  'Q',  'R',  'S',  'T',  'U',  'V',  'W',
70     'X',  'Y',  'Z',  '[',  '\\', ']',  '^',  '_',
71     '`',  'a',  'b',  'c',  'd',  'e',  'f',  'g',
72     'h',  'i',  'j',  'k',  'l',  'm',  'n',  'o',
73     'p',  'q',  'r',  's',  't',  'u',  'v',  'w',
74     'x',  'y',  'z',  '{',  '|',  '}',  '~',  '<',
75     '<',  '=',  '>',  '#',  '#',  '.',  '#',  '#',
76     '#',  '#',  ' ',  '#',  ' ',  '>',  '.',  '.',
77     '[',  ']',  '0',  '1',  '2',  '3',  '4',  '5',
78     '6',  '7',  '8',  '9',  '.',  '<',  '=',  '>',
79     ' ',  '!',  '"',  '#',  '$',  '%',  '&',  '\'',
80     '(',  ')',  '*',  '+',  ',',  '-',  '.',  '/',
81     '0',  '1',  '2',  '3',  '4',  '5',  '6',  '7',
82     '8',  '9',  ':',  ';',  '<',  '=',  '>',  '?',
83     '@',  'A',  'B',  'C',  'D',  'E',  'F',  'G',
84     'H',  'I',  'J',  'K',  'L',  'M',  'N',  'O',
85     'P',  'Q',  'R',  'S',  'T',  'U',  'V',  'W',
86     'X',  'Y',  'Z',  '[',  '\\', ']',  '^',  '_',
87     '`',  'a',  'b',  'c',  'd',  'e',  'f',  'g',
88     'h',  'i',  'j',  'k',  'l',  'm',  'n',  'o',
89     'p',  'q',  'r',  's',  't',  'u',  'v',  'w',
90     'x',  'y',  'z',  '{',  '|',  '}',  '~',  '<'
91 );
92 sub text_dp2ascii($)
93 {
94         my ($message) = @_;
95         $message = join '', map { $text_qfont_table[ord $_] } split //, $message;
96 }
97
98 sub color_dp_transform(&$)
99 {
100         my ($block, $message) = @_;
101
102         $message =~ s{(?:(\^\^)|\^x([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])|\^([0-9])|(.))(?=([0-9,]?))}{
103                 defined $1 ? $block->(char => '^', $7) :
104                 defined $2 ? $block->(rgb => [hex $2, hex $3, hex $4], $7) :
105                 defined $5 ? $block->(color => $5, $7) :
106                 defined $6 ? $block->(char => $6, $7) :
107                         die "Invalid match";
108         }esg;
109
110         return $message;
111 }
112
113 sub color_dp2none($)
114 {
115         my ($message) = @_;
116
117         return color_dp_transform
118         {
119                 my ($type, $data, $next) = @_;
120                 $type eq 'char'
121                         ? $text_qfont_table[ord $data]
122                         : "";
123         }
124         $message;
125 }
126
127 sub color_rgb2basic($)
128 {
129         my ($data) = @_;
130         my ($R, $G, $B) = @$data;
131         my $min = [sort { $a <=> $b } ($R, $G, $B)]->[0];
132         my $max = [sort { $a <=> $b } ($R, $G, $B)]->[-1];
133
134         my $v = $max / 15;
135         my $s = ($max == $min) ? 0 : 1 - $min/$max;
136
137         if($s < 0.2)
138         {
139                 return 0 if $v < 0.5;
140                 return 7;
141         }
142
143         my $h;
144         if($max == $min)
145         {
146                 $h = 0;
147         }
148         elsif($max == $R)
149         {
150                 $h = (60 * ($G - $B) / ($max - $min)) % 360;
151         }
152         elsif($max == $G)
153         {
154                 $h = (60 * ($B - $R) / ($max - $min)) + 120;
155         }
156         elsif($max == $B)
157         {
158                 $h = (60 * ($R - $G) / ($max - $min)) + 240;
159         }
160
161         return 1 if $h < 36;
162         return 3 if $h < 80;
163         return 2 if $h < 150;
164         return 5 if $h < 200;
165         return 4 if $h < 270;
166         return 6 if $h < 330;
167         return 1;
168 }
169
170 sub color_dp_rgb2basic($)
171 {
172         my ($message) = @_;
173         return color_dp_transform
174         {
175                 my ($type, $data, $next) = @_;
176                 $type eq 'char'  ? ($data eq '^' ? '^^' : $data) :
177                 $type eq 'color' ? "^$data" :
178                 $type eq 'rgb'   ? "^" . color_rgb2basic $data :
179                         die "Invalid type";
180         }
181         $message;
182 }
183
184 sub color_dp2irc($)
185 {
186         my ($message) = @_;
187         my $color = -1;
188         return color_dp_transform
189         {
190                 my ($type, $data, $next) = @_;
191
192                 if($type eq 'rgb')
193                 {
194                         $type = 'color';
195                         $data = color_rgb2basic $data;
196                 }
197
198                 $type eq 'char'  ? $text_qfont_table[ord $data] :
199                 $type eq 'color' ? do {
200                         my $oldcolor = $color;
201                         $color = $color_dp2irc_table[$data];
202
203                         $color == $oldcolor               ? '' :
204                         $color < 0                        ? "\017" :
205                         (index '0123456789,', $next) >= 0 ? "\003$color\002\002" :
206                                                             "\003$color";
207                 } :
208                         die "Invalid type";
209         }
210         $message;
211 }
212
213 sub color_dp2ansi($)
214 {
215         my ($message) = @_;
216         my $color = -1;
217         return color_dp_transform
218         {
219                 my ($type, $data, $next) = @_;
220
221                 if($type eq 'rgb')
222                 {
223                         $type = 'color';
224                         $data = color_rgb2basic $data;
225                 }
226
227                 $type eq 'char'  ? $text_qfont_table[ord $data] :
228                 $type eq 'color' ? do {
229                         my $oldcolor = $color;
230                         $color = $color_dp2ansi_table[$data];
231
232                         $color eq $oldcolor ? '' :
233                                               "\033[${color}"
234                 } :
235                         die "Invalid type";
236         }
237         $message;
238 }
239
240 sub color_dpfix($)
241 {
242         my ($message) = @_;
243         # if the message ends with an odd number of ^, kill one
244         chop $message if $message =~ /(?:^|[^\^])\^(\^\^)*$/;
245         return $message;
246 }
247
248
249
250
251 # Interfaces:
252 #   Connection:
253 #     $conn->sockname() returns a connection type specific representation
254 #       string of the local address, or undef if not applicable.
255 #     $conn->send("string") sends something over the connection.
256 #     $conn->recv() receives a string from the connection, or returns "" if no
257 #       data is available.
258 #     $conn->fds() returns all file descriptors used by the connection, so one
259 #       can use select() on them.
260 #   Channel:
261 #     Usually wraps around a connection and implements a command based
262 #     structure over it. It usually is constructed using new
263 #     ChannelType($connection, someparameters...)
264 #     @cmds = $chan->join_commands(@cmds) joins multiple commands to a single
265 #       command string if the protocol supports it, or does nothing and leaves
266 #       @cmds unchanged if the protocol does not support that usage (this is
267 #       meant to save send() invocations).
268 #     $chan->send($command, $nothrottle) sends a command over the channel. If
269 #       $nothrottle is sent, the command must not be left out even if the channel
270 #       is saturated (for example, because of IRC's flood control mechanism).
271 #     $chan->quote($str) returns a string in a quoted form so it can safely be
272 #       inserted as a substring into a command, or returns $str as is if not
273 #       applicable. It is assumed that the result of the quote method is used
274 #       as part of a quoted string, if the protocol supports that.
275 #     $chan->recv() returns a list of received commands from the channel, or
276 #       the empty list if none are available.
277 #     $conn->fds() returns all file descriptors used by the channel's
278 #       connections, so one can use select() on them.
279
280
281
282
283
284
285
286 # Socket connection.
287 # Represents a connection over a socket.
288 # Mainly used to wrap a channel around it for, in this case, line based or rcon-like operation.
289 package Connection::Socket;
290 use strict;
291 use warnings;
292 use IO::Socket::INET;
293 use IO::Handle;
294
295 # Constructor:
296 #   my $conn = new Connection::Socket(tcp => "localaddress" => "remoteaddress" => 6667);
297 # If the remote address does not contain a port number, the numeric port is
298 # used (it serves as a default port).
299 sub new($$)
300 {
301         my ($class, $proto, $local, $remote, $defaultport) = @_;
302         my $sock = IO::Socket::INET->new(
303                 Proto => $proto,
304                 (length($local) ? (LocalAddr => $local) : ()),
305                 PeerAddr => $remote,
306                 PeerPort => $defaultport
307         ) or die "socket $proto/$local/$remote/$defaultport: $!";
308         $sock->blocking(0);
309         my $you = {
310                 # Mortal fool! Release me from this wretched tomb! I must be set free
311                 # or I will haunt you forever! I will hide your keys beneath the
312                 # cushions of your upholstered furniture... and NEVERMORE will you be
313                 # able to find socks that match!
314                 sock => $sock,
315                 # My demonic powers have made me OMNIPOTENT! Bwahahahahahahaha!
316         };
317         return
318                 bless $you, 'Connection::Socket';
319 }
320
321 # $sock->sockname() returns the local address of the socket.
322 sub sockname($)
323 {
324         my ($self) = @_;
325         my ($port, $addr) = sockaddr_in $self->{sock}->sockname();
326         return "@{[inet_ntoa $addr]}:$port";
327 }
328
329 # $sock->send($data) sends some data over the socket; on success, 1 is returned.
330 sub send($$)
331 {
332         my ($self, $data) = @_;
333         return 1
334                 if not length $data;
335         if(not eval { $self->{sock}->send($data); })
336         {
337                 warn "$@";
338                 return 0;
339         }
340         return 1;
341 }
342
343 # $sock->recv() receives as much as possible from the socket (or at most 32k). Returns "" if no data is available.
344 sub recv($)
345 {
346         my ($self) = @_;
347         my $data = "";
348         if(defined $self->{sock}->recv($data, 32768, 0))
349         {
350                 return $data;
351         }
352         elsif($!{EAGAIN})
353         {
354                 return "";
355         }
356         else
357         {
358                 return undef;
359         }
360 }
361
362 # $sock->fds() returns the socket file descriptor.
363 sub fds($)
364 {
365         my ($self) = @_;
366         return fileno $self->{sock};
367 }
368
369
370
371
372
373
374
375 # QW rcon protocol channel.
376 # Wraps around a UDP based Connection and sends commands as rcon commands as
377 # well as receives rcon replies. The quote and join_commands methods are using
378 # DarkPlaces engine specific rcon protocol extensions.
379 package Channel::QW;
380 use strict;
381 use warnings;
382 use Digest::HMAC;
383 use Digest::MD4;
384
385 # Constructor:
386 #   my $chan = new Channel::QW($connection, "password");
387 sub new($$$)
388 {
389         my ($class, $conn, $password, $secure, $timeout) = @_;
390         my $you = {
391                 connector => $conn,
392                 password => $password,
393                 recvbuf => "",
394                 secure => $secure,
395                 timeout => $timeout,
396         };
397         return
398                 bless $you, 'Channel::QW';
399 }
400
401 # Note: multiple commands in one rcon packet is a DarkPlaces extension.
402 sub join_commands($@)
403 {
404         my ($self, @data) = @_;
405         return join "\0", @data;
406 }
407
408 sub send($$$)
409 {
410         my ($self, $line, $nothrottle) = @_;
411         if($self->{secure} > 1)
412         {
413                 $self->{connector}->send("\377\377\377\377getchallenge");
414                 my $c = $self->recvchallenge();
415                 return 0 if not defined $c;
416                 my $key = Digest::HMAC::hmac("$c $line", $self->{password}, \&Digest::MD4::md4);
417                 return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 CHALLENGE $key $c $line");
418         }
419         elsif($self->{secure})
420         {
421                 my $t = sprintf "%ld.%06d", time(), int rand 1000000;
422                 my $key = Digest::HMAC::hmac("$t $line", $self->{password}, \&Digest::MD4::md4);
423                 return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 TIME $key $t $line");
424         }
425         else
426         {
427                 return $self->{connector}->send("\377\377\377\377rcon $self->{password} $line");
428         }
429 }
430
431 # Note: backslash and quotation mark escaping is a DarkPlaces extension.
432 sub quote($$)
433 {
434         my ($self, $data) = @_;
435         $data =~ s/[\000-\037]//g;
436         $data =~ s/([\\"])/\\$1/g;
437         $data =~ s/\$/\$\$/g;
438         return $data;
439 }
440
441 sub recvchallenge($)
442 {
443         my ($self) = @_;
444
445         my $sel = IO::Select->new($self->fds());
446         my $endtime_max = Time::HiRes::time() + $self->{timeout};
447         my $endtime = $endtime_max;
448
449         while((my $dt = $endtime - Time::HiRes::time()) > 0)
450         {
451                 if($sel->can_read($dt))
452                 {
453                         for(;;)
454                         {
455                                 my $s = $self->{connector}->recv();
456                                 die "read error\n"
457                                         if not defined $s;
458                                 length $s
459                                         or last;
460                                 if($s =~ /^\377\377\377\377challenge (.*)$/s)
461                                 {
462                                         return $1;
463                                 }
464                                 next
465                                         if $s !~ /^\377\377\377\377n(.*)$/s;
466                                 $self->{recvbuf} .= $1;
467                         }
468                 }
469         }
470         return undef;
471 }
472
473 sub recv($)
474 {
475         my ($self) = @_;
476         for(;;)
477         {
478                 my $s = $self->{connector}->recv();
479                 die "read error\n"
480                         if not defined $s;
481                 length $s
482                         or last;
483                 next
484                         if $s !~ /^\377\377\377\377n(.*)$/s;
485                 $self->{recvbuf} .= $1;
486         }
487         my @out = ();
488         while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//)
489         {
490                 push @out, $1;
491         }
492         return @out;
493 }
494
495 sub fds($)
496 {
497         my ($self) = @_;
498         return $self->{connector}->fds();
499 }
500
501
502
503
504
505
506
507 package main;
508 use strict;
509 use warnings;
510 use IO::Select;
511 use Time::HiRes;
512
513 sub default($$)
514 {
515         my ($default, $value) = @_;
516         return $value if defined $value;
517         return $default;
518 }
519
520 my $server   = default '',       $ENV{rcon_address};
521 my $password = default '',       $ENV{rcon_password};
522 my $secure   = default '1',      $ENV{rcon_secure};
523 my $timeout  = default '5',      $ENV{rcon_timeout};
524 my $timeouti = default '0.2',    $ENV{rcon_timeout_inter};
525 my $timeoutc = default $timeout, $ENV{rcon_timeout_challenge};
526 my $colors   = default '0',      $ENV{rcon_colorcodes_raw};
527
528 if(!length $server)
529 {
530         print STDERR "Usage: rcon_address=SERVERIP:PORT rcon_password=PASSWORD $0 rconcommands...\n";
531         print STDERR "Optional: rcon_timeout=... (default: 5)\n";
532         print STDERR "          rcon_timeout_inter=... (default: 0.2)\n";
533         print STDERR "          rcon_timeout_challenge=... (default: 5)\n";
534         print STDERR "          rcon_colorcodes_raw=1 (to disable color codes translation)\n";
535         print STDERR "          rcon_secure=0 (to allow connecting to older servers not supporting secure rcon)\n";
536         exit 0;
537 }
538
539 my $connection = Connection::Socket->new("udp", "", $server, 26000);
540 my $rcon = Channel::QW->new($connection, $password, $secure, $timeoutc);
541
542 if(!$rcon->send($rcon->join_commands(@ARGV)))
543 {
544         die "send: $!";
545 }
546
547 if($timeout > 0)
548 {
549         my $sel = IO::Select->new($rcon->fds());
550         my $endtime_max = Time::HiRes::time() + $timeout;
551         my $endtime = $endtime_max;
552
553         while((my $dt = $endtime - Time::HiRes::time()) > 0)
554         {
555                 if($sel->can_read($dt))
556                 {
557                         for($rcon->recv())
558                         {
559                                 $_ = (color_dp2ansi $_) . "\033[m" unless $colors;
560                                 print "$_\n"
561                         }
562                         $endtime = Time::HiRes::time() + $timeouti;
563                         $endtime = $endtime_max
564                                 if $endtime > $endtime_max;
565                 }
566         }
567 }
568 exit 0;