#!/usr/bin/env perl
# SPDX-FileCopyrightText: 2026 GPForum Contributors
# SPDX-License-Identifier: BSD-3-Clause

package main;

use v5.40;

use FindBin qw($Bin);
use lib "$Bin/../lib";

# The event loop GPForum requires (kqueue or epoll) is chosen before anything
# loads EV or Mojo::IOLoop.
use GPForum::OS::Reactor;

use Carp qw(croak);
use Const::Fast;
use DBI;
use English       qw(-no_match_vars);
use Getopt::Long  qw(GetOptionsFromArray);
use JSON::MaybeXS qw(encode_json);
use List::Util    qw(sum0 max);
use Time::HiRes   qw(clock_gettime CLOCK_MONOTONIC);

use GPForum::Benchmark::Measure qw(percentile);
use GPForum::Command::Migrate;
use GPForum::Command::PerformanceSeed;
use GPForum::Web::PublicHttpCache;

our $VERSION = '0.001';

# What the hot pages cost to render, in process, on a real database: a
# throwaway database migrated and seeded with the medium profile (120 threads
# of 15 posts), a member registered through /register and signed in through
# /login, and each page requested through Test::Mojo after a warm-up. Per
# page it reports the request's median and p95, and the same for the time
# between the page's before_render hook and its after_render (the page's
# template, its partials and its layout). Under Devel::NYTProf (--nytprof
# FILE) it profiles only the measured requests and prints where their time
# went, by package and by subroutine.
#
# A guest's thread page is answered from the public page cache in
# production; the bench bypasses that cache, so the guest row is the cost of
# rendering the page, which is what a cache miss pays.
const my %DEFAULT => (
    iterations => 200,
    warmup     => 20,
    top        => 20,
);
const my $MILLISECONDS => 1_000;
const my $KIBIBYTE     => 1_024;
const my $PERCENT      => 100;
const my $P50          => 50;
const my $P95          => 95;
const my $HTTP_OK      => 200;
const my $USAGE_ERROR  => 2;
const my $READ_LIMIT   => 10_000_000;
const my $SUBROUTINE   => 64;
const my $PASSWORD     => 'render bench correct horse staple';
const my $MEMBER       => 'render_bench';
const my $THREAD_ID    => '018f1004-0001-7000-8000-000000000001';
const my $CATEGORY_ID  => '018f1001-0001-7000-8000-000000000001';
const my $COMPILED_EP  => 'templates (compiled EP)';
const my $TEMPLATE_CODE =>
  qr/\A (?:Mojo::Template|GPForum::Web::Partials)::Sandbox::/msx;
const my @PAGES => (
    [ thread_member        => 'member', "/t/$THREAD_ID" ],
    [ thread_guest         => 'guest',  "/t/$THREAD_ID" ],
    [ categories           => 'member', '/categories' ],
    [ category             => 'member', "/c/$CATEGORY_ID" ],
    [ home                 => 'member', q{/} ],
    [ search               => 'member', '/search?q=performance' ],
    [ autocomplete         => 'member', '/search/autocomplete?q=per' ],
    [ new_thread           => 'member', '/new-thread' ],
    [ drafts               => 'member', '/drafts' ],
    [ pending              => 'member', '/pending' ],
    [ bookmarks            => 'member', '/bookmarks' ],
    [ feed                 => 'member', '/feed' ],
    [ notifications        => 'member', '/notifications' ],
    [ notification_summary => 'member', '/notifications/summary' ],
    [ mentions             => 'member', '/mentions' ],
    [ messages             => 'member', '/messages' ],
    [ message_compose      => 'member', '/messages/new/perf_user_2' ],
    [ settings             => 'member', '/settings' ],
    [ security             => 'member', '/settings/security' ],
    [ avatar               => 'member', '/settings/avatar' ],
    [ relations            => 'member', '/settings/ignored' ],
    [ privacy              => 'member', '/privacy' ],
    [ profile              => 'guest',  '/u/perf_user_2' ],
    [ tags                 => 'guest',  '/tags' ],
    [ public_feed          => 'guest',  '/feed.atom' ],
    [ sitemap              => 'guest',  '/sitemap.xml' ],
    [ thread_archive       => 'guest',  "/t/$THREAD_ID/archive.mbox" ],
    [ category_archive     => 'guest',  "/c/$CATEGORY_ID/archive.mbox" ],
);

exit main(@ARGV);

sub main (@arguments) {
    my $option = _options(@arguments);
    return _usage( $option->{usage} ) if defined $option->{usage};
    return _profile_run($option)      if defined $option->{nytprof};

    my $admin_dsn = $ENV{GPFORUM_DATABASE_DSN}
      // croak 'set GPFORUM_DATABASE_DSN to a database the user may CREATE in';
    my $admin   = _connect($admin_dsn);
    my $name    = $option->{database} // "gpforum_bench_render_$PROCESS_ID";
    my $created = !defined $option->{database};
    my $drop    = $created && !$option->{'keep-database'};
    ( my $dsn = $admin_dsn ) =~ s/dbname=[^;]+/dbname=$name/msx;
    my $report;
    try {
        if ($created) {
            $admin->do( 'CREATE DATABASE ' . $admin->quote_identifier($name) );
        }
        $report = _bench( $dsn, $created, $option );
    }
    catch ($error) {
        _drop( $admin, $name, $drop );
        croak $error;
    };
    _drop( $admin, $name, $drop );
    $report->{database} = $name;
    $admin->disconnect;

    print $option->{json} ? encode_json($report) . "\n" : _text($report)
      or croak 'cannot write the report';

    return 0;
}

# The options, with usage set to the exit status when only the usage is to
# be printed: asked for, or a mistake.
sub _options (@arguments) {
    my %option = %DEFAULT;
    if (
        !GetOptionsFromArray(
            \@arguments, \%option,     'iterations=i',  'warmup=i',
            'page=s@',   'database=s', 'keep-database', 'nytprof=s',
            'top=i',     'json',       'help',
        )
      )
    {
        return { usage => $USAGE_ERROR };
    }
    return { usage => 0 } if $option{help};

    my %known   = map  { $_->[0] => 1 } @PAGES;
    my @unknown = grep { !$known{$_} } @{ $option{page} // [] };
    if ( @arguments || $option{iterations} < 1 || @unknown ) {
        return { usage => $USAGE_ERROR };
    }

    return \%option;
}

sub _usage ($status) {
    print 'Usage: script/bench-render [--iterations N] [--warmup N]'
      . " [--page NAME]... [--json]\n"
      . "       [--database NAME | --keep-database] [--nytprof FILE [--top N]]\n"
      . '       Pages: '
      . join( q{ }, map { $_->[0] } @PAGES ) . "\n"
      . "       GPFORUM_DATABASE_DSN names a server the user may CREATE DATABASE on.\n"
      or croak 'cannot write the usage';

    return $status;
}

sub _connect ($dsn) {
    return DBI->connect(
        $dsn,
        $ENV{GPFORUM_DATABASE_USER},
        $ENV{GPFORUM_DATABASE_PASSWORD},
        { AutoCommit => 1, PrintError => 0, RaiseError => 1 },
    );
}

sub _drop ( $admin, $name, $drop ) {
    if ($drop) {
        $admin->do( 'DROP DATABASE IF EXISTS '
              . $admin->quote_identifier($name)
              . ' WITH (FORCE)' );
    }

    return;
}

sub _bench ( $dsn, $created, $option ) {
    local $ENV{GPFORUM_DATABASE_DSN}              = $dsn;
    local $ENV{GPFORUM_MINION_ENABLED}            = 0;
    local $ENV{GPFORUM_REALTIME_LISTENER_ENABLED} = 0;
    local $ENV{GPFORUM_FORUM_READ_RATE_LIMIT}     = $READ_LIMIT;
    local $ENV{GPFORUM_LOG_LEVEL} = $ENV{GPFORUM_LOG_LEVEL} || 'fatal';

    require Test::Mojo;
    if ($created) {
        _quietly( sub { GPForum::Command::Migrate->new->run('--apply') } ) == 0
          or croak 'migrations failed';
        _quietly(
            sub {
                GPForum::Command::PerformanceSeed->new->run( '--profile',
                    'medium' );
            }
        ) == 0 or croak 'medium seed failed';
    }

    my $member = Test::Mojo->new('GPForum');
    my $app    = $member->app;
    my $guest  = Test::Mojo->new($app);
    $app->helper( gp_public_http_cache =>
          sub { return GPForum::Web::PublicHttpCache->new( cache => undef ); }
    );
    _sign_in( $member, $dsn, $created );

    my $render = _render_clock($app);
    my %client = ( member => $member, guest => $guest );
    my %wanted = map  { $_ => 1 } @{ $option->{page} // [] };
    my @pages  = grep { !%wanted || $wanted{ $_->[0] } } @PAGES;

    my @rows;
    for my $page (@pages) {
        my ( $label, $who, $path ) = @{$page};
        push @rows,
          _measure_page( $client{$who}, $label, $path, $render, $option );
    }
    if ( _profiling() ) {
        DB::finish_profile();
    }

    # End application connections before main drops its owned database.
    # Cached statements must not outlive DROP DATABASE ... WITH (FORCE).
    my $controller = $app->build_controller;
    $controller->gp_schema->storage->disconnect;

    return {
        iterations => $option->{iterations},
        warmup     => $option->{warmup},
        perl       => "$PERL_VERSION",
        pages      => \@rows,
        dataset    =>
'medium: 120 threads, 1800 posts, 25 seeded users plus a registered benchmark member; member-specific inboxes/lists start empty',
        cache =>
'SSR page cache bypassed; application and PostgreSQL caches warmed by warmup requests',
    };
}

# The member registers through the page, is activated in the database (the
# mail that would verify the address is not read), and signs in, so the
# session is a real server-side session with its cookie. A database kept
# from an earlier run (--database) already has the member.
sub _sign_in ( $client, $dsn, $created ) {
    my $ua  = $client->ua;
    my $dbh = _connect($dsn);
    if ($created) {
        my $form = $ua->get('/register');
        $ua->post(
            '/register' => form => {
                command_id   => _form_value( $form, 'command_id' ),
                csrf_token   => _form_value( $form, 'csrf_token' ),
                username     => $MEMBER,
                display_name => 'Render Bench',
                email        => "$MEMBER\@example.test",
                password     => $PASSWORD,
            }
        );
        $dbh->do(
            q{UPDATE users SET status = 'active', email_verified_at = now()}
              . ' WHERE username = ?',
            undef, $MEMBER
        );
    }
    else {
        # A database kept for repeated runs has counted every earlier
        # sign-in: the bench's own counters are cleared, not the limit.
        $dbh->do('DELETE FROM rate_limit_buckets');
    }
    $dbh->disconnect;

    my $form = $ua->get('/login');
    $ua->post(
        '/login' => form => {
            command_id => _form_value( $form, 'command_id' ),
            csrf_token => _form_value( $form, 'csrf_token' ),
            identifier => $MEMBER,
            password   => $PASSWORD,
        }
    );
    my $home = $ua->get(q{/})->res;
    croak 'the bench member could not sign in'
      if !$home->dom->at('form[action="/logout"]');

    return;
}

sub _form_value ( $tx, $name ) {
    my $input = $tx->res->dom->at(qq{input[name="$name"]})
      // croak "no $name field on " . $tx->req->url;

    return $input->attr('value');
}

# The time from a page's before_render to its after_render: the partials it
# includes emit no hook of their own (GPForum::Web::Partials), and only the
# outermost render emits after_render. It counts the renders too.
sub _render_clock ($app) {
    my %clock = ( started => undef, elapsed => 0, renders => 0 );
    $app->hook(
        before_render => sub ( $controller, $ ) {
            $clock{started} //= clock_gettime(CLOCK_MONOTONIC);
            ++$clock{renders};
            return;
        }
    );
    $app->hook(
        after_render => sub ( $controller, $, $ ) {
            if ( defined $clock{started} ) {
                $clock{elapsed} =
                  clock_gettime(CLOCK_MONOTONIC) - $clock{started};
            }
            return;
        }
    );

    return \%clock;
}

sub _measure_page ( $client, $label, $path, $render, $option ) {
    for ( 1 .. $option->{warmup} ) {
        _request( $client, $path, $render );
    }

    my $profiling = _profiling();
    if ($profiling) {
        DB::enable_profile();
    }
    my ( @request, @rendering, @database, @queries, @non_database );
    my ( $bytes, $renders ) = ( 0, 0 );
    for ( 1 .. $option->{iterations} ) {
        my ( $elapsed, $rendered, $size, $count, $stats ) =
          _request( $client, $path, $render );
        push @request,   $elapsed;
        push @rendering, $rendered;
        push @database,  $stats->{db_duration_ms};
        push @queries,   $stats->{queries};
        push @non_database,
          max( 0, $elapsed * $MILLISECONDS - $stats->{db_duration_ms} );
        ( $bytes, $renders ) = ( $size, $count );
    }
    if ($profiling) {
        DB::disable_profile();
    }

    @request      = sort { $a <=> $b } @request;
    @rendering    = sort { $a <=> $b } @rendering;
    @database     = sort { $a <=> $b } @database;
    @queries      = sort { $a <=> $b } @queries;
    @non_database = sort { $a <=> $b } @non_database;
    return {
        page              => $label,
        path              => $path,
        bytes             => $bytes,
        renders           => $renders,
        request_median_ms => _ms( percentile( \@request,   $P50 ) ),
        request_p95_ms    => _ms( percentile( \@request,   $P95 ) ),
        render_median_ms  => _ms( percentile( \@rendering, $P50 ) ),
        render_p95_ms     => _ms( percentile( \@rendering, $P95 ) ),
        db_median_ms => 0 + sprintf( '%.3f', percentile( \@database, $P50 ) ),
        db_p95_ms    => 0 + sprintf( '%.3f', percentile( \@database, $P95 ) ),
        non_db_median_ms => 0 +
          sprintf( '%.3f', percentile( \@non_database, $P50 ) ),
        queries_median => percentile( \@queries, $P50 ),
        queries_max    => max(@queries),
    };
}

sub _request ( $client, $path, $render ) {
    $render->{started} = undef;
    $render->{elapsed} = 0;
    $render->{renders} = 0;
    my $started = clock_gettime(CLOCK_MONOTONIC);
    my $tx      = $client->ua->get($path);
    my $elapsed = clock_gettime(CLOCK_MONOTONIC) - $started;
    my $code    = $tx->res->code // 0;
    croak "GET $path answered $code" if $code != $HTTP_OK;
    my $observer = $client->app->build_controller->gp_db_query_stats;
    my $stats    = $observer->last_request;
    croak "GET $path has no database timing observation" if !$stats;

    return ( $elapsed, $render->{elapsed}, length $tx->res->body,
        $render->{renders}, $stats );
}

sub _ms ($seconds) {
    return sprintf '%.3f', $seconds * $MILLISECONDS;
}

sub _profiling {
    return defined &DB::enable_profile;
}

# Runs a command that reports on STDOUT without letting it write there: the
# bench's own report is what STDOUT carries.
sub _quietly ($code) {
    my $output = q{};
    open my $handle, '>', \$output
      or croak 'failed to open output capture';
    my $status = do {
        local *STDOUT = $handle;
        $code->();
    };
    close $handle or croak 'failed to close output capture';

    return $status;
}

sub _text ($report) {
    my $text =
      sprintf "render bench: %d requests per page after %d warm-up (%s)\n",
      $report->{iterations}, $report->{warmup}, $report->{database};
    $text .= sprintf "%-22s %10s %10s %10s %10s %10s %10s %8s %8s\n", 'page',
      'req p50', 'req p95', 'render p50', 'render p95', 'DB p50', 'other p50',
      'queries', 'KiB';
    for my $row ( @{ $report->{pages} } ) {
        $text .= sprintf "%-22s %10s %10s %10s %10s %10s %10s %8d %8.1f\n",
          $row->{page},
          @{$row}{
            qw(request_median_ms request_p95_ms render_median_ms render_p95_ms db_median_ms non_db_median_ms queries_max)
          },
          $row->{bytes} / $KIBIBYTE;
    }

    return $text;
}

# Runs this bench again under Devel::NYTProf, with the profiler started only
# around the measured requests, then reads the profile: the exclusive time by
# package (the templates' compiled code as one), and the subroutines that
# took the most exclusive time, with their call counts. Profiled times are
# inflated by the profiler and only compare with each other.
sub _profile_run ($option) {
    my $file = $option->{nytprof};
    my @passed;
    for my $name (qw(iterations warmup database)) {
        if ( defined $option->{$name} ) {
            push @passed, "--$name", $option->{$name};
        }
    }
    push @passed, map { ( '--page', $_ ) } @{ $option->{page} // [] };
    if ( $option->{'keep-database'} ) {
        push @passed, '--keep-database';
    }
    local $ENV{NYTPROF} = join q{:}, "file=$file", 'start=no',
      $ENV{NYTPROF} // 'stmts=0';
    system( $EXECUTABLE_NAME, '-d:NYTProf', $PROGRAM_NAME, @passed ) == 0
      or croak "the profiled run failed: $CHILD_ERROR";

    require Devel::NYTProf::Data;
    my $profile =
      Devel::NYTProf::Data->new( { filename => $file, quiet => 1 } );
    my $summary = _profile_summary( $profile, $option->{top} );
    print $option->{json}
      ? encode_json($summary) . "\n"
      : _profile_text($summary)
      or croak 'cannot write the profile';

    return 0;
}

sub _profile_summary ( $profile, $top ) {
    my ( %package, @subs );
    for my $info ( values %{ $profile->subname_subinfo_map } ) {
        next if !$info->calls;
        my $package =
          $info->package =~ $TEMPLATE_CODE ? $COMPILED_EP : $info->package;
        $package{$package} += $info->excl_time;
        push @subs, $info;
    }
    my $total    = sum0( values %package ) || 1;
    my @packages = map {
        {
            package => $_,
            ms      => _ms( $package{$_} ),
            share   => sprintf( '%.1f', $PERCENT * $package{$_} / $total ),
        }
      }
      reverse sort { $package{$a} <=> $package{$b} } keys %package;
    @subs = reverse sort { $a->excl_time <=> $b->excl_time } @subs;

    return {
        profiled_ms => _ms($total),
        packages    => [ @packages[ 0 .. _last( \@packages, $top ) ] ],
        subs        => [
            map {
                {
                    sub     => $_->subname,
                    calls   => $_->calls,
                    excl_ms => _ms( $_->excl_time ),
                    incl_ms => _ms( $_->incl_time ),
                }
            } @subs[ 0 .. _last( \@subs, $top ) ]
        ],
    };
}

sub _last ( $list, $top ) {
    return ( @{$list} < $top ? scalar @{$list} : $top ) - 1;
}

sub _profile_text ($summary) {
    my $text = "profiled exclusive time: $summary->{profiled_ms} ms\n\n";
    $text .= sprintf "%-48s %10s %6s\n", 'package', 'excl ms', q{%};
    for my $row ( @{ $summary->{packages} } ) {
        $text .= sprintf "%-48s %10s %6s\n", @{$row}{qw(package ms share)};
    }
    $text .= sprintf "\n%-64s %9s %10s %10s\n", 'subroutine', 'calls',
      'excl ms', 'incl ms';
    for my $row ( @{ $summary->{subs} } ) {
        $text .= sprintf "%-64s %9d %10s %10s\n",
          substr( $row->{sub}, 0, $SUBROUTINE ),
          @{$row}{qw(calls excl_ms incl_ms)};
    }

    return $text;
}