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;
+