httpd   [plain text]

#!/usr/bin/perl -w -T

###----------------------------------------###
###     httpd server class                 ###
###----------------------------------------###
package MyHTTPD;

use vars qw(@ISA);
use strict;

### what type of server is this - we could
### use multi type when we add command line
### parsing to this http server to allow
### for different configurations
use Net::Server::PreFork;
@ISA = qw(Net::Server::PreFork);

### run the server
MyHTTPD->run();
exit;



### set up some server parameters
sub configure_hook {
  my $self = shift;

  $self->{server}->{port}   = ['*:80']; # port and addr to bind
  $self->{server}->{chdir}  = '/';      # chdir to root
  $self->{server}->{user}   = 'nobody'; # user to run as
  $self->{server}->{group}  = 'nobody'; # group to run as
  $self->{server}->{setsid} = 1;        # daemonize

  open(STDIN, '</dev/null') || die "Can't close STDIN [$!]";
  open(STDOUT,'>/dev/null') || die "Can't close STDOUT [$!]";
#  open(STDERR,'>&STDOUT')   || die "Can't close STDERR [$!]";


  $self->{document_root} = "/home/httpd/www";

  $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';

}


### process the request
sub process_request {
  my $self = shift;

  local %ENV = ();

  ### read the first line of response
  my $line = <STDIN>;
  $line =~ s/[\r\n]+$//;
  unless( $line =~ /^ (\w+) \ + (\S+) \ + (HTTP\/1.\d) $ /x ){
    return error(400, "Bad request");
  }
  my ($method,$req,$protocol) = ($1,$2,$3);

  ### read in other headers
  $self->read_headers || return error(400, "Strange headers");

  ### do we support the type
  unless( $method =~ /GET|POST|HEAD/ ){
    return error(400, "Unsupported Method");
  }

  ### can we read that request
  unless( $req =~ m%^ (?:http://[^/]+)? (.*) $%x ){
    return 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 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 error(404, "file not found");

  ### directory listing
  }elsif( -d $uri ){
    ### need work on this
    print content_type('text/html'),"\r\n";
    print "Directory listing not supported";

  ### spit it out
  }elsif( open(FILE, "<$uri") ){
    
    my ($type) = $uri =~ m/([^\.]+)$/;
    $type = exists($self->{mime_types}->{$type})
      ? $self->{mime_types}->{$type} : $self->{mime_default};

    print status(200), content_type( $type ), "\r\n";

    print STDOUT $_ while (<FILE>);
    close(FILE);

  }else{
    return error(500, "Can't open file [$!]");
  }

}

sub read_headers {
  my $self = shift;

  $self->{headers} = {};

  while(<STDIN>){
    s/[\r\n]+$//;
    last unless length $_;
    unless( /^([\w\-]+) :[\ \t]+ (.+) $/x ){
      return 0;
    }
    my $key = "HTTP_" . uc($1);
    $key =~ tr/-/_/;
    $self->{headers}->{$key} = $2;
  }
  
  return 1;
}

sub content_type {
  my $type = shift;
  return "Content-type: $type\r\n";
}

sub error{
  print &status;
  
  print "\r\n";
  #,shift();
}

sub status {
  my $number = shift;
  my $msg    = shift || '';
  return "Status $number: $msg\r\n";
}

1;