X-Git-Url: https://git.treefish.org/fex.git/blobdiff_plain/7fa382617fbaccc0ce522b2b3adbbee9db5ad227..cdeb354c4dbb11b683f9f8c5db2861f3dc572c61:/bin/fexsrv?ds=sidebyside diff --git a/bin/fexsrv b/bin/fexsrv index 27e3318..8bef7fc 100755 --- a/bin/fexsrv +++ b/bin/fexsrv @@ -1,4 +1,4 @@ -#!/usr/bin/perl -wT +#!/usr/bin/perl -T # fexsrv : web server for F*EX service # @@ -9,9 +9,50 @@ use 5.008; 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 = "

send this error to $admin

"; + } + $_ = join("\n",@_); + chomp; + s/&/&/g; + s/", + "

INTERNAL ERROR in $0

", + "
\n$_\n
\n

", + "$url\n

", + "$time\n

", + "$info\n

", + "" + ); + $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"; @@ -22,13 +63,13 @@ if (@ARGV and $ARGV[0] eq 'stunnel' and $ENV{REMOTE_HOST} =~ /(.+)/) { } # 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:) { @@ -50,25 +91,26 @@ foreach my $lib ( # 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} = ''; @@ -92,12 +134,12 @@ if ($keep_alive) { } $ra = $ENV{REMOTE_ADDR}; $rh = $ENV{REMOTE_HOST}; -} +} # new session else { my $iaddr; - + # HTTPS connect if ($ssl_ra) { $ENV{PROTO} = 'https'; @@ -114,12 +156,12 @@ else { $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); @@ -129,20 +171,21 @@ else { $^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) { @@ -170,7 +213,7 @@ REQUEST: while (*STDIN) { if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ } else { $ENV{REQUESTCOUNT} = 0 } - + $connect = sprintf "%s:%s %s %s %s [%s_%s]", $keep_alive ? 'CONTINUE' : 'CONNECT', $port, @@ -199,16 +242,21 @@ REQUEST: while (*STDIN) { $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*: ([\da-f:.]+)/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 } @@ -218,11 +266,11 @@ REQUEST: while (*STDIN) { exit unless @header; exit if $header =~ /^\s*$/; - + $ENV{HTTP_HEADER} = $header; debuglog($header); # http_die("

$header
"); - + $ENV{'HTTP_HEADER_LENGTH'} = $hl; $ENV{REQUEST_URI} = $uri = ''; $cgi = ''; @@ -234,7 +282,7 @@ REQUEST: while (*STDIN) { badlog("no HTTP request: $request"); exit; } - + if ($force_https and $port != 443 and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) { $request = $2; @@ -265,7 +313,7 @@ REQUEST: while (*STDIN) { } } - if ($request =~ /^OPTIONS FEX HTTP\/[\d\.]+$/i) { + if ($request =~ /^OPTIONS \/?FEX HTTP\/[\d\.]+$/i) { fexlog($connect,@log); nvt_print( "HTTP/1.1 201 OK", @@ -306,6 +354,7 @@ REQUEST: while (*STDIN) { } 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; @@ -320,7 +369,7 @@ REQUEST: while (*STDIN) { } while ($_ = shift @header) { - + # header inquisition! &$header_hook($connect,$_,$ra) if $header_hook; @@ -335,11 +384,11 @@ REQUEST: while (*STDIN) { 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); } @@ -412,7 +461,7 @@ REQUEST: while (*STDIN) { &$header_hook($connect,$header,$ra) if $header_hook; exit unless $cgi; - + # extra download request? (request http://fexserver//xkey) if ($cgi =~ m{^//([^/]+)$}) { my $xkey = $1; @@ -444,20 +493,38 @@ REQUEST: while (*STDIN) { # 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"); } @@ -470,15 +537,23 @@ REQUEST: while (*STDIN) { $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"; @@ -514,7 +589,7 @@ REQUEST: while (*STDIN) { 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 }; @@ -564,17 +639,17 @@ REQUEST: while (*STDIN) { 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); @@ -612,7 +687,7 @@ REQUEST: while (*STDIN) { } # neither document nor CGI ==> error - + if ($status) { fexlog($connect,@log,"FAILED to exec $cgi : $status"); http_error(666); @@ -628,6 +703,7 @@ REQUEST: while (*STDIN) { # read one text line unbuffered from STDIN sub getaline { my $line = ''; + my $n = 0; my $c; alarm($timeout); @@ -636,7 +712,12 @@ sub getaline { # (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); @@ -647,21 +728,23 @@ sub getaline { 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); @@ -672,7 +755,7 @@ sub badchar { sub bintar { my $tmpdir = "$FEXHOME/tmp"; my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}"; - + if (chdir "$FEXHOME/bin") { fexlog($connect,@log); chdir $fstb if $fstb; @@ -711,6 +794,9 @@ sub http_error { } 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) { @@ -733,7 +819,7 @@ sub disconnect { 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"); @@ -749,7 +835,7 @@ sub disconnect { sub http_error_header { my $error = shift; my $uri = $ENV{REQUEST_URI}; - + errorlog("$uri ==> $error") if $uri; nvt_print( "HTTP/1.1 $error", @@ -765,18 +851,57 @@ sub http_error_header { } +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( + '

Please use new URL: $newurl

' + '' + )); + } + fexlog($connect,@log,"REDIRECT $newurl"); + 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;