1 | package HTTP::Daemon;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use vars qw($VERSION @ISA $PROTO $DEBUG);
|
---|
5 |
|
---|
6 | $VERSION = "5.827";
|
---|
7 |
|
---|
8 | use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
|
---|
9 | @ISA=qw(IO::Socket::INET);
|
---|
10 |
|
---|
11 | $PROTO = "HTTP/1.1";
|
---|
12 |
|
---|
13 |
|
---|
14 | sub new
|
---|
15 | {
|
---|
16 | my($class, %args) = @_;
|
---|
17 | $args{Listen} ||= 5;
|
---|
18 | $args{Proto} ||= 'tcp';
|
---|
19 | return $class->SUPER::new(%args);
|
---|
20 | }
|
---|
21 |
|
---|
22 |
|
---|
23 | sub accept
|
---|
24 | {
|
---|
25 | my $self = shift;
|
---|
26 | my $pkg = shift || "HTTP::Daemon::ClientConn";
|
---|
27 | my ($sock, $peer) = $self->SUPER::accept($pkg);
|
---|
28 | if ($sock) {
|
---|
29 | ${*$sock}{'httpd_daemon'} = $self;
|
---|
30 | return wantarray ? ($sock, $peer) : $sock;
|
---|
31 | }
|
---|
32 | else {
|
---|
33 | return;
|
---|
34 | }
|
---|
35 | }
|
---|
36 |
|
---|
37 |
|
---|
38 | sub url
|
---|
39 | {
|
---|
40 | my $self = shift;
|
---|
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();
|
---|
46 | }
|
---|
47 | else {
|
---|
48 | $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
|
---|
49 | }
|
---|
50 | my $port = $self->sockport;
|
---|
51 | $url .= ":$port" if $port != $self->_default_port;
|
---|
52 | $url .= "/";
|
---|
53 | $url;
|
---|
54 | }
|
---|
55 |
|
---|
56 |
|
---|
57 | sub _default_port {
|
---|
58 | 80;
|
---|
59 | }
|
---|
60 |
|
---|
61 |
|
---|
62 | sub _default_scheme {
|
---|
63 | "http";
|
---|
64 | }
|
---|
65 |
|
---|
66 |
|
---|
67 | sub product_tokens
|
---|
68 | {
|
---|
69 | "libwww-perl-daemon/$HTTP::Daemon::VERSION";
|
---|
70 | }
|
---|
71 |
|
---|
72 |
|
---|
73 |
|
---|
74 | package HTTP::Daemon::ClientConn;
|
---|
75 |
|
---|
76 | use vars qw(@ISA $DEBUG);
|
---|
77 | use IO::Socket ();
|
---|
78 | @ISA=qw(IO::Socket::INET);
|
---|
79 | *DEBUG = \$HTTP::Daemon::DEBUG;
|
---|
80 |
|
---|
81 | use HTTP::Request ();
|
---|
82 | use HTTP::Response ();
|
---|
83 | use HTTP::Status;
|
---|
84 | use HTTP::Date qw(time2str);
|
---|
85 | use LWP::MediaTypes qw(guess_media_type);
|
---|
86 | use Carp ();
|
---|
87 |
|
---|
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");
|
---|
91 |
|
---|
92 |
|
---|
93 | sub get_request
|
---|
94 | {
|
---|
95 | my($self, $only_headers) = @_;
|
---|
96 | if (${*$self}{'httpd_nomore'}) {
|
---|
97 | $self->reason("No more requests from this connection");
|
---|
98 | return;
|
---|
99 | }
|
---|
100 |
|
---|
101 | $self->reason("");
|
---|
102 | my $buf = ${*$self}{'httpd_rbuf'};
|
---|
103 | $buf = "" unless defined $buf;
|
---|
104 |
|
---|
105 | my $timeout = $ {*$self}{'io_socket_timeout'};
|
---|
106 | my $fdset = "";
|
---|
107 | vec($fdset, $self->fileno, 1) = 1;
|
---|
108 | local($_);
|
---|
109 |
|
---|
110 | READ_HEADER:
|
---|
111 | while (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
|
---|
118 | }
|
---|
119 | elsif (length($buf) > 16*1024) {
|
---|
120 | $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
|
---|
121 | $self->reason("Very long header");
|
---|
122 | return;
|
---|
123 | }
|
---|
124 | }
|
---|
125 | else {
|
---|
126 | last READ_HEADER; # HTTP/0.9 client
|
---|
127 | }
|
---|
128 | }
|
---|
129 | elsif (length($buf) > 16*1024) {
|
---|
130 | $self->send_error(414); # REQUEST_URI_TOO_LARGE
|
---|
131 | $self->reason("Very long first line");
|
---|
132 | return;
|
---|
133 | }
|
---|
134 | print STDERR "Need more data for complete header\n" if $DEBUG;
|
---|
135 | return unless $self->_need_more($buf, $timeout, $fdset);
|
---|
136 | }
|
---|
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");
|
---|
141 | return;
|
---|
142 | }
|
---|
143 | my $method = $1;
|
---|
144 | my $uri = $2;
|
---|
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");
|
---|
152 |
|
---|
153 | if ($proto >= $HTTP_1_0) {
|
---|
154 | # we expect to find some headers
|
---|
155 | my($key, $val);
|
---|
156 | HEADER:
|
---|
157 | while ($buf =~ s/^([^\012]*)\012//) {
|
---|
158 | $_ = $1;
|
---|
159 | s/\015$//;
|
---|
160 | if (/^([^:\s]+)\s*:\s*(.*)/) {
|
---|
161 | $r->push_header($key, $val) if $key;
|
---|
162 | ($key, $val) = ($1, $2);
|
---|
163 | }
|
---|
164 | elsif (/^\s+(.*)/) {
|
---|
165 | $val .= " $1";
|
---|
166 | }
|
---|
167 | else {
|
---|
168 | last HEADER;
|
---|
169 | }
|
---|
170 | }
|
---|
171 | $r->push_header($key, $val) if $key;
|
---|
172 | }
|
---|
173 |
|
---|
174 | my $conn = $r->header('Connection');
|
---|
175 | if ($proto >= $HTTP_1_1) {
|
---|
176 | ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
|
---|
177 | }
|
---|
178 | else {
|
---|
179 | ${*$self}{'httpd_nomore'}++ unless $conn &&
|
---|
180 | lc($conn) =~ /\bkeep-alive\b/;
|
---|
181 | }
|
---|
182 |
|
---|
183 | if ($only_headers) {
|
---|
184 | ${*$self}{'httpd_rbuf'} = $buf;
|
---|
185 | return $r;
|
---|
186 | }
|
---|
187 |
|
---|
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');
|
---|
192 |
|
---|
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);
|
---|
197 | $self->send_crlf;
|
---|
198 | }
|
---|
199 | else {
|
---|
200 | $self->send_error(417);
|
---|
201 | $self->reason("Unsupported Expect header value");
|
---|
202 | return;
|
---|
203 | }
|
---|
204 | }
|
---|
205 |
|
---|
206 | if ($te && lc($te) eq 'chunked') {
|
---|
207 | # Handle chunked transfer encoding
|
---|
208 | my $body = "";
|
---|
209 | CHUNK:
|
---|
210 | while (1) {
|
---|
211 | print STDERR "Chunked\n" if $DEBUG;
|
---|
212 | if ($buf =~ s/^([^\012]*)\012//) {
|
---|
213 | my $chunk_head = $1;
|
---|
214 | unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
|
---|
215 | $self->send_error(400);
|
---|
216 | $self->reason("Bad chunk header $chunk_head");
|
---|
217 | return;
|
---|
218 | }
|
---|
219 | my $size = hex($1);
|
---|
220 | last CHUNK if $size == 0;
|
---|
221 |
|
---|
222 | my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
|
---|
223 | # must read until we have a complete chunk
|
---|
224 | while ($missing > 0) {
|
---|
225 | print STDERR "Need $missing more bytes\n" if $DEBUG;
|
---|
226 | my $n = $self->_need_more($buf, $timeout, $fdset);
|
---|
227 | return unless $n;
|
---|
228 | $missing -= $n;
|
---|
229 | }
|
---|
230 | $body .= substr($buf, 0, $size);
|
---|
231 | substr($buf, 0, $size+2) = '';
|
---|
232 |
|
---|
233 | }
|
---|
234 | else {
|
---|
235 | # need more data in order to have a complete chunk header
|
---|
236 | return unless $self->_need_more($buf, $timeout, $fdset);
|
---|
237 | }
|
---|
238 | }
|
---|
239 | $r->content($body);
|
---|
240 |
|
---|
241 | # pretend it was a normal entity body
|
---|
242 | $r->remove_header('Transfer-Encoding');
|
---|
243 | $r->header('Content-Length', length($body));
|
---|
244 |
|
---|
245 | my($key, $val);
|
---|
246 | FOOTER:
|
---|
247 | while (1) {
|
---|
248 | if ($buf !~ /\012/) {
|
---|
249 | # need at least one line to look at
|
---|
250 | return unless $self->_need_more($buf, $timeout, $fdset);
|
---|
251 | }
|
---|
252 | else {
|
---|
253 | $buf =~ s/^([^\012]*)\012//;
|
---|
254 | $_ = $1;
|
---|
255 | s/\015$//;
|
---|
256 | if (/^([\w\-]+)\s*:\s*(.*)/) {
|
---|
257 | $r->push_header($key, $val) if $key;
|
---|
258 | ($key, $val) = ($1, $2);
|
---|
259 | }
|
---|
260 | elsif (/^\s+(.*)/) {
|
---|
261 | $val .= " $1";
|
---|
262 | }
|
---|
263 | elsif (!length) {
|
---|
264 | last FOOTER;
|
---|
265 | }
|
---|
266 | else {
|
---|
267 | $self->reason("Bad footer syntax");
|
---|
268 | return;
|
---|
269 | }
|
---|
270 | }
|
---|
271 | }
|
---|
272 | $r->push_header($key, $val) if $key;
|
---|
273 |
|
---|
274 | }
|
---|
275 | elsif ($te) {
|
---|
276 | $self->send_error(501); # Unknown transfer encoding
|
---|
277 | $self->reason("Unknown transfer encoding '$te'");
|
---|
278 | return;
|
---|
279 |
|
---|
280 | }
|
---|
281 | elsif ($len) {
|
---|
282 | # Plain body specified by "Content-Length"
|
---|
283 | my $missing = $len - length($buf);
|
---|
284 | while ($missing > 0) {
|
---|
285 | print "Need $missing more bytes of content\n" if $DEBUG;
|
---|
286 | my $n = $self->_need_more($buf, $timeout, $fdset);
|
---|
287 | return unless $n;
|
---|
288 | $missing -= $n;
|
---|
289 | }
|
---|
290 | if (length($buf) > $len) {
|
---|
291 | $r->content(substr($buf,0,$len));
|
---|
292 | substr($buf, 0, $len) = '';
|
---|
293 | }
|
---|
294 | else {
|
---|
295 | $r->content($buf);
|
---|
296 | $buf='';
|
---|
297 | }
|
---|
298 | }
|
---|
299 | elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
|
---|
300 | # Handle multipart content type
|
---|
301 | my $boundary = "$CRLF--$2--";
|
---|
302 | my $index;
|
---|
303 | while (1) {
|
---|
304 | $index = index($buf, $boundary);
|
---|
305 | last if $index >= 0;
|
---|
306 | # end marker not yet found
|
---|
307 | return unless $self->_need_more($buf, $timeout, $fdset);
|
---|
308 | }
|
---|
309 | $index += length($boundary);
|
---|
310 | $r->content(substr($buf, 0, $index));
|
---|
311 | substr($buf, 0, $index) = '';
|
---|
312 |
|
---|
313 | }
|
---|
314 | ${*$self}{'httpd_rbuf'} = $buf;
|
---|
315 |
|
---|
316 | $r;
|
---|
317 | }
|
---|
318 |
|
---|
319 |
|
---|
320 | sub _need_more
|
---|
321 | {
|
---|
322 | my $self = shift;
|
---|
323 | #my($buf,$timeout,$fdset) = @_;
|
---|
324 | if ($_[1]) {
|
---|
325 | my($timeout, $fdset) = @_[1,2];
|
---|
326 | print STDERR "select(,,,$timeout)\n" if $DEBUG;
|
---|
327 | my $n = select($fdset,undef,undef,$timeout);
|
---|
328 | unless ($n) {
|
---|
329 | $self->reason(defined($n) ? "Timeout" : "select: $!");
|
---|
330 | return;
|
---|
331 | }
|
---|
332 | }
|
---|
333 | print STDERR "sysread()\n" if $DEBUG;
|
---|
334 | my $n = sysread($self, $_[0], 2048, length($_[0]));
|
---|
335 | $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
|
---|
336 | $n;
|
---|
337 | }
|
---|
338 |
|
---|
339 |
|
---|
340 | sub read_buffer
|
---|
341 | {
|
---|
342 | my $self = shift;
|
---|
343 | my $old = ${*$self}{'httpd_rbuf'};
|
---|
344 | if (@_) {
|
---|
345 | ${*$self}{'httpd_rbuf'} = shift;
|
---|
346 | }
|
---|
347 | $old;
|
---|
348 | }
|
---|
349 |
|
---|
350 |
|
---|
351 | sub reason
|
---|
352 | {
|
---|
353 | my $self = shift;
|
---|
354 | my $old = ${*$self}{'httpd_reason'};
|
---|
355 | if (@_) {
|
---|
356 | ${*$self}{'httpd_reason'} = shift;
|
---|
357 | }
|
---|
358 | $old;
|
---|
359 | }
|
---|
360 |
|
---|
361 |
|
---|
362 | sub proto_ge
|
---|
363 | {
|
---|
364 | my $self = shift;
|
---|
365 | ${*$self}{'httpd_client_proto'} >= _http_version(shift);
|
---|
366 | }
|
---|
367 |
|
---|
368 |
|
---|
369 | sub _http_version
|
---|
370 | {
|
---|
371 | local($_) = shift;
|
---|
372 | return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
|
---|
373 | $1 * 1000 + $2;
|
---|
374 | }
|
---|
375 |
|
---|
376 |
|
---|
377 | sub antique_client
|
---|
378 | {
|
---|
379 | my $self = shift;
|
---|
380 | ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
|
---|
381 | }
|
---|
382 |
|
---|
383 |
|
---|
384 | sub force_last_request
|
---|
385 | {
|
---|
386 | my $self = shift;
|
---|
387 | ${*$self}{'httpd_nomore'}++;
|
---|
388 | }
|
---|
389 |
|
---|
390 | sub head_request
|
---|
391 | {
|
---|
392 | my $self = shift;
|
---|
393 | ${*$self}{'httpd_head'};
|
---|
394 | }
|
---|
395 |
|
---|
396 |
|
---|
397 | sub send_status_line
|
---|
398 | {
|
---|
399 | my($self, $status, $message, $proto) = @_;
|
---|
400 | return if $self->antique_client;
|
---|
401 | $status ||= RC_OK;
|
---|
402 | $message ||= status_message($status) || "";
|
---|
403 | $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
|
---|
404 | print $self "$proto $status $message$CRLF";
|
---|
405 | }
|
---|
406 |
|
---|
407 |
|
---|
408 | sub send_crlf
|
---|
409 | {
|
---|
410 | my $self = shift;
|
---|
411 | print $self $CRLF;
|
---|
412 | }
|
---|
413 |
|
---|
414 |
|
---|
415 | sub send_basic_header
|
---|
416 | {
|
---|
417 | my $self = shift;
|
---|
418 | return if $self->antique_client;
|
---|
419 | $self->send_status_line(@_);
|
---|
420 | print $self "Date: ", time2str(time), $CRLF;
|
---|
421 | my $product = $self->daemon->product_tokens;
|
---|
422 | print $self "Server: $product$CRLF" if $product;
|
---|
423 | }
|
---|
424 |
|
---|
425 |
|
---|
426 | sub send_header
|
---|
427 | {
|
---|
428 | my $self = shift;
|
---|
429 | while (@_) {
|
---|
430 | my($k, $v) = splice(@_, 0, 2);
|
---|
431 | $v = "" unless defined($v);
|
---|
432 | print $self "$k: $v$CRLF";
|
---|
433 | }
|
---|
434 | }
|
---|
435 |
|
---|
436 |
|
---|
437 | sub send_response
|
---|
438 | {
|
---|
439 | my $self = shift;
|
---|
440 | my $res = shift;
|
---|
441 | if (!ref $res) {
|
---|
442 | $res ||= RC_OK;
|
---|
443 | $res = HTTP::Response->new($res, @_);
|
---|
444 | }
|
---|
445 | my $content = $res->content;
|
---|
446 | my $chunked;
|
---|
447 | unless ($self->antique_client) {
|
---|
448 | my $code = $res->code;
|
---|
449 | $self->send_basic_header($code, $res->message, $res->protocol);
|
---|
450 | if ($code =~ /^(1\d\d|[23]04)$/) {
|
---|
451 | # make sure content is empty
|
---|
452 | $res->remove_header("Content-Length");
|
---|
453 | $content = "";
|
---|
454 | }
|
---|
455 | elsif ($res->request && $res->request->method eq "HEAD") {
|
---|
456 | # probably OK
|
---|
457 | }
|
---|
458 | elsif (ref($content) eq "CODE") {
|
---|
459 | if ($self->proto_ge("HTTP/1.1")) {
|
---|
460 | $res->push_header("Transfer-Encoding" => "chunked");
|
---|
461 | $chunked++;
|
---|
462 | }
|
---|
463 | else {
|
---|
464 | $self->force_last_request;
|
---|
465 | }
|
---|
466 | }
|
---|
467 | elsif (length($content)) {
|
---|
468 | $res->header("Content-Length" => length($content));
|
---|
469 | }
|
---|
470 | else {
|
---|
471 | $self->force_last_request;
|
---|
472 | $res->header('connection','close');
|
---|
473 | }
|
---|
474 | print $self $res->headers_as_string($CRLF);
|
---|
475 | print $self $CRLF; # separates headers and content
|
---|
476 | }
|
---|
477 | if ($self->head_request) {
|
---|
478 | # no content
|
---|
479 | }
|
---|
480 | elsif (ref($content) eq "CODE") {
|
---|
481 | while (1) {
|
---|
482 | my $chunk = &$content();
|
---|
483 | last unless defined($chunk) && length($chunk);
|
---|
484 | if ($chunked) {
|
---|
485 | printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
|
---|
486 | }
|
---|
487 | else {
|
---|
488 | print $self $chunk;
|
---|
489 | }
|
---|
490 | }
|
---|
491 | print $self "0$CRLF$CRLF" if $chunked; # no trailers either
|
---|
492 | }
|
---|
493 | elsif (length $content) {
|
---|
494 | print $self $content;
|
---|
495 | }
|
---|
496 | }
|
---|
497 |
|
---|
498 |
|
---|
499 | sub send_redirect
|
---|
500 | {
|
---|
501 | my($self, $loc, $status, $content) = @_;
|
---|
502 | $status ||= RC_MOVED_PERMANENTLY;
|
---|
503 | Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
|
---|
504 | $self->send_basic_header($status);
|
---|
505 | my $base = $self->daemon->url;
|
---|
506 | $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
|
---|
507 | $loc = $loc->abs($base);
|
---|
508 | print $self "Location: $loc$CRLF";
|
---|
509 | if ($content) {
|
---|
510 | my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
|
---|
511 | print $self "Content-Type: $ct$CRLF";
|
---|
512 | }
|
---|
513 | print $self $CRLF;
|
---|
514 | print $self $content if $content && !$self->head_request;
|
---|
515 | $self->force_last_request; # no use keeping the connection open
|
---|
516 | }
|
---|
517 |
|
---|
518 |
|
---|
519 | sub send_error
|
---|
520 | {
|
---|
521 | my($self, $status, $error) = @_;
|
---|
522 | $status ||= RC_BAD_REQUEST;
|
---|
523 | Carp::croak("Status '$status' is not an error") unless is_error($status);
|
---|
524 | my $mess = status_message($status);
|
---|
525 | $error ||= "";
|
---|
526 | $mess = <<EOT;
|
---|
527 | <title>$status $mess</title>
|
---|
528 | <h1>$status $mess</h1>
|
---|
529 | $error
|
---|
530 | EOT
|
---|
531 | unless ($self->antique_client) {
|
---|
532 | $self->send_basic_header($status);
|
---|
533 | print $self "Content-Type: text/html$CRLF";
|
---|
534 | print $self "Content-Length: " . length($mess) . $CRLF;
|
---|
535 | print $self $CRLF;
|
---|
536 | }
|
---|
537 | print $self $mess unless $self->head_request;
|
---|
538 | $status;
|
---|
539 | }
|
---|
540 |
|
---|
541 |
|
---|
542 | sub send_file_response
|
---|
543 | {
|
---|
544 | my($self, $file) = @_;
|
---|
545 | if (-d $file) {
|
---|
546 | $self->send_dir($file);
|
---|
547 | }
|
---|
548 | elsif (-f _) {
|
---|
549 | # plain file
|
---|
550 | local(*F);
|
---|
551 | sysopen(F, $file, 0) or
|
---|
552 | return $self->send_error(RC_FORBIDDEN);
|
---|
553 | binmode(F);
|
---|
554 | my($ct,$ce) = guess_media_type($file);
|
---|
555 | my($size,$mtime) = (stat _)[7,9];
|
---|
556 | unless ($self->antique_client) {
|
---|
557 | $self->send_basic_header;
|
---|
558 | print $self "Content-Type: $ct$CRLF";
|
---|
559 | print $self "Content-Encoding: $ce$CRLF" if $ce;
|
---|
560 | print $self "Content-Length: $size$CRLF" if $size;
|
---|
561 | print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
|
---|
562 | print $self $CRLF;
|
---|
563 | }
|
---|
564 | $self->send_file(\*F) unless $self->head_request;
|
---|
565 | return RC_OK;
|
---|
566 | }
|
---|
567 | else {
|
---|
568 | $self->send_error(RC_NOT_FOUND);
|
---|
569 | }
|
---|
570 | }
|
---|
571 |
|
---|
572 |
|
---|
573 | sub send_dir
|
---|
574 | {
|
---|
575 | my($self, $dir) = @_;
|
---|
576 | $self->send_error(RC_NOT_FOUND) unless -d $dir;
|
---|
577 | $self->send_error(RC_NOT_IMPLEMENTED);
|
---|
578 | }
|
---|
579 |
|
---|
580 |
|
---|
581 | sub send_file
|
---|
582 | {
|
---|
583 | my($self, $file) = @_;
|
---|
584 | my $opened = 0;
|
---|
585 | local(*FILE);
|
---|
586 | if (!ref($file)) {
|
---|
587 | open(FILE, $file) || return undef;
|
---|
588 | binmode(FILE);
|
---|
589 | $file = \*FILE;
|
---|
590 | $opened++;
|
---|
591 | }
|
---|
592 | my $cnt = 0;
|
---|
593 | my $buf = "";
|
---|
594 | my $n;
|
---|
595 | while ($n = sysread($file, $buf, 8*1024)) {
|
---|
596 | last if !$n;
|
---|
597 | $cnt += $n;
|
---|
598 | print $self $buf;
|
---|
599 | }
|
---|
600 | close($file) if $opened;
|
---|
601 | $cnt;
|
---|
602 | }
|
---|
603 |
|
---|
604 |
|
---|
605 | sub daemon
|
---|
606 | {
|
---|
607 | my $self = shift;
|
---|
608 | ${*$self}{'httpd_daemon'};
|
---|
609 | }
|
---|
610 |
|
---|
611 |
|
---|
612 | 1;
|
---|
613 |
|
---|
614 | __END__
|
---|
615 |
|
---|
616 | =head1 NAME
|
---|
617 |
|
---|
618 | HTTP::Daemon - a simple http server class
|
---|
619 |
|
---|
620 | =head1 SYNOPSIS
|
---|
621 |
|
---|
622 | use HTTP::Daemon;
|
---|
623 | use HTTP::Status;
|
---|
624 |
|
---|
625 | my $d = HTTP::Daemon->new || die;
|
---|
626 | print "Please contact me at: <URL:", $d->url, ">\n";
|
---|
627 | while (my $c = $d->accept) {
|
---|
628 | while (my $r = $c->get_request) {
|
---|
629 | if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
|
---|
630 | # remember, this is *not* recommended practice :-)
|
---|
631 | $c->send_file_response("/etc/passwd");
|
---|
632 | }
|
---|
633 | else {
|
---|
634 | $c->send_error(RC_FORBIDDEN)
|
---|
635 | }
|
---|
636 | }
|
---|
637 | $c->close;
|
---|
638 | undef($c);
|
---|
639 | }
|
---|
640 |
|
---|
641 | =head1 DESCRIPTION
|
---|
642 |
|
---|
643 | Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
|
---|
644 | listen on a socket for incoming requests. The C<HTTP::Daemon> is a
|
---|
645 | subclass of C<IO::Socket::INET>, so you can perform socket operations
|
---|
646 | directly on it too.
|
---|
647 |
|
---|
648 | The accept() method will return when a connection from a client is
|
---|
649 | available. The returned value will be an C<HTTP::Daemon::ClientConn>
|
---|
650 | object which is another C<IO::Socket::INET> subclass. Calling the
|
---|
651 | get_request() method on this object will read data from the client and
|
---|
652 | return an C<HTTP::Request> object. The ClientConn object also provide
|
---|
653 | methods to send back various responses.
|
---|
654 |
|
---|
655 | This HTTP daemon does not fork(2) for you. Your application, i.e. the
|
---|
656 | user of the C<HTTP::Daemon> is responsible for forking if that is
|
---|
657 | desirable. Also note that the user is responsible for generating
|
---|
658 | responses that conform to the HTTP/1.1 protocol.
|
---|
659 |
|
---|
660 | The following methods of C<HTTP::Daemon> are new (or enhanced) relative
|
---|
661 | to the C<IO::Socket::INET> base class:
|
---|
662 |
|
---|
663 | =over 4
|
---|
664 |
|
---|
665 | =item $d = HTTP::Daemon->new
|
---|
666 |
|
---|
667 | =item $d = HTTP::Daemon->new( %opts )
|
---|
668 |
|
---|
669 | The constructor method takes the same arguments as the
|
---|
670 | C<IO::Socket::INET> constructor, but unlike its base class it can also
|
---|
671 | be called without any arguments. The daemon will then set up a listen
|
---|
672 | queue of 5 connections and allocate some random port number.
|
---|
673 |
|
---|
674 | A server that wants to bind to some specific address on the standard
|
---|
675 | HTTP port will be constructed like this:
|
---|
676 |
|
---|
677 | $d = HTTP::Daemon->new(
|
---|
678 | LocalAddr => 'www.thisplace.com',
|
---|
679 | LocalPort => 80,
|
---|
680 | );
|
---|
681 |
|
---|
682 | See L<IO::Socket::INET> for a description of other arguments that can
|
---|
683 | be used configure the daemon during construction.
|
---|
684 |
|
---|
685 | =item $c = $d->accept
|
---|
686 |
|
---|
687 | =item $c = $d->accept( $pkg )
|
---|
688 |
|
---|
689 | =item ($c, $peer_addr) = $d->accept
|
---|
690 |
|
---|
691 | This method works the same the one provided by the base class, but it
|
---|
692 | returns an C<HTTP::Daemon::ClientConn> reference by default. If a
|
---|
693 | package name is provided as argument, then the returned object will be
|
---|
694 | blessed into the given class. It is probably a good idea to make that
|
---|
695 | class a subclass of C<HTTP::Daemon::ClientConn>.
|
---|
696 |
|
---|
697 | The accept method will return C<undef> if timeouts have been enabled
|
---|
698 | and no connection is made within the given time. The timeout() method
|
---|
699 | is described in L<IO::Socket>.
|
---|
700 |
|
---|
701 | In list context both the client object and the peer address will be
|
---|
702 | returned; see the description of the accept method L<IO::Socket> for
|
---|
703 | details.
|
---|
704 |
|
---|
705 | =item $d->url
|
---|
706 |
|
---|
707 | Returns a URL string that can be used to access the server root.
|
---|
708 |
|
---|
709 | =item $d->product_tokens
|
---|
710 |
|
---|
711 | Returns the name that this server will use to identify itself. This
|
---|
712 | is the string that is sent with the C<Server> response header. The
|
---|
713 | main reason to have this method is that subclasses can override it if
|
---|
714 | they want to use another product name.
|
---|
715 |
|
---|
716 | The default is the string "libwww-perl-daemon/#.##" where "#.##" is
|
---|
717 | replaced with the version number of this module.
|
---|
718 |
|
---|
719 | =back
|
---|
720 |
|
---|
721 | The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
|
---|
722 | subclass. Instances of this class are returned by the accept() method
|
---|
723 | of C<HTTP::Daemon>. The following methods are provided:
|
---|
724 |
|
---|
725 | =over 4
|
---|
726 |
|
---|
727 | =item $c->get_request
|
---|
728 |
|
---|
729 | =item $c->get_request( $headers_only )
|
---|
730 |
|
---|
731 | This method reads data from the client and turns it into an
|
---|
732 | C<HTTP::Request> object which is returned. It returns C<undef>
|
---|
733 | if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
|
---|
734 | object ($c) should be discarded, and you should not try call this
|
---|
735 | method again on it. The $c->reason method might give you some
|
---|
736 | information about why $c->get_request failed.
|
---|
737 |
|
---|
738 | The get_request() method will normally not return until the whole
|
---|
739 | request has been received from the client. This might not be what you
|
---|
740 | want if the request is an upload of a large file (and with chunked
|
---|
741 | transfer encoding HTTP can even support infinite request messages -
|
---|
742 | uploading live audio for instance). If you pass a TRUE value as the
|
---|
743 | $headers_only argument, then get_request() will return immediately
|
---|
744 | after parsing the request headers and you are responsible for reading
|
---|
745 | the rest of the request content. If you are going to call
|
---|
746 | $c->get_request again on the same connection you better read the
|
---|
747 | correct number of bytes.
|
---|
748 |
|
---|
749 | =item $c->read_buffer
|
---|
750 |
|
---|
751 | =item $c->read_buffer( $new_value )
|
---|
752 |
|
---|
753 | Bytes read by $c->get_request, but not used are placed in the I<read
|
---|
754 | buffer>. The next time $c->get_request is called it will consume the
|
---|
755 | bytes in this buffer before reading more data from the network
|
---|
756 | connection itself. The read buffer is invalid after $c->get_request
|
---|
757 | has failed.
|
---|
758 |
|
---|
759 | If you handle the reading of the request content yourself you need to
|
---|
760 | empty this buffer before you read more and you need to place
|
---|
761 | unconsumed bytes here. You also need this buffer if you implement
|
---|
762 | services like I<101 Switching Protocols>.
|
---|
763 |
|
---|
764 | This method always returns the old buffer content and can optionally
|
---|
765 | replace the buffer content if you pass it an argument.
|
---|
766 |
|
---|
767 | =item $c->reason
|
---|
768 |
|
---|
769 | When $c->get_request returns C<undef> you can obtain a short string
|
---|
770 | describing why it happened by calling $c->reason.
|
---|
771 |
|
---|
772 | =item $c->proto_ge( $proto )
|
---|
773 |
|
---|
774 | Return TRUE if the client announced a protocol with version number
|
---|
775 | greater or equal to the given argument. The $proto argument can be a
|
---|
776 | string like "HTTP/1.1" or just "1.1".
|
---|
777 |
|
---|
778 | =item $c->antique_client
|
---|
779 |
|
---|
780 | Return TRUE if the client speaks the HTTP/0.9 protocol. No status
|
---|
781 | code and no headers should be returned to such a client. This should
|
---|
782 | be the same as !$c->proto_ge("HTTP/1.0").
|
---|
783 |
|
---|
784 | =item $c->head_request
|
---|
785 |
|
---|
786 | Return TRUE if the last request was a C<HEAD> request. No content
|
---|
787 | body must be generated for these requests.
|
---|
788 |
|
---|
789 | =item $c->force_last_request
|
---|
790 |
|
---|
791 | Make sure that $c->get_request will not try to read more requests off
|
---|
792 | this connection. If you generate a response that is not self
|
---|
793 | delimiting, then you should signal this fact by calling this method.
|
---|
794 |
|
---|
795 | This attribute is turned on automatically if the client announces
|
---|
796 | protocol HTTP/1.0 or worse and does not include a "Connection:
|
---|
797 | Keep-Alive" header. It is also turned on automatically when HTTP/1.1
|
---|
798 | or better clients send the "Connection: close" request header.
|
---|
799 |
|
---|
800 | =item $c->send_status_line
|
---|
801 |
|
---|
802 | =item $c->send_status_line( $code )
|
---|
803 |
|
---|
804 | =item $c->send_status_line( $code, $mess )
|
---|
805 |
|
---|
806 | =item $c->send_status_line( $code, $mess, $proto )
|
---|
807 |
|
---|
808 | Send the status line back to the client. If $code is omitted 200 is
|
---|
809 | assumed. If $mess is omitted, then a message corresponding to $code
|
---|
810 | is inserted. If $proto is missing the content of the
|
---|
811 | $HTTP::Daemon::PROTO variable is used.
|
---|
812 |
|
---|
813 | =item $c->send_crlf
|
---|
814 |
|
---|
815 | Send the CRLF sequence to the client.
|
---|
816 |
|
---|
817 | =item $c->send_basic_header
|
---|
818 |
|
---|
819 | =item $c->send_basic_header( $code )
|
---|
820 |
|
---|
821 | =item $c->send_basic_header( $code, $mess )
|
---|
822 |
|
---|
823 | =item $c->send_basic_header( $code, $mess, $proto )
|
---|
824 |
|
---|
825 | Send the status line and the "Date:" and "Server:" headers back to
|
---|
826 | the client. This header is assumed to be continued and does not end
|
---|
827 | with an empty CRLF line.
|
---|
828 |
|
---|
829 | See the description of send_status_line() for the description of the
|
---|
830 | accepted arguments.
|
---|
831 |
|
---|
832 | =item $c->send_header( $field, $value )
|
---|
833 |
|
---|
834 | =item $c->send_header( $field1, $value1, $field2, $value2, ... )
|
---|
835 |
|
---|
836 | Send one or more header lines.
|
---|
837 |
|
---|
838 | =item $c->send_response( $res )
|
---|
839 |
|
---|
840 | Write a C<HTTP::Response> object to the
|
---|
841 | client as a response. We try hard to make sure that the response is
|
---|
842 | self delimiting so that the connection can stay persistent for further
|
---|
843 | request/response exchanges.
|
---|
844 |
|
---|
845 | The content attribute of the C<HTTP::Response> object can be a normal
|
---|
846 | string or a subroutine reference. If it is a subroutine, then
|
---|
847 | whatever this callback routine returns is written back to the
|
---|
848 | client as the response content. The routine will be called until it
|
---|
849 | return an undefined or empty value. If the client is HTTP/1.1 aware
|
---|
850 | then we will use chunked transfer encoding for the response.
|
---|
851 |
|
---|
852 | =item $c->send_redirect( $loc )
|
---|
853 |
|
---|
854 | =item $c->send_redirect( $loc, $code )
|
---|
855 |
|
---|
856 | =item $c->send_redirect( $loc, $code, $entity_body )
|
---|
857 |
|
---|
858 | Send a redirect response back to the client. The location ($loc) can
|
---|
859 | be an absolute or relative URL. The $code must be one the redirect
|
---|
860 | status codes, and defaults to "301 Moved Permanently"
|
---|
861 |
|
---|
862 | =item $c->send_error
|
---|
863 |
|
---|
864 | =item $c->send_error( $code )
|
---|
865 |
|
---|
866 | =item $c->send_error( $code, $error_message )
|
---|
867 |
|
---|
868 | Send an error response back to the client. If the $code is missing a
|
---|
869 | "Bad Request" error is reported. The $error_message is a string that
|
---|
870 | is incorporated in the body of the HTML entity body.
|
---|
871 |
|
---|
872 | =item $c->send_file_response( $filename )
|
---|
873 |
|
---|
874 | Send back a response with the specified $filename as content. If the
|
---|
875 | file is a directory we try to generate an HTML index of it.
|
---|
876 |
|
---|
877 | =item $c->send_file( $filename )
|
---|
878 |
|
---|
879 | =item $c->send_file( $fd )
|
---|
880 |
|
---|
881 | Copy the file to the client. The file can be a string (which
|
---|
882 | will be interpreted as a filename) or a reference to an C<IO::Handle>
|
---|
883 | or glob.
|
---|
884 |
|
---|
885 | =item $c->daemon
|
---|
886 |
|
---|
887 | Return a reference to the corresponding C<HTTP::Daemon> object.
|
---|
888 |
|
---|
889 | =back
|
---|
890 |
|
---|
891 | =head1 SEE ALSO
|
---|
892 |
|
---|
893 | RFC 2616
|
---|
894 |
|
---|
895 | L<IO::Socket::INET>, L<IO::Socket>
|
---|
896 |
|
---|
897 | =head1 COPYRIGHT
|
---|
898 |
|
---|
899 | Copyright 1996-2003, Gisle Aas
|
---|
900 |
|
---|
901 | This library is free software; you can redistribute it and/or
|
---|
902 | modify it under the same terms as Perl itself.
|
---|
903 |
|
---|