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                         $next eq ','        ? "\003$color\002\002" :
 206                                               sprintf "\003%02d", $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: $!";
 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) = @_;
 390         my $you = {
 391                 connector => $conn,
 392                 password => $password,
 393                 recvbuf => "",
 394                 secure => $secure,
 395         };
 396         return
 397                 bless $you, 'Channel::QW';
 398 }
 399
 400 # Note: multiple commands in one rcon packet is a DarkPlaces extension.
 401 sub join_commands($@)
 402 {
 403         my ($self, @data) = @_;
 404         return join "\0", @data;
 405 }
 406
 407 sub send($$$)
 408 {
 409         my ($self, $line, $nothrottle) = @_;
 410         if($self->{secure})
 411         {
 412                 my $t = sprintf "%ld.%06d", time(), int rand 1000000;
 413                 my $key = Digest::HMAC::hmac("$t $line", $self->{password}, \&Digest::MD4::md4);
 414                 return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 TIME $key $t $line");
 415         }
 416         else
 417         {
 418                 return $self->{connector}->send("\377\377\377\377rcon $self->{password} $line");
 419         }
 420 }
 421
 422 # Note: backslash and quotation mark escaping is a DarkPlaces extension.
 423 sub quote($$)
 424 {
 425         my ($self, $data) = @_;
 426         $data =~ s/[\000-\037]//g;
 427         $data =~ s/([\\"])/\\$1/g;
 428         $data =~ s/\$/\$\$/g;
 429         return $data;
 430 }
 431
 432 sub recv($)
 433 {
 434         my ($self) = @_;
 435         for(;;)
 436         {
 437                 my $s = $self->{connector}->recv();
 438                 die "read error\n"
 439                         if not defined $s;
 440                 length $s
 441                         or last;
 442                 next
 443                         if $s !~ /^\377\377\377\377n(.*)$/s;
 444                 $self->{recvbuf} .= $1;
 445         }
 446         my @out = ();
 447         while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//)
 448         {
 449                 push @out, $1;
 450         }
 451         return @out;
 452 }
 453
 454 sub fds($)
 455 {
 456         my ($self) = @_;
 457         return $self->{connector}->fds();
 458 }
 459
 460
 461
 462
 463
 464
 465
 466 package main;
 467 use strict;
 468 use warnings;
 469 use IO::Select;
 470 use Time::HiRes;
 471
 472 sub default($$)
 473 {
 474         my ($default, $value) = @_;
 475         return $value if defined $value;
 476         return $default;
 477 }
 478
 479 my $server   = default '',    $ENV{rcon_address};
 480 my $password = default '',    $ENV{rcon_password};
 481 my $secure   = default '1',   $ENV{rcon_secure};
 482 my $timeout  = default '5',   $ENV{rcon_timeout};
 483 my $timeouti = default '0.2', $ENV{rcon_timeout_inter};
 484 my $colors   = default '0',   $ENV{rcon_colorcodes_raw};
 485
 486 if(!length $server)
 487 {
 488         print STDERR "Usage: rcon_address=SERVERIP:PORT rcon_password=PASSWORD $0 rconcommands...\n";
 489         print STDERR "Optional: rcon_timeout=... (default: 5)\n";
 490         print STDERR "          rcon_timeout_inter=... (default: 0.2)\n";
 491         print STDERR "          rcon_colorcodes_raw=1 (to disable color codes translation)\n";
 492         print STDERR "          rcon_secure=0 (to allow connecting to older servers not supporting secure rcon)\n";
 493         exit 0;
 494 }
 495
 496 my $connection = Connection::Socket->new("udp", "", $server, 26000);
 497 my $rcon = Channel::QW->new($connection, $password, $secure);
 498
 499 if(!$rcon->send($rcon->join_commands(@ARGV)))
 500 {
 501         die "send: $!";
 502 }
 503
 504 if($timeout > 0)
 505 {
 506         my $sel = IO::Select->new($rcon->fds());
 507         my $endtime_max = Time::HiRes::time() + $timeout;
 508         my $endtime = $endtime_max;
 509
 510         while((my $dt = $endtime - Time::HiRes::time()) > 0)
 511         {
 512                 if($sel->can_read($dt))
 513                 {
 514                         for($rcon->recv())
 515                         {
 516                                 $_ = (color_dp2ansi $_) . "\033[m" unless $colors;
 517                                 print "$_\n"
 518                         }
 519                         $endtime = Time::HiRes::time() + $timeouti;
 520                         $endtime = $endtime_max
 521                                 if $endtime > $endtime_max;
 522                 }
 523         }
 524 }
 525 exit 0;