Fix response content-type handling for 204

Author: Mons

MANIFEST

@@ -21,8 +21,10 @@ MANIFEST.SKIP
 README
 README.md
 t/00-load.t
-t/01-basic.t
-t/02-sendfile.t
+t/01-basic-ae.t
+t/02-basic-ev.t
+t/03-sendfile.t
+t/basic.pl
 t/pod.t
 t/testlib.pm
 test.sh

META.json

@@ -40,6 +40,6 @@
       }
    },
    "release_status" : "stable",
-   "version" : "1.99995",
+   "version" : "1.99996",
    "x_serialization_backend" : "JSON::PP version 4.06"
 }

META.yml

@@ -22,5 +22,5 @@ requires:
   Digest::SHA1: '2'
   HTTP::Easy: '0.02'
   JSON::XS: '3'
-version: '1.99995'
+version: '1.99996'
 x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

lib/AnyEvent/HTTP/Server.pm

@@ -8,7 +8,7 @@ AnyEvent::HTTP::Server - AnyEvent HTTP/1.1 Server
 
 our $VERSION;
 BEGIN{
-$VERSION = '1.99995';
+$VERSION = '1.99996';
 }
 
 use AnyEvent::HTTP::Server::Kit;

lib/AnyEvent/HTTP/Server/Req.pm

@@ -252,7 +252,7 @@ BEGIN {
 		sub sendfile {
 			my $self = shift;
 			my ( $code,$file,%args ) = @_;
-			$code ||=200;
+			$code ||= 200;
 			my $reply = "HTTP/1.0 $code $http{$code}$LF";
 			my $size = -s $file or $! and return warn "Can't sendfile `$file': $!";
 			open my $f, '<:raw',$file or return  warn "Can't open file `$file': $!";
@@ -303,7 +303,8 @@ BEGIN {
 			my $self = shift;
 			#return $self->headers(@_) if @_ % 2;
 			my ($code,$content,%args) = @_;
-			$code ||=200;
+			$code ||= 200;
+			$content = '' unless defined $content;
 			utf8::encode $content if utf8::is_utf8 $content;
 			my $reply = "HTTP/$self->{version} $code $http{$code}$LF";
 			my @good;my @bad;
@@ -333,6 +334,13 @@ BEGIN {
 				}
 				$content = '';
 			}
+
+			# https://www.rfc-editor.org/rfc/rfc7230#section-3.3.2
+			if ($code == 204 or $code == 304 or $code < 200) {
+				delete $h->{'content-length'};
+				$content = '';
+			}
+
 			if (exists $h->{'content-type'}) {
 				if( $h->{'content-type'} !~ m{[^;]+;\s*charset\s*=}
 				and $h->{'content-type'} =~ m{(?:^(?:text/|application/(?:json|(?:x-)?javascript))|\+(?:json|xml)\b)}i) {

t/basic.pl

@@ -1,6 +1,6 @@
 #!/usr/bin/env perl
 
-use Test::More tests => 194;
+use Test::More tests => 224;
 use Data::Dumper;
 use FindBin;
 use lib "$FindBin::Bin/..";
@@ -255,6 +255,42 @@
 	[["GET /test1 HTTP/1.1\nHost:localhost\nConnection:close\n\n"],                          500, {}, "Request not handled\nGET /test1\n" ],
 if ALL;
 
+test_server {
+	return 204, undef, headers => {};
+}	'204 - no cl - undef',
+	[["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ],
+if ALL;
+
+test_server {
+	return 204, "", headers => {};
+}	'204 - no cl - empty',
+	[["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ],
+if ALL;
+
+test_server {
+	my $s = shift;
+	my $r = shift;
+	return 204, "some content", headers => {};
+}	'204 - with content',
+	[["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ],
+if ALL;
+
+test_server {
+	my $s = shift;
+	my $r = shift;
+	return 204, "", headers => {'content-length' => 0};
+}	'204 - with header',
+	[["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ],
+if ALL;
+
+test_server {
+	my $s = shift;
+	my $r = shift;
+	return 200, undef;
+}	'200 - with undef body',
+	[["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'content-length' => 0 }, "" ],
+if ALL;
+
 }
 
 done_testing();