#
use File::Basename;
-use CGI::Carp qw(fatalsToBrowser);
use Fcntl qw(:flock :seek :mode);
use POSIX qw(strftime locale_h);
use Cwd qw(getcwd abs_path);
+use utf8;
+# use CGI::Carp qw(fatalsToBrowser);
# import from fex.pp
our ($bs,$tmpdir,@doc_dirs);
-my $log = "$logdir/dop.log";
+my $log = 'dop.log';
# POSIX time format needed for HTTP header
setlocale(LC_TIME,'POSIX');
my $seek = 0;
my $stop = 0;
my ($link,$host,$path,$range);
-
+
our $error = 'F*EX document output ERROR';
-
+
security_check($doc);
-
+
# reget?
if ($range = $ENV{HTTP_RANGE}) {
$seek = $1 if $range =~ /^bytes=(\d+)-/i;
$stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
}
- # redirect on relative symlinks without "../"
- if ($link = readlink($doc) and
+ # redirect on relative symlinks without "../"
+ if ($link = readlink($doc) and
$link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
$path = $ENV{REQUEST_URI};
$path =~ s:[^/]*$::;
$doc = "$path/$link";
$doc =~ s:/+:/:g;
$doc =~ s:^/::;
- $host = $ENV{HTTP_HOST} || $hostname;
nvt_print(
- "HTTP/1.1 301 Moved Permanently",
- "Location: $ENV{PROTO}://$host/$doc",
+ "HTTP/1.1 302 Found",
+ "Location: /$doc",
"Content-Length: 0",
- "Connection: close",
""
);
&reexec;
} elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
@files = ("$1.tar");
open $file,'-|',qw'gzip -c',@files or http_error(503);
- } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
- @s = lstat($streamfile = "$1.stream") and $s[4] == $<)
+ } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
+ @s = lstat($streamfile = "$1.stream") and
+ ($s[4] == $< or $s[4] == 0))
{
- # streaming file (only if it is owned by user fex)
+ # streaming file
chdir dirname($file);
security_check($file);
if (-l $streamfile and readlink($streamfile) =~ /^:(.+):$/) {
}
close $streamfile;
foreach (@files) {
- if (/^\// or /\.\.\//) {
+ if (/^\// or /\.\.\//) {
# absolute path or relative path with parent directory is not allowed
+ errorlog("$streamfile: $_ is not allowed for streaming");
+ http_error(403);
+ }
+ unless (-e $_) {
+ errorlog("$streamfile: $_ does not exist");
http_error(403);
}
- if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) {
+ if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) {
# file must be readable by user and group
+ errorlog("$streamfile: $_ is not readable by user and group");
http_error(403);
}
}
http_error(416) if $ENV{HTTP_RANGE};
close STDERR;
- if ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' }
+ if ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' }
elsif ($file =~ /\.tgz$/) { @a = qw'tar --exclude *~ --exclude .* -czf -' }
elsif ($file =~ /\.zip$/) { @a = qw'zip -x *~ */.*/* @ -rq -' }
else { http_error(400) }
} else {
http_error(404);
}
-
+
$type = 'application/octet-stream';
- if ($file =~ /\.html$/) { $type = 'text/html' }
+ if ($file =~ /\.html$/) { $type = 'text/html' }
# elsif ($file =~ /\.txt$/) { $type = 'text/plain' }
elsif ($file =~ /\.css$/) { $type = 'text/css' }
elsif ($file =~ /\.js$/) { $type = 'text/javascript' }
} elsif ($ENV{'QUERY_STRING'} eq '!') {
$type = 'text/plain';
}
-
-
+
+
if ($type eq 'text/html') {
$seek = $stop = 0;
local $^W = 0;
}
$dynamic = $htmldoc =~ s/$mark/$include/;
}
- # evaluate <<perl-code>>
- while ($htmldoc =~ /<<(.+?)>>/s) {
- local $pc = $1;
- local $__ = '';
- tie *STDOUT => "Buffer",\$__;
- $__ .= eval $pc;
- untie *STDOUT;
- $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
- };
+ # evaluate <<perl-code>> or <<<perl-code>>>
+ {
+ local $timeout = '';
+ local $SIG{ALRM} = sub { $timeout = '<h3>TIMEOUT!</h3>' };
+ alarm(10);
+ while ($htmldoc =~ /<<(.+?>?)>>/s) {
+ local $pc = $1;
+ if ($pc =~ s/^<(.+)>$/$1/) {
+ # eval code without output substitution
+ eval('package DOP;' . $pc);
+ last if $timeout;
+ $dynamic = $htmldoc =~ s/<<<(.+?)>>>//s;
+ } else {
+ # eval code with output substitution
+ local $__ = '';
+ local $^W = 0;
+ tie *STDOUT => "Buffer",\$__;
+ my $r .= eval('package DOP;' . $pc);
+ $__ .= $r if $pc !~ /;\s*$/;
+ untie *STDOUT;
+ last if $timeout;
+ $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
+ }
+ }
+ alarm(0);
+ $dynamic = $htmldoc =~ s/<<(.+?>?)>>/$timeout/sg if $timeout;
+ }
# substitute $variable$ with value from environment (if present)
while ($htmldoc =~ /\$([\w_]+)\$/g) {
$var = $1;
http_header('416 Requested Range Not Satisfiable');
exit;
}
-
+
alarm($timeout*10);
-
+
if ($seek or $stop) {
my $range;
if ($stop) {
"Content-Length: $size",
"Content-Range: $range",
"Content-Type: $type",
- '',
);
} else {
# streaming?
'Server: fexsrv',
"Expires: 0",
"Content-Type: $type",
- '',
);
} else {
# Java (clients) needs Last-Modified header!
"Content-Length: $size",
"Content-Type: $type",
);
- nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;
- nvt_print('');
+ # nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;
}
}
+ nvt_print($_) foreach(@extra_header);
+ nvt_print('');
if ($ENV{REQUEST_METHOD} eq 'GET') {
if ($type eq 'text/html') {
alarm($timeout*10);
print $htmldoc;
+ $s = $size;
} else {
# binary data # can be stream!
seek $file,$seek,0 if $seek;
$b = $size-$s;
$data = substr($data,0,$b)
}
- $s += $b;
+ $s += $b;
alarm($timeout*10);
print $data or last;
}
}
fdlog($log,$file,$s,$size) if $s;
}
-
+
alarm(0);
close $file;
exit if @files; # streaming end
my $allowed;
my ($htindex,$htauth);
local $_;
-
+
$uri =~ s:/+$::;
$dir =~ s:/+$::;
security_check($dir);
-
+
$htindex = "$dir/.htindex";
$htauth = "$dir/.htauth";
-
+
open $htindex,$htindex or http_error(403);
require_auth($htauth,$dir) if -f $htauth;
-
+
# .htindex may contain listing regexp
chomp ($allowed = <$htindex>||'.');
close $htindex;
-
+
opendir $dir,$dir or http_error(503);
while (defined($_ = readdir $dir)) {
next if /^[.#]/ or /~$/;
$htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
}
}
-
+
# # then the symlinks
# $htmldoc .= "\n<pre>\n";
# my $link;
# $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
# }
# }
-
+
# then the files
$htmldoc .= "\n<pre>\n";
foreach my $f (sort @files) {
}
}
$htmldoc .= "</pre>\n</HTML>\n";
-
+
$size = length($htmldoc);
nvt_print(
'HTTP/1.1 200 OK',
}
-sub mtime {
- return (lstat shift)[9];
-}
-
-
sub d3 {
local $_ = shift;
while (s/(\d)(\d\d\d\b)/$1,$2/) {};
sub http_date {
my $file = shift;
my @stat;
-
+
if (@stat = stat($file)) {
return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
} else {
# return real file name (from symlink)
sub realfilename {
my $file = shift;
-
+
return '' unless -e $file;
-
+
if (-l $file) {
return realfilename(readlink($file));
} else {
errorlog("$file contains @");
http_error(403);
}
-
+
# document filename must not end with ~
if (realfilename($file) =~ /~$/) {
errorlog("$file ends with ~");
http_error(403);
}
-
+
# file must be group or world readable
if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
errorlog("$file not group or world readable");
@s = lstat($file);
return if $s[4] == 0 or $s[4] == $<;
}
-
+
}
-
+
# file in allowed directory? ==> ok!
foreach my $dir (@doc_dirs) {
return if path_match($file,$dir);
}
-
+
errorlog("$file not in \@doc_dirs");
http_error(403);
}
local $_;
$dir .= '/x' if -d $dir;
-
+
while ($dir = dirname($dir) and $dir ne '/') {
$af = "$dir/.htaccessfrom";
if (open $af,$af) {
http_error(403);
}
}
-
+
}
# HTTP Basic authentication
my ($realm,$auth);
my @http_auth;
my $uri = $ENV{REQUEST_URI} || '/';
-
+
$uri =~ s/\/index\.html$//;
$uri =~ s/\/$//;
} else {
$realm = dirname($uri);
}
-
+
$auth = slurp($htauth);
unless ($auth and $realm) {
http_header("200 OK");
exit;
}
chomp $auth;
-
- if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/)
+
+ if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/)
{ @http_auth = split(':',decode_b64($1)) }
if (@http_auth != 2 or $http_auth[1] ne $auth) {
http_header(
return '';
}
-# tie STDOUT to buffer variable (redefining print)
+# tie STDOUT to buffer variable (redefining print and printf)
package Buffer;
-sub TIEHANDLE {
- my ($class,$buffer) = @_;
- bless $buffer,$class;
+sub TIEHANDLE {
+ my ($class,$buffer) = @_;
+ bless $buffer,$class;
}
-sub PRINT {
- my $buffer = shift;
- $$buffer .= $_ foreach @_;
+sub PRINT {
+ my $buffer = shift;
+ $$buffer .= $_ foreach @_;
}
-sub PRINTF {
- my $buffer = shift;
+sub PRINTF {
+ my $buffer = shift;
my $fmt = shift @_;
$$buffer .= sprintf($fmt,@_);
}
projects / fex.git / blobdiff