diff options
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm | 906 |
1 files changed, 906 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm new file mode 100644 index 00000000000..27a7bf4e173 --- /dev/null +++ b/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm @@ -0,0 +1,906 @@ +package HTTP::Daemon; + +use strict; +use vars qw($VERSION @ISA $PROTO $DEBUG); + +$VERSION = "6.01"; + +use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK 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(); + } + elsif ($addr eq INADDR_LOOPBACK) { + $url .= inet_ntoa($addr); + } + 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*</ ? "text/html" : "text/plain"; + print $self "Content-Type: $ct$CRLF"; + } + print $self $CRLF; + print $self $content if $content && !$self->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 = <<EOT; +<title>$status $mess</title> +<h1>$status $mess</h1> +$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:", $d->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<HTTP::Daemon> class are HTTP/1.1 servers that +listen on a socket for incoming requests. The C<HTTP::Daemon> is a +subclass of C<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 C<HTTP::Daemon::ClientConn> +object which is another C<IO::Socket::INET> subclass. Calling the +get_request() method on this object will read data from the client and +return an C<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 C<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 C<HTTP::Daemon> are new (or enhanced) relative +to the C<IO::Socket::INET> 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<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 L<IO::Socket::INET> 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<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 C<HTTP::Daemon::ClientConn>. + +The accept method will return C<undef> if timeouts have been enabled +and no connection is made within the given time. The timeout() method +is described in L<IO::Socket>. + +In list context both the client object and the peer address will be +returned; see the description of the accept method L<IO::Socket> 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<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. + +=back + +The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET> +subclass. Instances of this class are returned by the accept() method +of C<HTTP::Daemon>. 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<HTTP::Request> object which is returned. It returns C<undef> +if reading fails. If it fails, then the C<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. + +=item $c->read_buffer + +=item $c->read_buffer( $new_value ) + +Bytes read by $c->get_request, but not used are placed in the I<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 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<undef> 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<HEAD> 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<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 C<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. + +=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<IO::Handle> +or glob. + +=item $c->daemon + +Return a reference to the corresponding C<HTTP::Daemon> object. + +=back + +=head1 SEE ALSO + +RFC 2616 + +L<IO::Socket::INET>, L<IO::Socket> + +=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. + |