]>
git.proxmox.com Git - libhttp-daemon-perl.git/blob - lib/HTTP/Daemon.pm
4 use vars
qw($VERSION @ISA $PROTO $DEBUG);
8 use IO
::Socket
qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa);
9 @ISA=qw(IO::Socket::INET);
16 my($class, %args) = @_;
18 $args{Proto
} ||= 'tcp';
19 return $class->SUPER::new
(%args);
26 my $pkg = shift || "HTTP::Daemon::ClientConn";
27 my ($sock, $peer) = $self->SUPER::accept($pkg);
29 ${*$sock}{'httpd_daemon'} = $self;
30 return wantarray ?
($sock, $peer) : $sock;
41 my $url = $self->_default_scheme . "://";
42 my $addr = $self->sockaddr;
43 if (!$addr || $addr eq INADDR_ANY
) {
44 require Sys
::Hostname
;
45 $url .= lc Sys
::Hostname
::hostname
();
47 elsif ($addr eq INADDR_LOOPBACK
) {
48 $url .= inet_ntoa
($addr);
51 $url .= gethostbyaddr($addr, AF_INET
) || inet_ntoa
($addr);
53 my $port = $self->sockport;
54 $url .= ":$port" if $port != $self->_default_port;
72 "libwww-perl-daemon/$HTTP::Daemon::VERSION";
77 package HTTP
::Daemon
::ClientConn
;
79 use vars
qw(@ISA $DEBUG);
81 @ISA=qw(IO::Socket::INET);
82 *DEBUG
= \
$HTTP::Daemon
::DEBUG
;
85 use HTTP
::Response
();
87 use HTTP
::Date
qw(time2str);
88 use LWP
::MediaTypes
qw(guess_media_type);
91 my $CRLF = "\015\012"; # "\r\n" is not portable
92 my $HTTP_1_0 = _http_version
("HTTP/1.0");
93 my $HTTP_1_1 = _http_version
("HTTP/1.1");
98 my($self, $only_headers) = @_;
99 if (${*$self}{'httpd_nomore'}) {
100 $self->reason("No more requests from this connection");
105 my $buf = ${*$self}{'httpd_rbuf'};
106 $buf = "" unless defined $buf;
108 my $timeout = $ {*$self}{'io_socket_timeout'};
110 vec($fdset, $self->fileno, 1) = 1;
115 # loop until we have the whole header in $buf
116 $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
117 if ($buf =~ /\012/) { # potential, has at least one line
118 if ($buf =~ /^\w+[^\012]+HTTP\/\d
+\
.\d
+\015?
\012/) {
119 if ($buf =~ /\015?\012\015?\012/) {
120 last READ_HEADER
; # we have it
122 elsif (length($buf) > 16*1024) {
123 $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
124 $self->reason("Very long header");
129 last READ_HEADER
; # HTTP/0.9 client
132 elsif (length($buf) > 16*1024) {
133 $self->send_error(414); # REQUEST_URI_TOO_LARGE
134 $self->reason("Very long first line");
137 print STDERR
"Need more data for complete header\n" if $DEBUG;
138 return unless $self->_need_more($buf, $timeout, $fdset);
140 if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
141 ${*$self}{'httpd_client_proto'} = _http_version
("HTTP/1.0");
142 $self->send_error(400); # BAD_REQUEST
143 $self->reason("Bad request line: $buf");
148 my $proto = $3 || "HTTP/0.9";
149 $uri = "http://$uri" if $method eq "CONNECT";
150 $uri = $HTTP::URI_CLASS-
>new($uri, $self->daemon->url);
151 my $r = HTTP
::Request-
>new($method, $uri);
152 $r->protocol($proto);
153 ${*$self}{'httpd_client_proto'} = $proto = _http_version
($proto);
154 ${*$self}{'httpd_head'} = ($method eq "HEAD");
156 if ($proto >= $HTTP_1_0) {
157 # we expect to find some headers
160 while ($buf =~ s/^([^\012]*)\012//) {
163 if (/^([^:\s]+)\s*:\s*(.*)/) {
164 $r->push_header($key, $val) if $key;
165 ($key, $val) = ($1, $2);
174 $r->push_header($key, $val) if $key;
177 my $conn = $r->header('Connection');
178 if ($proto >= $HTTP_1_1) {
179 ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
182 ${*$self}{'httpd_nomore'}++ unless $conn &&
183 lc($conn) =~ /\bkeep-alive\b/;
187 ${*$self}{'httpd_rbuf'} = $buf;
191 # Find out how much content to read
192 my $te = $r->header('Transfer-Encoding');
193 my $ct = $r->header('Content-Type');
194 my $len = $r->header('Content-Length');
196 # Act on the Expect header, if it's there
197 for my $e ( $r->header('Expect') ) {
198 if( lc($e) eq '100-continue' ) {
199 $self->send_status_line(100);
203 $self->send_error(417);
204 $self->reason("Unsupported Expect header value");
209 if ($te && lc($te) eq 'chunked') {
210 # Handle chunked transfer encoding
214 print STDERR
"Chunked\n" if $DEBUG;
215 if ($buf =~ s/^([^\012]*)\012//) {
217 unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
218 $self->send_error(400);
219 $self->reason("Bad chunk header $chunk_head");
223 last CHUNK
if $size == 0;
225 my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
226 # must read until we have a complete chunk
227 while ($missing > 0) {
228 print STDERR
"Need $missing more bytes\n" if $DEBUG;
229 my $n = $self->_need_more($buf, $timeout, $fdset);
233 $body .= substr($buf, 0, $size);
234 substr($buf, 0, $size+2) = '';
238 # need more data in order to have a complete chunk header
239 return unless $self->_need_more($buf, $timeout, $fdset);
244 # pretend it was a normal entity body
245 $r->remove_header('Transfer-Encoding');
246 $r->header('Content-Length', length($body));
251 if ($buf !~ /\012/) {
252 # need at least one line to look at
253 return unless $self->_need_more($buf, $timeout, $fdset);
256 $buf =~ s/^([^\012]*)\012//;
259 if (/^([\w\-]+)\s*:\s*(.*)/) {
260 $r->push_header($key, $val) if $key;
261 ($key, $val) = ($1, $2);
270 $self->reason("Bad footer syntax");
275 $r->push_header($key, $val) if $key;
279 $self->send_error(501); # Unknown transfer encoding
280 $self->reason("Unknown transfer encoding '$te'");
285 # Plain body specified by "Content-Length"
286 my $missing = $len - length($buf);
287 while ($missing > 0) {
288 print "Need $missing more bytes of content\n" if $DEBUG;
289 my $n = $self->_need_more($buf, $timeout, $fdset);
293 if (length($buf) > $len) {
294 $r->content(substr($buf,0,$len));
295 substr($buf, 0, $len) = '';
302 elsif ($ct && $ct =~ m/^multipart\/\w
+\s
*;.*boundary\s
*=\s
*("?)(\w+)\1/i) {
303 # Handle multipart content type
304 my $boundary = "$CRLF--$2--";
307 $index = index($buf, $boundary);
309 # end marker not yet found
310 return unless $self->_need_more($buf, $timeout, $fdset);
312 $index += length($boundary);
313 $r->content(substr($buf, 0, $index));
314 substr($buf, 0, $index) = '';
317 ${*$self}{'httpd_rbuf'} = $buf;
326 #my($buf,$timeout,$fdset) = @_;
328 my($timeout, $fdset) = @_[1,2];
329 print STDERR "select(,,,$timeout)\n" if $DEBUG;
330 my $n = select($fdset,undef,undef,$timeout);
332 $self->reason(defined($n) ? "Timeout
" : "select: $!");
336 print STDERR "sysread()\n" if $DEBUG;
337 my $n = sysread($self, $_[0], 2048, length($_[0]));
338 $self->reason(defined($n) ? "Client closed
" : "sysread: $!") unless $n;
346 my $old = ${*$self}{'httpd_rbuf'};
348 ${*$self}{'httpd_rbuf'} = shift;
357 my $old = ${*$self}{'httpd_reason'};
359 ${*$self}{'httpd_reason'} = shift;
368 ${*$self}{'httpd_client_proto'} >= _http_version(shift);
375 return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
383 ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
387 sub force_last_request
390 ${*$self}{'httpd_nomore'}++;
396 ${*$self}{'httpd_head'};
402 my($self, $status, $message, $proto) = @_;
403 return if $self->antique_client;
405 $message ||= status_message($status) || "";
406 $proto ||= $HTTP::Daemon::PROTO || "HTTP
/1.1";
407 print $self "$proto $status $message$CRLF";
418 sub send_basic_header
421 return if $self->antique_client;
422 $self->send_status_line(@_);
423 print $self "Date
: ", time2str(time), $CRLF;
424 my $product = $self->daemon->product_tokens;
425 print $self "Server
: $product$CRLF" if $product;
433 my($k, $v) = splice(@_, 0, 2);
434 $v = "" unless defined($v);
435 print $self "$k: $v$CRLF";
446 $res = HTTP::Response->new($res, @_);
448 my $content = $res->content;
450 unless ($self->antique_client) {
451 my $code = $res->code;
452 $self->send_basic_header($code, $res->message, $res->protocol);
453 if ($code =~ /^(1\d\d|[23]04)$/) {
454 # make sure content is empty
455 $res->remove_header("Content-Length
");
458 elsif ($res->request && $res->request->method eq "HEAD
") {
461 elsif (ref($content) eq "CODE
") {
462 if ($self->proto_ge("HTTP
/1.1")) {
463 $res->push_header("Transfer-Encoding
" => "chunked
");
467 $self->force_last_request;
470 elsif (length($content)) {
471 $res->header("Content-Length
" => length($content));
474 $self->force_last_request;
475 $res->header('connection','close');
477 print $self $res->headers_as_string($CRLF);
478 print $self $CRLF; # separates headers and content
480 if ($self->head_request) {
483 elsif (ref($content) eq "CODE
") {
485 my $chunk = &$content();
486 last unless defined($chunk) && length($chunk);
488 printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
494 print $self "0$CRLF$CRLF" if $chunked; # no trailers either
496 elsif (length $content) {
497 print $self $content;
504 my($self, $loc, $status, $content) = @_;
505 $status ||= RC_MOVED_PERMANENTLY;
506 Carp::croak("Status
'$status' is not redirect
") unless is_redirect($status);
507 $self->send_basic_header($status);
508 my $base = $self->daemon->url;
509 $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
510 $loc = $loc->abs($base);
511 print $self "Location
: $loc$CRLF";
513 my $ct = $content =~ /^\s*</ ? "text
/html" : "text/plain
";
514 print $self "Content-Type
: $ct$CRLF";
517 print $self $content if $content && !$self->head_request;
518 $self->force_last_request; # no use keeping the connection open
524 my($self, $status, $error) = @_;
525 $status ||= RC_BAD_REQUEST;
526 Carp::croak("Status
'$status' is not an error
") unless is_error($status);
527 my $mess = status_message($status);
530 <title>$status $mess</title>
531 <h1>$status $mess</h1>
534 unless ($self->antique_client) {
535 $self->send_basic_header($status);
536 print $self "Content-Type: text/html$CRLF";
537 print $self "Content-Length: " . length($mess) . $CRLF;
540 print $self $mess unless $self->head_request;
545 sub send_file_response
547 my($self, $file) = @_;
549 $self->send_dir($file);
554 sysopen(F
, $file, 0) or
555 return $self->send_error(RC_FORBIDDEN
);
557 my($ct,$ce) = guess_media_type
($file);
558 my($size,$mtime) = (stat _
)[7,9];
559 unless ($self->antique_client) {
560 $self->send_basic_header;
561 print $self "Content-Type: $ct$CRLF";
562 print $self "Content-Encoding: $ce$CRLF" if $ce;
563 print $self "Content-Length: $size$CRLF" if $size;
564 print $self "Last-Modified: ", time2str
($mtime), "$CRLF" if $mtime;
567 $self->send_file(\
*F
) unless $self->head_request;
571 $self->send_error(RC_NOT_FOUND
);
578 my($self, $dir) = @_;
579 $self->send_error(RC_NOT_FOUND
) unless -d
$dir;
580 $self->send_error(RC_NOT_IMPLEMENTED
);
586 my($self, $file) = @_;
590 open(FILE
, $file) || return undef;
598 while ($n = sysread($file, $buf, 8*1024)) {
603 close($file) if $opened;
611 ${*$self}{'httpd_daemon'};
621 HTTP::Daemon - a simple http server class
628 my $d = HTTP::Daemon->new || die;
629 print "Please contact me at: <URL:", $d->url, ">\n";
630 while (my $c = $d->accept) {
631 while (my $r = $c->get_request) {
632 if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
633 # remember, this is *not* recommended practice :-)
634 $c->send_file_response("/etc/passwd");
637 $c->send_error(RC_FORBIDDEN)
646 Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
647 listen on a socket for incoming requests. The C<HTTP::Daemon> is a
648 subclass of C<IO::Socket::INET>, so you can perform socket operations
651 The accept() method will return when a connection from a client is
652 available. The returned value will be an C<HTTP::Daemon::ClientConn>
653 object which is another C<IO::Socket::INET> subclass. Calling the
654 get_request() method on this object will read data from the client and
655 return an C<HTTP::Request> object. The ClientConn object also provide
656 methods to send back various responses.
658 This HTTP daemon does not fork(2) for you. Your application, i.e. the
659 user of the C<HTTP::Daemon> is responsible for forking if that is
660 desirable. Also note that the user is responsible for generating
661 responses that conform to the HTTP/1.1 protocol.
663 The following methods of C<HTTP::Daemon> are new (or enhanced) relative
664 to the C<IO::Socket::INET> base class:
668 =item $d = HTTP::Daemon->new
670 =item $d = HTTP::Daemon->new( %opts )
672 The constructor method takes the same arguments as the
673 C<IO::Socket::INET> constructor, but unlike its base class it can also
674 be called without any arguments. The daemon will then set up a listen
675 queue of 5 connections and allocate some random port number.
677 A server that wants to bind to some specific address on the standard
678 HTTP port will be constructed like this:
680 $d = HTTP::Daemon->new(
681 LocalAddr => 'www.thisplace.com',
685 See L<IO::Socket::INET> for a description of other arguments that can
686 be used configure the daemon during construction.
688 =item $c = $d->accept
690 =item $c = $d->accept( $pkg )
692 =item ($c, $peer_addr) = $d->accept
694 This method works the same the one provided by the base class, but it
695 returns an C<HTTP::Daemon::ClientConn> reference by default. If a
696 package name is provided as argument, then the returned object will be
697 blessed into the given class. It is probably a good idea to make that
698 class a subclass of C<HTTP::Daemon::ClientConn>.
700 The accept method will return C<undef> if timeouts have been enabled
701 and no connection is made within the given time. The timeout() method
702 is described in L<IO::Socket>.
704 In list context both the client object and the peer address will be
705 returned; see the description of the accept method L<IO::Socket> for
710 Returns a URL string that can be used to access the server root.
712 =item $d->product_tokens
714 Returns the name that this server will use to identify itself. This
715 is the string that is sent with the C<Server> response header. The
716 main reason to have this method is that subclasses can override it if
717 they want to use another product name.
719 The default is the string "libwww-perl-daemon/#.##" where "#.##" is
720 replaced with the version number of this module.
724 The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
725 subclass. Instances of this class are returned by the accept() method
726 of C<HTTP::Daemon>. The following methods are provided:
730 =item $c->get_request
732 =item $c->get_request( $headers_only )
734 This method reads data from the client and turns it into an
735 C<HTTP::Request> object which is returned. It returns C<undef>
736 if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
737 object ($c) should be discarded, and you should not try call this
738 method again on it. The $c->reason method might give you some
739 information about why $c->get_request failed.
741 The get_request() method will normally not return until the whole
742 request has been received from the client. This might not be what you
743 want if the request is an upload of a large file (and with chunked
744 transfer encoding HTTP can even support infinite request messages -
745 uploading live audio for instance). If you pass a TRUE value as the
746 $headers_only argument, then get_request() will return immediately
747 after parsing the request headers and you are responsible for reading
748 the rest of the request content. If you are going to call
749 $c->get_request again on the same connection you better read the
750 correct number of bytes.
752 =item $c->read_buffer
754 =item $c->read_buffer( $new_value )
756 Bytes read by $c->get_request, but not used are placed in the I<read
757 buffer>. The next time $c->get_request is called it will consume the
758 bytes in this buffer before reading more data from the network
759 connection itself. The read buffer is invalid after $c->get_request
762 If you handle the reading of the request content yourself you need to
763 empty this buffer before you read more and you need to place
764 unconsumed bytes here. You also need this buffer if you implement
765 services like I<101 Switching Protocols>.
767 This method always returns the old buffer content and can optionally
768 replace the buffer content if you pass it an argument.
772 When $c->get_request returns C<undef> you can obtain a short string
773 describing why it happened by calling $c->reason.
775 =item $c->proto_ge( $proto )
777 Return TRUE if the client announced a protocol with version number
778 greater or equal to the given argument. The $proto argument can be a
779 string like "HTTP/1.1" or just "1.1".
781 =item $c->antique_client
783 Return TRUE if the client speaks the HTTP/0.9 protocol. No status
784 code and no headers should be returned to such a client. This should
785 be the same as !$c->proto_ge("HTTP/1.0").
787 =item $c->head_request
789 Return TRUE if the last request was a C<HEAD> request. No content
790 body must be generated for these requests.
792 =item $c->force_last_request
794 Make sure that $c->get_request will not try to read more requests off
795 this connection. If you generate a response that is not self
796 delimiting, then you should signal this fact by calling this method.
798 This attribute is turned on automatically if the client announces
799 protocol HTTP/1.0 or worse and does not include a "Connection:
800 Keep-Alive" header. It is also turned on automatically when HTTP/1.1
801 or better clients send the "Connection: close" request header.
803 =item $c->send_status_line
805 =item $c->send_status_line( $code )
807 =item $c->send_status_line( $code, $mess )
809 =item $c->send_status_line( $code, $mess, $proto )
811 Send the status line back to the client. If $code is omitted 200 is
812 assumed. If $mess is omitted, then a message corresponding to $code
813 is inserted. If $proto is missing the content of the
814 $HTTP::Daemon::PROTO variable is used.
818 Send the CRLF sequence to the client.
820 =item $c->send_basic_header
822 =item $c->send_basic_header( $code )
824 =item $c->send_basic_header( $code, $mess )
826 =item $c->send_basic_header( $code, $mess, $proto )
828 Send the status line and the "Date:" and "Server:" headers back to
829 the client. This header is assumed to be continued and does not end
830 with an empty CRLF line.
832 See the description of send_status_line() for the description of the
835 =item $c->send_header( $field, $value )
837 =item $c->send_header( $field1, $value1, $field2, $value2, ... )
839 Send one or more header lines.
841 =item $c->send_response( $res )
843 Write a C<HTTP::Response> object to the
844 client as a response. We try hard to make sure that the response is
845 self delimiting so that the connection can stay persistent for further
846 request/response exchanges.
848 The content attribute of the C<HTTP::Response> object can be a normal
849 string or a subroutine reference. If it is a subroutine, then
850 whatever this callback routine returns is written back to the
851 client as the response content. The routine will be called until it
852 return an undefined or empty value. If the client is HTTP/1.1 aware
853 then we will use chunked transfer encoding for the response.
855 =item $c->send_redirect( $loc )
857 =item $c->send_redirect( $loc, $code )
859 =item $c->send_redirect( $loc, $code, $entity_body )
861 Send a redirect response back to the client. The location ($loc) can
862 be an absolute or relative URL. The $code must be one the redirect
863 status codes, and defaults to "301 Moved Permanently"
867 =item $c->send_error( $code )
869 =item $c->send_error( $code, $error_message )
871 Send an error response back to the client. If the $code is missing a
872 "Bad Request" error is reported. The $error_message is a string that
873 is incorporated in the body of the HTML entity body.
875 =item $c->send_file_response( $filename )
877 Send back a response with the specified $filename as content. If the
878 file is a directory we try to generate an HTML index of it.
880 =item $c->send_file( $filename )
882 =item $c->send_file( $fd )
884 Copy the file to the client. The file can be a string (which
885 will be interpreted as a filename) or a reference to an C<IO::Handle>
890 Return a reference to the corresponding C<HTTP::Daemon> object.
898 L<IO::Socket::INET>, L<IO::Socket>
902 Copyright 1996-2003, Gisle Aas
904 This library is free software; you can redistribute it and/or
905 modify it under the same terms as Perl itself.