games/minimal/mods/default/textures/default_tool_woodaxe.png

#!/usr/bin/perl

=info
install:
 cpan JSON JSON::XS
 touch list_full list
 chmod a+rw list_full list

freebsd:
 www/fcgiwrap www/nginx

rc.conf.local:
nginx_enable="YES"
fcgiwrap_enable="YES"
fcgiwrap_user="www"

nginx:

        location / {
            index  index.html;
        }
        location /announce {
            fastcgi_pass   unix:/var/run/fcgiwrap/fcgiwrap.sock;
            fastcgi_param  SCRIPT_FILENAME $document_root/master.cgi;
            include        fastcgi_params;
        }


apache .htaccess:
 AddHandler cgi-script .cgi
 DirectoryIndex index.html
 Options +ExecCGI +FollowSymLinks
 Order allow,deny
 <FilesMatch (\.(html?|cgi|fcgi|css|js|gif|png|jpe?g|ico)|(^)|\w+)$>
  Allow from all
 </FilesMatch>
 Deny from all


=cut

use strict;
no strict qw(refs);
use warnings "NONFATAL" => "all";
no warnings qw(uninitialized);
use utf8;
use Socket;
use Time::HiRes qw(time sleep);
use IO::Socket::INET;
use JSON;
use Net::Ping;
our $root_path;
($ENV{'SCRIPT_FILENAME'} || $0) =~ m|^(.+)[/\\].+?$|;    #v0w
$root_path = $1 . '/' if $1;
$root_path =~ s|\\|/|g;

our %config = (
    #debug        => 1,
    list_full    => $root_path . 'list_full',
    list_pub     => $root_path . 'list',
    time_purge   => 86400 * 30,
    time_alive   => 650,
    source_check => 1,
    ping_timeout => 3,
    ping         => 1,
    mineping     => 1,
    pingable     => 1,
    trusted      => [qw( 176.9.122.10 )],       #masterserver self ip - if server on same ip with masterserver doesnt announced
    #blacklist => [], # [qw(2.3.4.5 4.5.6.7 8.9.0.1), '1.2.3.4', qr/^10\.20\.30\./, ], # list, or quoted, ips, or regex
);
do($root_path . 'config.pl');
our $ping = Net::Ping->new("udp", $config{ping_timeout});
$ping->hires();

sub get_params_one(@) {
    local %_ = %{ref $_[0] eq 'HASH' ? shift : {}};
    for (@_) {
        tr/+/ /, s/%([a-f\d]{2})/pack 'H*', $1/gei for my ($k, $v) = /^([^=]+=?)=(.+)$/ ? ($1, $2) : (/^([^=]*)=?$/, /^-/);
        $_{$k} = $v;
    }
    wantarray ? %_ : \%_;
}

sub get_params(;$$) {    #v7
    my ($string, $delim) = @_;
    $delim ||= '&';
    read(STDIN, local $_ = '', $ENV{'CONTENT_LENGTH'}) if !$string and $ENV{'CONTENT_LENGTH'};
    local %_ =
      $string
      ? get_params_one split $delim, $string
      : (get_params_one(@ARGV), map { get_params_one split $delim, $_ } split(/;\s*/, $ENV{'HTTP_COOKIE'}), $ENV{'QUERY_STRING'}, $_);
    wantarray ? %_ : \%_;
}

sub get_params_utf8(;$$) {
    local $_ = &get_params;
    utf8::decode $_ for %$_;
    wantarray ? %$_ : $_;
}

sub file_rewrite(;$@) {
    local $_ = shift;
    return unless open my $fh, '>', $_;
    print $fh @_;
}

sub file_read ($) {
    open my $f, '<', $_[0] or return;
    local $/ = undef;
    my $ret = <$f>;
    close $f;
    return \$ret;
}

sub read_json {
    my $ret = {};
    eval { $ret = JSON->new->utf8->relaxed(1)->decode(${ref $_[0] ? $_[0] : file_read($_[0]) or \''} || '{}'); };    #'mc
    warn "json error [$@] on [", ${ref $_[0] ? $_[0] : \$_[0]}, "]" if $@;
    $ret;
}

sub printu (@) {
    for (@_) {
        print($_), next unless utf8::is_utf8($_);
        my $s = $_;
        utf8::encode($s);
        print($s);
    }
}

sub name_to_ip_noc($) {
    my ($name) = @_;
    unless ($name =~ /^\d+\.\d+\.\d+\.\d+$/) {
        local $_ = (gethostbyname($name))[4];
        return ($name, 1) unless length($_) == 4;
        $name = inet_ntoa($_);
    }
    return $name;
}

sub float {
    return ($_[0] < 8 and $_[0] - int($_[0]))
      ? sprintf('%.' . ($_[0] < 1 ? 3 : ($_[0] < 3 ? 2 : 1)) . 'f', $_[0])
      : int($_[0]);

}

sub mineping ($$) {
    my ($addr, $port) = @_;
    warn "mineping($addr, $port)" if $config{debug};
    my $data;
    my $time = time;
    eval {
        my $socket = IO::Socket::INET->new(
            'PeerAddr' => $addr,
            'PeerPort' => $port,
            'Proto'    => 'udp',
            'Timeout'  => $config{ping_timeout},
        );
        $socket->send("\x4f\x45\x74\x03\x00\x00\x00\x01");
        local $SIG{ALRM} = sub { die "alarm time out"; };
        alarm $config{ping_timeout};
        $socket->recv($data, POSIX::BUFSIZ) or die "recv: $!";
        alarm 0;
        1;    # return value from eval on normalcy
    } or return 0;
    return 0 unless length $data;
    $time = float(time - $time);
    warn "recvd: ", length $data, " [$time]" if $config{debug};
    return $time;
}

sub request (;$) {
    my ($r) = @_;
    $r ||= \%ENV;
    my $param = get_params_utf8;
    my $after = sub {
        if ($param->{json}) {
            my $j = {};
            eval { $j = JSON->new->decode($param->{json}) || {} };
            $param->{$_} = $j->{$_} for keys %$j;
            delete $param->{json};
        }
        if (%$param) {
            s/^false$// for values %$param;
            $param->{ip} = $r->{REMOTE_ADDR};
            for (@{$config{blacklist}}) {
                return if $param->{ip} ~~ $_;
            }
            $param->{address} ||= $param->{ip};
            if ($config{source_check} and name_to_ip_noc($param->{address}) ne $param->{ip} and !($param->{ip} ~~ $config{trusted})) {
                warn("bad address [$param->{address}] ne [$param->{ip}]") if $config{debug};
                return;
            }
            $param->{port} ||= 30000;
            $param->{key} = "$param->{ip}:$param->{port}";
            $param->{off} = time if $param->{action} ~~ 'delete';

            if ($config{ping} and $param->{action} ne 'delete') {
                if ($config{mineping}) {
                    $param->{ping} = mineping($param->{ip}, $param->{port});
                } else {
                    $ping->port_number($param->{port});
                    $ping->service_check(0);
                    my ($pingret, $duration, $ip) = $ping->ping($param->{address});
                    if ($ip ne $param->{ip} and !($param->{ip} ~~ $config{trusted})) {
                        warn "strange ping ip [$ip] != [$param->{ip}]" if $config{debug};
                        return if $config{source_check} and !($param->{ip} ~~ $config{trusted});
                    }
                    $param->{ping} = $duration if $pingret;
                    warn " PING t=$config{ping_timeout}, $param->{address}:$param->{port} = ( $pingret, $duration, $ip )" if $config{debug};
                }
            }
            my $list = read_json($config{list_full}) || {};
            warn "readed[$config{list_full}] list size=", scalar @{$list->{list}};
            my $listk = {map { $_->{key} => $_ } @{$list->{list}}};
            my $old = $listk->{$param->{key}};
            $param->{time} = $old->{time} if $param->{off};
            $param->{time} ||= int time;
            $param->{start} = $param->{action} ~~ 'start' ? $param->{time} : $old->{start} || $param->{time};
            delete $param->{start} if $param->{off};
            $param->{first} ||= $old->{first} || $old->{time} || $param->{time};
            $param->{clients_top} = $old->{clients_top} if $old->{clients_top} > $param->{clients};
            $param->{clients_top} ||= $param->{clients} || 0;
            delete $param->{action};
            $listk->{$param->{key}} = $param;
            $list->{list} = [grep { $_->{time} > time - $config{time_purge} } values %$listk];
            file_rewrite($config{list_full}, JSON->new->encode($list));
            warn "writed[$config{list_full}] list size=", scalar @{$list->{list}};
            $list->{list} = [
                sort { $b->{clients} <=> $a->{clients} || $a->{start} <=> $b->{start} }
                  grep { $_->{time} > time - $config{time_alive} and !$_->{off} and (!$config{ping} or !$config{pingable} or $_->{ping}) }
                  @{$list->{list}}
            ];
            file_rewrite($config{list_pub}, JSON->new->encode($list));
            warn "writed[$config{list_pub}] list size=", scalar @{$list->{list}};
        }
    };
    return [200, ["Content-type", "application/json"], [JSON->new->encode({})]], $after;
}

sub request_cgi {
    my ($p, $after) = request(@_);
    shift @$p;
    printu join "\n", map { join ': ', @$_ } shift @$p;
    printu "\n\n";
    printu join '', map { join '', @$_ } @$p;
    if (fork) {
        unless ($config{debug}) {
            close STDOUT;
            close STDERR;
        }
    } else {
        $after->() if ref $after ~~ 'CODE';
    }
}
request_cgi() unless caller;
ofs	hex dump	ascii
0000	89 50 4e 47 0d 0a 1a 0a 00 00 00 0d 49 48 44 52 00 00 00 10 00 00 00 10 08 03 00 00 00 28 2d 0f	.PNG........IHDR.............(-.
0020	53 00 00 00 0c 50 4c 54 45 00 00 00 42 22 09 5d 3d 24 70 4e 28 22 09 c1 b9 00 00 00 01 74 52 4e	S....PLTE...B".]=$pN(".......tRN
0040	53 00 40 e6 d8 66 00 00 00 28 49 44 41 54 78 da bd ca 21 12 00 00 08 02 41 94 ff ff 59 aa 50 4c	S.@..f...(IDATx...!.....A...Y.PL
0060	5e 5b 06 dc a3 bb 69 56 6b 91 ed 93 97 72 e3 d1 d9 00 28 ab 00 44 61 c9 01 83 00 00 00 00 49 45	^[....iVk....r....(..Da.......IE
0080	4e 44 ae 42 60 82	ND.B`.