daemon.pm

美国CMU大学开发的操作系统健壮性评测软件

# $Id: Daemon.pm,v 1.1 1999/07/21 19:12:27 kraven Exp $
#

use strict;

package HTTP::Daemon;

=head1 NAME

HTTP::Daemon - a simple http server class

=head1 SYNOPSIS

  use HTTP::Daemon;
  use HTTP::Status;

  my $d = new HTTP::Daemon;
  print "Please contact me at: <URL:", $d->url, ">\n";
  while (my $c = $d->accept) {
      while (my $r = $c->get_request) {
	  if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
              # remember, this is *not* recommened practice :-)
	      $c->send_file_response("/etc/passwd");
	  } else {
	      $c->send_error(RC_FORBIDDEN)
	  }
      }
      $c->close;
      undef($c);
  }

=head1 DESCRIPTION

Instances of the I<HTTP::Daemon> class are HTTP/1.1 servers that
listens on a socket for incoming requests. The I<HTTP::Daemon> is a
sub-class of I<IO::Socket::INET>, so you can do socket operations
directly on it too.

The accept() method will return when a connection from a client is
available. The returned value will be a reference to a object of the
I<HTTP::Daemon::ClientConn> class which is another I<IO::Socket::INET>
subclass. Calling the get_request() method on this object will read
data from the client and return an I<HTTP::Request> object reference.

This HTTP daemon does not fork(2) for you.  Your application, i.e. the
user of the I<HTTP::Daemon> is reponsible for forking if that is
desirable.  Also note that the user is responsible for generating
responses that conforms to the HTTP/1.1 protocol.  The
I<HTTP::Daemon::ClientConn> provide some methods that make this easier.

=head1 METHODS

The following is a list of methods that are new (or enhanced) relative
to the I<IO::Socket::INET> base class.

=over 4

=cut


use vars qw($VERSION @ISA $PROTO $DEBUG);

$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);

use IO::Socket ();
@ISA=qw(IO::Socket::INET);

$PROTO = "HTTP/1.1";

=item $d = new HTTP::Daemon

The object constructor takes the same parameters as the
I<IO::Socket::INET> constructor.  It can be called without specifying
any parameters. The daemon will then set up a listen queue of 5
connections and allocate some random port number.  A server that want
to bind to some specific address on the standard HTTP port will be
constructed like this:

  $d = new HTTP::Daemon
        LocalAddr => 'www.someplace.com',
        LocalPort => 80;

=cut

sub new
{
    my($class, %args) = @_;
    $args{Listen} ||= 5;
    $args{Proto}  ||= 'tcp';
    my $self = $class->SUPER::new(%args);
    return undef unless $self;

    my $host = $args{LocalAddr};
    unless ($host) {
	require Sys::Hostname;
	$host = Sys::Hostname::hostname();
    }
    ${*$self}{'httpd_server_name'} = $host;
    $self;
}


=item $c = $d->accept([$pkg])

Same as I<IO::Socket::accept> but will return an
I<HTTP::Daemon::ClientConn> reference by default.  It will return
undef if you have specified a timeout and no connection is made within
that time.

=cut

sub accept
{
    my $self = shift;
    my $pkg = shift || "HTTP::Daemon::ClientConn";
    my $sock = $self->SUPER::accept($pkg);
    ${*$sock}{'httpd_daemon'} = $self if $sock;
    $sock;
}


=item $d->url

Returns a URL string that can be used to access the server root.

=cut

sub url
{
    my $self = shift;
    my $url = "http://";
    $url .= ${*$self}{'httpd_server_name'};
    my $port = $self->sockport;
    $url .= ":$port" if $port != 80;
    $url .= "/";
    $url;
}


=item $d->product_tokens

Returns the name that this server will use to identify itself.  This
is the string that is sent with the I<Server> response header.  The
main reason to have this method is that subclasses can override it if
they want to use another product name.

=cut

sub product_tokens
{
    "libwww-perl-daemon/$HTTP::Daemon::VERSION";
}


package HTTP::Daemon::ClientConn;

use vars qw(@ISA $DEBUG);
use IO::Socket ();
@ISA=qw(IO::Socket::INET);
*DEBUG = \$HTTP::Daemon::DEBUG;

use HTTP::Request  ();
use HTTP::Response ();
use HTTP::Status;
use HTTP::Date qw(time2str);
use URI::URL qw(url);
use LWP::MediaTypes qw(guess_media_type);
use Carp ();

my $CRLF = "\015\012";   # "\r\n" is not portable
my $HTTP_1_0 = _http_version("HTTP/1.0");
my $HTTP_1_1 = _http_version("HTTP/1.1");

=back

The I<HTTP::Daemon::ClientConn> is also a I<IO::Socket::INET>
subclass. Instances of this class are returned by the accept() method
of the I<HTTP::Daemon>.  The following additional methods are
provided:

=over 4

=item $c->get_request([$headers_only])

This method will read data from the client and turn it into a
I<HTTP::Request> object which is then returned.  It returns C<undef>
if reading of the request fails.  If it fails, then the
I<HTTP::Daemon::ClientConn> object ($c) should be discarded, and you
should not call this method again.  The $c->reason method might give
you some information on why $c->get_request returned C<undef>.

The $c->get_request method support HTTP/1.1 request content bodies,
including I<chunked> transfer encoding with footer and self delimiting
I<multipart/*> content types.

The $c->get_request method will normally not return until the whole
request has been received from the client.  This might not be what you
want if the request is an upload of a multi-mega-byte file (and with
chunked transfer encoding HTTP can even support infinite request
messages - uploading live audio for instance).  If you pass a TRUE
value as the $headers_only argument, then $c->get_request will return
immediately after parsing the request headers and you are responsible
for reading the rest of the request content (and if you are going to
call $c->get_request again on the same connection you better read the
correct number of bytes).

=cut

sub get_request
{
    my($self, $only_headers) = @_;
    if (${*$self}{'httpd_nomore'}) {
        $self->reason("No more requests from this connection");
	return;
    }

    $self->reason("");
    my $buf = ${*$self}{'httpd_rbuf'};
    $buf = "" unless defined $buf;
    
    my $timeout = $ {*$self}{'io_socket_timeout'};
    my $fdset = "";
    vec($fdset, $self->fileno, 1) = 1;
    local($_);

  READ_HEADER:
    while (1) {
	# loop until we have the whole header in $buf
	$buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
	if ($buf =~ /\012/) {  # potential, has at least one line
	    if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
		if ($buf =~ /\015?\012\015?\012/) {
		    last READ_HEADER;  # we have it
		} elsif (length($buf) > 16*1024) {
		    $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
		    $self->reason("Very long header");
		    return;
		}
	    } else {
		last READ_HEADER;  # HTTP/0.9 client
	    }
	} elsif (length($buf) > 16*1024) {
	    $self->send_error(414); # REQUEST_URI_TOO_LARGE
	    $self->reason("Very long first line");
	    return;
	}
	print STDERR "Need more data for complete header\n" if $DEBUG;
	return unless $self->_need_more($buf, $timeout, $fdset);
    }
    if ($buf !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
	$self->send_error(400);  # BAD_REQUEST
	$self->reason("Bad request line");
	return;
    }
    my $proto = $3 || "HTTP/0.9";
    my $r = HTTP::Request->new($1, url($2, $self->daemon->url));
    $r->protocol($proto);
    ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);

    if ($proto >= $HTTP_1_0) {
	# we expect to find some headers
	my($key, $val);
      HEADER:
	while ($buf =~ s/^([^\012]*)\012//) {
	    $_ = $1;
	    s/\015$//;
	    if (/^([\w\-]+)\s*:\s*(.*)/) {
		$r->push_header($key, $val) if $key;
		($key, $val) = ($1, $2);
	    } elsif (/^\s+(.*)/) {
		$val .= " $1";
	    } else {
		last HEADER;
	    }
	}
	$r->push_header($key, $val) if $key;
    }

    my $conn = $r->header('Connection');
    if ($proto >= $HTTP_1_1) {
	${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
    } else {
	${*$self}{'httpd_nomore'}++ unless $conn &&
                                           lc($conn) =~ /\bkeep-alive\b/;
    }

    if ($only_headers) {
	${*$self}{'httpd_rbuf'} = $buf;
        return $r;
    }

    # Find out how much content to read
    my $te  = $r->header('Transfer-Encoding');
    my $ct  = $r->header('Content-Type');
    my $len = $r->header('Content-Length');

    if ($te && lc($te) eq 'chunked') {
	# Handle chunked transfer encoding
	my $body = "";
      CHUNK:
	while (1) {
	    print STDERR "Chunked\n" if $DEBUG;
	    if ($buf =~ s/^([^\012]*)\012//) {
		my $chunk_head = $1;
		unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
		    $self->send_error(400);
		    $self->reason("Bad chunk header $chunk_head");
		    return;
		}
		my $size = hex($1);
		last CHUNK if $size == 0;

		my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
		# must read until we have a complete chunk
		while ($missing > 0) {
		    print STDERR "Need $missing more bytes\n" if $DEBUG;
		    my $n = $self->_need_more($buf, $timeout, $fdset);
		    return unless $n;
		    $missing -= $n;
		}
		$body .= substr($buf, 0, $size);
		substr($buf, 0, $size+2) = '';

	    } else {
		# need more data in order to have a complete chunk header
		return unless $self->_need_more($buf, $timeout, $fdset);
	    }
	}
	$r->content($body);

	# pretend it was a normal entity body
	$r->remove_header('Transfer-Encoding');
	$r->header('Content-Length', length($body));

	my($key, $val);
      FOOTER:
	while (1) {
	    if ($buf !~ /\012/) {
		# need at least one line to look at
		return unless $self->_need_more($buf, $timeout, $fdset);
	    } else {
		$buf =~ s/^([^\012]*)\012//;
		$_ = $1;
		s/\015$//;
		if (/^([\w\-]+)\s*:\s*(.*)/) {
		    $r->push_header($key, $val) if $key;
		    ($key, $val) = ($1, $2);
		} elsif (/^\s+(.*)/) {
		    $val .= " $1";
		} elsif (!length) {
		    last FOOTER;
		} else {
		    $self->reason("Bad footer syntax");
		    return;
		}
	    }
	}
	$r->push_header($key, $val) if $key;

    } elsif ($te) {
	$self->send_error(501); 	# Unknown transfer encoding
	$self->reason("Unknown transfer encoding '$te'");
	return;

    } elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
	# Handle multipart content type
	my $boundary = "$CRLF--$1--$CRLF";
	my $index;
	while (1) {
	    $index = index($buf, $boundary);
	    last if $index >= 0;
	    # end marker not yet found
	    return unless $self->_need_more($buf, $timeout, $fdset);
	}
	$index += length($boundary);
	$r->content(substr($buf, 0, $index));
	substr($buf, 0, $index) = '';

    } elsif ($len) {
	# Plain body specified by "Content-Length"
	my $missing = $len - length($buf);
	while ($missing > 0) {
	    print "Need $missing more bytes of content\n" if $DEBUG;
	    my $n = $self->_need_more($buf, $timeout, $fdset);
	    return unless $n;
	    $missing -= $n;
	}
	if (length($buf) > $len) {
	    $r->content(substr($buf,0,$len));
	    substr($buf, 0, $len) = '';
	} else {
	    $r->content($buf);
	    $buf='';
	}
    }
    ${*$self}{'httpd_rbuf'} = $buf;

    $r;
}

sub _need_more
{
    my $self = shift;