script/query-plan-check
Rama main · réplica de lectura del repositorio original.
#!/usr/bin/env perl
# SPDX-FileCopyrightText: 2026 GPForum Contributors
# SPDX-License-Identifier: BSD-3-Clause
package main;
use v5.40;
use Carp qw(croak);
use English qw(-no_match_vars);
use File::Basename qw(basename);
use File::Find qw(find);
our $VERSION = '0.001';
my @required_indexes = (
[ category_listing => 'idx_categories_space_position' ],
[ thread_latest_public => 'idx_threads_public_activity' ],
[ thread_category_hot => 'idx_threads_category_activity_visible_locked' ],
[ thread_posts_keyset => 'idx_posts_visible_thread_position' ],
[ thread_category_own_deleted => 'idx_threads_deleted_category_activity' ],
[ profile_author_threads => 'idx_threads_author_public_activity' ],
[ search_vector => 'idx_search_documents_vector' ],
[ search_title_trigram => 'idx_search_documents_title_trgm' ],
[ search_candidates => 'idx_search_documents_created' ],
[ event_log_aggregate => 'idx_event_log_aggregate_created_at' ],
[ event_log_brin => 'idx_event_log_created_at_brin' ],
[ audit_actor => 'idx_audit_log_actor_created_at' ],
[ audit_brin => 'idx_audit_log_created_at_brin' ],
[ outbox_dispatch => 'idx_outbox_messages_status_created' ],
[ outbox_claim_ready => 'idx_outbox_messages_claim_ready' ],
[ outbox_stale_locks => 'idx_outbox_messages_stale_locks' ],
[ outbox_realtime_poll => 'idx_outbox_messages_realtime_poll' ],
[ notification_recipient => 'idx_notifications_recipient_created_at' ],
[ notification_brin => 'idx_notifications_created_at_brin' ],
[ notification_inbox => 'idx_notification_inbox_recipient_created' ],
[ feed_user_created => 'idx_user_feed_items_user_created' ],
[ report_duplicate => 'idx_reports_reporter_target_open_unique' ],
);
# CI passes --require-db. Without it the database half is skipped when no DSN is
# set -- right for a laptop -- and the gate still reported status=ok, so if the
# CI job ever lost its DSN the check that EXPLAINs real plans would quietly
# stop running while the step stayed green.
my $require_db = grep { $_ eq '--require-db' } @ARGV;
# A CREATE [UNIQUE] INDEX or DROP INDEX statement, in the parts that matter:
# the verb and the index name, past the optional CONCURRENTLY and IF [NOT]
# EXISTS and a schema the name is qualified by: migration 1040's
# DROP INDEX IF EXISTS public.idx_... read as dropping an index named public,
# and the three it dropped were still reported present. Named so the loop that replays migrations stays readable.
my $INDEX_VERB = qr/CREATE (?: \s+ UNIQUE )? \s+ INDEX | DROP \s+ INDEX/msx;
my $INDEX_GUARD =
qr/(?: \s+ CONCURRENTLY )? (?: \s+ IF \s+ (?: NOT \s+ )? EXISTS )?/msx;
my $INDEX_STATEMENT =
qr/\b ($INDEX_VERB) $INDEX_GUARD \s+ (?: [[:alnum:]_]+ [.] )? ([[:alnum:]_]+)/msx;
# The indexes that exist once every migration has run, in order: an index
# created in one migration and dropped in a later one does not count, as it
# would in a match over the concatenated migration text.
my %final_indexes = _final_indexes();
my @missing;
for my $check (@required_indexes) {
my ( $name, $index ) = @{$check};
if ( !$final_indexes{$index} ) {
push @missing, "$name:$index";
}
}
my @offset_violations = _offset_violations();
my $db_evidence = _db_evidence();
if ( @missing || @offset_violations || !$db_evidence->{ok} ) {
print 'query-plan-check status=fail'
. ' missing_indexes='
. join( q{,}, @missing )
. ' offset_violations='
. join( q{,}, @offset_violations )
. ' db_evidence='
. $db_evidence->{status} . "\n"
or croak 'failed to write query plan check result';
_print_db_output($db_evidence);
exit 1;
}
print 'query-plan-check status=ok indexes='
. scalar(@required_indexes)
. ' offset_violations=0 db_evidence='
. $db_evidence->{status} . "\n"
or croak 'failed to write query plan check result';
_print_db_output($db_evidence);
exit 0;
# What the database evidence printed, when it printed anything.
sub _print_db_output ($db_evidence) {
if ( length $db_evidence->{output} ) {
print $db_evidence->{output}
or croak 'failed to write database evidence';
}
return;
}
sub _final_indexes {
my %index;
my @files;
find(
{
no_chdir => 1,
wanted => sub {
if ( -f && basename($_) =~ /\A [[:digit:]]+ _ .+ [.]sql \z/msx )
{
push @files, $File::Find::name;
}
},
},
'migrations'
);
for my $file (
sort { _migration_version($a) <=> _migration_version($b) || $a cmp $b }
@files )
{
my $sql = _slurp($file);
$sql =~ s/--[^\n]*//gmsx;
while ( $sql =~ /$INDEX_STATEMENT/gimsx ) {
my ( $verb, $name ) = ( uc $1, lc $2 );
if ( $verb =~ /\A DROP/msx ) {
delete $index{$name};
next;
}
$index{$name} = $file;
}
}
return %index;
}
sub _offset_violations {
my @violations;
for my $file ( _scan_files() ) {
my $line_number = 0;
for my $line ( split /\n/msx, _slurp($file) ) {
$line_number++;
next if $line =~ /query-plan-check/msx;
next if $line !~ /\b OFFSET \b|-> \s* search .* offset/msx;
push @violations, "$file:$line_number";
}
}
return @violations;
}
sub _scan_files {
my @files;
for my $root (qw(lib templates)) {
next if !-d $root;
push @files, _files_under($root);
}
return @files;
}
sub _db_evidence {
if ( !_database_dsn_present() ) {
if ($require_db) {
return { ok => 0, status => 'missing-dsn', output => q{} };
}
return { ok => 1, status => 'skipped', output => q{} };
}
my $output = q{};
open my $evidence, q{-|}, 'bin/gpforum', 'query-plan-evidence', '--check',
'--analyze', '--profile', 'medium'
or croak 'failed to run DB-backed query plan evidence';
while ( my $line = <$evidence> ) {
$output .= $line;
}
my $ok = close $evidence ? 1 : 0;
return {
ok => $ok,
status => $ok ? 'ok' : 'fail',
output => $output,
};
}
sub _database_dsn_present {
return defined $ENV{GPFORUM_DATABASE_DSN}
&& length $ENV{GPFORUM_DATABASE_DSN} ? 1 : 0;
}
sub _migration_version ($file) {
my ($version) = basename($file) =~ /\A ([[:digit:]]+) /msx;
return $version;
}
sub _files_under {
my ($root) = @_;
my @files;
my @pending = ($root);
while (@pending) {
my $path = shift @pending;
if ( -d $path ) {
opendir my $directory, $path
or croak "failed to read directory $path";
push @pending, map { "$path/$_" }
grep { $_ ne q{.} && $_ ne q{..} } readdir $directory;
closedir $directory
or croak "failed to close directory $path";
next;
}
if ( $path =~ /[.](?:pm|ep)\z/msx ) {
push @files, $path;
}
}
return @files;
}
sub _slurp {
my ($file) = @_;
open my $handle, '<', $file
or croak "failed to read $file";
local $INPUT_RECORD_SEPARATOR = undef;
my $content = <$handle>;
close $handle
or croak "failed to close $file";
return $content;
}