iframe-proxy | Sunbelt Computer Software

executable file
191 lines (176 loc) · 5.02 KB
#!/usr/bin/perl
# dead-simple HTTP server
# serves current directory on localhost:80
use Socket;
use Fcntl qw(:DEFAULT :flock);
use strict;
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 $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;
    $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);
  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;
    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!/\.\.(?:/|$)!/!;
  return ($path, $query_string, $qu);
sub escape {
  my ($d) = @_; 
  $d =~ s/&/&amp;/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 $path = '?';
  ($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 = "<!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 _) {
    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);
    die("404 File not found\n");
reply_error($@) if $@;
close $sock;
print "[$status $path]";
Sunbelt Computer Software

PL/B Language Development and Support

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

Uh oh!

Sunbelt Computer Software

PL/B Language Development and Support

Uh oh!

FilesExpand file tree

dummyhttpserver

Latest commit

History

dummyhttpserver

File metadata and controls
