From af03addfcbcd7ba09602f3947fd4d88e5a136094 Mon Sep 17 00:00:00 2001 From: Ricardo Signes Date: Sun, 30 Apr 2023 20:48:42 +0200 Subject: [PATCH] xxx package errors --- lib/PAUSE/Indexer/Context.pm | 83 +++++++++++++++++++++++ lib/PAUSE/Indexer/Errors.pm | 125 ++++++++++++++++++++++++++-------- lib/PAUSE/dist.pm | 15 +++-- lib/PAUSE/mldistwatch.pm | 6 +- lib/PAUSE/package.pm | 126 ++++++++++------------------------- lib/PAUSE/pmfile.pm | 1 + t/lib/Mock/Dist.pm | 2 +- t/lib/PAUSE/Test/pmfile.pm | 11 ++- t/mldistwatch-misc.t | 2 +- 9 files changed, 235 insertions(+), 136 deletions(-) diff --git a/lib/PAUSE/Indexer/Context.pm b/lib/PAUSE/Indexer/Context.pm index 5eed3a6e5..8ad71a1da 100644 --- a/lib/PAUSE/Indexer/Context.pm +++ b/lib/PAUSE/Indexer/Context.pm @@ -28,9 +28,92 @@ sub add_package_warning { text => $warning, }; + $Logger->log([ + "adding package warning to %s: %s", + $package_obj->{PACKAGE}, + $list->[-1], + ]); + + return; +} + +has package_status => ( + is => 'bare', + reader => '_package_status', + default => sub { {} }, +); + +sub _set_package_error { + my ($self, $package_obj, $status) = @_; + + # XXX remove this block when ->index_status is dead + $package_obj->{FIO}{DIO}->index_status( + $self, + $package_obj->{PACKAGE}, + $package_obj->{PP}{version}, + $package_obj->{PP}{infile}, + 2, # OK + $status->{header}, + ); + + $self->_package_status->{ $package_obj->{PACKAGE} } = { + is_success => 0, + filename => $package_obj->{PP}{infile}, + version => $package_obj->{PP}{version}, + header => $status->{header}, + body => $status->{body}, + }; + + $Logger->log([ + "set error status for %s", + $package_obj->{PACKAGE}, + ]); + return; } +sub record_package_indexing { + my ($self, $package_obj) = @_; + + # XXX remove this block when ->index_status is dead + $package_obj->{FIO}{DIO}->index_status( + $self, + $package_obj->{PACKAGE}, + $package_obj->{PP}{version}, + $package_obj->{PP}{infile}, + 1, # OK + "it worked", + ); + + $self->_package_status->{ $package_obj->{PACKAGE} } = { + is_success => 1, + filename => $package_obj->{PP}{infile}, + version => $package_obj->{PP}{version}, + header => "package indexed successfully", + body => "the package was indexed successfully", + }; + + $Logger->log([ + "set OK status for %s", + $package_obj->{PACKAGE}, + ]); + + return; +} + +sub abort_indexing_package { + my ($self, $package_obj, $error) = @_; + + $Logger->log("abort indexing $package_obj->{PACKAGE}"); + + $self->_set_package_error($package_obj, $error); + + die PAUSE::Indexer::Abort::Package->new({ + message => $error->{header}, + public => 1, + }); +} + sub warnings_for_all_packages { my ($self) = @_; diff --git a/lib/PAUSE/Indexer/Errors.pm b/lib/PAUSE/Indexer/Errors.pm index 400d68384..2425edca7 100644 --- a/lib/PAUSE/Indexer/Errors.pm +++ b/lib/PAUSE/Indexer/Errors.pm @@ -3,22 +3,14 @@ use v5.12.0; use warnings; use Sub::Exporter -setup => { - exports => [ 'ERROR' ], - groups => { default => [ 'ERROR' ] }, + exports => [ qw( DISTERROR PKGERROR ) ], + groups => { default => [ qw( DISTERROR PKGERROR ) ] }, }; -my %ERROR; +sub dist_error; +sub pkg_error; -sub public_error { - my ($name, $arg) = @_; - $ERROR{$name} = { - ident => $name, - public => 1, - %$arg, - }; -} - -public_error blib => { +dist_error blib => { header => 'archive contains a "blib" directory', body => <<'EOF' The distribution contains a blib/ directory and is therefore not being indexed. @@ -26,7 +18,7 @@ Hint: try 'make dist'. EOF }; -public_error multiroot => { +dist_error multiroot => { header => 'archive has multiple roots', body => sub { my ($dist) = @_; @@ -38,7 +30,7 @@ EOF }, }; -public_error no_distname_permission => { +dist_error no_distname_permission => { header => 'missing permissions on distname package', body => sub { my ($dist) = @_; @@ -57,7 +49,7 @@ EOF }, }; -public_error no_meta => { +dist_error no_meta => { header => "no META.yml or META.json found", body => <<'EOF', Your archive didn't contain a META.json or META.yml file. You need to include @@ -66,7 +58,7 @@ ExtUtils::MakeMaker can help with this. EOF }; -public_error single_pm => { +dist_error single_pm => { header => 'dist is a single-.pm-file upload', body => <<"EOF", You've uploaded a compressed .pm file without a META.json, a build tool, or the @@ -75,7 +67,7 @@ no longer is. Please use a CPAN distribution building tool. EOF }; -public_error unstable_release => { +dist_error unstable_release => { header => 'META release_status is not stable', body => <<'EOF', Your META file provides a release status other than "stable", so this @@ -83,7 +75,7 @@ distribution will not be indexed. EOF }; -public_error worldwritable => { +dist_error worldwritable => { header => 'archive has world writable files', body => sub { my ($dist) = @_; @@ -95,7 +87,7 @@ EOF }, }; -public_error xact_fail => { +dist_error xact_fail => { header => "ERROR: Database error occurred during index update", body => <<'EOF', This distribution was not indexed due to database errors. You can request @@ -103,21 +95,102 @@ another indexing attempt be made by logging into https://pause.perl.org/ EOF }; -sub ERROR { +pkg_error bad_package_name => { + header => 'Not indexed because of invalid package name.', + body => <<'EOF', +This package wasn't indexed because its name doesn't conform to standard +naming. Basically: one or more valid identifiers, separated by double colons +(::). +EOF +}; + +pkg_error no_permission => { + header => 'Not indexed because the required permissions were missing.', + body => <<'EOF', +This package wasn't indexed because you don't have permission to use this +package name. Hint: you can always find the legitimate maintainer(s) on PAUSE +under "View Permissions". +EOF +}; + +pkg_error version_openerr => { + header => 'Not indexed because of version handling error.', + body => <<'EOF', +The PAUSE indexer was not able to read the file. +EOF +}; + +pkg_error version_parse => { + header => 'Not indexed because of version parsing error.', + body => <<'EOF', +The PAUSE indexer was not able to parse the file. + +Note: the indexer is running in a Safe compartement and cannot provide the full +functionality of perl in the VERSION line. It is trying hard, but sometime it +fails. As a workaround, please consider writing a META.yml that contains a +"provides" attribute, or contact the CPAN admins to investigate (yet another) +workaround against "Safe" limitations. +EOF +}; + +pkg_error version_too_long => { + header => 'Not indexed because the version string was too long.', + body => <<'EOF', +The maximum length of a version string is 16 bytes, which is already quite +long. Please consider picking a shorter version. +EOF +}; + +pkg_error wtf => { + header => 'Not indexed: something surprising happened.', + body => <<'EOF', +The PAUSE indexer couldn't index this package. It ended up with a weird +internal state, like thinking your package name was empty or your version was +undefined. If you see this, you should probably contact the PAUSE admins. +EOF +}; + +my %DIST_ERROR; +my %PKG_ERROR; + +sub DISTERROR { + my ($ident) = @_; + + my $error = $DIST_ERROR{$ident}; + unless ($error) { + Carp::confess("requested unknown distribution error: $ident"); + } + + return $error; +} + +sub PKGERROR { my ($ident) = @_; - my $error = PAUSE::Indexer::Errors->error_named($ident); + my $error = $PKG_ERROR{$ident}; unless ($error) { - Carp::confess("requested unknown error: $ident"); + Carp::confess("requested unknown package error: $ident"); } return $error; } -sub error_named { - my ($self, $ident) = @_; +sub dist_error { + my ($name, $arg) = @_; + $DIST_ERROR{$name} = { + ident => $name, + public => 1, + %$arg, + }; +} - return $ERROR{$ident}; +sub pkg_error { + my ($name, $arg) = @_; + $PKG_ERROR{$name} = { + ident => $name, + public => 1, + %$arg, + }; } 1; diff --git a/lib/PAUSE/dist.pm b/lib/PAUSE/dist.pm index d77461c80..5db3af0a9 100644 --- a/lib/PAUSE/dist.pm +++ b/lib/PAUSE/dist.pm @@ -298,7 +298,7 @@ sub examine_dist { } } elsif ($dist =~ /\.pm\.(?:Z|gz|bz2)$/) { $self->{SUFFIX} = "N/A"; - $ctx->abort_indexing_dist(ERROR('single_pm')); + $ctx->abort_indexing_dist(DISTERROR('single_pm')); } elsif ($dist =~ /\.zip$/) { $self->{SUFFIX} = "zip"; my $unzipbin = $self->hub->{UNZIPBIN}; @@ -573,7 +573,7 @@ sub check_blib { my ($self, $ctx) = @_; if (grep m|^[^/]+/blib/|, @{$self->{MANIFOUND}}) { $self->{HAS_BLIB}++; - $ctx->abort_indexing_dist(ERROR('blib')); + $ctx->abort_indexing_dist(DISTERROR('blib')); } # sometimes they package their stuff deep inside a hierarchy my @found = @{$self->{MANIFOUND}}; @@ -598,7 +598,7 @@ sub check_blib { # more than one entry in this directory means final check if (grep m|^blib/|, @found) { $self->{HAS_BLIB}++; - $ctx->abort_indexing_dist(ERROR('blib')); + $ctx->abort_indexing_dist(DISTERROR('blib')); } last DIRDOWN; } @@ -610,7 +610,7 @@ sub check_multiple_root { my @top = grep { s|/.*||; !$seen{$_}++ } map { $_ } @{$self->{MANIFOUND}}; if (@top > 1) { $self->{HAS_MULTIPLE_ROOT} = \@top; - $ctx->abort_indexing_dist(ERROR('multiroot')); + $ctx->abort_indexing_dist(DISTERROR('multiroot')); } else { $self->{DISTROOT} = $top[0]; } @@ -633,7 +633,7 @@ sub check_world_writable { $Logger->log([ "archive has world writable files: %s", [ sort @ww ] ]); $self->{HAS_WORLD_WRITABLE} = \@ww; - $ctx->abort_indexing_dist(ERROR('worldwritable')); + $ctx->abort_indexing_dist(DISTERROR('worldwritable')); } sub filter_pms { @@ -827,6 +827,7 @@ sub examine_pms { } if ($indexing_method) { + $Logger->log("indexing via $indexing_method"); $self->$indexing_method($ctx, $pmfiles, $provides); } else { $ctx->alert("Couldn't determine an indexing method!"); @@ -921,7 +922,7 @@ sub extract_readme_and_meta { unless ($json || $yaml) { $self->{METAFILE} = "No META.yml or META.json found"; - $ctx->abort_indexing_dist(ERROR('no_meta')); + $ctx->abort_indexing_dist(DISTERROR('no_meta')); return; } @@ -971,7 +972,7 @@ sub check_indexability { if (($self->{META_CONTENT}{release_status} // 'stable') ne 'stable') { # META.json / META.yml declares it's not stable; do not index! - $ctx->abort_indexing_dist(ERROR('unstable_release')); + $ctx->abort_indexing_dist(DISTERROR('unstable_release')); return; } } diff --git a/lib/PAUSE/mldistwatch.pm b/lib/PAUSE/mldistwatch.pm index d1079dbf6..54af18696 100644 --- a/lib/PAUSE/mldistwatch.pm +++ b/lib/PAUSE/mldistwatch.pm @@ -370,10 +370,10 @@ sub _do_the_database_work { my $main_pkg = $dio->_package_governing_permission; if ($self->permissions->userid_has_permissions_on_package($dio->{USERID}, $main_pkg)) { - $dbh->commit; + my $ok = $dbh->commit; } else { $ctx->alert("Uploading user has no permissions on package $main_pkg"); - $ctx->add_dist_error(ERROR('no_distname_permission')); + $ctx->add_dist_error(DISTERROR('no_distname_permission')); $dbh->rollback; } @@ -493,7 +493,7 @@ sub maybe_index_dist { if ($attempt == 3) { $Logger->log_debug("tried $attempt times to do db work, but all failed"); $ctx->alert("database errors while indexing"); - $ctx->add_dist_error(ERROR('xact_fail')); + $ctx->add_dist_error(DISTERROR('xact_fail')); } } diff --git a/lib/PAUSE/package.pm b/lib/PAUSE/package.pm index 50652587d..844929846 100644 --- a/lib/PAUSE/package.pm +++ b/lib/PAUSE/package.pm @@ -6,6 +6,7 @@ use vars qw($AUTOLOAD); use PAUSE::Logger '$Logger'; use PAUSE::mldistwatch::Constants; +use PAUSE::Indexer::Errors; use CPAN::DistnameInfo; =comment @@ -108,7 +109,7 @@ sub give_regdowner_perms { # on Foo is the same as having it on foo # package PAUSE::package; -sub perm_check { +sub assert_permissions_okay { my ($self, $ctx) = @_; my $dist = $self->{DIST}; my $package = $self->{PACKAGE}; @@ -159,18 +160,7 @@ sub perm_check { // "unknown"; my $error = "not owner"; - my $message = qq{Not indexed because permission missing. -Current registered primary maintainer is $owner. -Hint: you can always find the legitimate maintainer(s) on PAUSE under -"View Permissions".}; - $self->index_status($ctx, - $package, - $pp->{version}, - $pp->{infile}, - PAUSE::mldistwatch::Constants::EMISSPERM, - $message, - ); $ctx->alert(qq{$error: package[$package] version[$pp->{version}] @@ -180,7 +170,8 @@ userid[$userid] owners[@owners] owner[$owner] }); - return; # early return + + $ctx->abort_indexing_package($self, PKGERROR('no_permission')); } } else { @@ -251,17 +242,12 @@ sub examine_pkg { # should they be cought earlier? Maybe. # but as an ultimate sanity check suggested by Richard Soderberg if ($self->_pkg_name_insane($ctx)) { - $Logger->log("package[$package] name seems illegal"); - delete $self->{FIO}; # circular reference - return; + $ctx->abort_indexing_package($self, "invalid package name"); } # Query all users with perms for this package - unless ($self->perm_check($ctx)) { # (P2.0&P3.0) - delete $self->{FIO}; # circular reference - return; - } + $self->assert_permissions_okay($ctx); # Check that package name matches case of file name { @@ -284,48 +270,19 @@ sub examine_pkg { if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error my $err = JSON::jsonToObj($pp->{version}); if ($err->{openerr}) { - $self->index_status($ctx, - $package, - "undef", - $pp->{infile}, - PAUSE::mldistwatch::Constants::EOPENFILE, - - qq{The PAUSE indexer was not able to - read the file. It issued the following error: C< $err->{openerr} >}, - ); - } else { - $self->index_status($ctx, - $package, - "undef", - $pp->{infile}, - PAUSE::mldistwatch::Constants::EPARSEVERSION, - - qq{The PAUSE indexer was not able to - parse the following line in that file: C< $err->{line} > - - Note: the indexer is running in a Safe compartement and cannot - provide the full functionality of perl in the VERSION line. It - is trying hard, but sometime it fails. As a workaround, please - consider writing a META.yml that contains a 'provides' - attribute or contact the CPAN admins to investigate (yet - another) workaround against "Safe" limitations.)}, - - ); + # TODO: get $err->{openerr} back in here, I guess? + $ctx->abort_indexing_package($self, PKGERROR('version_openerr')); } - delete $self->{FIO}; # circular reference - return; + + # TODO: get $err->{line} back in here, I guess? + $ctx->abort_indexing_package($self, PKGERROR('version_parse')); } # Sanity checks - - for ( - $package, - $pp->{version}, - $dist - ) { - if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here - delete $self->{FIO}; # circular reference - return; # don't screw up 02packages + for ($package, $pp->{version}, $dist) { + if (!defined || /^\s*$/ || /\s/) { + # If we got here, what on earth happened? + $ctx->abort_indexing_package($self, PKGERROR('wtf')); } } @@ -333,27 +290,19 @@ sub examine_pkg { delete $self->{FIO}; # circular reference } -sub _version_ok { - my ($self, $ctx, $pp, $package, $dist) = @_; - if (length $pp->{version} > 16) { - my $errno = PAUSE::mldistwatch::Constants::ELONGVERSION; - my $error = PAUSE::mldistwatch::Constants::heading($errno); - $self->index_status($ctx, - $package, - $pp->{version}, - $pp->{infile}, - $errno, - $error, - ); - $ctx->alert(qq{$error: -package[$package] -version[$pp->{version}] -file[$pp->{infile}] -dist[$dist] +sub assert_version_ok { + my ($self, $ctx) = @_; + + return if length $self->{PP}{version} <= 16; + + $ctx->alert(qq{version string was too long: +package[$self->{PACKAGE}] +version[$self->{PP}{version}] +file[$self->{PP}{infile}] +dist[$self->{DIST}] }); - return; - } - return 1; + + $ctx->abort_indexing_package($self, PKGERROR('version_too_long')); } # package PAUSE::package; @@ -368,7 +317,6 @@ sub update_package { my $pmfile = $self->{PMFILE}; my $fio = $self->{FIO}; - my($opack,$oldversion,$odist,$ofilemtime,$ofile) = @$row{ qw( package version dist filemtime file ) }; @@ -620,8 +568,7 @@ Please report the case to the PAUSE admins at modules\@perl.org.}, # ->abort_indexing_package! } - return unless $self->_version_ok($ctx, $pp, $package, $dist); - + $self->assert_version_ok($ctx); $Logger->log([ "updating packages: %s", { @@ -781,7 +728,7 @@ sub insert_into_package { } ]); - return unless $self->_version_ok($ctx, $pp, $package, $dist); + $self->assert_version_ok($ctx); $dbh->do($query, undef, $package, @@ -792,13 +739,8 @@ sub insert_into_package { $self->dist->{TIME}, $distname, ); - $self->index_status($ctx, - $package, - $pp->{version}, - $pp->{infile}, - PAUSE::mldistwatch::Constants::OK, - "indexed", - ); + + $ctx->record_package_indexing($self); } # package PAUSE::package; @@ -883,10 +825,10 @@ sub checkin { $self->insert_into_package($ctx); } - my $status = $self->get_index_status_status($ctx); - if (! $status or $status == PAUSE::mldistwatch::Constants::OK) { + # my $status = $self->get_index_status_status($ctx); + # if (! $status or $status == PAUSE::mldistwatch::Constants::OK) { $self->checkin_into_primeur($ctx); # called in void context! - } + # } } diff --git a/lib/PAUSE/pmfile.pm b/lib/PAUSE/pmfile.pm index bc97753a5..da09196aa 100644 --- a/lib/PAUSE/pmfile.pm +++ b/lib/PAUSE/pmfile.pm @@ -169,6 +169,7 @@ sub examine_fio { push @packages, $pio; } + $Logger->log("<<>> packages: @packages"); $self->{DIO}->index_packages($ctx, \@packages); delete $self->{DIO}; # circular reference diff --git a/t/lib/Mock/Dist.pm b/t/lib/Mock/Dist.pm index c9e80121a..1c6231d1f 100644 --- a/t/lib/Mock/Dist.pm +++ b/t/lib/Mock/Dist.pm @@ -9,7 +9,7 @@ use Test::Deep (); my $null = sub {}; -my @NULL = qw(verbose connect disconnect mlroot); +my @NULL = qw(verbose connect disconnect mlroot index_packages); my %ALWAYS = ( version_from_meta_ok => 1, diff --git a/t/lib/PAUSE/Test/pmfile.pm b/t/lib/PAUSE/Test/pmfile.pm index cbc02d247..abe06a070 100644 --- a/t/lib/PAUSE/Test/pmfile.pm +++ b/t/lib/PAUSE/Test/pmfile.pm @@ -153,12 +153,11 @@ sub examine_fio :Test :Plan(3) { $pmfile->{PMFILE} = $self->fake_dist_dir->file('lib/My/Dist.pm')->stringify; $pmfile->examine_fio; - cmp_deeply( - $Logger->events, - [ - ignore(), - superhashof({ message => re(qr/will examine packages: \Q{{["My::Dist"]}}\E\z/) }), - ], + ok( + ( + grep {; $_->{message} =~ qr/will examine packages: \Q{{["My::Dist"]}}\E\z/ } + @{ $Logger->events } + ), "we see the event log we expected", ); diff --git a/t/mldistwatch-misc.t b/t/mldistwatch-misc.t index a4ebd0b05..46cb065d8 100644 --- a/t/mldistwatch-misc.t +++ b/t/mldistwatch-misc.t @@ -370,7 +370,7 @@ subtest "check overlong versions" => sub { my $etoolong = sub { like( $_[0]{email}->object->body_str, - qr/Version string exceeds maximum allowed length/, + qr/version string was too long/, "email contains ELONGVERSION string", ); };