commit faebad54455c2c2919e234202362570925fb99d1
Author: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date:   Tue Jun 21 20:30:36 2022 +0000

    Add new test for Content-Length issues
    
    prove we fixed CVE-2022-31081

diff --git a/t/content_length.t b/t/content_length.t
new file mode 100644
index 0000000..1751845
--- /dev/null
+++ b/t/content_length.t
@@ -0,0 +1,278 @@
+use strict;
+use warnings;
+
+use Test::More 0.98;
+
+use Config;
+
+use HTTP::Daemon;
+use HTTP::Response;
+use HTTP::Status;
+use HTTP::Tiny 0.042;
+
+patch_http_tiny(); # do not fix Content-Length, we want to forge something bad
+
+plan skip_all => "This system cannot fork" unless can_fork();
+
+my $BASE_URL;
+my @TESTS = get_tests();
+
+for my $test (@TESTS) {
+    
+    my $http_daemon = HTTP::Daemon->new() or die "HTTP::Daemon->new: $!";
+    $BASE_URL = $http_daemon->url;
+
+    my $pid = fork;
+    die "fork: $!" if !defined $pid;
+    if ($pid == 0) {
+        accept_requests($http_daemon);
+    }
+    
+    my $resp = http_test_request($test);
+    
+    ok $resp, $test->{title};
+    
+    is $resp->{status}, $test->{status},
+        "... and has expected status";
+    
+    like $resp->{content}, $test->{like},
+        "... and body does match"
+        if $test->{like};
+    
+}
+
+done_testing;
+
+
+
+sub get_tests{
+    {
+        title   => "Hello World Request ... it works as expected",
+        path    => "hello-world",
+        status  => 200,
+        like    => qr/^Hello World$/,
+    },
+    {
+        title   => "Positive Content Length",
+        method  => "POST",
+        headers => {
+            'Content-Length' => '+1', # quotes are needed to retain plus-sign
+        },
+        status  => 400,
+        like    => qr/value must be an unsigned integer/,
+    },
+    {
+        title   => "Negative Content Length",
+        method  => "POST",
+        headers => {
+            'Content-Length' => '-1',
+        },
+        status  => 400,
+        like    => qr/value must be an unsigned integer/,
+    },
+    {
+        title   => "Non Integer Content Length",
+        method  => "POST",
+        headers => {
+            'Content-Length' => '3.14',
+        },
+        status  => 400,
+        like    => qr/value must be an unsigned integer/,
+    },
+    {
+        title   => "Explicit Content Length ... with exact length",
+        method  => "POST",
+        headers => {
+            'Content-Length' => '8',
+        },
+        body    => "ABCDEFGH",
+        status  => 200,
+        like    => qr/^ABCDEFGH$/,
+    },
+    {
+        title   => "Implicit Content Length ... will always pass",
+        method  => "POST",
+        body    => "ABCDEFGH",
+        status  => 200,
+        like    => qr/^ABCDEFGH$/,
+    },
+    {
+        title   => "Shorter Content Length ... gets truncated",
+        method  => "POST",
+        headers => {
+            'Content-Length' => '4',
+        },
+        body    => "ABCDEFGH",
+        status  => 200,
+        like    => qr/^ABCD$/,
+    },
+    {
+        title   => "Different Content Length ... must fail",
+        method  => "POST",
+        headers => {
+            'Content-Length' => ['8', '4'],
+        },
+        body    => "ABCDEFGH",
+        status  => 400,
+        like    => qr/values are not the same/,
+    },
+    {
+        title   => "Underscore Content Length ... must match",
+        method  => "POST",
+        headers => {
+            'Content_Length' => '4',
+        },
+        body    => "ABCDEFGH",
+        status  => 400,
+        like    => qr/values are not the same/,
+    },
+    {
+        title   => "Longer Content Length ... gets timeout",
+        method  => "POST",
+        headers => {
+            'Content-Length' => '9',
+        },
+        body    => "ABCDEFGH",
+        status  => 599, # silly code !!!
+        like    => qr/^Timeout/,
+    },
+
+}
+
+
+
+sub router_table {
+    {
+        '/hello-world' => {
+            'GET' => sub {
+                my $resp = HTTP::Response->new(200);
+                $resp->content('Hello World');
+                return $resp;
+            },
+        },
+        
+        '/' => {
+            'POST' => sub {
+                my $rqst = shift;
+                
+                my $body = $rqst->content();
+                
+                my $resp = HTTP::Response->new(200);
+                $resp->content($body);
+                
+                return $resp
+            },
+        },
+    }
+}
+
+
+
+sub can_fork {
+    $Config{d_fork} || (($^O eq 'MSWin32' || $^O eq 'NetWare')
+    and $Config{useithreads}
+    and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+}
+
+
+
+# run the mini HTTP dispatcher that can handle various routes / methods
+sub accept_requests{
+    my $http_daemon = shift;
+    while (my $conn = $http_daemon->accept) {
+        while (my $rqst = $conn->get_request) {
+            if (my $resp = dispatch_request($rqst)) {
+                $conn->send_response($resp);
+            }
+        }
+        $conn->close;
+        undef($conn);
+        $http_daemon->close;
+        exit 1;
+    }
+}
+
+
+
+sub dispatch_request{
+    my $rqst = shift
+        or return;
+    my $path = $rqst->uri->path
+        or return;
+    my $meth = $rqst->method
+        or return;
+    my $code =  router_table()->{$path}{$meth}
+        or return HTTP::Response->new(RC_NOT_FOUND);
+    my $resp = $code->($rqst);
+    return $resp;
+}
+
+
+
+sub http_test_request {
+    my $test = shift;
+    my $http_client = HTTP::Tiny->new(
+        timeout => 5,
+        proxy => undef,
+        http_proxy => undef,
+        https_proxy => undef,
+    );
+    my $resp;
+    eval {
+        local $SIG{ALRM} = sub { die "Timeout\n" };
+        alarm 2;
+        $resp = $http_client->request(
+            $test->{method} || "GET",
+            $BASE_URL . ($test->{path} || ""),
+            {
+                headers => $test->{headers},
+                content => $test->{body}
+            },
+        );
+    };
+    my $err = $@;
+    alarm 0;
+    diag $err if $err;
+
+    return $resp
+}
+
+
+
+sub patch_http_tiny {
+    
+    # we need to patch write_content_body
+    # this is part of HTTP::Tiny internal module HTTP::Tiny::Handle
+    #
+    # the below code is from the original HTTP::Tiny module, where just two lines
+    # have been commented out
+    
+    no strict 'refs';
+    
+    *HTTP::Tiny::Handle::write_content_body = sub {
+        @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
+        my ($self, $request) = @_;
+        
+        my ($len, $content_length) = (0, $request->{headers}{'content-length'});
+        while () {
+            my $data = $request->{cb}->();
+            
+            defined $data && length $data
+                or last;
+            
+            if ( $] ge '5.008' ) {
+                utf8::downgrade($data, 1)
+                    or die(qq/Wide character in write_content()\n/);
+            }
+            
+            $len += $self->write($data);
+        }
+        
+#       this should not be checked during our tests, we want to forge bad requests
+#       
+#       $len == $content_length
+#           or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
+        
+        return $len;
+    };
+}