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