Fix linked-server uploads over partial TLS writes

ⓘ Stream linked-server request bodies in bounded chunks, retry partial SSL writes with byte-safe offsets, detect incomplete forwarding, and add regression coverage.

https://github.com/webmin/webmin/issues/2784

servers/link.cgi

@@ -141,10 +141,12 @@ if (($ENV{'HTTP_X_REQUESTED_WITH_PROXY'} || '') eq 'XMLHttpRequest') {
 	&write_http_connection($con, "X-Requested-With: XMLHttpRequest\r\n");
 	}
 &write_http_connection($con, "\r\n");
-my $post;
 if ($cl) {
-	&read_fully(\*STDIN, \$post, $cl);
-	&write_http_connection($con, $post);
+	my $got = &copydata_len(\*STDIN,
+		sub { &write_http_connection($con, $_[0]) },
+		$cl, &get_buffer_size_binary());
+	defined($got) || &error("Failed to forward request body");
+	$got == $cl || &error("Failed to read complete request body");
 	}
 
 # read back the headers

t/web-lib-funcs-io.t

@@ -0,0 +1,109 @@
+#!/usr/bin/perl
+# Unit tests for byte-copying helpers in web-lib-funcs.pl.
+
+use strict;
+use warnings;
+use Test::More;
+use File::Basename qw(dirname);
+use File::Spec;
+use bytes ();
+
+my $script = File::Spec->rel2abs(
+	File::Spec->catfile(dirname(__FILE__), '..', 'web-lib-funcs.pl'));
+require $script;
+
+subtest 'copydata_len to file handle' => sub {
+	my $source = "abcdef";
+	my $dest = "";
+	open(my $in, '<', \$source) or die "open input scalar: $!";
+	open(my $out, '>', \$dest) or die "open output scalar: $!";
+
+	is(main::copydata_len($in, $out, 4, 2), 4,
+	   'reports copied byte count');
+	is($dest, 'abcd', 'copies only the requested bytes');
+
+	my $left = <$in>;
+	is($left, 'ef', 'leaves bytes past the requested length unread');
+};
+
+subtest 'copydata_len to writer callback' => sub {
+	my $source = "0123456789";
+	my @chunks;
+	open(my $in, '<', \$source) or die "open input scalar: $!";
+
+	is(main::copydata_len($in, sub { push(@chunks, $_[0]); 1 }, 7, 3),
+	   7, 'reports bytes copied through callback');
+	is(join('', @chunks), '0123456', 'callback receives requested data');
+	is_deeply([ map { length($_) } @chunks ], [ 3, 3, 1 ],
+		  'callback receives bounded chunks');
+};
+
+subtest 'copydata_len short input and write failure' => sub {
+	my $short = "abc";
+	my $dest = "";
+	open(my $in, '<', \$short) or die "open input scalar: $!";
+	open(my $out, '>', \$dest) or die "open output scalar: $!";
+
+	is(main::copydata_len($in, $out, 5, 2), 3,
+	   'short input returns actual copied byte count');
+	is($dest, 'abc', 'short input copies available bytes');
+
+	my $source = "abcdef";
+	open(my $fail_in, '<', \$source) or die "open input scalar: $!";
+	is(main::copydata_len($fail_in, sub { 0 }, 4, 2), undef,
+	   'writer callback failure returns undef');
+};
+
+subtest 'write_http_connection retries partial SSL writes' => sub {
+	my @writes;
+	{
+		no warnings 'redefine';
+		local *Net::SSLeay::write = sub {
+			my ($ssl, $data) = @_;
+			push(@writes, $data);
+			return length($data) > 2 ? 2 : length($data);
+			};
+
+		ok(main::write_http_connection(
+			{ ssl_ctx => 1, ssl_con => 'ssl' }, 'abcde'),
+		   'partial SSL writes eventually succeed');
+		}
+	is_deeply(\@writes, [ 'abcde', 'cde', 'e' ],
+		  'remaining bytes are retried after each partial write');
+};
+
+subtest 'write_http_connection uses byte offsets for UTF-8 strings' => sub {
+	my $source = "\x{100}\x{101}\x{102}";
+	my @accepted;
+	{
+		no warnings 'redefine';
+		local *Net::SSLeay::write = sub {
+			my ($ssl, $data) = @_;
+			my $len = bytes::length($data);
+			my $wrote = $len > 3 ? 3 : $len;
+			push(@accepted,
+			     unpack('H*', bytes::substr($data, 0, $wrote)));
+			return $wrote;
+			};
+
+		ok(main::write_http_connection(
+			{ ssl_ctx => 1, ssl_con => 'ssl' }, $source),
+		   'partial SSL writes preserve a UTF-8-flagged scalar');
+		}
+	is(join('', @accepted),
+	   unpack('H*', bytes::substr($source, 0, bytes::length($source))),
+	   'byte-count return values are applied as byte offsets');
+};
+
+subtest 'write_http_connection fails on SSL write error' => sub {
+	{
+		no warnings 'redefine';
+		local *Net::SSLeay::write = sub { return 0; };
+
+		ok(!main::write_http_connection(
+			{ ssl_ctx => 1, ssl_con => 'ssl' }, 'abc'),
+		   'zero-byte SSL write is reported as failure');
+		}
+};
+
+done_testing();

web-lib-funcs.pl

@@ -16,6 +16,7 @@ Example code:
 use Socket;
 use POSIX;
 use IO::Handle;
+use bytes ();
 use feature 'state';
 eval "use Socket6";
 $ipv6_module_error = $@;
@@ -928,6 +929,38 @@ while(read($in, $buf, $bs) > 0) {
 return 1;
 }
 
+=head2 copydata_len(in-handle, out-handle|&writer, length, [buffer-size])
+
+Read a fixed number of bytes from one file handle and write them to another,
+or pass each chunk to a writer function. The writer must synchronously consume
+the entire chunk and return true on success. Returns the number of bytes
+copied, or undef if a read or write fails.
+
+=cut
+sub copydata_len
+{
+my ($in, $out, $len, $bs) = @_;
+$in = &callers_package($in);
+$out = &callers_package($out) if (ref($out) ne 'CODE');
+$bs ||= &get_buffer_size();
+my $got = 0;
+while($got < $len) {
+	my $want = $len - $got;
+	$want = $bs if ($want > $bs);
+	my $buf;
+	my $r = read($in, $buf, $want);
+	if (!defined($r)) {
+		next if ($!{'EINTR'});
+		return undef;
+		}
+	last if (!$r);
+	my $ok = ref($out) eq 'CODE' ? &$out($buf) : print $out $buf;
+	return undef if (!$ok);
+	$got += $r;
+	}
+return $got;
+}
+
 =head2 ReadParseMime([maximum], [&cbfunc, &cbargs], [array-mode], [&direct-write])
 
 Read data submitted via a POST request using the multipart/form-data coding,
@@ -9893,9 +9926,21 @@ my $h = shift(@_);
 my $fh = $h->{'fh'};
 my $allok = 1;
 if ($h->{'ssl_ctx'}) {
+	# Net::SSLeay::write returns a byte count, but regular length/substr may
+	# count characters for UTF-8-flagged strings. Mixing those units could
+	# end the retry loop early or skip data, so track lengths and offsets in
+	# bytes.
 	foreach my $s (@_) {
-		my $ok = Net::SSLeay::write($h->{'ssl_con'}, $s);
-		$allok = 0 if (!$ok);
+		my $len = bytes::length($s);
+		my $got = 0;
+		while($got < $len) {
+			my $ok = Net::SSLeay::write(
+				$h->{'ssl_con'}, bytes::substr($s, $got));
+			if (!defined($ok) || $ok <= 0) {
+				return 0;
+				}
+			$got += $ok;
+			}
 		}
 	}
 else {