From: Nicholas Bamber Date: Wed, 9 Mar 2011 15:30:36 +0000 (+0000) Subject: [svn-inject] Installing original source of libhttp-daemon-perl (6.00) X-Git-Url: https://git.proxmox.com/?p=libhttp-daemon-perl.git;a=commitdiff_plain;h=b1832b9ea9719c0dcc25e912c2d152d097f3d692 [svn-inject] Installing original source of libhttp-daemon-perl (6.00) --- b1832b9ea9719c0dcc25e912c2d152d097f3d692 diff --git a/Changes b/Changes new file mode 100644 index 0000000..a855a2e --- /dev/null +++ b/Changes @@ -0,0 +1,7 @@ +_______________________________________________________________________________ +2011-02-25 HTTP-Daemon 6.00 + +Initial release of HTTP-Daemon as a separate distribution. There are no code +changes besides incrementing the version number since libwww-perl-5.837. + +The HTTP::Daemon used to be bundled with the libwww-perl distribution. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..0f76363 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,12 @@ +Changes +lib/HTTP/Daemon.pm +Makefile.PL +MANIFEST This list of files +README +t/chunked.t +t/local/http.t +t/misc/httpd +t/misc/httpd_term.pl +t/robot/ua-get.t +t/robot/ua.t +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..9dd817b --- /dev/null +++ b/META.yml @@ -0,0 +1,32 @@ +--- #YAML:1.0 +name: HTTP-Daemon +version: 6.00 +abstract: a simple http server class +author: + - Gisle Aas +license: perl +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + ExtUtils::MakeMaker: 0 +requires: + HTTP::Date: 6 + HTTP::Request: 6 + HTTP::Response: 6 + HTTP::Status: 6 + IO::Socket: 0 + LWP::MediaTypes: 6 + perl: 5.008008 + Sys::Hostname: 0 +resources: + MailingList: mailto:libwww@perl.org + repository: http://github.com/gisle/libwww-perl +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.56 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..fe981cc --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,52 @@ +#!perl -w + +require 5.008008; +use strict; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'HTTP::Daemon', + VERSION_FROM => 'lib/HTTP/Daemon.pm', + ABSTRACT_FROM => 'lib/HTTP/Daemon.pm', + AUTHOR => 'Gisle Aas ', + LICENSE => "perl", + MIN_PERL_VERSION => 5.008008, + PREREQ_PM => { + 'Sys::Hostname' => 0, + 'IO::Socket' => 0, + 'HTTP::Request' => 6, + 'HTTP::Response' => 6, + 'HTTP::Status' => 6, + 'HTTP::Date' => 6, + 'LWP::MediaTypes' => 6, + }, + META_MERGE => { + resources => { + repository => 'http://github.com/gisle/libwww-perl', + MailingList => 'mailto:libwww@perl.org', + } + }, +); + + +BEGIN { + # compatibility with older versions of MakeMaker + my $developer = -f ".gitignore"; + my %mm_req = ( + LICENCE => 6.31, + META_MERGE => 6.45, + META_ADD => 6.45, + MIN_PERL_VERSION => 6.48, + ); + undef(*WriteMakefile); + *WriteMakefile = sub { + my %arg = @_; + for (keys %mm_req) { + unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { + warn "$_ $@" if $developer; + delete $arg{$_}; + } + } + ExtUtils::MakeMaker::WriteMakefile(%arg); + }; +} diff --git a/README b/README new file mode 100644 index 0000000..be5a20a --- /dev/null +++ b/README @@ -0,0 +1,237 @@ +NAME + HTTP::Daemon - a simple http server class + +SYNOPSIS + use HTTP::Daemon; + use HTTP::Status; + + my $d = HTTP::Daemon->new || die; + print "Please contact me at: url, ">\n"; + while (my $c = $d->accept) { + while (my $r = $c->get_request) { + if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") { + # remember, this is *not* recommended practice :-) + $c->send_file_response("/etc/passwd"); + } + else { + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + } + +DESCRIPTION + Instances of the `HTTP::Daemon' class are HTTP/1.1 servers that listen + on a socket for incoming requests. The `HTTP::Daemon' is a subclass of + `IO::Socket::INET', so you can perform socket operations directly on it + too. + + The accept() method will return when a connection from a client is + available. The returned value will be an `HTTP::Daemon::ClientConn' + object which is another `IO::Socket::INET' subclass. Calling the + get_request() method on this object will read data from the client and + return an `HTTP::Request' object. The ClientConn object also provide + methods to send back various responses. + + This HTTP daemon does not fork(2) for you. Your application, i.e. the + user of the `HTTP::Daemon' is responsible for forking if that is + desirable. Also note that the user is responsible for generating + responses that conform to the HTTP/1.1 protocol. + + The following methods of `HTTP::Daemon' are new (or enhanced) relative + to the `IO::Socket::INET' base class: + + $d = HTTP::Daemon->new + $d = HTTP::Daemon->new( %opts ) + The constructor method takes the same arguments as the + `IO::Socket::INET' constructor, but unlike its base class it can + also be called without any arguments. The daemon will then set up a + listen queue of 5 connections and allocate some random port number. + + A server that wants to bind to some specific address on the standard + HTTP port will be constructed like this: + + $d = HTTP::Daemon->new( + LocalAddr => 'www.thisplace.com', + LocalPort => 80, + ); + + See IO::Socket::INET for a description of other arguments that can + be used configure the daemon during construction. + + $c = $d->accept + $c = $d->accept( $pkg ) + ($c, $peer_addr) = $d->accept + This method works the same the one provided by the base class, but + it returns an `HTTP::Daemon::ClientConn' reference by default. If a + package name is provided as argument, then the returned object will + be blessed into the given class. It is probably a good idea to make + that class a subclass of `HTTP::Daemon::ClientConn'. + + The accept method will return `undef' if timeouts have been enabled + and no connection is made within the given time. The timeout() + method is described in IO::Socket. + + In list context both the client object and the peer address will be + returned; see the description of the accept method IO::Socket for + details. + + $d->url + Returns a URL string that can be used to access the server root. + + $d->product_tokens + Returns the name that this server will use to identify itself. This + is the string that is sent with the `Server' response header. The + main reason to have this method is that subclasses can override it + if they want to use another product name. + + The default is the string "libwww-perl-daemon/#.##" where "#.##" is + replaced with the version number of this module. + + The `HTTP::Daemon::ClientConn' is a `IO::Socket::INET' subclass. + Instances of this class are returned by the accept() method of + `HTTP::Daemon'. The following methods are provided: + + $c->get_request + $c->get_request( $headers_only ) + This method reads data from the client and turns it into an + `HTTP::Request' object which is returned. It returns `undef' if + reading fails. If it fails, then the `HTTP::Daemon::ClientConn' + object ($c) should be discarded, and you should not try call this + method again on it. The $c->reason method might give you some + information about why $c->get_request failed. + + The 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 large 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 get_request() will return + immediately after parsing the request headers and you are + responsible for reading the rest of the request content. If you are + going to call $c->get_request again on the same connection you + better read the correct number of bytes. + + $c->read_buffer + $c->read_buffer( $new_value ) + Bytes read by $c->get_request, but not used are placed in the *read + buffer*. The next time $c->get_request is called it will consume the + bytes in this buffer before reading more data from the network + connection itself. The read buffer is invalid after $c->get_request + has failed. + + If you handle the reading of the request content yourself you need + to empty this buffer before you read more and you need to place + unconsumed bytes here. You also need this buffer if you implement + services like *101 Switching Protocols*. + + This method always returns the old buffer content and can optionally + replace the buffer content if you pass it an argument. + + $c->reason + When $c->get_request returns `undef' you can obtain a short string + describing why it happened by calling $c->reason. + + $c->proto_ge( $proto ) + Return TRUE if the client announced a protocol with version number + greater or equal to the given argument. The $proto argument can be a + string like "HTTP/1.1" or just "1.1". + + $c->antique_client + Return TRUE if the client speaks the HTTP/0.9 protocol. No status + code and no headers should be returned to such a client. This should + be the same as !$c->proto_ge("HTTP/1.0"). + + $c->head_request + Return TRUE if the last request was a `HEAD' request. No content + body must be generated for these requests. + + $c->force_last_request + Make sure that $c->get_request will not try to read more requests + off this connection. If you generate a response that is not self + delimiting, then you should signal this fact by calling this method. + + This attribute is turned on automatically if the client announces + protocol HTTP/1.0 or worse and does not include a "Connection: + Keep-Alive" header. It is also turned on automatically when HTTP/1.1 + or better clients send the "Connection: close" request header. + + $c->send_status_line + $c->send_status_line( $code ) + $c->send_status_line( $code, $mess ) + $c->send_status_line( $code, $mess, $proto ) + Send the status line back to the client. If $code is omitted 200 is + assumed. If $mess is omitted, then a message corresponding to $code + is inserted. If $proto is missing the content of the + $HTTP::Daemon::PROTO variable is used. + + $c->send_crlf + Send the CRLF sequence to the client. + + $c->send_basic_header + $c->send_basic_header( $code ) + $c->send_basic_header( $code, $mess ) + $c->send_basic_header( $code, $mess, $proto ) + Send the status line and the "Date:" and "Server:" headers back to + the client. This header is assumed to be continued and does not end + with an empty CRLF line. + + See the description of send_status_line() for the description of the + accepted arguments. + + $c->send_header( $field, $value ) + $c->send_header( $field1, $value1, $field2, $value2, ... ) + Send one or more header lines. + + $c->send_response( $res ) + Write a `HTTP::Response' object to the client as a response. We try + hard to make sure that the response is self delimiting so that the + connection can stay persistent for further request/response + exchanges. + + The content attribute of the `HTTP::Response' object can be a normal + string or a subroutine reference. If it is a subroutine, then + whatever this callback routine returns is written back to the client + as the response content. The routine will be called until it return + an undefined or empty value. If the client is HTTP/1.1 aware then we + will use chunked transfer encoding for the response. + + $c->send_redirect( $loc ) + $c->send_redirect( $loc, $code ) + $c->send_redirect( $loc, $code, $entity_body ) + Send a redirect response back to the client. The location ($loc) can + be an absolute or relative URL. The $code must be one the redirect + status codes, and defaults to "301 Moved Permanently" + + $c->send_error + $c->send_error( $code ) + $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. + + $c->send_file_response( $filename ) + Send back a response with the specified $filename as content. If the + file is a directory we try to generate an HTML index of it. + + $c->send_file( $filename ) + $c->send_file( $fd ) + Copy the file to the client. The file can be a string (which will be + interpreted as a filename) or a reference to an `IO::Handle' or + glob. + + $c->daemon + Return a reference to the corresponding `HTTP::Daemon' object. + +SEE ALSO + RFC 2616 + + IO::Socket::INET, IO::Socket + +COPYRIGHT + Copyright 1996-2003, Gisle Aas + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm new file mode 100644 index 0000000..6988bd4 --- /dev/null +++ b/lib/HTTP/Daemon.pm @@ -0,0 +1,903 @@ +package HTTP::Daemon; + +use strict; +use vars qw($VERSION @ISA $PROTO $DEBUG); + +$VERSION = "6.00"; + +use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa); +@ISA=qw(IO::Socket::INET); + +$PROTO = "HTTP/1.1"; + + +sub new +{ + my($class, %args) = @_; + $args{Listen} ||= 5; + $args{Proto} ||= 'tcp'; + return $class->SUPER::new(%args); +} + + +sub accept +{ + my $self = shift; + my $pkg = shift || "HTTP::Daemon::ClientConn"; + my ($sock, $peer) = $self->SUPER::accept($pkg); + if ($sock) { + ${*$sock}{'httpd_daemon'} = $self; + return wantarray ? ($sock, $peer) : $sock; + } + else { + return; + } +} + + +sub url +{ + my $self = shift; + my $url = $self->_default_scheme . "://"; + my $addr = $self->sockaddr; + if (!$addr || $addr eq INADDR_ANY) { + require Sys::Hostname; + $url .= lc Sys::Hostname::hostname(); + } + else { + $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr); + } + my $port = $self->sockport; + $url .= ":$port" if $port != $self->_default_port; + $url .= "/"; + $url; +} + + +sub _default_port { + 80; +} + + +sub _default_scheme { + "http"; +} + + +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 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"); + + +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/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { + ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); + $self->send_error(400); # BAD_REQUEST + $self->reason("Bad request line: $buf"); + return; + } + my $method = $1; + my $uri = $2; + my $proto = $3 || "HTTP/0.9"; + $uri = "http://$uri" if $method eq "CONNECT"; + $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url); + my $r = HTTP::Request->new($method, $uri); + $r->protocol($proto); + ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto); + ${*$self}{'httpd_head'} = ($method eq "HEAD"); + + if ($proto >= $HTTP_1_0) { + # we expect to find some headers + my($key, $val); + HEADER: + while ($buf =~ s/^([^\012]*)\012//) { + $_ = $1; + s/\015$//; + if (/^([^:\s]+)\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'); + + # Act on the Expect header, if it's there + for my $e ( $r->header('Expect') ) { + if( lc($e) eq '100-continue' ) { + $self->send_status_line(100); + $self->send_crlf; + } + else { + $self->send_error(417); + $self->reason("Unsupported Expect header value"); + return; + } + } + + 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 ($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=''; + } + } + elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) { + # Handle multipart content type + my $boundary = "$CRLF--$2--"; + 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) = ''; + + } + ${*$self}{'httpd_rbuf'} = $buf; + + $r; +} + + +sub _need_more +{ + my $self = shift; + #my($buf,$timeout,$fdset) = @_; + if ($_[1]) { + my($timeout, $fdset) = @_[1,2]; + print STDERR "select(,,,$timeout)\n" if $DEBUG; + my $n = select($fdset,undef,undef,$timeout); + unless ($n) { + $self->reason(defined($n) ? "Timeout" : "select: $!"); + return; + } + } + print STDERR "sysread()\n" if $DEBUG; + my $n = sysread($self, $_[0], 2048, length($_[0])); + $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; + $n; +} + + +sub read_buffer +{ + my $self = shift; + my $old = ${*$self}{'httpd_rbuf'}; + if (@_) { + ${*$self}{'httpd_rbuf'} = shift; + } + $old; +} + + +sub reason +{ + my $self = shift; + my $old = ${*$self}{'httpd_reason'}; + if (@_) { + ${*$self}{'httpd_reason'} = shift; + } + $old; +} + + +sub proto_ge +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} >= _http_version(shift); +} + + +sub _http_version +{ + local($_) = shift; + return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i; + $1 * 1000 + $2; +} + + +sub antique_client +{ + my $self = shift; + ${*$self}{'httpd_client_proto'} < $HTTP_1_0; +} + + +sub force_last_request +{ + my $self = shift; + ${*$self}{'httpd_nomore'}++; +} + +sub head_request +{ + my $self = shift; + ${*$self}{'httpd_head'}; +} + + +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 || "HTTP/1.1"; + print $self "$proto $status $message$CRLF"; +} + + +sub send_crlf +{ + my $self = shift; + print $self $CRLF; +} + + +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; +} + + +sub send_header +{ + my $self = shift; + while (@_) { + my($k, $v) = splice(@_, 0, 2); + $v = "" unless defined($v); + print $self "$k: $v$CRLF"; + } +} + + +sub send_response +{ + my $self = shift; + my $res = shift; + if (!ref $res) { + $res ||= RC_OK; + $res = HTTP::Response->new($res, @_); + } + my $content = $res->content; + my $chunked; + unless ($self->antique_client) { + my $code = $res->code; + $self->send_basic_header($code, $res->message, $res->protocol); + if ($code =~ /^(1\d\d|[23]04)$/) { + # make sure content is empty + $res->remove_header("Content-Length"); + $content = ""; + } + elsif ($res->request && $res->request->method eq "HEAD") { + # probably OK + } + elsif (ref($content) eq "CODE") { + if ($self->proto_ge("HTTP/1.1")) { + $res->push_header("Transfer-Encoding" => "chunked"); + $chunked++; + } + else { + $self->force_last_request; + } + } + elsif (length($content)) { + $res->header("Content-Length" => length($content)); + } + else { + $self->force_last_request; + $res->header('connection','close'); + } + print $self $res->headers_as_string($CRLF); + print $self $CRLF; # separates headers and content + } + if ($self->head_request) { + # no content + } + elsif (ref($content) eq "CODE") { + while (1) { + my $chunk = &$content(); + last unless defined($chunk) && length($chunk); + if ($chunked) { + printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF; + } + else { + print $self $chunk; + } + } + print $self "0$CRLF$CRLF" if $chunked; # no trailers either + } + elsif (length $content) { + print $self $content; + } +} + + +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); + my $base = $self->daemon->url; + $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc); + $loc = $loc->abs($base); + print $self "Location: $loc$CRLF"; + if ($content) { + my $ct = $content =~ /^\s*head_request; + $self->force_last_request; # no use keeping the connection open +} + + +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 ||= ""; + $mess = <$status $mess +

$status $mess

+$error +EOT + unless ($self->antique_client) { + $self->send_basic_header($status); + print $self "Content-Type: text/html$CRLF"; + print $self "Content-Length: " . length($mess) . $CRLF; + print $self $CRLF; + } + print $self $mess unless $self->head_request; + $status; +} + + +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); + binmode(F); + 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" if $size; + print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; + print $self $CRLF; + } + $self->send_file(\*F) unless $self->head_request; + 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); +} + + +sub send_file +{ + my($self, $file) = @_; + my $opened = 0; + local(*FILE); + if (!ref($file)) { + open(FILE, $file) || return undef; + binmode(FILE); + $file = \*FILE; + $opened++; + } + my $cnt = 0; + my $buf = ""; + my $n; + while ($n = sysread($file, $buf, 8*1024)) { + last if !$n; + $cnt += $n; + print $self $buf; + } + close($file) if $opened; + $cnt; +} + + +sub daemon +{ + my $self = shift; + ${*$self}{'httpd_daemon'}; +} + + +1; + +__END__ + +=head1 NAME + +HTTP::Daemon - a simple http server class + +=head1 SYNOPSIS + + use HTTP::Daemon; + use HTTP::Status; + + my $d = HTTP::Daemon->new || die; + print "Please contact me at: url, ">\n"; + while (my $c = $d->accept) { + while (my $r = $c->get_request) { + if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") { + # remember, this is *not* recommended practice :-) + $c->send_file_response("/etc/passwd"); + } + else { + $c->send_error(RC_FORBIDDEN) + } + } + $c->close; + undef($c); + } + +=head1 DESCRIPTION + +Instances of the C class are HTTP/1.1 servers that +listen on a socket for incoming requests. The C is a +subclass of C, so you can perform socket operations +directly on it too. + +The accept() method will return when a connection from a client is +available. The returned value will be an C +object which is another C subclass. Calling the +get_request() method on this object will read data from the client and +return an C object. The ClientConn object also provide +methods to send back various responses. + +This HTTP daemon does not fork(2) for you. Your application, i.e. the +user of the C is responsible for forking if that is +desirable. Also note that the user is responsible for generating +responses that conform to the HTTP/1.1 protocol. + +The following methods of C are new (or enhanced) relative +to the C base class: + +=over 4 + +=item $d = HTTP::Daemon->new + +=item $d = HTTP::Daemon->new( %opts ) + +The constructor method takes the same arguments as the +C constructor, but unlike its base class it can also +be called without any arguments. The daemon will then set up a listen +queue of 5 connections and allocate some random port number. + +A server that wants to bind to some specific address on the standard +HTTP port will be constructed like this: + + $d = HTTP::Daemon->new( + LocalAddr => 'www.thisplace.com', + LocalPort => 80, + ); + +See L for a description of other arguments that can +be used configure the daemon during construction. + +=item $c = $d->accept + +=item $c = $d->accept( $pkg ) + +=item ($c, $peer_addr) = $d->accept + +This method works the same the one provided by the base class, but it +returns an C reference by default. If a +package name is provided as argument, then the returned object will be +blessed into the given class. It is probably a good idea to make that +class a subclass of C. + +The accept method will return C if timeouts have been enabled +and no connection is made within the given time. The timeout() method +is described in L. + +In list context both the client object and the peer address will be +returned; see the description of the accept method L for +details. + +=item $d->url + +Returns a URL string that can be used to access the server root. + +=item $d->product_tokens + +Returns the name that this server will use to identify itself. This +is the string that is sent with the C response header. The +main reason to have this method is that subclasses can override it if +they want to use another product name. + +The default is the string "libwww-perl-daemon/#.##" where "#.##" is +replaced with the version number of this module. + +=back + +The C is a C +subclass. Instances of this class are returned by the accept() method +of C. The following methods are provided: + +=over 4 + +=item $c->get_request + +=item $c->get_request( $headers_only ) + +This method reads data from the client and turns it into an +C object which is returned. It returns C +if reading fails. If it fails, then the C +object ($c) should be discarded, and you should not try call this +method again on it. The $c->reason method might give you some +information about why $c->get_request failed. + +The 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 large 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 get_request() will return immediately +after parsing the request headers and you are responsible for reading +the rest of the request content. If you are going to call +$c->get_request again on the same connection you better read the +correct number of bytes. + +=item $c->read_buffer + +=item $c->read_buffer( $new_value ) + +Bytes read by $c->get_request, but not used are placed in the I. The next time $c->get_request is called it will consume the +bytes in this buffer before reading more data from the network +connection itself. The read buffer is invalid after $c->get_request +has failed. + +If you handle the reading of the request content yourself you need to +empty this buffer before you read more and you need to place +unconsumed bytes here. You also need this buffer if you implement +services like I<101 Switching Protocols>. + +This method always returns the old buffer content and can optionally +replace the buffer content if you pass it an argument. + +=item $c->reason + +When $c->get_request returns C you can obtain a short string +describing why it happened by calling $c->reason. + +=item $c->proto_ge( $proto ) + +Return TRUE if the client announced a protocol with version number +greater or equal to the given argument. The $proto argument can be a +string like "HTTP/1.1" or just "1.1". + +=item $c->antique_client + +Return TRUE if the client speaks the HTTP/0.9 protocol. No status +code and no headers should be returned to such a client. This should +be the same as !$c->proto_ge("HTTP/1.0"). + +=item $c->head_request + +Return TRUE if the last request was a C request. No content +body must be generated for these requests. + +=item $c->force_last_request + +Make sure that $c->get_request will not try to read more requests off +this connection. If you generate a response that is not self +delimiting, then you should signal this fact by calling this method. + +This attribute is turned on automatically if the client announces +protocol HTTP/1.0 or worse and does not include a "Connection: +Keep-Alive" header. It is also turned on automatically when HTTP/1.1 +or better clients send the "Connection: close" request header. + +=item $c->send_status_line + +=item $c->send_status_line( $code ) + +=item $c->send_status_line( $code, $mess ) + +=item $c->send_status_line( $code, $mess, $proto ) + +Send the status line back to the client. If $code is omitted 200 is +assumed. If $mess is omitted, then a message corresponding to $code +is inserted. If $proto is missing the content of the +$HTTP::Daemon::PROTO variable is used. + +=item $c->send_crlf + +Send the CRLF sequence to the client. + +=item $c->send_basic_header + +=item $c->send_basic_header( $code ) + +=item $c->send_basic_header( $code, $mess ) + +=item $c->send_basic_header( $code, $mess, $proto ) + +Send the status line and the "Date:" and "Server:" headers back to +the client. This header is assumed to be continued and does not end +with an empty CRLF line. + +See the description of send_status_line() for the description of the +accepted arguments. + +=item $c->send_header( $field, $value ) + +=item $c->send_header( $field1, $value1, $field2, $value2, ... ) + +Send one or more header lines. + +=item $c->send_response( $res ) + +Write a C object to the +client as a response. We try hard to make sure that the response is +self delimiting so that the connection can stay persistent for further +request/response exchanges. + +The content attribute of the C object can be a normal +string or a subroutine reference. If it is a subroutine, then +whatever this callback routine returns is written back to the +client as the response content. The routine will be called until it +return an undefined or empty value. If the client is HTTP/1.1 aware +then we will use chunked transfer encoding for the response. + +=item $c->send_redirect( $loc ) + +=item $c->send_redirect( $loc, $code ) + +=item $c->send_redirect( $loc, $code, $entity_body ) + +Send a redirect response back to the client. The location ($loc) can +be an absolute or relative URL. The $code must be one the redirect +status codes, and defaults to "301 Moved Permanently" + +=item $c->send_error + +=item $c->send_error( $code ) + +=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. + +=item $c->send_file_response( $filename ) + +Send back a response with the specified $filename as content. If the +file is a directory we try to generate an HTML index of it. + +=item $c->send_file( $filename ) + +=item $c->send_file( $fd ) + +Copy the file to the client. The file can be a string (which +will be interpreted as a filename) or a reference to an C +or glob. + +=item $c->daemon + +Return a reference to the corresponding C object. + +=back + +=head1 SEE ALSO + +RFC 2616 + +L, L + +=head1 COPYRIGHT + +Copyright 1996-2003, Gisle Aas + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/t/chunked.t b/t/chunked.t new file mode 100644 index 0000000..e11799f --- /dev/null +++ b/t/chunked.t @@ -0,0 +1,184 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Config; +use HTTP::Daemon; +use Test::More; +# use Time::HiRes qw(sleep); +our $CRLF; +use Socket qw($CRLF); + +our $LOGGING = 0; + +our @TESTS = ( + { + expect => 629, + comment => "traditional, unchunked POST request", + raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1 +User-Agent: UNTRUSTED/1.0 +Content-Type: application/x-www-form-urlencoded +Content-Length: 629 +Host: localhost + +JSR-205=0;font_small=15;png=1;jpg=1;alpha_channel=256;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;pointer_motion_event=0;camera=1;free_memory=455472;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;color=65536;JSR-120=1;JSR-184=1;JSR-180=0;JSR-75-file=0;push_socket=0;pointer_event=0;nokia-ui=1;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;gif=1;midp=MIDP-1.0 MIDP-2.0;font_large=22;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;" + }, + { + expect => 8, + comment => "chunked with illegal Content-Length header; tiny message", + raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1 +Host: localhost +Content-Type: application/x-www-form-urlencoded +Content-Length: 8 +Transfer-Encoding: chunked + +8 +icm.x=u2 +0 + +", + }, + { + expect => 868, + comment => "chunked with illegal Content-Length header; medium sized", + raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1 +Host:dev05 +Connection:close +Content-Type:application/x-www-form-urlencoded +Content-Length:868 +transfer-encoding:chunked + +364 +JSR-205=0;font_small=20;png=1;jpg=1;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;free_memory=733456;user_agent=xxxxxxxxx/xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=815080;cldc=CLDC-1.0;canvas_size_y=182;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=20;JSR-184=0;JSR-120=1;color=32768;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=22;NAVIGATION RIGHT=5;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=0;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;gif=1;KEY NUM 4=52;NAVIGATION UP=1;KEY NUM 3=51;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-2.0 VSCL-1.1.0;font_large=20;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=2;LEFT SOFT KEY=21;font_medium=20;fullscreen_canvas_size_y=204;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=6;java_locale=en-DE; +0 + +", + }, + { + expect => 1104, + comment => "chunked correctly, size ~1k; base for the big next test", + raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1 +User-Agent: UNTRUSTED/1.0 +Content-Type: application/x-www-form-urlencoded +Host: localhost:80 +Transfer-Encoding: chunked + +450 +JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220; +0 + +" + }, + { + expect => 1104*1024, + comment => "chunked with many chunks", + raw => ("POST /cgi-bin/redir-TE.pl HTTP/1.1 +User-Agent: UNTRUSTED/1.0 +Content-Type: application/x-www-form-urlencoded +Host: localhost:80 +Transfer-Encoding: chunked + +".("450 +JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220; +"x1024)."0 + +") + }, + ); + + +my $can_fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); + +my $tests = @TESTS; +my $tport = 8333; + +my $tsock = IO::Socket::INET->new(LocalAddr => '0.0.0.0', + LocalPort => $tport, + Listen => 1, + ReuseAddr => 1); +if (!$can_fork) { + plan skip_all => "This system cannot fork"; +} +elsif (!$tsock) { + plan skip_all => "Cannot listen on 0.0.0.0:$tport"; +} +else { + close $tsock; + plan tests => $tests; +} + +sub mywarn ($) { + return unless $LOGGING; + my($mess) = @_; + open my $fh, ">>", "http-daemon.out" + or die $!; + my $ts = localtime; + print $fh "$ts: $mess\n"; + close $fh or die $!; +} + + +my $pid; +if ($pid = fork) { + sleep 4; + for my $t (0..$#TESTS) { + my $test = $TESTS[$t]; + my $raw = $test->{raw}; + $raw =~ s/\r?\n/$CRLF/mg; + if (0) { + open my $fh, "| socket localhost $tport" or die; + print $fh $test; + } + use IO::Socket::INET; + my $sock = IO::Socket::INET->new( + PeerAddr => "127.0.0.1", + PeerPort => $tport, + ) or die; + if (0) { + for my $pos (0..length($raw)-1) { + print $sock substr($raw,$pos,1); + sleep 0.001; + } + } else { + print $sock $raw; + } + local $/; + my $resp = <$sock>; + close $sock; + my($got) = $resp =~ /\r?\n\r?\n(\d+)/s; + is($got, + $test->{expect}, + "[$test->{expect}] $test->{comment}", + ); + } + wait; +} else { + die "cannot fork: $!" unless defined $pid; + my $d = HTTP::Daemon->new( + LocalAddr => '0.0.0.0', + LocalPort => $tport, + ReuseAddr => 1, + ) or die; + mywarn "Starting new daemon as '$$'"; + my $i; + LISTEN: while (my $c = $d->accept) { + my $r = $c->get_request; + mywarn sprintf "headers[%s] content[%s]", $r->headers->as_string, $r->content; + my $res = HTTP::Response->new(200,undef,undef,length($r->content).$CRLF); + $c->send_response($res); + $c->force_last_request; # we're just not mature enough + $c->close; + undef($c); + last if ++$i >= $tests; + } +} + + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 2 +# End: diff --git a/t/local/http.t b/t/local/http.t new file mode 100644 index 0000000..421e7a3 --- /dev/null +++ b/t/local/http.t @@ -0,0 +1,380 @@ +if ($^O eq "MacOS") { + print "1..0\n"; + exit(0); +} + +unless (-f "CAN_TALK_TO_OURSELF") { + print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n"; + exit; +} + +$| = 1; # autoflush + +require IO::Socket; # make sure this work before we try to make a HTTP::Daemon + +# First we make ourself a daemon in another process +my $D = shift || ''; +if ($D eq 'daemon') { + + require HTTP::Daemon; + + my $d = HTTP::Daemon->new(Timeout => 10); + + print "Please to meet you at: url, ">\n"; + open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null"); + + while ($c = $d->accept) { + $r = $c->get_request; + if ($r) { + my $p = ($r->uri->path_segments)[1]; + my $func = lc("httpd_" . $r->method . "_$p"); + if (defined &$func) { + &$func($c, $r); + } + else { + $c->send_error(404); + } + } + $c = undef; # close connection + } + print STDERR "HTTP Server terminated\n"; + exit; +} +else { + use Config; + my $perl = $Config{'perlpath'}; + $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i; + open(DAEMON, "$perl local/http.t daemon |") or die "Can't exec daemon: $!"; +} + +use Test; +plan tests => 54; + +my $greeting = ; +$greeting =~ /(<[^>]+>)/; + +require URI; +my $base = URI->new($1); +sub url { + my $u = URI->new(@_); + $u = $u->abs($_[1]) if @_ > 1; + $u->as_string; +} + +print "Will access HTTP server at $base\n"; + +require LWP::UserAgent; +require HTTP::Request; +$ua = new LWP::UserAgent; +$ua->agent("Mozilla/0.01 " . $ua->agent); +$ua->from('gisle@aas.no'); + +#---------------------------------------------------------------- +print "Bad request...\n"; +$req = new HTTP::Request GET => url("/not_found", $base); +$req->header(X_Foo => "Bar"); +$res = $ua->request($req); + +ok($res->is_error); +ok($res->code, 404); +ok($res->message, qr/not\s+found/i); +# we also expect a few headers +ok($res->server); +ok($res->date); + +#---------------------------------------------------------------- +print "Simple echo...\n"; +sub httpd_get_echo +{ + my($c, $req) = @_; + $c->send_basic_header(200); + print $c "Content-Type: message/http\015\012"; + $c->send_crlf; + print $c $req->as_string; +} + +$req = new HTTP::Request GET => url("/echo/path_info?query", $base); +$req->push_header(Accept => 'text/html'); +$req->push_header(Accept => 'text/plain; q=0.9'); +$req->push_header(Accept => 'image/*'); +$req->push_header(':foo_bar' => 1); +$req->if_modified_since(time - 300); +$req->header(Long_text => 'This is a very long header line +which is broken between +more than one line.'); +$req->header(X_Foo => "Bar"); + +$res = $ua->request($req); +#print $res->as_string; + +ok($res->is_success); +ok($res->code, 200); +ok($res->message, "OK"); + +$_ = $res->content; +@accept = /^Accept:\s*(.*)/mg; + +ok($_, qr/^From:\s*gisle\@aas\.no\n/m); +ok($_, qr/^Host:/m); +ok(@accept, 3); +ok($_, qr/^Accept:\s*text\/html/m); +ok($_, qr/^Accept:\s*text\/plain/m); +ok($_, qr/^Accept:\s*image\/\*/m); +ok($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m); +ok($_, qr/^Long-Text:\s*This.*broken between/m); +ok($_, qr/^Foo-Bar:\s*1\n/m); +ok($_, qr/^X-Foo:\s*Bar\n/m); +ok($_, qr/^User-Agent:\s*Mozilla\/0.01/m); + +# Try it with the higher level 'get' interface +$res = $ua->get(url("/echo/path_info?query", $base), + Accept => 'text/html', + Accept => 'text/plain; q=0.9', + Accept => 'image/*', + X_Foo => "Bar", +); +#$res->dump; +ok($res->code, 200); +ok($res->content, qr/^From: gisle\@aas.no$/m); + +#---------------------------------------------------------------- +print "Send file...\n"; + +my $file = "test-$$.html"; +open(FILE, ">$file") or die "Can't create $file: $!"; +binmode FILE or die "Can't binmode $file: $!"; +print FILE <En prøve +

Dette er en testfil

+Jeg vet ikke hvor stor fila behøver å være heller, men dette +er sikkert nok i massevis. +EOT +close(FILE); + +sub httpd_get_file +{ + my($c, $r) = @_; + my %form = $r->uri->query_form; + my $file = $form{'name'}; + $c->send_file_response($file); + unlink($file) if $file =~ /^test-/; +} + +$req = new HTTP::Request GET => url("/file?name=$file", $base); +$res = $ua->request($req); +#print $res->as_string; + +ok($res->is_success); +ok($res->content_type, 'text/html'); +ok($res->content_length, 147); +ok($res->title, 'En prøve'); +ok($res->content, qr/å være/); + +# A second try on the same file, should fail because we unlink it +$res = $ua->request($req); +#print $res->as_string; +ok($res->is_error); +ok($res->code, 404); # not found + +# Then try to list current directory +$req = new HTTP::Request GET => url("/file?name=.", $base); +$res = $ua->request($req); +#print $res->as_string; +ok($res->code, 501); # NYI + + +#---------------------------------------------------------------- +print "Check redirect...\n"; +sub httpd_get_redirect +{ + my($c) = @_; + $c->send_redirect("/echo/redirect"); +} + +$req = new HTTP::Request GET => url("/redirect/foo", $base); +$res = $ua->request($req); +#print $res->as_string; + +ok($res->is_success); +ok($res->content, qr|/echo/redirect|); +ok($res->previous->is_redirect); +ok($res->previous->code, 301); + +# Let's test a redirect loop too +sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") } +sub httpd_get_redirect3 { shift->send_redirect("/redirect2/") } + +$req->uri(url("/redirect2", $base)); +$ua->max_redirect(5); +$res = $ua->request($req); +#print $res->as_string; +ok($res->is_redirect); +ok($res->header("Client-Warning"), qr/loop detected/i); +ok($res->redirects, 5); + +$ua->max_redirect(0); +$res = $ua->request($req); +ok($res->previous, undef); +ok($res->redirects, 0); +$ua->max_redirect(5); + +#---------------------------------------------------------------- +print "Check basic authorization...\n"; +sub httpd_get_basic +{ + my($c, $r) = @_; + #print STDERR $r->as_string; + my($u,$p) = $r->authorization_basic; + if (defined($u) && $u eq 'ok 12' && $p eq 'xyzzy') { + $c->send_basic_header(200); + print $c "Content-Type: text/plain"; + $c->send_crlf; + $c->send_crlf; + $c->print("$u\n"); + } + else { + $c->send_basic_header(401); + $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012"); + $c->send_crlf; + } +} + +{ + package MyUA; @ISA=qw(LWP::UserAgent); + sub get_basic_credentials { + my($self, $realm, $uri, $proxy) = @_; + if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") { + return ("ok 12", "xyzzy"); + } + else { + return undef; + } + } +} +$req = new HTTP::Request GET => url("/basic", $base); +$res = MyUA->new->request($req); +#print $res->as_string; + +ok($res->is_success); +#print $res->content; + +# Let's try with a $ua that does not pass out credentials +$res = $ua->request($req); +ok($res->code, 401); + +# Let's try to set credentials for this realm +$ua->credentials($req->uri->host_port, "libwww-perl", "ok 12", "xyzzy"); +$res = $ua->request($req); +ok($res->is_success); + +# Then illegal credentials +$ua->credentials($req->uri->host_port, "libwww-perl", "user", "passwd"); +$res = $ua->request($req); +ok($res->code, 401); + + +#---------------------------------------------------------------- +print "Check proxy...\n"; +sub httpd_get_proxy +{ + my($c,$r) = @_; + if ($r->method eq "GET" and + $r->uri->scheme eq "ftp") { + $c->send_basic_header(200); + $c->send_crlf; + } + else { + $c->send_error; + } +} + +$ua->proxy(ftp => $base); +$req = new HTTP::Request GET => "ftp://ftp.perl.com/proxy"; +$res = $ua->request($req); +#print $res->as_string; +ok($res->is_success); + +#---------------------------------------------------------------- +print "Check POSTing...\n"; +sub httpd_post_echo +{ + my($c,$r) = @_; + $c->send_basic_header; + $c->print("Content-Type: text/plain"); + $c->send_crlf; + $c->send_crlf; + + # Do it the hard way to test the send_file + open(TMP, ">tmp$$") || die; + binmode(TMP); + print TMP $r->as_string; + close(TMP) || die; + + $c->send_file("tmp$$"); + + unlink("tmp$$"); +} + +$req = new HTTP::Request POST => url("/echo/foo", $base); +$req->content_type("application/x-www-form-urlencoded"); +$req->content("foo=bar&bar=test"); +$res = $ua->request($req); +#print $res->as_string; + +$_ = $res->content; +ok($res->is_success); +ok($_, qr/^Content-Length:\s*16$/mi); +ok($_, qr/^Content-Type:\s*application\/x-www-form-urlencoded$/mi); +ok($_, qr/^foo=bar&bar=test$/m); + +$req = HTTP::Request->new(POST => url("/echo/foo", $base)); +$req->content_type("multipart/form-data"); +$req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "Hi\n")); +$req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "there\n")); +$res = $ua->request($req); +#print $res->as_string; +ok($res->is_success); +ok($res->content =~ /^Content-Type: multipart\/form-data; boundary=/m); + +#---------------------------------------------------------------- +print "Check partial content response...\n"; +sub httpd_get_partial +{ + my($c) = @_; + $c->send_basic_header(206); + print $c "Content-Type: image/jpeg\015\012"; + $c->send_crlf; + print $c "some fake JPEG content"; + +} + +{ + $req = HTTP::Request->new( GET => url("/partial", $base) ); + $res = $ua->request($req); + ok($res->is_success); # "a 206 response is considered successful" +} +{ + $ua->max_size(3); + $req = HTTP::Request->new( GET => url("/partial", $base) ); + $res = $ua->request($req); + ok($res->is_success); # "a 206 response is considered successful" + # Put max_size back how we found it. + $ua->max_size(undef); + ok($res->as_string, qr/Client-Aborted: max_size/); # Client-Aborted is returned when max_size is given +} + + +#---------------------------------------------------------------- +print "Terminating server...\n"; +sub httpd_get_quit +{ + my($c) = @_; + $c->send_error(503, "Bye, bye"); + exit; # terminate HTTP server +} + +$req = new HTTP::Request GET => url("/quit", $base); +$res = $ua->request($req); + +ok($res->code, 503); +ok($res->content, qr/Bye, bye/); diff --git a/t/misc/httpd b/t/misc/httpd new file mode 100755 index 0000000..f17a2bf --- /dev/null +++ b/t/misc/httpd @@ -0,0 +1,31 @@ +#!/local/perl/bin/perl -w + +use HTTP::Daemon (); + +my $s = new HTTP::Daemon; +die "Can't create daemon: $!" unless $s; + +print $s->url, "\n"; + +my $c = $s->accept; +die "Can't accept" unless $c; + +$c->timeout(60); +my $req = $c->get_request; + +die "No request" unless $req; + +my $abs = $req->uri->abs; + +print $req->as_string; + +$c->send_file_response("/etc"); + +#$c->send_redirect("http://www.sn.no/aas", 301, "Piss off"); + +#my $res = HTTP::Response->new(400, undef, +# HTTP::Headers->new(Foo => 'bar'), +# "Gisle\n" +# ); +#$c->send_response($res); + diff --git a/t/misc/httpd_term.pl b/t/misc/httpd_term.pl new file mode 100755 index 0000000..ce38c22 --- /dev/null +++ b/t/misc/httpd_term.pl @@ -0,0 +1,25 @@ +#!/local/perl/bin/perl + +use HTTP::Daemon; +#$HTTP::Daemon::DEBUG++; + +my $d = HTTP::Daemon->new(Timeout => 60); +print "Please contact me at: url, ">\n"; + +while (my $c = $d->accept) { + CONNECTION: + while (my $r = $c->get_request) { + print $r->as_string; + $c->autoflush; + RESPONSE: + while () { + last RESPONSE if $_ eq ".\n"; + last CONNECTION if $_ eq "..\n"; + print $c $_; + } + print "\nEOF\n"; + } + print "CLOSE: ", $c->reason, "\n"; + $c->close; + $c = undef; +} diff --git a/t/robot/ua-get.t b/t/robot/ua-get.t new file mode 100644 index 0000000..5c18afa --- /dev/null +++ b/t/robot/ua-get.t @@ -0,0 +1,156 @@ +if($^O eq "MacOS") { + print "1..0\n"; + exit(0); +} + +unless (-f "CAN_TALK_TO_OURSELF") { + print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n"; + exit; +} + +$| = 1; # autoflush +require IO::Socket; # make sure this work before we try to make a HTTP::Daemon + +# First we make ourself a daemon in another process +my $D = shift || ''; +if ($D eq 'daemon') { + + require HTTP::Daemon; + + my $d = new HTTP::Daemon Timeout => 10; + + print "Please to meet you at: url, ">\n"; + open(STDOUT, $^O eq 'MSWin32' ? ">nul" : $^O eq 'VMS' ? ">NL:" : ">/dev/null"); + + while ($c = $d->accept) { + $r = $c->get_request; + if ($r) { + my $p = ($r->uri->path_segments)[1]; + $p =~ s/\W//g; + my $func = lc("httpd_" . $r->method . "_$p"); + #print STDERR "Calling $func...\n"; + if (defined &$func) { + &$func($c, $r); + } + else { + $c->send_error(404); + } + } + $c = undef; # close connection + } + print STDERR "HTTP Server terminated\n"; + exit; +} +else { + use Config; + my $perl = $Config{'perlpath'}; + $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i; + open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!"; +} + +print "1..8\n"; + + +$greating = ; +$greating =~ /(<[^>]+>)/; + +require URI; +my $base = URI->new($1); +sub url { + my $u = URI->new(@_); + $u = $u->abs($_[1]) if @_ > 1; + $u->as_string; +} + +print "Will access HTTP server at $base\n"; + +require LWP::RobotUA; +require HTTP::Request; +$ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no'; +$ua->delay(0.05); # rather quick robot + +#---------------------------------------------------------------- +sub httpd_get_robotstxt +{ + my($c,$r) = @_; + $c->send_basic_header; + $c->print("Content-Type: text/plain"); + $c->send_crlf; + $c->send_crlf; + $c->print("User-Agent: * +Disallow: /private + +"); +} + +sub httpd_get_someplace +{ + my($c,$r) = @_; + $c->send_basic_header; + $c->print("Content-Type: text/plain"); + $c->send_crlf; + $c->send_crlf; + $c->print("Okidok\n"); +} + +$res = $ua->get( url("/someplace", $base) ); +#print $res->as_string; +print "not " unless $res->is_success; +print "ok 1\n"; + +$res = $ua->get( url("/private/place", $base) ); +#print $res->as_string; +print "not " unless $res->code == 403 + and $res->message =~ /robots.txt/; +print "ok 2\n"; + + +$res = $ua->get( url("/foo", $base) ); +#print $res->as_string; +print "not " unless $res->code == 404; # not found +print "ok 3\n"; + +# Let the robotua generate "Service unavailable/Retry After response"; +$ua->delay(1); +$ua->use_sleep(0); + +$res = $ua->get( url("/foo", $base) ); +#print $res->as_string; +print "not " unless $res->code == 503 # Unavailable + and $res->header("Retry-After"); +print "ok 4\n"; + +#---------------------------------------------------------------- +print "Terminating server...\n"; +sub httpd_get_quit +{ + my($c) = @_; + $c->send_error(503, "Bye, bye"); + exit; # terminate HTTP server +} + +$ua->delay(0); + +$res = $ua->get( url("/quit", $base) ); + +print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/; +print "ok 5\n"; + +#--------------------------------------------------------------- +$ua->delay(1); + +# host_wait() should be around 60s now +print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5; +print "ok 6\n"; + +# Number of visits to this place should be +print "not " unless $ua->no_visits($base->host_port) == 4; +print "ok 7\n"; + +# RobotUA used to have problem with mailto URLs. +$ENV{SENDMAIL} = "dummy"; +$res = $ua->get("mailto:gisle\@aas.no"); +#print $res->as_string; + +print "not " unless $res->code == 400 && $res->message eq "Library does not allow method GET for 'mailto:' URLs"; +print "ok 8\n"; diff --git a/t/robot/ua.t b/t/robot/ua.t new file mode 100644 index 0000000..5f679ae --- /dev/null +++ b/t/robot/ua.t @@ -0,0 +1,151 @@ +if($^O eq "MacOS") { + print "1..0\n"; + exit(0); +} + +unless (-f "CAN_TALK_TO_OURSELF") { + print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n"; + exit; +} + +$| = 1; # autoflush +require IO::Socket; # make sure this work before we try to make a HTTP::Daemon + +# First we make ourself a daemon in another process +my $D = shift || ''; +if ($D eq 'daemon') { + + require HTTP::Daemon; + + my $d = new HTTP::Daemon Timeout => 10; + + print "Please to meet you at: url, ">\n"; + open(STDOUT, $^O eq 'MSWin32' ? ">nul" : $^O eq 'VMS' ? ">NL:" : ">/dev/null"); + + while ($c = $d->accept) { + $r = $c->get_request; + if ($r) { + my $p = ($r->uri->path_segments)[1]; + $p =~ s/\W//g; + my $func = lc("httpd_" . $r->method . "_$p"); + #print STDERR "Calling $func...\n"; + if (defined &$func) { + &$func($c, $r); + } + else { + $c->send_error(404); + } + } + $c = undef; # close connection + } + print STDERR "HTTP Server terminated\n"; + exit; +} +else { + use Config; + my $perl = $Config{'perlpath'}; + $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i; + open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!"; +} + +print "1..7\n"; + + +$greating = ; +$greating =~ /(<[^>]+>)/; + +require URI; +my $base = URI->new($1); +sub url { + my $u = URI->new(@_); + $u = $u->abs($_[1]) if @_ > 1; + $u->as_string; +} + +print "Will access HTTP server at $base\n"; + +require LWP::RobotUA; +require HTTP::Request; +$ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no'; +$ua->delay(0.05); # rather quick robot + +#---------------------------------------------------------------- +sub httpd_get_robotstxt +{ + my($c,$r) = @_; + $c->send_basic_header; + $c->print("Content-Type: text/plain"); + $c->send_crlf; + $c->send_crlf; + $c->print("User-Agent: * +Disallow: /private + +"); +} + +sub httpd_get_someplace +{ + my($c,$r) = @_; + $c->send_basic_header; + $c->print("Content-Type: text/plain"); + $c->send_crlf; + $c->send_crlf; + $c->print("Okidok\n"); +} + +$req = new HTTP::Request GET => url("/someplace", $base); +$res = $ua->request($req); +#print $res->as_string; +print "not " unless $res->is_success; +print "ok 1\n"; + +$req = new HTTP::Request GET => url("/private/place", $base); +$res = $ua->request($req); +#print $res->as_string; +print "not " unless $res->code == 403 + and $res->message =~ /robots.txt/; +print "ok 2\n"; + +$req = new HTTP::Request GET => url("/foo", $base); +$res = $ua->request($req); +#print $res->as_string; +print "not " unless $res->code == 404; # not found +print "ok 3\n"; + +# Let the robotua generate "Service unavailable/Retry After response"; +$ua->delay(1); +$ua->use_sleep(0); +$req = new HTTP::Request GET => url("/foo", $base); +$res = $ua->request($req); +#print $res->as_string; +print "not " unless $res->code == 503 # Unavailable + and $res->header("Retry-After"); +print "ok 4\n"; + +#---------------------------------------------------------------- +print "Terminating server...\n"; +sub httpd_get_quit +{ + my($c) = @_; + $c->send_error(503, "Bye, bye"); + exit; # terminate HTTP server +} + +$ua->delay(0); +$req = new HTTP::Request GET => url("/quit", $base); +$res = $ua->request($req); + +print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/; +print "ok 5\n"; + +#--------------------------------------------------------------- +$ua->delay(1); + +# host_wait() should be around 60s now +print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5; +print "ok 6\n"; + +# Number of visits to this place should be +print "not " unless $ua->no_visits($base->host_port) == 4; +print "ok 7\n"; +