CLIX - Fazer Clix Custa Nix/CLIX-CD.cdr/mac/lib/HTTP/Daemon.pm

Perl POD Document | 1996-12-04 | 13.2 KB | 583 lines | [TEXT/McPL]

# $Id: Daemon.pm,v 1.13 1996/11/13 13:22:21 aas Exp $
#

use strict;

package HTTP::Daemon;

=head1 NAME

HTTP::Daemon - a simple http server class

=head1 SYNOPSIS

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

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

=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.

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

$VERSION = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\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 also 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

Same as I<IO::Socket::accept> but will return an
I<HTTP::Daemon::ClientConn> reference.  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 $sock = $self->SUPER::accept(@_);
    if ($sock) {
    $sock = bless $sock, "HTTP::Daemon::ClientConn";
    ${*$sock}{'httpd_daemon'} = $self;
    }
    $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.

=cut

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


package HTTP::Daemon::ClientConn;

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

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

=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

Will read data from the client and turn it into a I<HTTP::Request>
object which is then returned. Will return undef if reading of the
request failed.  If it fails, then the I<HTTP::Daemon::ClientConn>
object ($c) should be discarded.

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

=cut

sub get_request
{
    my $self = shift;
    my $buf = "";

    my $timeout = $ {*$self}{'io_socket_timeout'};
    my  $fdset = "";
    vec($fdset, $self->fileno,1) = 1;

  READ_HEADER:
    while (1) {
    if ($timeout) {
        return undef unless select($fdset,undef,undef,$timeout);
    }
    my $n = sysread($self, $buf, 1024, length($buf));
    return undef if $n == 0;  # unexpected EOF
    if ($buf =~ /^\w+[^\n]+HTTP\/\d+\.\d+\015?\012/) {
        last READ_HEADER if $buf =~ /(\015?\012){2}/;
    } elsif ($buf =~ /\012/) {
        last READ_HEADER;  # HTTP/0.9 client
    }
    }
    $buf =~ s/^(\w+)\s+(\S+)(?:\s+(HTTP\/\d+\.\d+))?[^\012]*\012//;
    my $proto = $3 || "HTTP/0.9";
    ${*$self}{'httpd_client_proto'} = $proto;
    my $r = HTTP::Request->new($1, url($2, $self->daemon->url));
    $r->protocol($proto);

    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 $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) {
        if ($buf =~ s/^([^\012]*)\012//) {
        my $chunk_head = $1;
        $chunk_head =~ /^([0-9A-Fa-f]+)/;
        return undef unless length($1);
        my $size = hex($1);
        last CHUNK if $size == 0;

        my $missing = $size - length($buf);
        $missing += 2; # also read CRLF at chunk end
        $body .= $buf;
        $buf = "";
        # must read rest of chunk and append it to the $body
        while ($missing > 0) {
            if ($timeout) {
            return undef unless select($fdset,undef,undef,$timeout);
            }
            my $n = sysread($self, $body, $missing, length($body));
            return undef if $n == 0;
            $missing -= $n;
        }
        substr($body, -2, 2) = ''; # remove CRLF at end

        } else {
        # need more data in order to have a complete chunk header
        if ($timeout) {
            return undef unless select($fdset,undef,undef,$timeout);
        }
        my $n = sysread($self, $buf, 2048, length($buf));
        return undef if $n == 0;
        }
    }
    $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
        if ($timeout) {
            return undef unless select($fdset,undef,undef,$timeout);
        }
        my $n = sysread($self, $buf, 2048, length($buf));
        return undef if $n == 0;
        } else {
        $buf =~ s/^([^\012]*)\012//;
        $_ = $1;
        s/\015$//;
        last FOOTER if length($_) == 0;

        if (/^([\w\-]+)\s*:\s*(.*)/) {
            $r->push_header($key, $val) if $key;
            ($key, $val) = ($1, $2);
        } elsif (/^\s+(.*)/) {
            $val .= " $1";
        } else {
            return undef;  # bad syntax
        }
        }
    }
    $r->push_header($key, $val) if $key;

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

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

    } elsif ($len) {
    # Plain body specified by "Content-Length"

    $len -= length($buf);
    while ($len > 0) {
        if ($timeout) {
        return undef unless select($fdset,undef,undef,$timeout);
        }
        my $n = sysread($self, $buf, $len, length($buf));
        return undef if $n == 0;
        $len -= $n;
    }
    $r->content($buf);

    }

    $r;
}


=item $c->antique_client

Returns TRUE if the client speaks the HTTP/0.9 protocol, i.e. no
status code or headers should be returned.

=cut

sub antique_client
{
    my $self = shift;
    ${*$self}{'httpd_client_proto'} eq 'HTTP/0.9';
}


=item $c->send_status_line( [$code, [$mess, [$proto]]] )

Sends the status line back to the client.

=cut

sub send_status_line
{
    my($self, $status, $message, $proto) = @_;
    return if $self->antique_client;
    $status  ||= RC_OK;
    $message ||= status_message($status);
    $proto   ||= $HTTP::Daemon::PROTO;
    print $self "$proto $status $message$CRLF";
}


sub send_crlf
{
    my $self = shift;
    print $self $CRLF;
}


=item $c->send_basic_header( [$code, [$mess, [$proto]]] )

Sends the status line and the "Date:" and "Server:" headers back to
the client.

=cut

sub send_basic_header
{
    my $self = shift;
    return if $self->antique_client;
    $self->send_status_line(@_);
    print $self "Date: ", time2str(time), $CRLF;
    my $product = $self->daemon->product_tokens;
    print $self "Server: $product$CRLF" if $product;
}


=item $c->send_response( [$res] )

Takes a I<HTTP::Response> object as parameter and send it back to the
client as the response.

=cut

sub send_response
{
    my $self = shift;
    my $res = shift;
    if (!ref $res) {
    $res ||= RC_OK;
    $res = HTTP::Response->new($res, @_);
    }
    unless ($self->antique_client) {
    $self->send_basic_header($res->code, $res->message, $res->protocol);
    print $self $res->headers_as_string($CRLF);
    print $self $CRLF;  # separates headers and content
    }
    print $self $res->content;
}


=item $c->send_redirect( $loc, [$code, [$entity_body]] )

Sends a redirect response back to the client.  The location ($loc) can
be an absolute or a relative URL. The $code must be one the redirect
status codes, and it defaults to "301 Moved Permanently"

=cut

sub send_redirect
{
    my($self, $loc, $status, $content) = @_;
    $status ||= RC_MOVED_PERMANENTLY;
    Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
    $self->send_basic_header($status);
    $loc = url($loc, $self->daemon->url) unless ref($loc);
    $loc = $loc->abs;
    print $self "Location: $loc$CRLF";
    if ($content) {
    my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
    print $self "Content-Type: $ct$CRLF";
    }
    print $self $CRLF;
    print $self $content if $content;
}


=item $c->send_error( [$code, [$error_message]] )

Send an error response back to the client.  If the $code is missing a
"Bad Request" error is reported.  The $error_message is a string that
is incorporated in the body of the HTML entity body.

=cut

sub send_error
{
    my($self, $status, $error) = @_;
    $status ||= RC_BAD_REQUEST;
    Carp::croak("Status '$status' is not an error") unless is_error($status);
    my $mess = status_message($status);
    $error  ||= "";
    unless ($self->antique_client) {
        $self->send_basic_header($status);
        print $self "Content-Type: text/html$CRLF";
        print $self $CRLF;
    }
    print $self <<EOT;
<title>$status $mess</title>
<h1>$status $mess</h1>
$error
EOT
    $status;
}


=item $c->send_file_response($filename)

Send back a response with the specified $filename as content.  If the
file happen to be a directory we will generate a HTML index for it.

=cut

sub send_file_response
{
    my($self, $file) = @_;
    if (-d $file) {
    $self->send_dir($file);
    } elsif (-f _) {
    # plain file
    local(*F);
    sysopen(F, $file, 0) or
      return $self->send_error(RC_FORBIDDEN);
    my($ct,$ce) = guess_media_type($file);
    my($size,$mtime) = (stat _)[7,9];
    unless ($self->antique_client) {
        $self->send_basic_header;
        print $self "Content-Type: $ct$CRLF";
        print $self "Content-Encoding: $ce$CRLF" if $ce;
        print $self "Content-Length: $size$CRLF";
        print $self "Last-Modified: ", time2str($mtime), "$CRLF";
        print $self $CRLF;
    }
    $self->send_file(\*F);
    return RC_OK;
    } else {
    $self->send_error(RC_NOT_FOUND);
    }
}


sub send_dir
{
    my($self, $dir) = @_;
    $self->send_error(RC_NOT_FOUND) unless -d $dir;
    $self->send_error(RC_NOT_IMPLEMENTED);
}


=item $c->send_file($fd);

Copies the file back to the client.  The file can be a string (which
will be interpreted as a filename) or a reference to a glob.

=cut

sub send_file
{
    my($self, $file) = @_;
    my $opened = 0;
    if (!ref($file)) {
    local(*F);
    open(F, $file) || return undef;
    $file = \*F;
    $opened++;
    }
    my $cnt = 0;
    my $buf = "";
    my $n;
    while ($n = sysread($file, $buf, 8*1024)) {
    last if $n <= 0;
    $cnt += $n;
    print $self $buf;
    }
    close($file) if $opened;
    $cnt;
}


=item $c->daemon

Return a reference to the corresponding I<HTTP::Daemon> object.

=cut

sub daemon
{
    my $self = shift;
    ${*$self}{'httpd_daemon'};
}

=back

=head1 SEE ALSO

L<IO::Socket>, L<Apache>

=head1 COPYRIGHT

Copyright 1996, Gisle Aas

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1;