perl - 如何使用 Perl 为 HTTP 请求发送不正确的 Content-Length header ？

Question

我正在尝试调试一个奇怪的警告，该警告在服务器日志中出现时 Plack::Request正在解析。在某些情况下，损坏的 UserAgent 会发送类似于“6375, 6375”的 Content-Length header ，这显然是错误的。

要正确解决此问题，我需要能够重现警告。我想将其包含在单元测试中，以便我可以确保警告消失后不会出现倒退。但是，我在使用 Perl 时遇到了麻烦。我知道这可以使用 netcat 和 socat 来完成，但我不希望单元测试必须依赖于安装其他二进制文件。

这是我尝试过的:

#!/usr/bin/env perl

use strict;
use warnings;

use JSON::XS qw( encode_json );
use WWW::Mechanize;

my $mech = WWW::Mechanize->new;

$mech->add_handler(
    request_prepare => sub {
        my ( $req, $ua, $h ) = @_;
        $req->headers->header( 'Content-Length' => 9999 );
        return;
    }
);

my $json = encode_json( { foo => 'bar' } );

$mech->post(
    'http://example.com'/url,
    'Content-Length' => 999,
    Content          => $json
);

输出是:

Content-Length header value was wrong, fixed at /opt/perl5.16.3/lib/site_perl/5.16.3/LWP/Protocol/http.pm line 260.
200

这对我来说太有帮助了。 :)

如果我使用 HTTP::Request和 LWP::UserAgent , 这是相同的最终结果。

所以，我尝试了 HTTP::Tiny .

#!/usr/bin/env perl

use strict;
use warnings;

use DDP;
use HTTP::Tiny;
use JSON::XS qw( encode_json );

my $http = HTTP::Tiny->new;

my $json = encode_json( { foo => 'bar' } );
my $response = $http->request(
    'POST',
    'http://example.com'/url',
    {   headers => { 'Content-Length' => 999, },
        content => $json,
    }
);

p $response;

输出是:

{   content => "Content-Length missmatch (got: 13 expected: 999)
",
    headers => {
        content
            -length => 49,
        content-type => "text/plain",
    },
    reason  => "Internal Exception",
    status  => 599,
    success => "",
    url     => "http://example.com'/url",
}

同样，太有帮助了。在这一点上，我可以使用一些建议。

Answer 1

似乎更高级别的 API 正在修复您的错误；这是一个使用原始套接字来克服这个问题的示例；

#!/usr/bin/env perl
use strict 'vars';
use warnings;
use Socket;

# initialize host and port
my $host = 'www.example.com';
my $port =  80;

# contact the server
open_tcp(F, $host, $port) 
  or die 'Could not connect to server';

# Send request data
while ( my $request = <DATA> ) {
  print F $request;
}

# Get Response
while ( my $response = <F> ) {
  print "Response:> $response";
}

close(F);

# TCP Helper
sub open_tcp
{
  # get parameters
  my ($FS, $dest, $port) = @_;

  my $proto = getprotobyname('tcp');
  socket($FS, PF_INET, SOCK_STREAM, $proto);
  my $sin = sockaddr_in($port,inet_aton($dest));
  connect($FS,$sin);

  my $old_fh = select($FS); 
  $| = 1; # don't buffer output
  select($old_fh);
}

__DATA__
GET / HTTP/1.1
Host: example.com
Content-Length: 999


-END-