4 use vars qw($VERSION @ISA $PROTO $DEBUG);
8 use IO::Socket qw(AF_INET INADDR_ANY 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();
48 $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
50 my $port = $self->sockport;
51 $url .= ":$port" if $port != $self->_default_port;
69 "libwww-perl-daemon/$HTTP::Daemon::VERSION";
74 package HTTP::Daemon::ClientConn;
76 use vars qw(@ISA $DEBUG);
78 @ISA=qw(IO::Socket::INET);
79 *DEBUG = \$HTTP::Daemon::DEBUG;
82 use HTTP::Response ();
84 use HTTP::Date qw(time2str);
85 use LWP::MediaTypes qw(guess_media_type);
88 my $CRLF = "\015\012"; # "\r\n" is not portable
89 my $HTTP_1_0 = _http_version("HTTP/1.0");
90 my $HTTP_1_1 = _http_version("HTTP/1.1");
95 my($self, $only_headers) = @_;
96 if (${*$self}{'httpd_nomore'}) {
97 $self->reason("No more requests from this connection");
102 my $buf = ${*$self}{'httpd_rbuf'};
103 $buf = "" unless defined $buf;
105 my $timeout = $ {*$self}{'io_socket_timeout'};
107 vec($fdset, $self->fileno, 1) = 1;
112 # loop until we have the whole header in $buf
113 $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
114 if ($buf =~ /\012/) { # potential, has at least one line
115 if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
116 if ($buf =~ /\015?\012\015?\012/) {
117 last READ_HEADER; # we have it
119 elsif (length($buf) > 16*1024) {
120 $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
121 $self->reason("Very long header");
126 last READ_HEADER; # HTTP/0.9 client
129 elsif (length($buf) > 16*1024) {
130 $self->send_error(414); # REQUEST_URI_TOO_LARGE
131 $self->reason("Very long first line");
134 print STDERR "Need more data for complete header\n" if $DEBUG;
135 return unless $self->_need_more($buf, $timeout, $fdset);
137 if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
138 ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
139 $self->send_error(400); # BAD_REQUEST
140 $self->reason("Bad request line: $buf");
145 my $proto = $3 || "HTTP/0.9";
146 $uri = "http://$uri" if $method eq "CONNECT";
147 $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
148 my $r = HTTP::Request->new($method, $uri);
149 $r->protocol($proto);
150 ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
151 ${*$self}{'httpd_head'} = ($method eq "HEAD");
153 if ($proto >= $HTTP_1_0) {
154 # we expect to find some headers
157 while ($buf =~ s/^([^\012]*)\012//) {
160 if (/^([^:\s]+)\s*:\s*(.*)/) {
161 $r->push_header($key, $val) if $key;
162 ($key, $val) = ($1, $2);
171 $r->push_header($key, $val) if $key;
174 my $conn = $r->header('Connection');
175 if ($proto >= $HTTP_1_1) {
176 ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
179 ${*$self}{'httpd_nomore'}++ unless $conn &&
180 lc($conn) =~ /\bkeep-alive\b/;
184 ${*$self}{'httpd_rbuf'} = $buf;
188 # Find out how much content to read
189 my $te = $r->header('Transfer-Encoding');
190 my $ct = $r->header('Content-Type');
191 my $len = $r->header('Content-Length');
193 # Act on the Expect header, if it's there
194 for my $e ( $r->header('Expect') ) {
195 if( lc($e) eq '100-continue' ) {
196 $self->send_status_line(100);
199 $self->send_error(417);
200 $self->reason("Unsupported Expect header value");
205 if ($te && lc($te) eq 'chunked') {
206 # Handle chunked transfer encoding
210 print STDERR "Chunked\n" if $DEBUG;
211 if ($buf =~ s/^([^\012]*)\012//) {
213 unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
214 $self->send_error(400);
215 $self->reason("Bad chunk header $chunk_head");
219 last CHUNK if $size == 0;
221 my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
222 # must read until we have a complete chunk
223 while ($missing > 0) {
224 print STDERR "Need $missing more bytes\n" if $DEBUG;
225 my $n = $self->_need_more($buf, $timeout, $fdset);
229 $body .= substr($buf, 0, $size);
230 substr($buf, 0, $size+2) = '';
234 # need more data in order to have a complete chunk header
235 return unless $self->_need_more($buf, $timeout, $fdset);
240 # pretend it was a normal entity body
241 $r->remove_header('Transfer-Encoding');
242 $r->header('Content-Length', length($body));
247 if ($buf !~ /\012/) {
248 # need at least one line to look at
249 return unless $self->_need_more($buf, $timeout, $fdset);
252 $buf =~ s/^([^\012]*)\012//;
255 if (/^([\w\-]+)\s*:\s*(.*)/) {
256 $r->push_header($key, $val) if $key;
257 ($key, $val) = ($1, $2);
266 $self->reason("Bad footer syntax");
271 $r->push_header($key, $val) if $key;
275 $self->send_error(501); # Unknown transfer encoding
276 $self->reason("Unknown transfer encoding '$te'");
280 elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
281 # Handle multipart content type
282 my $boundary = "$CRLF--$1--$CRLF";
285 $index = index($buf, $boundary);
287 # end marker not yet found
288 return unless $self->_need_more($buf, $timeout, $fdset);
290 $index += length($boundary);
291 $r->content(substr($buf, 0, $index));
292 substr($buf, 0, $index) = '';
296 # Plain body specified by "Content-Length"
297 my $missing = $len - length($buf);
298 while ($missing > 0) {
299 print "Need $missing more bytes of content\n" if $DEBUG;
300 my $n = $self->_need_more($buf, $timeout, $fdset);
304 if (length($buf) > $len) {
305 $r->content(substr($buf,0,$len));
306 substr($buf, 0, $len) = '';
313 ${*$self}{'httpd_rbuf'} = $buf;
322 #my($buf,$timeout,$fdset) = @_;
324 my($timeout, $fdset) = @_[1,2];
325 print STDERR "select(,,,$timeout)\n" if $DEBUG;
326 my $n = select($fdset,undef,undef,$timeout);
328 $self->reason(defined($n) ? "Timeout" : "select: $!");
332 print STDERR "sysread()\n" if $DEBUG;
333 my $n = sysread($self, $_[0], 2048, length($_[0]));
334 $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
342 my $old = ${*$self}{'httpd_rbuf'};
344 ${*$self}{'httpd_rbuf'} = shift;
353 my $old = ${*$self}{'httpd_reason'};
355 ${*$self}{'httpd_reason'} = shift;
364 ${*$self}{'httpd_client_proto'} >= _http_version(shift);
371 return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
379 ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
383 sub force_last_request
386 ${*$self}{'httpd_nomore'}++;
392 ${*$self}{'httpd_head'};
398 my($self, $status, $message, $proto) = @_;
399 return if $self->antique_client;
401 $message ||= status_message($status) || "";
402 $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
403 print $self "$proto $status $message$CRLF";
414 sub send_basic_header
417 return if $self->antique_client;
418 $self->send_status_line(@_);
419 print $self "Date: ", time2str(time), $CRLF;
420 my $product = $self->daemon->product_tokens;
421 print $self "Server: $product$CRLF" if $product;
431 $res = HTTP::Response->new($res, @_);
433 my $content = $res->content;
435 unless ($self->antique_client) {
436 my $code = $res->code;
437 $self->send_basic_header($code, $res->message, $res->protocol);
438 if ($code =~ /^(1\d\d|[23]04)$/) {
439 # make sure content is empty
440 $res->remove_header("Content-Length");
443 elsif ($res->request && $res->request->method eq "HEAD") {
446 elsif (ref($content) eq "CODE") {
447 if ($self->proto_ge("HTTP/1.1")) {
448 $res->push_header("Transfer-Encoding" => "chunked");
452 $self->force_last_request;
455 elsif (length($content)) {
456 $res->header("Content-Length" => length($content));
459 $self->force_last_request;
460 $res->header('connection','close');
462 print $self $res->headers_as_string($CRLF);
463 print $self $CRLF; # separates headers and content
465 if ($self->head_request) {
468 elsif (ref($content) eq "CODE") {
470 my $chunk = &$content();
471 last unless defined($chunk) && length($chunk);
473 printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
479 print $self "0$CRLF$CRLF" if $chunked; # no trailers either
481 elsif (length $content) {
482 print $self $content;
489 my($self, $loc, $status, $content) = @_;
490 $status ||= RC_MOVED_PERMANENTLY;
491 Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
492 $self->send_basic_header($status);
493 my $base = $self->daemon->url;
494 $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
495 $loc = $loc->abs($base);
496 print $self "Location: $loc$CRLF";
498 my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
499 print $self "Content-Type: $ct$CRLF";
502 print $self $content if $content && !$self->head_request;
503 $self->force_last_request; # no use keeping the connection open
509 my($self, $status, $error) = @_;
510 $status ||= RC_BAD_REQUEST;
511 Carp::croak("Status '$status' is not an error") unless is_error($status);
512 my $mess = status_message($status);
515 <title>$status $mess</title>
516 <h1>$status $mess</h1>
519 unless ($self->antique_client) {
520 $self->send_basic_header($status);
521 print $self "Content-Type: text/html$CRLF";
522 print $self "Content-Length: " . length($mess) . $CRLF;
525 print $self $mess unless $self->head_request;
530 sub send_file_response
532 my($self, $file) = @_;
534 $self->send_dir($file);
539 sysopen(F, $file, 0) or
540 return $self->send_error(RC_FORBIDDEN);
542 my($ct,$ce) = guess_media_type($file);
543 my($size,$mtime) = (stat _)[7,9];
544 unless ($self->antique_client) {
545 $self->send_basic_header;
546 print $self "Content-Type: $ct$CRLF";
547 print $self "Content-Encoding: $ce$CRLF" if $ce;
548 print $self "Content-Length: $size$CRLF" if $size;
549 print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
552 $self->send_file(\*F) unless $self->head_request;
556 $self->send_error(RC_NOT_FOUND);
563 my($self, $dir) = @_;
564 $self->send_error(RC_NOT_FOUND) unless -d $dir;
565 $self->send_error(RC_NOT_IMPLEMENTED);
571 my($self, $file) = @_;
575 open(FILE, $file) || return undef;
583 while ($n = sysread($file, $buf, 8*1024)) {
588 close($file) if $opened;
596 ${*$self}{'httpd_daemon'};
606 HTTP::Daemon - a simple http server class
613 my $d = HTTP::Daemon->new || die;
614 print "Please contact me at: <URL:", $d->url, ">\n";
615 while (my $c = $d->accept) {
616 while (my $r = $c->get_request) {
617 if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
618 # remember, this is *not* recommended practice :-)
619 $c->send_file_response("/etc/passwd");
622 $c->send_error(RC_FORBIDDEN)
631 Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
632 listen on a socket for incoming requests. The C<HTTP::Daemon> is a
633 subclass of C<IO::Socket::INET>, so you can perform socket operations
636 The accept() method will return when a connection from a client is
637 available. The returned value will be an C<HTTP::Daemon::ClientConn>
638 object which is another C<IO::Socket::INET> subclass. Calling the
639 get_request() method on this object will read data from the client and
640 return an C<HTTP::Request> object. The ClientConn object also provide
641 methods to send back various responses.
643 This HTTP daemon does not fork(2) for you. Your application, i.e. the
644 user of the C<HTTP::Daemon> is responsible for forking if that is
645 desirable. Also note that the user is responsible for generating
646 responses that conform to the HTTP/1.1 protocol.
648 The following methods of C<HTTP::Daemon> are new (or enhanced) relative
649 to the C<IO::Socket::INET> base class:
653 =item $d = HTTP::Daemon->new
655 =item $d = HTTP::Daemon->new( %opts )
657 The constructor method takes the same arguments as the
658 C<IO::Socket::INET> constructor, but unlike its base class it can also
659 be called without any arguments. The daemon will then set up a listen
660 queue of 5 connections and allocate some random port number.
662 A server that wants to bind to some specific address on the standard
663 HTTP port will be constructed like this:
665 $d = HTTP::Daemon->new(
666 LocalAddr => 'www.thisplace.com',
670 See L<IO::Socket::INET> for a description of other arguments that can
671 be used configure the daemon during construction.
673 =item $c = $d->accept
675 =item $c = $d->accept( $pkg )
677 =item ($c, $peer_addr) = $d->accept
679 This method works the same the one provided by the base class, but it
680 returns an C<HTTP::Daemon::ClientConn> reference by default. If a
681 package name is provided as argument, then the returned object will be
682 blessed into the given class. It is probably a good idea to make that
683 class a subclass of C<HTTP::Daemon::ClientConn>.
685 The accept method will return C<undef> if timeouts have been enabled
686 and no connection is made within the given time. The timeout() method
687 is described in L<IO::Socket>.
689 In list context both the client object and the peer address will be
690 returned; see the description of the accept method L<IO::Socket> for
695 Returns a URL string that can be used to access the server root.
697 =item $d->product_tokens
699 Returns the name that this server will use to identify itself. This
700 is the string that is sent with the C<Server> response header. The
701 main reason to have this method is that subclasses can override it if
702 they want to use another product name.
704 The default is the string "libwww-perl-daemon/#.##" where "#.##" is
705 replaced with the version number of this module.
709 The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
710 subclass. Instances of this class are returned by the accept() method
711 of C<HTTP::Daemon>. The following methods are provided:
715 =item $c->get_request
717 =item $c->get_request( $headers_only )
719 This method read data from the client and turns it into an
720 C<HTTP::Request> object which is returned. It returns C<undef>
721 if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
722 object ($c) should be discarded, and you should not try call this
723 method again on it. The $c->reason method might give you some
724 information about why $c->get_request failed.
726 The get_request() method will normally not return until the whole
727 request has been received from the client. This might not be what you
728 want if the request is an upload of a large file (and with chunked
729 transfer encoding HTTP can even support infinite request messages -
730 uploading live audio for instance). If you pass a TRUE value as the
731 $headers_only argument, then get_request() will return immediately
732 after parsing the request headers and you are responsible for reading
733 the rest of the request content. If you are going to call
734 $c->get_request again on the same connection you better read the
735 correct number of bytes.
737 =item $c->read_buffer
739 =item $c->read_buffer( $new_value )
741 Bytes read by $c->get_request, but not used are placed in the I<read
742 buffer>. The next time $c->get_request is called it will consume the
743 bytes in this buffer before reading more data from the network
744 connection itself. The read buffer is invalid after $c->get_request
747 If you handle the reading of the request content yourself you need to
748 empty this buffer before you read more and you need to place
749 unconsumed bytes here. You also need this buffer if you implement
750 services like I<101 Switching Protocols>.
752 This method always return the old buffer content and can optionally
753 replace the buffer content if you pass it an argument.
757 When $c->get_request returns C<undef> you can obtain a short string
758 describing why it happened by calling $c->reason.
760 =item $c->proto_ge( $proto )
762 Return TRUE if the client announced a protocol with version number
763 greater or equal to the given argument. The $proto argument can be a
764 string like "HTTP/1.1" or just "1.1".
766 =item $c->antique_client
768 Return TRUE if the client speaks the HTTP/0.9 protocol. No status
769 code and no headers should be returned to such a client. This should
770 be the same as !$c->proto_ge("HTTP/1.0").
772 =item $c->head_request
774 Return TRUE if the last request was a C<HEAD> request. No content
775 body must be generated for these requests.
777 =item $c->force_last_request
779 Make sure that $c->get_request will not try to read more requests off
780 this connection. If you generate a response that is not self
781 delimiting, then you should signal this fact by calling this method.
783 This attribute is turned on automatically if the client announces
784 protocol HTTP/1.0 or worse and does not include a "Connection:
785 Keep-Alive" header. It is also turned on automatically when HTTP/1.1
786 or better clients send the "Connection: close" request header.
788 =item $c->send_status_line
790 =item $c->send_status_line( $code )
792 =item $c->send_status_line( $code, $mess )
794 =item $c->send_status_line( $code, $mess, $proto )
796 Send the status line back to the client. If $code is omitted 200 is
797 assumed. If $mess is omitted, then a message corresponding to $code
798 is inserted. If $proto is missing the content of the
799 $HTTP::Daemon::PROTO variable is used.
803 Send the CRLF sequence to the client.
805 =item $c->send_basic_header
807 =item $c->send_basic_header( $code )
809 =item $c->send_basic_header( $code, $mess )
811 =item $c->send_basic_header( $code, $mess, $proto )
813 Send the status line and the "Date:" and "Server:" headers back to
814 the client. This header is assumed to be continued and does not end
815 with an empty CRLF line.
817 See the description of send_status_line() for the description of the
820 =item $c->send_response( $res )
822 Write a C<HTTP::Response> object to the
823 client as a response. We try hard to make sure that the response is
824 self delimiting so that the connection can stay persistent for further
825 request/response exchanges.
827 The content attribute of the C<HTTP::Response> object can be a normal
828 string or a subroutine reference. If it is a subroutine, then
829 whatever this callback routine returns is written back to the
830 client as the response content. The routine will be called until it
831 return an undefined or empty value. If the client is HTTP/1.1 aware
832 then we will use chunked transfer encoding for the response.
834 =item $c->send_redirect( $loc )
836 =item $c->send_redirect( $loc, $code )
838 =item $c->send_redirect( $loc, $code, $entity_body )
840 Send a redirect response back to the client. The location ($loc) can
841 be an absolute or relative URL. The $code must be one the redirect
842 status codes, and defaults to "301 Moved Permanently"
846 =item $c->send_error( $code )
848 =item $c->send_error( $code, $error_message )
850 Send an error response back to the client. If the $code is missing a
851 "Bad Request" error is reported. The $error_message is a string that
852 is incorporated in the body of the HTML entity body.
854 =item $c->send_file_response( $filename )
856 Send back a response with the specified $filename as content. If the
857 file is a directory we try to generate an HTML index of it.
859 =item $c->send_file( $filename )
861 =item $c->send_file( $fd )
863 Copy the file to the client. The file can be a string (which
864 will be interpreted as a filename) or a reference to an C<IO::Handle>
869 Return a reference to the corresponding C<HTTP::Daemon> object.
877 L<IO::Socket::INET>, L<IO::Socket>
881 Copyright 1996-2003, Gisle Aas
883 This library is free software; you can redistribute it and/or
884 modify it under the same terms as Perl itself.