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