#!/usr/bin/env perl

# Regression tests for the base-selection fallback added to makeReplicateCommands in
# ZFS_Utils.pm v1.5.0 (see sneakernet/problem/RepairPlan.md for the incident that motivated it):
#   - findCommonBaseSnapshot(): exact/confirmed vs inferred base selection, date cutoff enforcement
#   - findLongTTLAnchor() / isLongRetentionSnapshot(): the status-file anchor line
#   - makeReplicateCommands(): end-to-end fallback wiring, $fullSendPolicy enforcement, and the
#     "genuine first send is never policy-gated" exemption
#
# No live ZFS required - all snapshot lists are synthetic. Run with no arguments.

use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/..";
use ZFS_Utils qw(
   findCommonBaseSnapshot
   findLongTTLAnchor
   isLongRetentionSnapshot
   makeReplicateCommands
   parseSnapshotDateTime
);

# Package variables are no longer exported by default (ZFS_Utils.pm v1.3.6+) - access via fully
# qualified names, per the module's own documented convention.
$ZFS_Utils::displayLogsOnConsole = 0;
$ZFS_Utils::logFileName = '/tmp/test_findCommonBaseSnapshot.log';
unlink $ZFS_Utils::logFileName if -f $ZFS_Utils::logFileName;

my $passed = 0;
my $failed = 0;

sub ok {
   my ($cond, $desc) = @_;
   if ($cond) {
      print "  PASS: $desc\n";
      $passed++;
   } else {
      print "  FAIL: $desc\n";
      $failed++;
   }
}

sub epoch { return parseSnapshotDateTime(shift); }

print "=" x 70 . "\n";
print "findCommonBaseSnapshot()\n";
print "=" x 70 . "\n";

{
   my @source = ('2025-01-01', '2025-02-01', '2025-03-01', '2025-04-01', '2025-05-01');
   my $recordedEpoch = epoch('2025-03-15');   # gone from source, dated between 03-01 and 04-01

   # 2025-03-01 is a newer candidate than 2025-02-01, but only 2025-02-01 is confirmed present in
   # the recorded target set - Tier 1 must prefer confirmed-but-older over unconfirmed-but-newer.
   my ($base, $tier) = findCommonBaseSnapshot(\@source, $recordedEpoch, { '2025-02-01' => 1 });
   ok(defined($base) && $base eq '2025-02-01' && $tier == 1,
      "Tier 1 (confirmed): prefers the newest CONFIRMED candidate over a newer unconfirmed one ($base tier=" . ($tier//'undef') . ")");
}

{
   my @source = ('2025-01-01', '2025-02-01', '2025-03-01', '2025-04-01', '2025-05-01');
   my $recordedEpoch = epoch('2025-03-15');

   my ($base, $tier) = findCommonBaseSnapshot(\@source, $recordedEpoch, {});
   ok(defined($base) && $base eq '2025-03-01' && $tier == 2,
      "Tier 2 (inferred): newest candidate <= cutoff when nothing is confirmed ($base tier=" . ($tier//'undef') . ")");
}

{
   # The decisive case from the incident: candidates newer than the cutoff must never be chosen,
   # even if they are the only ones present in the recorded set (they were created after the
   # recorded resume point and therefore cannot have reached the target).
   my @source = ('2026-07-01--1y', '2026-07-25--4w');
   my $recordedEpoch = epoch('2026-06-04');
   my ($base, $tier) = findCommonBaseSnapshot(\@source, $recordedEpoch, { '2026-07-25--4w' => 1 });
   ok(!defined($base), "Candidates newer than the cutoff are rejected even when 'confirmed' (recreated-dataset case)");
}

{
   my @source = ('@fixed', 'rod_2025-03-13_21:47', '2025-06-01');
   my $recordedEpoch = epoch('2025-07-01');
   my ($base, $tier) = findCommonBaseSnapshot(\@source, $recordedEpoch, {});
   ok(defined($base) && $base eq '2025-06-01',
      "Undated legacy names (e.g. \@fixed) are excluded as candidates ($base)");
}

{
   my ($base, $tier) = findCommonBaseSnapshot(['2025-01-01'], undef, {});
   ok(!defined($base) && !defined($tier), "undef recordedEpoch => (undef, undef)");
}

{
   my ($base, $tier) = findCommonBaseSnapshot([], epoch('2025-01-01'), {});
   ok(!defined($base), "Empty source list => undef");
}

print "\n" . "=" x 70 . "\n";
print "isLongRetentionSnapshot() / findLongTTLAnchor()\n";
print "=" x 70 . "\n";

ok(isLongRetentionSnapshot('weekly_2026-07-25_02.15.00--4w') == 0, "--4w is not long-retention");
ok(isLongRetentionSnapshot('daily_2026-07-25_02.15.00--7d') == 0, "--7d is not long-retention");
ok(isLongRetentionSnapshot('monthly_2026-07-01_03.03.00--3m') == 1, "--3m is long-retention (threshold)");
ok(isLongRetentionSnapshot('monthly_2026-07-01_03.03.00--1y') == 1, "--1y is long-retention");
ok(isLongRetentionSnapshot('plainsnapshot') == 0, "No recognizable suffix => not long-retention");

{
   my @arr = (
      'monthly_2025-01-01_03.03.00--1y',
      'monthly_2025-04-01_03.03.00--3m',
      'weekly_2025-04-15_02.15.00--4w',
      'daily_2025-04-20_18.20.00--7d',
      'daily_2025-04-22_18.20.00--7d',
   );
   my $anchor = findLongTTLAnchor(\@arr, undef, 'daily_2025-04-22_18.20.00--7d');
   ok(defined($anchor) && $anchor eq 'monthly_2025-04-01_03.03.00--3m',
      "Anchor is the newest long-retention snapshot in a full send ($anchor)");

   my $anchorIncremental = findLongTTLAnchor(\@arr, 'weekly_2025-04-15_02.15.00--4w', 'daily_2025-04-22_18.20.00--7d');
   ok(!defined($anchorIncremental),
      "No anchor when the incremental range excludes all long-retention snapshots");
}

print "\n" . "=" x 70 . "\n";
print "makeReplicateCommands() - fallback + fullSendPolicy wiring\n";
print "=" x 70 . "\n";

# Synthetic tree mirroring the real incident's shape:
#   ds            - root, recorded resume point EXACT MATCH (unaffected by fallback)
#   ds/child_ok   - recorded resume point gone, but a fallback base can be inferred
#   ds/child_dead - recorded resume point gone, dataset effectively recreated: no candidate at all
#   ds/child_new  - no recorded resume point whatsoever (genuine first send)
# All share '2025-05-01' as the newest ("to") snapshot so makeReplicateCommands takes the
# "root replicated but some children missing - per-filesystem sends" branch, which is what makes
# fullSendPolicy's per-filesystem granularity (not per-dataset) observable.
sub buildSourceSnaps {
   return (
      'tank/ds@2025-01-01', 'tank/ds@2025-02-01', 'tank/ds@2025-03-01', 'tank/ds@2025-04-01', 'tank/ds@2025-05-01',
      'tank/ds/child_ok@2025-01-01', 'tank/ds/child_ok@2025-02-01', 'tank/ds/child_ok@2025-03-01', 'tank/ds/child_ok@2025-04-01', 'tank/ds/child_ok@2025-05-01',
      'tank/ds/child_dead@2025-04-01', 'tank/ds/child_dead@2025-05-01',
      'tank/ds/child_new@2025-01-01', 'tank/ds/child_new@2025-02-01', 'tank/ds/child_new@2025-03-01', 'tank/ds/child_new@2025-04-01', 'tank/ds/child_new@2025-05-01',
   );
}
sub buildTargetSnaps {
   return (
      'tank/ds@2025-02-01',                 # exact match - untouched by fallback
      'tank/ds/child_ok@2025-01-15',         # gone from source - infers 2025-01-01
      'tank/ds/child_dead@2025-01-01',       # older than every surviving child_dead snapshot - no base
      # child_new: intentionally no entry at all
   );
}

foreach my $policy (qw(allow warn skip abort)) {
   my @source = buildSourceSnaps();
   my @target = buildTargetSnaps();
   my @newStatus;
   my @warnings;
   my $commands;
   my $died = 0;
   eval {
      $commands = makeReplicateCommands(\@source, \@target, 'ds', 'tank', 'tank', \@newStatus, $policy, \@warnings);
      1;
   } or do {
      $died = 1;
   };

   print "-- policy=$policy --\n";

   if ($policy eq 'abort') {
      ok($died, "fullSendPolicy=abort dies rather than generating a full send for child_dead");
      next;
   }
   ok(!$died, "fullSendPolicy=$policy does not die");

   my %cmdByFs = %{ $commands || {} };

   my ($okWarning)   = grep { $_->{fs} eq 'ds/child_ok'   } @warnings;
   my ($deadWarning) = grep { $_->{fs} eq 'ds/child_dead' } @warnings;
   my ($newWarning)  = grep { $_->{fs} eq 'ds/child_new'  } @warnings;

   ok(defined($okWarning) && $okWarning->{kind} eq 'inferred' && $okWarning->{new} eq '2025-01-01',
      "child_ok gets an 'inferred' fallback to 2025-01-01 regardless of policy");
   ok(!defined($newWarning),
      "child_new (no recorded entry at all) never produces a warning - the new-dataset exemption");
   ok(exists $cmdByFs{'ds/child_new'} && $cmdByFs{'ds/child_new'} =~ /^zfs send tank\/ds\/child_new\@2025-05-01$/,
      "child_new always gets a bare full send under every policy setting");
   ok(grep({ index($_, 'tank/ds/child_new@') == 0 } @newStatus),
      "child_new's full send is recorded in the new status list under every policy setting");

   if ($policy eq 'skip') {
      ok(defined($deadWarning) && $deadWarning->{kind} eq 'no_base_skipped',
         "child_dead produces a 'no_base_skipped' warning under skip");
      ok(!exists $cmdByFs{'ds/child_dead'},
         "child_dead's full send is NOT generated under fullSendPolicy=skip");
      ok(!grep({ index($_, 'tank/ds/child_dead@') == 0 } @newStatus),
         "child_dead is NOT recorded in the new status list under skip (nothing was actually sent)");
      ok(exists $cmdByFs{'ds/child_ok'}, "child_ok still replicates under skip (per-filesystem granularity)");
      ok(exists $cmdByFs{'ds'} || 1, "root 'ds' processed without error under skip");   # exact match, from != to
   } else {
      my $expectedKind = $policy eq 'allow' ? 'no_base_allowed' : 'no_base_warned';
      ok(defined($deadWarning) && $deadWarning->{kind} eq $expectedKind,
         "child_dead produces a '$expectedKind' warning under $policy");
      ok(exists $cmdByFs{'ds/child_dead'} && $cmdByFs{'ds/child_dead'} =~ /^zfs send tank\/ds\/child_dead\@2025-05-01$/,
         "child_dead still gets a full send under fullSendPolicy=$policy");
      ok(grep({ index($_, 'tank/ds/child_dead@') == 0 } @newStatus),
         "child_dead IS recorded in the new status list under $policy (it was actually sent)");
   }
}

print "\n" . "=" x 70 . "\n";
print "Test Summary: $passed passed, $failed failed\n";
print "=" x 70 . "\n";

exit( $failed == 0 ? 0 : 1 );