Fix CVE-2026-8450: send_file() honoured 2-arg open() shell-magic

.github/workflows/build-and-test.yml

@@ -28,6 +28,25 @@ jobs:
         with:
           name: build_dir
           path: build_dir
+  lint:
+    name: Lint
+    needs: build
+    runs-on: ubuntu-24.04
+    container:
+      image: perldocker/perl-tester:5.42
+    steps:
+      - uses: actions/checkout@v6
+      - uses: oalders/install-ubi-action@v0.0.6
+        with:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+          projects: |
+            houseabsolute/precious
+            houseabsolute/omegasort
+      - uses: perl-actions/install-with-cpm@v2
+        with:
+          install: App::perlvars
+          sudo: false
+      - run: precious lint --all
   coverage-job:
     needs: build
     runs-on: ubuntu-24.04

Changes

@@ -1,6 +1,18 @@
 Revision history for HTTP-Daemon
 
 {{$NEXT}}
+  - Fix CVE-2026-8450 (affects 6.15 and earlier): 2-arg open() in
+    send_file() enabled RCE / arbitrary file write / response-body
+    exfiltration when a string argument was derived from attacker-
+    influenced input. send_file() now uses 3-arg open() with an
+    explicit '<' read mode, so the path is always treated as a literal
+    filename and 2-arg open() shell-magic shapes ('| cmd', 'cmd |',
+    '> path', etc.) are no longer interpreted. send_file() now also
+    returns '0E0' (true zero) on a successful zero-byte transfer so
+    callers can distinguish empty file from open failure (undef). See
+    https://www.cve.org/CVERecord?id=CVE-2026-8450 for the advisory.
+    Reported and patched by Stig Palmquist (stigtsp). (Stig Palmquist,
+    Olaf Alders)
   - Bump LWP::UserAgent to 6.37 in TestSuggests (GH#65) (Olaf Alders)
 
 6.15      2023-02-22 22:02:46Z

lib/HTTP/Daemon.pm

@@ -598,11 +598,10 @@ sub send_dir {
 sub send_file {
     my ($self, $file) = @_;
     my $opened = 0;
-    local (*FILE);
     if (!ref($file)) {
-        open(FILE, $file) || return undef;
-        binmode(FILE);
-        $file = \*FILE;
+        open(my $fh, '<', $file) || return undef;
+        binmode($fh)             || do { close($fh); return undef };
+        $file = $fh;
         $opened++;
     }
     my $cnt = 0;
@@ -614,7 +613,11 @@ sub send_file {
         print $self $buf;
     }
     close($file) if $opened;
-    $cnt;
+
+    # Return a "true zero" for empty-but-successful copies so callers
+    # using `send_file or die` can distinguish open failure (undef)
+    # from a successful zero-byte transfer.
+    $cnt || '0E0';
 }
 
 sub daemon {
@@ -896,6 +899,28 @@ Copy the file to the client.  The file can be a string (which
 will be interpreted as a filename) or a reference to an C<IO::Handle>
 or glob.
 
+Returns the number of bytes copied on success, or C<undef> if the
+filename form failed to open.  An empty file returns the string
+C<'0E0'> (zero numerically, true in boolean context) so that callers
+using C<< send_file or die >> can distinguish open failure from a
+successful zero-byte transfer.
+
+The filename form uses Perl's 3-argument C<open> with an explicit C<<
+< >> mode, so the path is no longer interpreted as a 2-argument
+C<open> shell-magic shape such as C<< | cmd >>, C<< cmd | >>, or
+C<< > path >>.  See
+L<CVE-2026-8450|https://www.cve.org/CVERecord?id=CVE-2026-8450> for
+the prior 2-argument C<open> behaviour this replaces.
+
+Note that this fix only neutralises 2-argument C<open> shell-magic.
+Callers remain responsible for validating attacker-influenced paths:
+C<send_file> will still happily open symlinks, character/block devices
+(e.g. C</dev/zero>, C</dev/stdin>), named pipes (which may block the
+worker), and files outside an intended document root.  If C<$filename>
+can be derived from request input, validate it (canonicalise, reject
+C<..> segments, require C<-f _> and a vetted prefix) before passing it
+in.
+
 =item $c->daemon
 
 Return a reference to the corresponding C<HTTP::Daemon> object.

precious.toml

@@ -21,3 +21,10 @@ cmd     = ["omegasort", "--sort", "path", "--unique"]
 lint-flags = ["--check"]
 ok-exit-codes = [0]
 lint-failure-exit-codes = [1]
+
+[commands.perlcritic]
+type    = "lint"
+include = ["**/*.{pl,pm,t,psgi}"]
+cmd     = ["perlcritic", "--noprofile", "--single-policy", "InputOutput::ProhibitTwoArgOpen"]
+ok-exit-codes = [0]
+lint-failure-exit-codes = [2]

t/lib/TestServer.pm

@@ -29,26 +29,13 @@ sub lib_dirs {
     return @libs;
 }
 
-sub perl_cmd {
-    my $self = shift;
-    my $perl = $self->perl;
-    $perl = qq["$perl"] if $perl =~ /\s/;
-
-    for my $lib ($self->lib_dirs) {
-        my $quoted = $lib =~ /\s/ ? qq["$lib"] : $lib;
-        $perl .= " -I$quoted";
-    }
-
-    return $perl;
-}
-
 sub start {
     my $self  = shift;
     my $class = ref $self;
 
-    my $perl = $self->perl_cmd;
+    my @perl = ($self->perl, map {"-I$_"} $self->lib_dirs);
 
-    my $pid = open my $DAEMON, "$perl -M$class=run -e1 |"
+    my $pid = open my $DAEMON, '-|', @perl, "-M$class=run", '-e1'
         or die "Can't exec daemon: $!";
 
     my $greeting = <$DAEMON>;

t/send-file-magic-open.t

@@ -0,0 +1,133 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+    if ($^O eq 'MSWin32') {
+        plan skip_all =>
+            'POSIX shell is required to exercise 2-arg open() shell-magic shapes';
+    }
+}
+
+use File::Spec   ();
+use File::Temp   qw(tempfile tempdir);
+use Socket       qw(AF_UNIX SOCK_STREAM PF_UNSPEC);
+use HTTP::Daemon ();    # also defines HTTP::Daemon::ClientConn, which
+                        # is where send_file() actually lives
+
+# Regression test for CVE-2026-8450. send_file() used to call open() in
+# the 2-arg form, which interpreted shell-magic prefixes in the path.
+# The 3-arg form with an explicit '<' mode treats the path as a literal
+# filename. The load-bearing oracle for each shape is a marker file:
+# an unpatched build runs a child that creates the marker, the patched
+# build never does. For the pipe shapes the marker path is passed to
+# the child via an env var (not shell-interpolated) so the test is
+# robust to spaces/quotes in $TMPDIR. For the redirect shape the path
+# goes straight to Perl's open() with no shell, so a literal path is
+# fine there too.
+
+# Stand up a real HTTP::Daemon::ClientConn so $self in send_file is
+# a blessed socket. Any future method dispatch on $self surfaces here
+# instead of silently no-oping against an unblessed scalar filehandle.
+sub make_clientconn {
+    socketpair(my $server, my $client, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
+        or die "socketpair: $!";
+    bless $server, 'HTTP::Daemon::ClientConn';
+    return ($server, $client);
+}
+
+my $tmpdir = tempdir(CLEANUP => 1);
+
+# A perl one-liner that touches $ENV{HTTPD_MAGIC_MARKER}. Single-quoted
+# for the shell so $f / $ENV are seen by perl, not by the shell.
+my $writer
+    = qq{$^X -e 'open my \$f, q{>}, \$ENV{HTTPD_MAGIC_MARKER} or die; close \$f'};
+
+my @magic_shapes = (
+
+    # One pipe shape stands for the whole command-execution family
+    # (| cmd, cmd |, ...). The leading-space spelling is the one kept:
+    # 2-arg open() strips leading whitespace before testing for a magic
+    # prefix, so " | cmd" also exercises that quirk.
+    {name => 'pipe',           shape => sub {" | $writer"}},
+    {name => 'write-redirect', shape => sub { my ($m) = @_; "> $m" }},
+);
+
+for my $case (@magic_shapes) {
+    my $name   = $case->{name};
+    my $marker = File::Spec->catfile($tmpdir, "marker-$name");
+    unlink $marker;
+    my $shape = $case->{shape}->($marker);
+
+    local $ENV{HTTPD_MAGIC_MARKER} = $marker;
+
+    my ($server, $client) = make_clientconn();
+
+    my $rv = $server->send_file($shape);
+
+    is($rv, undef, "[$name] send_file refuses magic shape '$shape'");
+    ok(!-e $marker, "[$name] no on-disk side effect for '$shape'");
+
+    close $server;
+    my $captured = do { local $/; <$client> };
+    $captured = q{} unless defined $captured;
+    is($captured, q{}, "[$name] no bytes streamed for '$shape'");
+}
+
+# Bare "<file" prefix: under 2-arg open() this opens "file" for read,
+# bypassing any path validation a caller may have done on the
+# attacker-supplied string. Under 3-arg open with mode '<' the leading
+# '<' is part of the literal filename, so the open fails and no bytes
+# leak. Place a real file at the would-be target so an unpatched build
+# would actually stream its contents (and the assertion would catch it),
+# rather than failing for the boring reason that the file doesn't exist.
+{
+    my $secret = File::Spec->catfile($tmpdir, 'secret-do-not-leak');
+    open my $f, '>', $secret or die "open $secret: $!";
+    print $f "do-not-leak-this-string\n";
+    close $f;
+
+    my $shape = "<$secret";
+    my ($server, $client) = make_clientconn();
+    my $rv = $server->send_file($shape);
+
+    is($rv, undef, "[bare-lt] send_file refuses magic shape '$shape'");
+    close $server;
+    my $captured = do { local $/; <$client> };
+    $captured = q{} unless defined $captured;
+    unlike($captured, qr/do-not-leak/,
+        '[bare-lt] secret contents did not stream to the client');
+}
+
+# Positive control: an ordinary file still streams through the real
+# blessed ClientConn.
+my ($src_fh, $src) = tempfile(UNLINK => 1);
+binmode $src_fh;
+print $src_fh "hello world\n";
+close $src_fh;
+
+my ($server, $client) = make_clientconn();
+my $rv = $server->send_file($src);
+close $server;
+my $captured = do { local $/; <$client> };
+$captured = q{} unless defined $captured;
+
+ok(defined $rv, 'send_file still works on an ordinary filename');
+cmp_ok($rv, '>', 0, 'non-zero byte count returned');
+like($captured, qr/hello world/, 'file contents reach the client end');
+
+# Return-value contract: an empty-but-successful copy must be
+# distinguishable from open failure. send_file() returns '0E0' (zero
+# numerically, true in boolean context) on success-with-no-bytes so
+# that `send_file or die` only trips on undef.
+{
+    my (undef, $empty) = tempfile(UNLINK => 1);
+    my ($server) = make_clientconn();
+    my $rv = $server->send_file($empty);
+    ok(defined $rv, 'empty file: rv is defined');
+    ok($rv,         'empty file: rv is true (so `or die` does not fire)');
+    cmp_ok($rv, '==', 0, 'empty file: rv compares numerically equal to 0');
+}
+
+done_testing();