I couldn't figure out a nice way to fix this and [rt #69744] in separate
patches, so I did them both at once.
Code, POD, and regression tests included in this patch.
It doesn't seem to me like a final way to fix the problems performance-
wise, but it does fix the issues reliably. (Each header_* operation in
HTTPD::Util is O(n) on the number of headers, best possible is O(1) as
implemented e.g. by LWP's HTTP::Headers)
Also, there's a small semantic difference added: when the Content-Length
header is removed, force Connection: close. I don't think this was a
reachable glitch before. (This is also tested, including an update to the
test_connect routine in HTTPD::Util to time out after 15 seconds.)
From 561d01710448ba7b6287f1bc76bbb8b7454862c2 Mon Sep 17 00:00:00 2001
From: Chris Kastorff <encryptio@gmail.com>
Date: Mon, 25 Jul 2011 03:15:49 -0700
Subject: [PATCH] Handle header overrides flexibly, including removal
Fixes [rt #69744] [rt #69743]
Also adds support for tests failing due to timeout in
AnyEvent::HTTPD::Util (needed for the tests to fail in previous
versions)
---
lib/AnyEvent/HTTPD.pm | 5 ++-
lib/AnyEvent/HTTPD/HTTPConnection.pm | 27 ++++++++-------
lib/AnyEvent/HTTPD/Request.pm | 10 ++++++
lib/AnyEvent/HTTPD/Util.pm | 53 +++++++++++++++++++++++++++++-
t/14_header_unset.t | 59 ++++++++++++++++++++++++++++++++++
5 files changed, 138 insertions(+), 16 deletions(-)
create mode 100644 t/14_header_unset.t
diff --git a/lib/AnyEvent/HTTPD.pm b/lib/AnyEvent/HTTPD.pm
index 5c9664c..3e2f60f 100644
--- a/lib/AnyEvent/HTTPD.pm
+++ b/lib/AnyEvent/HTTPD.pm
@@ -406,8 +406,9 @@ to your server or is disconnected from it.
Any response from the HTTP server will have C<Cache-Control> set to C<max-age=0> and
also the C<Expires> header set to the C<Date> header. Meaning: Caching is disabled.
-You can of course set those headers yourself in the response, but keep in mind
-that the default for those headers are like mentioned above.
+You can of course set those headers yourself in the response, or remove them by
+setting them to undef, but keep in mind that the default for those headers are
+like mentioned above.
If you need more support here you can send me a mail or even better: a patch :)
diff --git a/lib/AnyEvent/HTTPD/HTTPConnection.pm b/lib/AnyEvent/HTTPD/HTTPConnection.pm
index db99f62..3226930 100644
--- a/lib/AnyEvent/HTTPD/HTTPConnection.pm
+++ b/lib/AnyEvent/HTTPD/HTTPConnection.pm
@@ -110,23 +110,26 @@ sub response {
return unless $self->{hdl};
my $res = "HTTP/1.0 $code $msg\015\012";
- $hdr->{'Date'} = _time_to_http_date time
- unless defined $hdr->{'Date'};
- $hdr->{'Expires'} = $hdr->{'Date'}
- unless defined $hdr->{'Expires'};
- $hdr->{'Cache-Control'} = "max-age=0"
- unless defined $hdr->{'Cache-Control'};
- $hdr->{'Connection'} = $self->{keep_alive} ? 'Keep-Alive' : 'close';
-
- $hdr->{'Content-Length'} = length "$content"
- if not (defined $hdr->{'Content-Length'}) && not ref $content;
-
- unless (defined $hdr->{'Content-Length'}) {
+ header_set $hdr, 'Date' => _time_to_http_date time
+ unless header_exists $hdr, 'Date';
+ header_set $hdr, 'Expires' => header_get $hdr, 'Date'
+ unless header_exists $hdr, 'Expires';
+ header_set $hdr, 'Cache-Control' => "max-age=0"
+ unless header_exists $hdr, 'Cache-Control';
+ header_set $hdr, 'Connection' =>
+ ($self->{keep_alive} ? 'Keep-Alive' : 'close');
+
+ header_set $hdr, 'Content-Length' => length "$content"
+ if not header_exists($hdr, 'Content-Length') && not ref $content;
+
+ unless (defined header_get($hdr, 'Content-Length')) {
# keep alive with no content length will NOT work.
delete $self->{keep_alive};
+ header_set $hdr, 'Connection' => 'close';
}
while (my ($h, $v) = each %$hdr) {
+ next if not defined $v;
$res .= "$h: $v\015\012";
}
diff --git a/lib/AnyEvent/HTTPD/Request.pm b/lib/AnyEvent/HTTPD/Request.pm
index b41c9b5..215b3a6 100644
--- a/lib/AnyEvent/HTTPD/Request.pm
+++ b/lib/AnyEvent/HTTPD/Request.pm
@@ -49,6 +49,16 @@ Then the array reference has these elements:
my ($code, $message, $header_hash, $content) =
[200, 'ok', { 'Content-Type' => 'text/html' }, '<h1>Test</h1>' }]
+You can remove most headers added by default (like C<Cache-Control>, C<Expires>, and C<Content-Length>) by setting them to undef, like so:
+
+ $req->respond([200, 'OK', {
+ 'Content-Type' => 'text/html',
+ 'Cache-Control' => 'max-age=3600',
+ 'Expires' => undef,
+ },
+ 'This data will be cached for one hour.'
+ ]);
+
=item * a hash reference
If it was a hash reference the hash is first searched for the C<redirect>
diff --git a/lib/AnyEvent/HTTPD/Util.pm b/lib/AnyEvent/HTTPD/Util.pm
index ec984f2..cf9029d 100644
--- a/lib/AnyEvent/HTTPD/Util.pm
+++ b/lib/AnyEvent/HTTPD/Util.pm
@@ -6,7 +6,7 @@ use common::sense;
require Exporter;
our @ISA = qw/Exporter/;
-our @EXPORT = qw/parse_urlencoded url_unescape/;
+our @EXPORT = qw/parse_urlencoded url_unescape header_set header_get header_exists/;
=head1 NAME
@@ -59,7 +59,17 @@ sub test_connect {
$hdl =
AnyEvent::Handle->new (
- fh => $fh, on_eof => sub { $c->send ($buf) },
+ fh => $fh,
+ timeout => 15,
+ on_eof => sub {
+ $c->send($buf);
+ undef $hdl;
+ },
+ on_timeout => sub {
+ warn "test_connect timed out";
+ $c->send($buf);
+ undef $hdl;
+ },
on_read => sub {
$buf .= $hdl->rbuf;
$hdl->rbuf = '';
@@ -71,6 +81,45 @@ sub test_connect {
$c
}
+###
+# these functions set/get/check existence of a header name:value pair while
+# ignoring the case of the name
+#
+# quick hack, does not scale to large hashes. however, it's not expected to be
+# run on large hashes.
+#
+# a more performant alternative would be to keep two hashes for each set of
+# headers, one for the headers in the case they like, and one a mapping of
+# names from some consistent form (say, all lowercase) to the name in the other
+# hash, including capitalization. (this style is used in HTTP::Headers)
+
+sub header_set {
+ my ($hdrs, $name, $value) = @_;
+
+ my $lname = lc $name;
+ my ($match_name) = grep { lc eq $lname } keys %$hdrs;
+
+ $hdrs->{defined $match_name ? $match_name : $name} = $value;
+}
+
+sub header_get {
+ my ($hdrs, $name) = @_;
+
+ $name = lc $name;
+ my ($match_name) = grep { lc eq $name } keys %$hdrs;
+
+ return defined $match_name ? $hdrs->{$match_name} : undef;
+}
+
+sub header_exists {
+ my ($hdrs, $name) = @_;
+
+ $name = lc $name;
+ my ($match_name) = grep { lc eq $name } keys %$hdrs;
+
+ # NB: even if the value is undefined, return true
+ return defined $match_name;
+}
=back
diff --git a/t/14_header_unset.t b/t/14_header_unset.t
new file mode 100644
index 0000000..8a9fa15
--- /dev/null
+++ b/t/14_header_unset.t
@@ -0,0 +1,59 @@
+#!perl
+use common::sense;
+use Test::More tests => 8;
+use AnyEvent::Impl::Perl;
+use AnyEvent;
+use AnyEvent::HTTPD;
+
+my $h = AnyEvent::HTTPD->new (port => 19090);
+
+$h->reg_cb (
+ '/header-unset' => sub {
+ my ($httpd, $req) = @_;
+ $req->respond ([200, 'OK', {
+ 'Cache-Control' => undef,
+ 'Expires' => undef,
+ 'Content-Length' => undef,
+ }, "Test response"]);
+ },
+ '/header-override-lowercase' => sub {
+ my ($httpd, $req) = @_;
+ $req->respond ([200, 'OK', {
+ 'cache-control' => "nonsensical",
+ }, "Test response"]);
+ },
+ '/header-override-uppercase' => sub {
+ my ($httpd, $req) = @_;
+ $req->respond ([200, 'OK', {
+ 'CACHE-CONTROL' => "nonsensical",
+ }, "Test response"]);
+ },
+);
+
+
+my $c1 = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
+ "GET\040/header-unset\040HTTP/1.0\015\012Connection: Keep-Alive\015\012\015\012");
+my $c2 = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
+ "GET\040/header-override-lowercase\040HTTP/1.0\015\012\015\012");
+my $c3 = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
+ "GET\040/header-override-uppercase\040HTTP/1.0\015\012\015\012");
+my $r1 = $c1->recv;
+my $r2 = $c2->recv;
+my $r3 = $c3->recv;
+
+unlike($r1, qr/^expires:/im, "Can unset Expires header");
+unlike($r1, qr/^cache-control:/im, "Can unset Cache-Control header");
+unlike($r1, qr/^content-length:/im, "Can unset Content-Length header");
+unlike($r1, qr/^connection:\s*close$/im,
+ "Unsetting Content-Length implies no keep-alive");
+
+like($r2, qr/^cache-control:\s*nonsensical/im,
+ "Cache-Control set with lowercase gets through");
+unlike($r2, qr/^cache-control:\s*max-age/im,
+ "Cache-Control set with lowercase removes default header");
+
+like($r3, qr/^cache-control:\s*nonsensical/im,
+ "Cache-Control set with uppercase gets through");
+unlike($r3, qr/^cache-control:\s*max-age/im,
+ "Cache-Control set with uppercase removes default header");
+
--
1.7.6
