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