dummyhttpserver

#!/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/</&lt;/sg;
  $d =~ s/>/&gt;/sg;
  $d =~ s/"/&quot;/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]";