summaryrefslogtreecommitdiffstats
path: root/t/simple-httpd
diff options
context:
space:
mode:
Diffstat (limited to 't/simple-httpd')
-rwxr-xr-xt/simple-httpd191
1 files changed, 191 insertions, 0 deletions
diff --git a/t/simple-httpd b/t/simple-httpd
new file mode 100755
index 00000000..ff485228
--- /dev/null
+++ b/t/simple-httpd
@@ -0,0 +1,191 @@
+#!/usr/bin/perl -w
+
+###----------------------------------------###
+### httpd server class ###
+###----------------------------------------###
+
+use base qw(Net::Server::Single);
+use strict;
+
+@ARGV == 3 or die "usage: simple-httpd <document root> <log dir> <port>\n";
+my ($DOCUMENT_ROOT, $SERVER_ROOT, $PORT) = @ARGV;
+
+### run the server
+__PACKAGE__->run;
+exit;
+
+###----------------------------------------------------------------###
+
+### set up some server parameters
+sub configure_hook {
+ my $self = shift;
+
+ my $root = $self->{server_root} = $SERVER_ROOT;
+
+ $self->{server}->{port} = "*:$PORT"; # port and addr to bind
+ $self->{server}->{user} = 'nobody'; # user to run as
+ $self->{server}->{group} = 'nobody'; # group to run as
+ $self->{server}->{setsid} = 1; # daemonize
+ $self->{server}->{log_file} = "$root/server.log";
+
+
+ $self->{document_root} = $DOCUMENT_ROOT;
+ $self->{access_log} = "$root/access.log";
+ $self->{error_log} = "$root/error.log";
+
+ $self->{default_index} = [ qw(index.html index.htm main.htm) ];
+
+ $self->{mime_types} = {
+ html => 'text/html',
+ htm => 'text/html',
+ gif => 'image/gif',
+ jpg => 'image/jpeg',
+ };
+ $self->{mime_default} = 'text/plain';
+
+}
+
+sub post_configure_hook {
+ my $self = shift;
+
+ open(STDERR, ">>". $self->{error_log}) || die "Couldn't open STDERR: $!";
+ open(ACCESS, ">>". $self->{access_log}) || die "Couldn't open ACCESS: $!";
+ my $old = select ACCESS;
+ $| = 1;
+ select STDERR;
+ $| = 1;
+ select $old;
+}
+
+
+### process the request
+sub process_request {
+ my $self = shift;
+
+ local %ENV = ();
+ local $self->{needs_header} = 1;
+
+ ### read the first line of response
+ my $line = <STDIN> || return $self->error(400, "No Data");
+ $line =~ s/[\r\n]+$//;
+ if ($line !~ /^ (\w+) \ + (\S+) \ + (HTTP\/[01].\d) $ /x) {
+ return $self->error(400, "Bad request $line");
+ }
+ my ($method, $req, $protocol) = ($1, $2, $3);
+ print ACCESS join(" ", time, $method, $req)."\n";
+
+ ### read in other headers
+ $self->read_headers || return $self->error(400, "Strange headers");
+
+ ### do we support the type
+ if ($method !~ /GET|POST|HEAD/) {
+ return $self->error(400, "Unsupported Method");
+ }
+ $ENV{REQUEST_METHOD} = $method;
+
+ ### can we read that request
+ if ($req !~ m|^ (?:http://[^/]+)? (.*) $|x) {
+ return $self->error(400, "Malformed URL");
+ }
+ $ENV{REQUEST_URI} = $1;
+
+ ### parse out the uri and query string
+ my $uri = '';
+ $ENV{QUERY_STRING} = '';
+ if ($ENV{REQUEST_URI} =~ m|^ ([^\?]+) (?:\?(.+))? $|x) {
+ $ENV{QUERY_STRING} = defined($2) ? $2 : '';
+ $uri = $1;
+ }
+
+ ### clean up uri
+ if ($uri =~ /[\ \;]/) {
+ return $self->error(400, "Malformed URL");
+ }
+ $uri =~ s/%(\w\w)/chr(hex($1))/eg;
+ 1 while $uri =~ s|^\.\./+||; # can't go below doc root
+
+
+ ### at this point the uri should be ready to use
+ $uri = "$self->{document_root}$uri";
+
+ ### see if there's an index page
+ if (-d $uri) {
+ foreach (@{ $self->{default_index} }){
+ if (-e "$uri/$_") {
+ $uri = "$uri/$_";
+ last;
+ }
+ }
+ }
+
+ ### error 404
+ if (! -e $uri) {
+ return $self->error(404, "file not found");
+
+ ### directory listing
+ } elsif (-d $uri) {
+ ### need work on this
+ print $self->content_type('text/html'),"\r\n";
+ print "Directory listing not supported";
+
+ }
+
+ ### spit it out
+ open(my $fh, "<$uri") || return $self->error(500, "Can't open file [$!]");
+
+ my ($type) = $uri =~ /([^\.]+)$/;
+ $type = $self->{mime_types}->{$type} || $self->{mime_default};
+
+ print $self->status(200), $self->content_type($type), "\r\n";
+
+ print STDOUT $_ while read $fh, $_, 8192;
+ close $fh;
+
+}
+
+sub read_headers {
+ my $self = shift;
+
+ $self->{headers} = {};
+
+ while (defined($_ = <STDIN>)) {
+ s/[\r\n]+$//;
+ last unless length $_;
+ return 0 if ! /^ ([\w\-]+) :[\ \t]+ (.+) $/x;
+ my $key = "HTTP_" . uc($1);
+ $key =~ tr/-/_/;
+ $self->{headers}->{$key} = $2;
+ }
+
+ return 1;
+}
+
+sub content_type {
+ my ($self, $type) = @_;
+ $self->http_header;
+ return "Content-type: $type\r\n";
+}
+
+sub error{
+ my ($self, $number, $msg) = @_;
+ print $self->status($number, $msg), "\r\n";
+ warn "Error - $number - $msg\n";
+}
+
+sub status {
+ my ($self, $number, $msg) = @_;
+ $msg = '' if ! defined $msg;
+ return if $self->http_header($number);
+ return "Status $number: $msg\r\n";
+}
+
+sub http_header {
+ my $self = shift;
+ my $number = shift || 200;
+ return if ! delete $self->{needs_header};
+ print "HTTP/1.0 $number\r\n";
+ return 1;
+}
+
+1;
+