pool/perl-HTTP-Daemon
SHA256
4
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Accepting request 991013 from devel:languages:perl

Browse Source 
OBS-URL: https://build.opensuse.org/request/show/991013
OBS-URL: https://build.opensuse.org/package/show/openSUSE:Factory/perl-HTTP-Daemon?expand=0&rev=17
This commit is contained in:
Fabian Vogt 2022-07-31 21:00:35 +00:00 committed by Git OBS Bridge
commit 6a44b03da6
5 changed files with 414 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
CVE-2022-31081-2.patch Normal file
View File

@ -0,0 +1,36 @@
From 8dc5269d59e2d5d9eb1647d82c449ccd880f7fd0 Mon Sep 17 00:00:00 2001
From: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date: Tue, 21 Jun 2022 20:00:47 +0000
Subject: [PATCH] Include reason in response body content
---
lib/HTTP/Daemon.pm | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)
diff --git a/lib/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm
index a5112b3..2d022ae 100644
--- a/lib/HTTP/Daemon.pm
+++ b/lib/HTTP/Daemon.pm
@@ -299,16 +299,18 @@ READ_HEADER:
# check that they are all numbers (RFC: Content-Length = 1*DIGIT)
my @nums = grep { /^[0-9]+$/} @vals;
unless (@vals == @nums) {
- $self->send_error(400);
- $self->reason("Content-Length value must be a unsigned integer");
+ my $reason = "Content-Length value must be an unsigned integer";
+ $self->send_error(400, $reason);
+ $self->reason($reason);
return;
}
# check they are all the same
my $len = shift @nums;
foreach (@nums) {
next if $_ == $len;
- $self->send_error(400);
- $self->reason("Content-Length values are not the same");
+ my $reason = "Content-Length values are not the same";
+ $self->send_error(400, $reason);
+ $self->reason($reason);
return;
}
# ensure we have now a fixed header, with only 1 value

312
CVE-2022-31081-Add-new-test-for-Content-Length-issues.patch Normal file
View File

@ -0,0 +1,312 @@
From faebad54455c2c2919e234202362570925fb99d1 Mon Sep 17 00:00:00 2001
From: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date: Tue, 21 Jun 2022 20:30:36 +0000
Subject: [PATCH] Add new test for Content-Length issues
prove we fixed CVE-2022-31081
From 211a29732760c9887c15e8dc344e15cf8cdf2807 Mon Sep 17 00:00:00 2001
From: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date: Mon, 27 Jun 2022 22:42:31 +0200
Subject: [PATCH 1/3] Fix tests to match with correct grammar in error message
From 2b7fd55a55313b6f04c92fbfee6458d1f7b908fd Mon Sep 17 00:00:00 2001
From: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date: Mon, 27 Jun 2022 22:44:11 +0200
Subject: [PATCH 2/3] Remove warnings about Subroutine write_content_body
redefined
From cfa63717a3aeedf6aaec16c4091098c05c2d7e01 Mon Sep 17 00:00:00 2001
From: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date: Mon, 27 Jun 2022 23:33:05 +0200
Subject: [PATCH 3/3] Send some body to see what we get returned
---
t/content_length.t | 282 +++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 282 insertions(+)
create mode 100644 t/content_length.t
--- /dev/null
+++ b/t/content_length.t
@@ -0,0 +1,282 @@
+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",
+ body => "ABCDEFGH",
+ headers => {
+ 'Content-Length' => '+6', # quotes are needed to retain plus-sign
+ },
+ status => 400,
+ like => qr/value must be an unsigned integer/,
+ },
+ {
+ title => "Negative Content Length",
+ method => "POST",
+ body => "ABCDEFGH",
+ headers => {
+ 'Content-Length' => '-5',
+ },
+ status => 400,
+ like => qr/value must be an unsigned integer/,
+ },
+ {
+ title => "Non Integer Content Length",
+ method => "POST",
+ body => "ABCDEFGH",
+ 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';
+ no warnings;
+
+ *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;
+ };
+}

50
CVE-2022-31081.patch Normal file
View File

@ -0,0 +1,50 @@
From e84475de51d6fd7b29354a997413472a99db70b2 Mon Sep 17 00:00:00 2001
From: Theo van Hoesel <tvanhoesel@perceptyx.com>
Date: Thu, 16 Jun 2022 08:28:30 +0000
Subject: [PATCH] Fix Content-Length ', '-separated string issues
After a security issue, we ensure we comply to
RFC-7230 -- HTTP/1.1 Message Syntax and Routing
- section 3.3.2 -- Content-Length
- section 3.3.3 -- Message Body Length
---
lib/HTTP/Daemon.pm | 26 ++++++++++++++++++++++++++
1 file changed, 26 insertions(+)
diff --git a/lib/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm
index c0cdf76..a5112b3 100644
--- a/lib/HTTP/Daemon.pm
+++ b/lib/HTTP/Daemon.pm
@@ -288,6 +288,32 @@ READ_HEADER:
}
elsif ($len) {
+ # After a security issue, we ensure we comply to
+ # RFC-7230 -- HTTP/1.1 Message Syntax and Routing
+ # section 3.3.2 -- Content-Length
+ # section 3.3.3 -- Message Body Length
+
+ # split and clean up Content-Length ', ' separated string
+ my @vals = map {my $str = $_; $str =~ s/^\s+//; $str =~ s/\s+$//; $str }
+ split ',', $len;
+ # check that they are all numbers (RFC: Content-Length = 1*DIGIT)
+ my @nums = grep { /^[0-9]+$/} @vals;
+ unless (@vals == @nums) {
+ $self->send_error(400);
+ $self->reason("Content-Length value must be a unsigned integer");
+ return;
+ }
+ # check they are all the same
+ my $len = shift @nums;
+ foreach (@nums) {
+ next if $_ == $len;
+ $self->send_error(400);
+ $self->reason("Content-Length values are not the same");
+ return;
+ }
+ # ensure we have now a fixed header, with only 1 value
+ $r->header('Content-Length' => $len);
+
# Plain body specified by "Content-Length"
my $missing = $len - length($buf);
while ($missing > 0) {

9
perl-HTTP-Daemon.changes
View File

@ -1,3 +1,12 @@
-------------------------------------------------------------------
Wed Jul 13 09:04:49 UTC 2022 - Otto Hollmann <otto.hollmann@suse.com>
- Fix request smuggling in HTTP::Daemon
(CVE-2022-31081, bsc#1201157)
* CVE-2022-31081.patch
* CVE-2022-31081-2.patch
* CVE-2022-31081-Add-new-test-for-Content-Length-issues.patch
------------------------------------------------------------------- -------------------------------------------------------------------
Fri Mar 4 03:07:35 UTC 2022 - Tina Müller <timueller+perl@suse.de> Fri Mar 4 03:07:35 UTC 2022 - Tina Müller <timueller+perl@suse.de>

9
perl-HTTP-Daemon.spec
View File

@ -20,11 +20,16 @@
Name: perl-HTTP-Daemon Name: perl-HTTP-Daemon
Version: 6.14 Version: 6.14
Release: 0 Release: 0
License: Artistic-1.0 OR GPL-1.0-or-later
Summary: Simple http server class Summary: Simple http server class
License: Artistic-1.0 OR GPL-1.0-or-later
URL: https://metacpan.org/release/%{cpan_name} URL: https://metacpan.org/release/%{cpan_name}
Source0: https://cpan.metacpan.org/authors/id/O/OA/OALDERS/%{cpan_name}-%{version}.tar.gz Source0: https://cpan.metacpan.org/authors/id/O/OA/OALDERS/%{cpan_name}-%{version}.tar.gz
Source1: cpanspec.yml Source1: cpanspec.yml
# PATCH-FIX-SECURITY bsc#1201157 otto.hollmann@suse.com
# Fix request smuggling in HTTP::Daemon
Patch0: CVE-2022-31081.patch
Patch1: CVE-2022-31081-2.patch
Patch2: CVE-2022-31081-Add-new-test-for-Content-Length-issues.patch
BuildArch: noarch BuildArch: noarch
BuildRequires: perl BuildRequires: perl
BuildRequires: perl-macros BuildRequires: perl-macros
@ -65,7 +70,7 @@ method on this object will read data from the client and return an
back various responses. back various responses.
%prep %prep
%autosetup -n %{cpan_name}-%{version} %autosetup -n %{cpan_name}-%{version} -p1
find . -type f ! -path "*/t/*" ! -name "*.pl" ! -path "*/bin/*" ! -path "*/script/*" ! -name "configure" -print0 | xargs -0 chmod 644 find . -type f ! -path "*/t/*" ! -name "*.pl" ! -path "*/bin/*" ! -path "*/script/*" ! -name "configure" -print0 | xargs -0 chmod 644
%build %build