#!/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) = @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 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);
my $l;
while (length($data)) {
$l = syswrite($sock, $data, length($data));
die("write error: $!\n") unless $l;
$data = substr($data, $l);
}
}
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;
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';
# 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;
} else {
die("501 Bad method, must be GET\n") if $act ne '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 ($path, $query_string, $qu);
}
sub escape {
my ($d) = @_;
$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 $path = '?';
eval {
($path) = readrequest();
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 = "\n";
$body .= "Directory listing for ".escape($path)."\n";
$body .= "\n";
$body .= "Directory listing for ".escape($path)."
\n";
$body .= "
\n\n
\n\n\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]";