-#!/usr/bin/perl -wT
+#!/usr/bin/perl -T
# fexsrv : web server for F*EX service
#
use Socket;
use IO::Handle;
use Fcntl qw':flock :seek';
-
-# stunnel workaround
-BEGIN { $SIG{CHLD} = "DEFAULT" }
+use warnings;
+
+BEGIN {
+ # stunnel workaround
+ $SIG{CHLD} = "DEFAULT";
+ $ENV{PERLINIT} = q{
+ unshift @INC,(getpwuid($<))[7].'/perl';
+ # web error handler
+ $SIG{__DIE__} = $SIG{__WARN__} = sub {
+ my $info = '';
+ my $url = $ENV{REQUEST_URL}||'';
+ my @d = localtime time;
+ my $time = sprintf('%d-%02d-%02d %02d:%02d:%02d',
+ $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
+ if ($admin) {
+ my $mailto = "mailto:$admin?subject=fex%20bug";
+ $info = "<h3>send this error to <a href=\"$mailto\">$admin</a></h3>";
+ }
+ $_ = join("\n",@_);
+ chomp;
+ s/&/&/g;
+ s/</</g;
+ $_ = join("\n",
+ "<html><body>",
+ "<h1>INTERNAL ERROR in $0</h1>",
+ "<pre>\n$_\n</pre>\n<p>",
+ "$url\n<p>",
+ "$time\n<p>",
+ "$info\n<p>",
+ "</body></html>"
+ );
+ $length = length;
+ unless ($HTTP_HEADER) {
+ print "HTTP/1.0 200 ERROR\r\n";
+ print "Content-Type: text/html\r\n";
+ print "Content-Length: $length\r\n";
+ print "\r\n";
+ }
+ print;
+ exit 99;
+ }
+ };
+ eval $ENV{PERLINIT};
+}
# use BSD::Resource;
# setrlimit(RLIMIT_CPU,999,999) or die "$0: $!\n";
}
# KEEP_ALIVE <== callback from CGI
-if ($ENV{KEEP_ALIVE}) {
+if ($ENV{KEEP_ALIVE}) {
$keep_alive = $ENV{KEEP_ALIVE};
} else {
- %ENV = (); # clean environment
+ %ENV = ( PERLINIT => $ENV{PERLINIT} ); # clean environment
}
-$ENV{HOME} = (getpwuid($<))[7] or die "$0: no HOME\n";
+$ENV{HOME} = (getpwuid($<))[7] or die "no HOME";
# fexsrv MUST be run with full path!
if ($0 =~ m:^(/.+)/bin/fexsrv:) {
# import from fex.pp
our ($hostname,$debug,$timeout,$max_error,$max_error_handler);
-our ($spooldir,$logdir,$docdir,$xkeydir,$lockdir);
-our ($force_https,$default_locale,$bs,$adlm);
+our ($spooldir,@logdir,$docdir,$xkeydir,$akeydir,$lockdir);
+our ($force_https,$default_locale,$bs,$MB,$adlm);
our (@locales);
# load common code (local config: $FEXHOME/lib/fex.ph)
-require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
+require "$FEXLIB/fex.pp" or die "cannot load $FEXLIB/fex.pp - $!\n";
chdir $spooldir or http_die("$0: $spooldir - $!\n");
-our $log = "$logdir/fexsrv.log";
+our $log = 'fexsrv.log';
our $error = 'F*EX ERROR';
our $htmlsource;
our $hid = ''; # header ID
our @log;
$0 = untaint($0);
-
-$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
+
+$ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
$ENV{SERVER_NAME} = $hostname;
+$ENV{REQUEST_METHOD} = '';
$ENV{QUERY_STRING} = '';
$ENV{HTTP_COOKIE} = '';
$ENV{PATH_INFO} = '';
}
$ra = $ENV{REMOTE_ADDR};
$rh = $ENV{REMOTE_HOST};
-}
+}
# new session
else {
my $iaddr;
-
+
# HTTPS connect
if ($ssl_ra) {
$ENV{PROTO} = 'https';
$rh ||= '-';
$port = 443;
# print {$log} "X-SSL-Remote-Host: $ssl_ra\n";
- }
+ }
# HTTP connect
else {
$ENV{PROTO} = 'http';
- my $sa = getpeername(STDIN) or die "$0: no network stream on STDIN\n";
+ my $sa = getpeername(STDIN) or die "no network stream on STDIN\n";
if (sockaddr_family($sa) == AF_INET) {
($ENV{REMOTE_PORT},$iaddr) = sockaddr_in($sa);
$ENV{REMOTE_ADDR} = $ra = inet_ntoa($iaddr);
$^W = 0; eval 'use Socket6'; $^W = 1;
http_error(503) if $@;
($ENV{REMOTE_PORT},$iaddr) = unpack_sockaddr_in6($sa);
- $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6, $iaddr);
+ $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6,$iaddr);
$rh = gethostbyaddr($iaddr,AF_INET6);
($port) = unpack_sockaddr_in6(getsockname(STDIN));
} else {
- die "$0: unknown IP version\n";
+ die "unknown IP version\n";
}
$port = 80 unless $port;
}
$ENV{REMOTE_HOST} = $rh || '';
- $ENV{HTTP_HOST} = ($port == 80 or $port == 443)
+ $ENV{HTTP_HOST} = ($port == 80 or $port == 443)
? $hostname : "$hostname:$port";
+ $ENV{PORT} = $port;
}
if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra) {
if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ }
else { $ENV{REQUESTCOUNT} = 0 }
-
+
$connect = sprintf "%s:%s %s %s %s [%s_%s]",
$keep_alive ? 'CONTINUE' : 'CONNECT',
$port,
$header{$1} = $2 if /(.+)\s*:\s*(.+)/;
push @log,$_;
}
-
- if (/^(GET \/|X-Forwarded-For|User-Agent)/i) {
+ if ($hl > $MB) {
+ fexlog($connect,@log,"OVERRUN");
+ http_error(413);
+ }
+
+ if (/^(GET \/|\S*Forwarded|\S*Client-IP|\S*Coming-From|User-Agent)/i) {
$hid .= $_."\n";
}
# reverse-proxy?
+ # (only IPv4 support!)
if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra and
- /^X-Forwarded-For: ([\d.]+)/
+ /^\S*(Forwarded|Client-IP|Coming-From)\S*: ([\d.]+)/i
) {
- $ENV{REMOTE_ADDR} = $ra = $1;
+ $ENV{REMOTE_ADDR} = $ra = $2;
$ENV{REMOTE_HOST} = $rh = gethostbyaddr(inet_aton($ra),AF_INET) || '';
$ENV{HTTP_HOST} = $hostname;
if ($ENV{PROTO} eq 'https') { $port = 443 }
exit unless @header;
exit if $header =~ /^\s*$/;
-
+
$ENV{HTTP_HEADER} = $header;
debuglog($header);
# http_die("<pre>$header</pre>");
-
+
$ENV{'HTTP_HEADER_LENGTH'} = $hl;
$ENV{REQUEST_URI} = $uri = '';
$cgi = '';
badlog("no HTTP request: $request");
exit;
}
-
+
if ($force_https and $port != 443
and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
$request = $2;
}
}
- if ($request =~ /^OPTIONS FEX HTTP\/[\d\.]+$/i) {
+ if ($request =~ /^OPTIONS \/?FEX HTTP\/[\d\.]+$/i) {
fexlog($connect,@log);
nvt_print(
"HTTP/1.1 201 OK",
}
if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
+ $ENV{REQUEST} = $_;
$ENV{REQUEST_METHOD} = uc($1);
$ENV{REQUEST_URI} = $uri = $cgi = $2;
$ENV{HTTP_VERSION} = $protocol = $3;
}
while ($_ = shift @header) {
-
+
# header inquisition!
&$header_hook($connect,$_,$ra) if $header_hook;
if ($header =~ /\nRange:/ and /^User-Agent: (FDM)/) {
disconnect($1,"499 Download Manager $1 Not Supported",30);
}
-
+
if (/^User-Agent: (Java\/[\d\.]+)/) {
disconnect($1,"499 User-Agent $1 Not Supported",30);
}
-
+
if (/^Range:.*,/) {
disconnect("Range a,b","416 Requested Range Not Satisfiable",30);
}
&$header_hook($connect,$header,$ra) if $header_hook;
exit unless $cgi;
-
+
# extra download request? (request http://fexserver//xkey)
if ($cgi =~ m{^//([^/]+)$}) {
my $xkey = $1;
# get locale
if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or
- $ENV{HTTP_COOKIE} =~ /.*locale=([\w-]+)/)
+ $ENV{HTTP_COOKIE} =~ /.*locale=([\w-]+)/)
and -d "$FEXHOME/locale/$1") {
$ENV{LOCALE} = $locale = $1;
} else {
$ENV{LOCALE} = $locale = $default_locale;
}
+ # for dynamic HTML documents
+ if ($ENV{HTTP_COOKIE} =~ /akey=(\w+)/) {
+ my $akey = $1;
+ my ($user,$id);
+ if ($user = readlink "$akeydir/$akey") {
+ $user =~ s:.*/::;
+ $user = untaint($user);
+ if ($id = slurp("$spooldir/$user/@")) {
+ chomp $id;
+ $ENV{AKEY} = $akey;
+ $ENV{USER} = $user;
+ $ENV{ID} = $id;
+ }
+ }
+ }
+
# check for name based virtual host
$vhost = vhost($ENV{'HTTP_HOST'});
if ($debug) {
debuglog("ENV:\n");
foreach $var (sort keys %ENV) {
- debuglog(sprintf " %s = >%s<\n",$var,$ENV{$var});
+ if (defined($ENV{$var})) {
+ debuglog(sprintf " %s = >%s<\n",$var,$ENV{$var});
+ }
}
debuglog("\n");
}
$locale = $default_locale;
}
}
-
+
# prepare document file name
if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
+ if (%redirect) {
+ foreach my $r (keys %redirect) {
+ if ($uri =~ /^\Q$r/) {
+ redirect($uri,$r);
+ exit;
+ }
+ }
+ }
$doc = untaint($uri);
$doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
$doc =~ m:/\.\./: and http_error(403);
$doc =~ s:^/+::;
$doc =~ s/\?.*//;
- if ($locale and -e "$docdir/locale/$locale/$doc") {
+ if ($locale and $locale ne 'english' and -e "$docdir/locale/$locale/$doc") {
$doc = "$docdir/locale/$locale/$doc";
} else {
$doc = "$docdir/$doc";
fexlog($connect,@log,"FORBIDDEN");
http_error(403);
}
- unlink "$logdir/.error/$ra";
+ unlink "$spooldir/.error/$ra";
# push @log,"DEBUG: locale=$locale locales=(@locales)";
fexlog($connect,@log,"EXEC $cgi");
eval { local $^W = 0; exec $cgi };
bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz');
}
# URL ends with ".html!" or ".html?!"
- if ($doc =~ s/(\.html)!$/$1/ or
- $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!')
+ if ($doc =~ s/(\.html)!$/$1/ or
+ $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!')
{ $htmlsource = $doc } else { $htmlsource = '' }
- if (-f $doc
+ if (-f $doc
or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream")
or $doc =~ /(.+)\.tgz$/ and -f "$1.tar"
or $doc =~ /(.+)\.gz$/ and -f $1)
{
- unlink "$logdir/.error/$ra";
- delete $ENV{SCRIPT_FILENAME};
+ unlink "$spooldir/.error/$ra";
+ delete $ENV{SCRIPT_FILENAME};
$ENV{DOCUMENT_FILENAME} = $doc;
require "$FEXLIB/dop";
fexlog($connect,@log);
}
# neither document nor CGI ==> error
-
+
if ($status) {
fexlog($connect,@log,"FAILED to exec $cgi : $status");
http_error(666);
# read one text line unbuffered from STDIN
sub getaline {
my $line = '';
+ my $n = 0;
my $c;
alarm($timeout);
# (later exec would destroy line buffer)
while (sysread STDIN,$c,1) {
$line .= $c;
+ $n++;
last if $c eq "\n";
+ if ($n > $bs) {
+ fexlog($connect,@log,$line,"OVERRUN");
+ http_error(413);
+ }
}
alarm(0);
sub fexlog {
my @log = @_;
- if (open $log,">>$log") {
- flock $log,LOCK_EX;
- seek $log,0,SEEK_END;
- print {$log} "\n",join("\n",@log),"\n";
- close $log;
- } else {
- http_die("$0: cannot write to $log - $!\n");
+
+ foreach my $logdir (@logdir) {
+ if (open $log,'>>',"$logdir/$log") {
+ flock $log,LOCK_EX;
+ seek $log,0,SEEK_END;
+ print {$log} "\n",join("\n",@log),"\n";
+ close $log;
+ } else {
+ http_die("$0: cannot write to $logdir/$log - $!\n");
+ }
}
}
-
sub badchar {
my $bc = shift;
-
+
fexlog($connect,@log,"DISCONNECT: bad characters in URL");
debuglog("DISCONNECT: bad characters in URL $uri");
badlog($request);
sub bintar {
my $tmpdir = "$FEXHOME/tmp";
my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";
-
+
if (chdir "$FEXHOME/bin") {
fexlog($connect,@log);
chdir $fstb if $fstb;
} elsif ($error eq 404) {
http_error_header("404 Not Found");
nvt_print("The requested URI $URI was not found on this server.");
+ } elsif ($error eq 413) {
+ http_error_header("413 Payload Too Large");
+ nvt_print("Your HTTP header is too large.");
} elsif ($error eq 416) {
http_error_header("416 Requested Range Not Satisfiable");
} elsif ($error eq 503) {
my $info = shift;
my $error = shift;
my $wait = shift||0;
-
+
# &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
fexlog($connect,@log,"DISCONNECT: $info");
debuglog("DISCONNECT: $info");
sub http_error_header {
my $error = shift;
my $uri = $ENV{REQUEST_URI};
-
+
errorlog("$uri ==> $error") if $uri;
nvt_print(
"HTTP/1.1 $error",
}
+sub redirect {
+ my $uri = shift;
+ my $r = shift;
+ my $rr = $redirect{$r};
+ my $newurl;
+
+ $uri =~ s/\Q$r//;
+
+ if ($rr =~ s/^!//) {
+ $newurl = $rr.$uri;
+ nvt_print(
+ "HTTP/1.1 301 Moved Permanently",
+ "Location: $newurl",
+ "Content-Length: 0",
+ ""
+ );
+ } else {
+ if ($rr =~ /^http/) {
+ $newurl = $rr.$uri;
+ } else {
+ $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri";
+ }
+
+ http_header("200 OK");
+ print html_header("$hostname page has moved");
+ pq(qq(
+ '<h3>Please use new URL: <a href="$newurl">$newurl</a></h3>'
+ '</body></html>'
+ ));
+ }
+ if ($rr =~ /^http/) {
+ exit;
+ } else {
+ &reexec;
+ }
+}
+
+
sub badlog {
my $request = shift;
my @n;
my $ed = "$spooldir/.error";
local $_;
-
+
if (@ignore_error) {
foreach (@ignore_error) {
return if $request =~ /$_/;
}
}
-
+
if ($ra and $max_error and $max_error_handler) {
mkdir($ed) unless -d $ed;
projects / fex.git / blobdiff