perlcraft
Corion
#!/usr/bin/perl -wT
use strict;
use IO::File;
use Cwd;
use HTTP::Daemon;
use HTTP::Status;
$| = 1;
# We are quite explicit about where we listen
my $d = new HTTP::Daemon
Reuse => 1,
LocalAddr => '192.168.1.100',
LocalPort => 8889;
my $nofork = $^O =~ /Win32/i; # For easy testing under Win32
$SIG{__WARN__} = sub { warn __stamp(shift) };
$SIG{__DIE__} = sub { die __stamp(shift) };
$SIG{CHLD} = 'IGNORE';
warn "Please contact me at: <URL:" . $d->url . ">\n";
$ENV{PATH} = '/bin:/usr/bin'; # Set our path to something secure
my $root = $ARGV[0] || cwd;
$root = $1 if $root =~ /^(.*)$/; # untaint document root
$root .= "/" unless $root =~ m!/$!;
# This sub Copyright (c) 1996,97,98,99,2000,01 by Randal L. Schwartz
sub __stamp {
my ($message) = @_;
my $stamp = sprintf "[$$] [%02d@%02d:%02d:%02d] ", (localtime)[3,2,1,0];
$message =~ s/^/$stamp/gm;
$message;
}
sub handleConnection {
local $SIG{PIPE} = 'IGNORE';
my ($connection) = @_;
while (my $r = $connection->get_request()) {
warn $r->as_string; # Yes, that's verbose.
my $url = $r->url->path;
$url = "/$url" unless $url =~ m!^/!; # Remove all suspicious paths
$url =~ s!/.?.(?=/|$)!/!g;
$url =~ tr!\x00-\x1F!!d;
my $response = new HTTP::Response( 404,undef,undef,"404 - Not found." );
if (-d "$root$url") {
$url = "$url/" unless $url =~ m!/$!;
opendir DIR, "$root$url";
$response->code(200);
$response->content(
"<html><head><title>$url</title></head><body><h1>$url</h1><tt>"
. join( "<br>",
map { my ($cmt,$link) = ((-s "$root$url$_")." bytes",$_);
-d _ and $cmt = "directory";
$link =~ s/([ '"?%&:])/{'%'.unpack("H2",$1)}/eg;
"<A href='$url$link'>$_</A> $cmt"
} sort grep { /^[^.]/ } readdir DIR )
. "</tt></body></html>" );
closedir DIR;
} else {
my $file = new IO::File "< $root$url";
if (defined $file) {
$response->code( 200 );
binmode $file;
my $size = -s $file;
my ($startrange, $endrange) = (0,$size-1);
if (defined $r->header("Range")
and $r->header("Range") =~ /bytes\s*=\s*(\d+)-(\d+)?/) {
$response->code( 206 );
($startrange,$endrange) = ($1,$2 || $endrange);
};
$file->seek($startrange,0);
$response->header(Content_Length => $endrange-$startrange);
$response->header(Content_Range => "bytes $startrange-$endrange/$size");
$response->content( sub {
sysread($file, my ($buf), 16*1024); # No error checking ???
return $buf;
});
};
};
warn "Response :",$response->code;
$connection->send_response($response);
};
warn "Handled connection (closed, " . $connection->reason . ")";
$connection->close;
};
while (my $connection = $d->accept) {
# Really condensed fork/nofork handler code
next unless $nofork || ! fork();
warn "Forked child" unless $nofork;
handleConnection( $connection );
die "Child quit." unless $nofork;
}