File dummyhttpserver of Package build
#!/usr/bin/perl
# dead-simple HTTP server
# serves current directory on localhost:80
use Socket;
use POSIX;
use Fcntl qw(:DEFAULT :flock);
use strict;
$| = 1;
my ($build_root, $dir, $uploaddir) = @ARGV;
if (defined($build_root)) {
chroot($build_root) || die("chroot $build_root: $!\n");
chdir('/') || die("chdir /: $!\n");
}
if (defined($dir)) {
chdir($dir) || die("chdir $dir: $!\n");
}
my $tcpproto = getprotobyname('tcp');
my $acceptsock;
socket($acceptsock , PF_INET, SOCK_STREAM, $tcpproto) || die "socket: $!\n";
setsockopt($acceptsock, SOL_SOCKET, SO_REUSEADDR, pack("l",1));
bind($acceptsock, sockaddr_in(80, inet_aton('127.0.0.1'))) || die "bind: $!\n";
listen($acceptsock , 512) || die "listen: $!\n";
my $sock;
my $status;
sub replyraw {
my ($data) = @_;
my $l;
while (length($data)) {
$l = syswrite($sock, $data, length($data));
die("write error: $!\n") unless $l;
$data = substr($data, $l);
}
}
sub reply {
my ($str, @hdrs) = @_;
if (@hdrs && $hdrs[0] =~ /^status: ((\d+).*)/i) {
$status = $2;
$hdrs[0] = "HTTP/1.1 $1";
$hdrs[0] =~ s/:/ /g;
} else {
$status = 200;
unshift @hdrs, "HTTP/1.1 200 OK";
}
push @hdrs, "Cache-Control: no-cache";
push @hdrs, "Connection: close";
push @hdrs, "Content-Length: ".length($str) if defined($str);
my $data = join("\r\n", @hdrs)."\r\n\r\n";
$data .= $str if defined $str;
fcntl($sock, F_SETFL,O_NONBLOCK);
my $dummy = '';
1 while sysread($sock, $dummy, 1024, 0);
fcntl($sock, F_SETFL,0);
replyraw($data);
}
sub reply_error {
my ($errstr) = @_;
my $code = 400;
my $tag = 'Error';
if ($errstr =~ /^(\d+)\s+([^\r\n]*)/) {
$code = $1;
$tag = $2;
} elsif ($errstr =~ /^([^\r\n]+)/) {
$tag = $1;
}
reply("$errstr\n", "Status: $code $tag", 'Content-Type: text/plain');
}
sub readrequest {
my $qu = '';
my ($request, $rawhdrs);
while (1) {
if ($qu =~ /^(.*?)\r?\n/s) {
$request = $1;
last;
}
die($qu eq '' ? "empty query\n" : "received truncated query\n") if !sysread($sock, $qu, 1024, length($qu));
}
my ($act, $path, $vers, undef) = split(' ', $request, 4);
die("400 No method name\n") if !$act;
if ($vers) {
die("501 Unsupported method: $act\n") if $act ne 'GET' && $act ne 'HEAD' && $act ne 'PUT';
# read in all headers
while ($qu !~ /^(.*?)\r?\n\r?\n(.*)$/s) {
die("501 received truncated query\n") if !sysread($sock, $qu, 1024, length($qu));
}
$qu =~ /^(.*?)\r?\n\r?\n(.*)$/s; # redo regexp to work around perl bug
$qu = $2;
$rawhdrs = "Request: $1";
} else {
die("501 Bad method, must be GET\n") if $act ne 'GET';
$rawhdrs = 'Request: GET';
$qu = '';
}
my $query_string = '';
if ($path =~ /^(.*?)\?(.*)$/) {
$path = $1;
$query_string = $2;
}
$path =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; # unescape path
die("501 invalid path\n") unless $path =~ /^\//s; # forbid relative paths
die("501 invalid path\n") if $path =~ /\0/s;
# do simple path substitutions
while (1) {
next if $path =~ s!//!/!;
next if $path =~ s!/\.(?:/|$)!/!;
next if $path =~ s!/[^/]+/\.\.(?:/|$)!/!;
next if $path =~ s!/\.\.(?:/|$)!/!;
last;
}
return ($act, $path, $query_string, $rawhdrs, $qu);
}
sub escape {
my ($d) = @_;
$d =~ s/&/&/sg;
$d =~ s/</</sg;
$d =~ s/>/>/sg;
$d =~ s/"/"/sg;
return $d;
}
while (1) {
my $peeraddr = accept($sock, $acceptsock);
next unless $peeraddr;
my $pid = fork();
last if defined($pid) && !$pid;
close $sock;
1 while waitpid(-1, POSIX::WNOHANG) > 0;
}
close($acceptsock);
my $action;
my $rawheaders;
my $content;
my $path = '?';
eval {
($action, $path, undef, $rawheaders, $content) = readrequest();
if ($action eq 'PUT') {
die("no upload configured\n") unless defined($uploaddir) && $uploaddir ne '';
die("bad upload path\n") unless $path =~ /^\/[a-zA-Z0-9_][a-zA-Z0-9_\.]*$/s;
die("no content length\n") unless $rawheaders =~ /^content-length:\s*(\d+)/im;
my $cl = $1;
die("bad content length $cl\n") if $cl > 100000000;
my $lpath = "$uploaddir$path";
replyraw("HTTP/1.1 100 continue\r\n\r\n") if $rawheaders =~ /^expect:\s*100-continue/im;
$content = substr($content, 0, $cl) if length($content) > $cl;
my $fd;
open($fd, '>', $lpath) || die("$lpath: $!\n");
if ($content ne '') {
syswrite($fd, $content) == length($content) || die("syswrite: $!\n");
$cl -= length($content);
}
while ($cl > 0) {
$content = '';
die("501 received truncated body\n") if !sysread($sock, $content, $cl > 8192 ? 8192 : $cl);
syswrite($fd, $content) == length($content) || die("syswrite: $!\n");
$cl -= length($content);
}
close($fd) || die("close: $!\n");
reply("Thank you.\n", 'Content-type: text/plain');
close $sock;
print "[$status PUT:$path]";
exit(0);
}
my $lpath = ".$path";
if (-d $lpath) {
if ($path !~ /\/$/) {
my $rpath = "$path/";
$rpath =~ s/([\000-\040<>;\"#\?&\+=%[\177-\377])/sprintf("%%%02X",ord($1))/sge;
;
reply('', 'Status: 301 Moved Permanently', "Location: $rpath");
} else {
my %d;
my $dir;
if (opendir($dir, $lpath)) {
%d = map {$_ => 1} readdir($dir);
closedir($dir);
}
delete $d{'.'};
delete $d{'..'};
my $body = "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\"><html>\n";
$body .= "<title>Directory listing for ".escape($path)."</title>\n";
$body .= "<body>\n";
$body .= "<h2>Directory listing for ".escape($path)."</h2>\n";
$body .= "<hr>\n<ul>\n";
$body .= "<li><a href=\"".escape($_)."\">".escape($_)."</a>\n" for sort keys %d;
$body .= "</ul>\n<hr>\n</body>\n</html>\n";
reply($body, 'Content-type: text/html');
}
} elsif (-e _) {
my $f;
open($f, '<', $lpath) || die("500 $lpath: $!\n");
my @s = stat($f);
die("stat: $!\n") unless @s;
my $l = $s[7];
reply(undef, "Content-Length: $l", 'Content-Type: application/octet-stream');
my $data;
while (1) {
last unless $l;
my $r = sysread($f, $data, 8192);
$data = substr($data, 0, $l) if length($data) > $l;
$l -= length($data);
while (length($data)) {
my $l2 = syswrite($sock, $data, length($data));
die("socket write: $!\n") unless $l2;
$data = substr($data, $l2);
}
}
close($f);
} else {
die("404 File not found\n");
}
};
reply_error($@) if $@;
close $sock;
print "[$status $path]";
