#!/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;
}