#!/usr/local/cpanel/3rdparty/bin/perl

#                                      Copyright 2026 WebPros International, LLC
#                                                           All rights reserved.
# copyright@cpanel.net                                         http://cpanel.net
# This code is subject to the cPanel license. Unauthorized copying is prohibited.

package scripts::comet_pkgacct_stream_guard;

use cPstrict;

=encoding utf-8

=head1 NAME

comet_pkgacct_stream_guard - fail a Comet backup rather than vault a corrupted
C<pkgacct --stdout-archive> stream (CPANEL-55666)

=head1 SYNOPSIS

comet_pkgacct_stream_guard <cpanel_user> [ pkgacct option ... ]

=head1 DESCRIPTION

The legacy C<databases_program_output> and C<pkgacct_program_output> Protected
Items are C<engine1/stdout> sources: the Comet C<backup-tool> agent forks the
item's C<EngineProps.COMMAND> and streams the command's STDOUT straight into the
Storage Vault. Under C<--stdout-archive>, B<STDOUT IS THE ARCHIVE>.

That makes any core code path which prints to STDOUT during a C<pkgacct> run a
silent data-loss hazard, and there is one:
C<Cpanel::Pkgacct::Components::Mysql> hardcodes C<< ERRORS_TO_STDOUT => 1 >>
(Mysql.pm:673) and C<Cpanel::DBAdmin> raw-prints its error text to STDOUT
(DBAdmin.pm:201). A single stale C<dbmap> entry therefore PREPENDS a few hundred
bytes of human-readable error text to the gzip stream. C<pkgacct> still exits
B<0> with an empty STDERR, so the agent records a perfectly successful backup of
an archive that C<gzip> cannot open and C<restorepkg> cannot extract. The core
half of that is a separate case; this guard is the plugin's half.

C<run()> forks C<pkgacct> with its STDOUT on a pipe and inspects the FIRST TWO
BYTES (after any leading blank bytes) before anything reaches our own STDOUT:

=over 4

=item * B<leading blank bytes> — up to C<$MAX_LEADING_WHITESPACE_BYTES> of
C<\n>, C<\r>, space and tab ahead of the gzip magic are skipped and NOT written
(CPANEL-57691: core C<pkgacct> prints blank lines before the archive for accounts
with Mailman lists). How many were skipped is logged to
C</var/log/comet_backup.log>, NOT to STDERR: the agent grades any STDERR output as
a warning (Comet 7001), which fails the backup. The checks below apply to the
first two bytes after them.

=item * B<gzip magic (C<\x1f\x8b>)> — the two bytes are written through and the
rest of the stream is pumped verbatim to STDOUT until EOF. On the happy path
this is a pure passthrough, so the vaulted CONTENT is byte-identical to what the
un-wrapped C<pkgacct> COMMAND produced. C<pkgacct>'s own exit status is then
propagated.

=item * B<anything else> — this is the corruption case, and the leading bytes
ARE the error message the administrator needs. Up to
C<$MAX_CAPTURED_GARBAGE_BYTES> of them are captured and printed to STDERR (which
the agent files into the Comet job log), the rest of the stream is DRAINED AND
DISCARDED, and the guard exits non-zero having written B<ZERO BYTES> to STDOUT.

=item * B<EOF before two bytes> — an empty stream. Nothing is written, a
diagnostic naming CPANEL-55666 goes to STDERR, and the guard exits non-zero.

=back

B<Zero bytes on STDOUT is load-bearing, not tidiness.> Comet grades a
C<engine1/stdout> job that exits non-zero having produced SOME output as a
FAILED_WARNING rather than a hard failure, and this plugin's own
C<_warning_completion_is_success> treats several warning shapes as success. A
non-zero exit with no output is what makes the job unambiguously failed, so a
corrupted snapshot is never recorded as a restore point.

B<There is deliberately NO full-stream gunzip validation, and that is a design
decision rather than an omission.> C<pkgacct> dumps every database into its
working directory B<before> it streams the tar, so the whole demonstrated error
class — C<DBAdmin> printing to STDOUT from the C<Mysql> component — lands
B<ahead> of the archive bytes. A two-byte head check therefore covers it at zero
streaming cost, whereas decompressing every byte of a multi-gigabyte account
archive in-line would double the CPU of every legacy backup to catch a class of
corruption nobody has observed.

The C<pkgacct> path lives in the package variable C<$PKGACCT_BIN> purely so the
unit suite can point it at a fixture after C<do>-loading this file. It is
B<deliberately not> settable from the environment or the command line: this
program is exec'd by the backup agent from a string stored on the Comet server,
so an override would be runtime attack surface for no operational gain.

=cut

# Path to the real pkgacct. A package variable ONLY so t/small can retarget it
# after do-loading this file; never read from %ENV or @ARGV (see the DESCRIPTION).
our $PKGACCT_BIN = '/usr/local/cpanel/scripts/pkgacct';

# gzip's two-byte file magic. pkgacct --stdout-archive always emits a gzip
# stream (it is a .tar.gz), so these are the first two bytes of every good run.
our $GZIP_MAGIC = "\x1f\x8b";

# How much of a corrupted stream's leading garbage is echoed to STDERR. The
# DBAdmin error text this exists to surface is a few hundred bytes; the cap
# keeps a pathological stream from flooding the Comet job log.
our $MAX_CAPTURED_GARBAGE_BYTES = 4096;

our $READ_CHUNK_BYTES = 65_536;

# CPANEL-57691: core pkgacct can print a few blank lines to STDOUT before the
# archive (seen with Mailman lists on 138: "\n\n\n" then the gzip data). Up to
# this many leading whitespace bytes (\n, \r, space, tab) are skipped before the
# gzip magic is required. The cap keeps a stream of nothing but whitespace from
# being read forever.
our $MAX_LEADING_WHITESPACE_BYTES = 4096;

exit run(@ARGV) unless caller;

=head1 FUNCTIONS

=head2 run( @argv )

Runs C<$PKGACCT_BIN @argv> behind the head check described above. Returns the
process exit code: 0 only when the stream carried gzip magic, was pumped through
in full, and C<pkgacct> itself exited 0.

=cut

sub run (@argv) {

    # A vanished consumer must not kill us mid-write: with SIGPIPE ignored the
    # syswrite below fails EPIPE instead, so the child is still reaped and an
    # exit code is still chosen deliberately.
    local $SIG{'PIPE'} = 'IGNORE';

    binmode STDOUT;

    my $out_fh = _spawn_pkgacct(@argv) or return 1;

    my ( $skipped, $head ) = _read_head($out_fh);

    return _refuse_truncated_stream( $out_fh, $head )         if !defined $head || length($head) < length $GZIP_MAGIC;
    return _refuse_corrupt_stream( $out_fh, $head, $skipped ) if $head ne $GZIP_MAGIC;

    _note( 'Skipped blank bytes that pkgacct printed before the account backup archive', { user => $argv[0] // '', bytes => $skipped } ) if $skipped;

    return _pass_stream_through( $out_fh, $head );
}

=head2 _read_head( $fh )

Reads the stream's head: skips up to C<$MAX_LEADING_WHITESPACE_BYTES> leading
whitespace bytes (C<\n>, C<\r>, space, tab), then reads the next two bytes.
Returns C<( $skipped_count, $head )>. C<$head> is C<undef> on a read error and
shorter than two bytes at EOF. Once the cap is reached a further whitespace byte
is NOT skipped, so it becomes part of C<$head> and the stream is refused.

The skipped bytes are dropped; everything from the gzip magic on is passed
through unchanged, so the stored archive is exactly the gzip data.

=cut

sub _read_head ($fh) {
    my $skipped = 0;
    my $byte;

    while (1) {
        $byte = _read_exactly( $fh, 1 );
        return ( $skipped, $byte ) if !defined $byte                     || !length $byte;
        last                       if $byte !~ m{\A[\x09\x0a\x0d\x20]\z} || $skipped >= $MAX_LEADING_WHITESPACE_BYTES;
        $skipped++;
    }

    my $rest = _read_exactly( $fh, length($GZIP_MAGIC) - 1 );
    return ( $skipped, defined $rest ? $byte . $rest : undef );
}

# Forks $PKGACCT_BIN with its STDOUT on a pipe we own. STDERR is inherited on
# purpose: pkgacct's own diagnostics belong in the Comet job log unchanged.
sub _spawn_pkgacct (@argv) {
    my $fh;
    my $pid = open( $fh, '-|', $PKGACCT_BIN, @argv );

    if ( !$pid ) {
        my $err = $!;
        _diag("could not run $PKGACCT_BIN: $err");
        _diag('No backup data was produced.');
        return;
    }

    binmode $fh;
    return $fh;
}

# EOF (or a read error) before even the two magic bytes could be read. Reported
# separately from the wrong-magic case because the operator's next step differs:
# there is no leading garbage to read here, only an archive that was not produced.
sub _refuse_truncated_stream ( $out_fh, $head ) {
    my $got    = defined $head ? length $head : 0;
    my $status = _reap($out_fh);

    _diag("the account backup produced no data (it ended after $got byte(s)).");
    _diag( sprintf( 'pkgacct exited with status %d. The backup failed and nothing was stored.', _exit_code_from_status($status) ) );

    return 1;
}

# Wrong magic: the leading bytes are error TEXT that core printed into the
# archive stream. Surface them, discard the stream, write nothing.
sub _refuse_corrupt_stream ( $out_fh, $head, $skipped = 0 ) {
    my $captured = $head . _drain( $out_fh, $MAX_CAPTURED_GARBAGE_BYTES - length $head );
    my $status   = _reap($out_fh);

    my $hex = join( ' ', map { sprintf( '0x%02x', ord ) } split( //, $head ) );

    _diag('the account backup data is not a valid archive and was discarded. The backup failed.');
    _diag( $skipped ? "After $skipped blank byte(s), the next two bytes were $hex, expected 0x1f 0x8b." : "First two bytes were $hex, expected 0x1f 0x8b." );
    _diag( sprintf( 'pkgacct exited with status %d.', _exit_code_from_status($status) ) );
    _diag('The error text pkgacct printed is shown below:');
    _diag_block($captured);

    return 1;
}

# Happy path: write the magic we consumed, then pump the rest verbatim.
sub _pass_stream_through ( $out_fh, $head ) {
    my $pump   = _write_all($head) ? _pump($out_fh) : 'write_error';
    my $status = _reap($out_fh);

    if ( $pump eq 'write_error' ) {

        # The vault side went away. Quiet on purpose: this is not a corrupted
        # snapshot, it is a consumer that stopped reading, and the agent already
        # knows why.
        _diag('the backup destination stopped reading before the backup finished; aborting.');
        return 1;
    }

    if ( $pump eq 'read_error' ) {
        _diag('could not read all of the account backup data. The backup failed.');
        return 1;
    }

    my $exit_code = _exit_code_from_status($status);
    if ($exit_code) {
        _diag("pkgacct exited with status $exit_code. The backup failed.");
        return $exit_code;
    }

    return 0;
}

=head2 _read_exactly( $fh, $want )

Reads exactly C<$want> bytes, looping over short C<sysread>s. Returns the bytes
read (possibly fewer than C<$want> at EOF), or C<undef> on a read error.

=cut

sub _read_exactly ( $fh, $want ) {
    my $buf = '';

    while ( length($buf) < $want ) {
        my $got = sysread( $fh, my $chunk, $want - length($buf) );
        return undef if !defined $got;
        last         if $got == 0;
        $buf .= $chunk;
    }

    return $buf;
}

# Reads the rest of the stream to EOF, keeping at most $limit bytes of it. The
# child is NEVER killed: it is left to finish writing into a pipe we are
# draining, which is what keeps this a clean reap instead of a SIGPIPE race.
sub _drain ( $fh, $limit ) {
    my $captured = '';

    while (1) {
        my $got = sysread( $fh, my $chunk, $READ_CHUNK_BYTES );
        last if !defined $got || $got == 0;

        my $room = $limit - length $captured;
        $captured .= substr( $chunk, 0, $room ) if $room > 0;
    }

    return $captured;
}

# Copies $fh to STDOUT until EOF. Returns 'ok', 'read_error' or 'write_error'.
sub _pump ($fh) {
    while (1) {
        my $got = sysread( $fh, my $chunk, $READ_CHUNK_BYTES );
        return 'read_error'  if !defined $got;
        last                 if $got == 0;
        return 'write_error' if !_write_all($chunk);
    }

    return 'ok';
}

# syswrite can be short; loop until the whole buffer is out. Returns 0 on any
# write failure, EPIPE included (SIGPIPE is ignored by run()).
sub _write_all ($data) {
    my $len     = length $data;
    my $written = 0;

    while ( $written < $len ) {
        my $wrote = syswrite( STDOUT, $data, $len - $written, $written );
        return 0 if !defined $wrote;
        $written += $wrote;
    }

    return 1;
}

# Closing a piped filehandle waits for the child and puts its wait status in $?.
sub _reap ($fh) {
    close $fh;
    return $?;
}

sub _exit_code_from_status ($status) {
    return 0 if !$status;

    my $code = $status >> 8;
    return $code if $code > 0 && $code < 256;

    # Death by signal, or a status we cannot express as an exit code.
    return 1;
}

# CPANEL-57691: a note for /var/log/comet_backup.log, never STDERR. The agent grades an
# engine1 job that wrote anything to STDERR as a warning (Comet status 7001), and the
# plugin fails a warning, so a line on STDERR would fail the very backup it describes.
# Fail-soft and silent: a log that cannot be written must not change the result.
sub _note ( $message, $context = {} ) {
    local $@;
    local $SIG{'__WARN__'} = sub { };
    eval {
        require Whostmgr::CometBackup::Logger;
        Whostmgr::CometBackup::Logger->new()->info( $message, $context );
        1;
    };
    return;
}

sub _diag ($message) {
    print {*STDERR} "comet_pkgacct_stream_guard: $message\n";
    return;
}

# Echoes captured stream bytes, rendering anything that is not printable ASCII
# (or tab/newline) as an escape so a binary fragment cannot mangle the job log.
sub _diag_block ($bytes) {
    my $rendered = $bytes;
    $rendered =~ s{([^\x09\x0a\x20-\x7e])}{sprintf( '\\x%02x', ord $1 )}ge;

    print {*STDERR} "--- begin captured stream head ---\n$rendered\n--- end captured stream head ---\n";
    return;
}

1;