util/master/master.cgi

   1 #!/usr/bin/perl
   2
   3 =info
   4 install:
   5  cpan JSON JSON::XS
   6  touch list_full list
   7  chmod a+rw list_full list
   8
   9 freebsd:
  10  www/fcgiwrap www/nginx
  11
  12 rc.conf.local:
  13 nginx_enable="YES"
  14 fcgiwrap_enable="YES"
  15 fcgiwrap_user="www"
  16
  17 nginx:
  18
  19         location / {
  20             index  index.html;
  21             add_header Access-Control-Allow-Origin *;
  22         }
  23         location /announce {
  24             fastcgi_pass   unix:/var/run/fcgiwrap/fcgiwrap.sock;
  25             fastcgi_param  SCRIPT_FILENAME $document_root/master.cgi;
  26             include        fastcgi_params;
  27         }
  28
  29
  30 apache .htaccess:
  31  AddHandler cgi-script .cgi
  32  DirectoryIndex index.html
  33  Options +ExecCGI +FollowSymLinks
  34  Order allow,deny
  35  <FilesMatch (\.(html?|cgi|fcgi|css|js|gif|png|jpe?g|ico)|(^)|\w+)$>
  36   Allow from all
  37  </FilesMatch>
  38  Deny from all
  39  <ifModule mod_headers.c>
  40      Header set Access-Control-Allow-Origin: *
  41  </ifModule>
  42
  43
  44
  45 =cut
  46
  47 use strict;
  48 no strict qw(refs);
  49 use warnings "NONFATAL" => "all";
  50 no warnings qw(uninitialized);
  51 use utf8;
  52 use Socket;
  53 use Time::HiRes qw(time sleep);
  54 use IO::Socket::INET;
  55 use JSON;
  56 use Net::Ping;
  57 our $root_path;
  58 ($ENV{'SCRIPT_FILENAME'} || $0) =~ m|^(.+)[/\\].+?$|;    #v0w
  59 $root_path = $1 . '/' if $1;
  60 $root_path =~ s|\\|/|g;
  61
  62 our %config = (
  63     #debug        => 1,
  64     list_full    => $root_path . 'list_full',
  65     list_pub     => $root_path . 'list',
  66     time_purge   => 86400 * 30,
  67     time_alive   => 650,
  68     source_check => 1,
  69     ping_timeout => 3,
  70     ping         => 1,
  71     mineping     => 1,
  72     pingable     => 1,
  73     trusted      => [qw( 176.9.122.10 )],       #masterserver self ip - if server on same ip with masterserver doesnt announced
  74     #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
  75 );
  76 do($root_path . 'config.pl');
  77 our $ping = Net::Ping->new("udp", $config{ping_timeout});
  78 $ping->hires();
  79
  80 sub get_params_one(@) {
  81     local %_ = %{ref $_[0] eq 'HASH' ? shift : {}};
  82     for (@_) {
  83         tr/+/ /, s/%([a-f\d]{2})/pack 'H*', $1/gei for my ($k, $v) = /^([^=]+=?)=(.+)$/ ? ($1, $2) : (/^([^=]*)=?$/, /^-/);
  84         $_{$k} = $v;
  85     }
  86     wantarray ? %_ : \%_;
  87 }
  88
  89 sub get_params(;$$) {    #v7
  90     my ($string, $delim) = @_;
  91     $delim ||= '&';
  92     read(STDIN, local $_ = '', $ENV{'CONTENT_LENGTH'}) if !$string and $ENV{'CONTENT_LENGTH'};
  93     local %_ =
  94       $string
  95       ? get_params_one split $delim, $string
  96       : (get_params_one(@ARGV), map { get_params_one split $delim, $_ } split(/;\s*/, $ENV{'HTTP_COOKIE'}), $ENV{'QUERY_STRING'}, $_);
  97     wantarray ? %_ : \%_;
  98 }
  99
 100 sub get_params_utf8(;$$) {
 101     local $_ = &get_params;
 102     utf8::decode $_ for %$_;
 103     wantarray ? %$_ : $_;
 104 }
 105
 106 sub file_rewrite(;$@) {
 107     local $_ = shift;
 108     return unless open my $fh, '>', $_;
 109     print $fh @_;
 110 }
 111
 112 sub file_read ($) {
 113     open my $f, '<', $_[0] or return;
 114     local $/ = undef;
 115     my $ret = <$f>;
 116     close $f;
 117     return \$ret;
 118 }
 119
 120 sub read_json {
 121     my $ret = {};
 122     eval { $ret = JSON->new->utf8->relaxed(1)->decode(${ref $_[0] ? $_[0] : file_read($_[0]) or \''} || '{}'); };    #'mc
 123     warn "json error [$@] on [", ${ref $_[0] ? $_[0] : \$_[0]}, "]" if $@;
 124     $ret;
 125 }
 126
 127 sub printu (@) {
 128     for (@_) {
 129         print($_), next unless utf8::is_utf8($_);
 130         my $s = $_;
 131         utf8::encode($s);
 132         print($s);
 133     }
 134 }
 135
 136 sub name_to_ip_noc($) {
 137     my ($name) = @_;
 138     unless ($name =~ /^\d+\.\d+\.\d+\.\d+$/) {
 139         local $_ = (gethostbyname($name))[4];
 140         return ($name, 1) unless length($_) == 4;
 141         $name = inet_ntoa($_);
 142     }
 143     return $name;
 144 }
 145
 146 sub float {
 147     return ($_[0] < 8 and $_[0] - int($_[0]))
 148       ? sprintf('%.' . ($_[0] < 1 ? 3 : ($_[0] < 3 ? 2 : 1)) . 'f', $_[0])
 149       : int($_[0]);
 150
 151 }
 152
 153 sub mineping ($$) {
 154     my ($addr, $port) = @_;
 155     warn "mineping($addr, $port)" if $config{debug};
 156     my $data;
 157     my $time = time;
 158     eval {
 159         my $socket = IO::Socket::INET->new(
 160             'PeerAddr' => $addr,
 161             'PeerPort' => $port,
 162             'Proto'    => 'udp',
 163             'Timeout'  => $config{ping_timeout},
 164         );
 165         $socket->send("\x4f\x45\x74\x03\x00\x00\x00\x01");
 166         local $SIG{ALRM} = sub { die "alarm time out"; };
 167         alarm $config{ping_timeout};
 168         $socket->recv($data, POSIX::BUFSIZ) or die "recv: $!";
 169         alarm 0;
 170         1;    # return value from eval on normalcy
 171     } or return 0;
 172     return 0 unless length $data;
 173     $time = float(time - $time);
 174     warn "recvd: ", length $data, " [$time]" if $config{debug};
 175     return $time;
 176 }
 177
 178 sub request (;$) {
 179     my ($r) = @_;
 180     $r ||= \%ENV;
 181     my $param = get_params_utf8;
 182     my $after = sub {
 183         if ($param->{json}) {
 184             my $j = {};
 185             eval { $j = JSON->new->decode($param->{json}) || {} };
 186             $param->{$_} = $j->{$_} for keys %$j;
 187             delete $param->{json};
 188         }
 189         if (%$param) {
 190             s/^false$// for values %$param;
 191             $param->{ip} = $r->{REMOTE_ADDR};
 192             for (@{$config{blacklist}}) {
 193                 return if $param->{ip} ~~ $_;
 194             }
 195             $param->{address} ||= $param->{ip};
 196             if ($config{source_check} and name_to_ip_noc($param->{address}) ne $param->{ip} and !($param->{ip} ~~ $config{trusted})) {
 197                 warn("bad address [$param->{address}] ne [$param->{ip}]") if $config{debug};
 198                 return;
 199             }
 200             $param->{port} ||= 30000;
 201             $param->{key} = "$param->{ip}:$param->{port}";
 202             $param->{off} = time if $param->{action} ~~ 'delete';
 203
 204             if ($config{ping} and $param->{action} ne 'delete') {
 205                 if ($config{mineping}) {
 206                     $param->{ping} = mineping($param->{ip}, $param->{port});
 207                 } else {
 208                     $ping->port_number($param->{port});
 209                     $ping->service_check(0);
 210                     my ($pingret, $duration, $ip) = $ping->ping($param->{address});
 211                     if ($ip ne $param->{ip} and !($param->{ip} ~~ $config{trusted})) {
 212                         warn "strange ping ip [$ip] != [$param->{ip}]" if $config{debug};
 213                         return if $config{source_check} and !($param->{ip} ~~ $config{trusted});
 214                     }
 215                     $param->{ping} = $duration if $pingret;
 216                     warn " PING t=$config{ping_timeout}, $param->{address}:$param->{port} = ( $pingret, $duration, $ip )" if $config{debug};
 217                 }
 218             }
 219             my $list = read_json($config{list_full}) || {};
 220             warn "readed[$config{list_full}] list size=", scalar @{$list->{list}};
 221             my $listk = {map { $_->{key} => $_ } @{$list->{list}}};
 222             my $old = $listk->{$param->{key}};
 223             $param->{time} = $old->{time} if $param->{off};
 224             $param->{time} ||= int time;
 225             $param->{start} = $param->{action} ~~ 'start' ? $param->{time} : $old->{start} || $param->{time};
 226             delete $param->{start} if $param->{off};
 227             $param->{first} ||= $old->{first} || $old->{time} || $param->{time};
 228             $param->{clients_top} = $old->{clients_top} if $old->{clients_top} > $param->{clients};
 229             $param->{clients_top} ||= $param->{clients} || 0;
 230             delete $param->{action};
 231             $listk->{$param->{key}} = $param;
 232             $list->{list} = [grep { $_->{time} > time - $config{time_purge} } values %$listk];
 233             file_rewrite($config{list_full}, JSON->new->encode($list));
 234             warn "writed[$config{list_full}] list size=", scalar @{$list->{list}};
 235             $list->{list} = [
 236                 sort { $b->{clients} <=> $a->{clients} || $a->{start} <=> $b->{start} }
 237                   grep { $_->{time} > time - $config{time_alive} and !$_->{off} and (!$config{ping} or !$config{pingable} or $_->{ping}) }
 238                   @{$list->{list}}
 239             ];
 240             file_rewrite($config{list_pub}, JSON->new->encode($list));
 241             warn "writed[$config{list_pub}] list size=", scalar @{$list->{list}};
 242         }
 243     };
 244     return [200, ["Content-type", "application/json"], [JSON->new->encode({})]], $after;
 245 }
 246
 247 sub request_cgi {
 248     my ($p, $after) = request(@_);
 249     shift @$p;
 250     printu join "\n", map { join ': ', @$_ } shift @$p;
 251     printu "\n\n";
 252     printu join '', map { join '', @$_ } @$p;
 253     if (fork) {
 254         unless ($config{debug}) {
 255             close STDOUT;
 256             close STDERR;
 257         }
 258     } else {
 259         $after->() if ref $after ~~ 'CODE';
 260     }
 261 }
 262 request_cgi() unless caller;