#!/usr/bin/perl -w
# Copyright 2022 Ian Jackson and contributors to dkim-rotate
# SPDX-License-Identifier: GPL-3.0-or-later
# There is NO WARRANTY.
use strict;

use Carp;
use Fcntl qw(:flock);
use Getopt::Long::Descriptive qw(describe_options prog_name);
use POSIX;
use MIME::QuotedPrint;

our $dummy_time_t = 1000000000;

our %duration_units = qw(
			  s 1
			  m 60
			  h 3600
			  d 3600*24
			  w 3600*24*7
		       );
foreach (%duration_units) { $_ = eval "$_"; }

sub defopt {
  my ($opt, $doc, $def, @other) = @_;
  [ "$opt=s",
    "$doc (default $def)",
    { default => $def,
      @other } ]
}

my ($opt, $usage) = describe_options
  (
   "dkim-rotate <options> [<instance> | <path-to-config>]",
   [ ],
   [ 'modes (one must be specified:):' ],
   [ 'mode' => hidden => { one_of =>
    [
     [ 'major' => 'main run: do all relevant work, maybe change key' ],
     [ 'minor' => 'auxiliary run: do not change current key' ],
     [ 'new' => 'first run: allow creation of instance and early key use' ],
     [ 'reinstall' => 'reinstall MTA and/or DNS (do not rotate)' ],
     [ 'status' => "show status" ],
    ] } ],
   [ ],
   [ 'options:' ],
   defopt('etc-dir', "config files directory", '/etc/dkim-rotate'),
   defopt('var-dir', "state and outputs directory", '/var/lib/dkim-rotate'),
  );

$opt->mode or die <<END;
need mode option, --major | --minor | --status

$usage
END

$ENV{PATH} // confess "PATH not set";
$ENV{PATH} .= ":/usr/local/bin:/sbin:/usr/sbin"
  unless grep { $_ eq '/usr/sbin' } split /\:/, $ENV{PATH};

our $instance;
our $config_file;
our $var; # config option instance_var_dir

sub msg_prefix () { return prog_name.": instance $instance: "; }
sub fail ($) { die msg_prefix()."error: $_[0]\n"; }
sub warning ($) { warn msg_prefix()."warning: $_[0]\n"; }

our %cfg;
our $zone;
our $sel_offset;
our $sel_limit;
our $last_serial;

#-------------------- primary data structure --------------------

our @si2st = qw(-1 +0 +N +X);
our %st2si;

# Keys are
#  $keys[$si]{time_t}
#  $keys[$si]{keyname}
#  $keys[$si]{txtdata}
#  $keys[$si]{sel}
our @keys;

foreach my $i (0..$#si2st) {
  $st2si{$si2st[$i]} = $i;
  push @keys, [ ];
}
our ($key_1, $key0, $keysN, $keysX) = @keys;

#-------------------- utilities and helpers --------------------

sub count_keys_advertised () {
  my $n = 0;
  $n += @$_ foreach @keys[0..2]; # excludes $keysX
  return $n;
}

sub keys_forall ($) {
  my ($f) = @_;
  foreach my $keys (@keys) {
    foreach (@$keys) {
      $f->();
    }
  }
}

sub child_failed ($) {
  my ($what) = @_;
  if ($? & 0xff00) {
    fail "subprocess ($what) failed, exit status ".($? >> 8);
  } elsif ($?) {
    fail "subprocess ($what) failed, wait status $? (signal?)";
  } elsif ($!) {
    fail "subprocess communication failed ($what): $!";
  } else {
    fail "subprocess operation ($what) failed for unknown reason";
  }
}

sub selector_of_index ($) {
  my ($i) = @_;
  return chr(
	     ($i + $sel_offset) % $sel_limit
	     + ord('a')
	    );
}

sub key_priv_priv_file ($) {
  my ($key) = @_;
  return "$var/priv/$key->{keyname}.pem";
}
sub key_priv_pub_leaf ($) {
  my ($key) = @_;
  $key->{keyname} =~ m{^[0-9a-f]{2}} or confess "bad keyname";
  return "$&/$key->{keyname}.pem";
}
sub pub_url_of ($) {
  my ($leaf) = @_;
  my $url = $cfg{pub_url};
  return undef if $url eq '-';
  $url =~ s{/$}{}s;
  $url .= "/$leaf";
}

sub show_time ($) {
  strftime '%Y-%m-%d %H:%M:%S %z', localtime $_[0]
}

sub progress ($$$$) {
  my ($st, $newst, $key, $msg) = @_;
  printf("%-19s  %s %2s %2s %s\n",
	 $instance,
	 !$key ? ' - ' : $st eq '+X' ? "($key->{sel})" : " $key->{sel} ",
	 $st, $newst,
	 $msg)
    and flush STDOUT
    or fail "write progress: $!\n";
}

sub progress_no ($$$$) {
  my ($st, $key, $action, $reason) = @_;
  progress $st,'', $key, sprintf "%-12s %s", "$action?", $reason;
}

sub key_time_elapsed ($$$$) {
  my ($st, $key, $kw, $action) = @_;
  if (!$key) {
    progress_no $st,$key, $action, 'no key';
    return 0;
  }
  my $time_t = $key->{time_t};
  if ($time_t =~ m/[A-Z]/) {
    progress_no $st,$key, $action, "failed update/reload of $time_t";
    return 0;
  }
  my $lag = $cfg{$kw} // confess "$kw ?";
  my $thresh = $time_t + $lag;
  if (time < $thresh) {
    progress_no $st,$key, $action, "not until ". show_time $thresh;
    return 0;
  } else {
    return 1;
  }
}

sub check_revealed ($) {
  my ($pub_leaf) = @_;
  my $url = pub_url_of($pub_leaf) // return;
  my @cmd = (qw(curl -sS -f -o /dev/null --), $url);
  $!=$?=0;
  system @cmd and warning
    "failed to check accessibility of revealed key: $url ($? $!)";
}

sub active_key_info () {
  my ($key, $st, $warning);
  if (($key) = @$key0) {
    $st = '+0';
  } elsif (($key) = @$key_1) {
    $st = '-1';
    $warning = "starting signing with not-yet-published-long enough key";
  } else {
    $warning = "no key exists! how is this possible!";
  }
  return ($key, $st, $warning)
}

sub selector_was_abolished ($$) {
  my ($st,$i) = @_;
  $i >= $sel_limit and $st eq '+X';
}

#-------------------- readme --------------------

sub prepare_pub_readme () {
  my $readme_file = "$var/pub/README.txt";
  my $readme_text = <<'END';
Expired (rotated-out) DKIM mail signing keys - private keys!

These directories contain the private keys which were used in the past
by this system as part of the DKIM email signing antispam system.

After each key has been rotated out, the secret key is published here.
This is to make emails sent by our users non-nonrepudiable:

If you have what purports to be a leaked email from our system, the
DKIM signature on it does not necessarily confirm that the email is genuine.
The person giving you the "leaked email" might have edited it, or
completely made it up, and then used one of these private keys to sign it.


To obtain the private key for a particular public key, use the following
procedure.  Starting (say) with the DKIM selector TXT RR content:
   * Find the base64string following `p=`, which is the public key.
   * base64 decode it.
   * feed the resulting binary file through MD5.
   * Convert to hex.
   * The first two digits of the hex string are the directory name.
   * The filename is HEX.pem where HEX is the complete
     hex string, from above.
   * Strip README.txt from the end of the URL of this file and
     replace it with hh/xxxxx.pem, as computed above.

Calculating the end of the URL can be done with a rune like this:

 echo 'MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA2ycQ99x3kKz6aUKj' | base64 -d | md5sum | perl -pe 's/ .*//; s#^..#$&/$&#; s/$/.pem/'

supposing MIIBIjAN... came from the DKIM selector.

END

  if (open R, '<', $readme_file) {
    local $/;
    undef $/;
    my $already = <R>;
    R->error and fail "read $readme_file: $!";
    return if $already eq $readme_text;
  } else {
    $!==ENOENT or fail "open README.txt (for checking): $readme_file: $!";
  }

  open R, ">", "$readme_file.tmp" or fail "create $readme_file.tmp: $!";
  print R $readme_text or fail "write $readme_file.tmp: $!";
  close R or fail "close $readme_file.tmp: $!";
  rename "$readme_file.tmp", $readme_file or fail "install $readme_file: $!";
}

#-------------------- preparation and file reading --------------------

sub zone_header_serial ($) {
  my ($serial) = @_;
  local $_ = $zone;
  s{^([^;]*) \b (\d+) (?= \s* ;! SERIAL \b )}{$1$serial}mx
    or fail "config file $config_file: ".
    (m{; \s* ! \s* SERIAL}x
     ? ";!SERIAL comment found but syntax or surrounding context is wrong"
     : ";!SERIAL comment missing");
  return ($_, $2);
}

sub read_config () {
  $zone = '';
  %cfg = (
	  max_selector => 12,
	  dns_lag => 4*3600,
	  email_lag => (24*3 + 16)*3500,
	  rsa_bits => 2048,
	  dkim_txt => 'v=DKIM1; h=sha256; s=email',
	  dns_reload => 'rndc reload >/dev/null',
	  mta_reload => 'true',
	  mta_group => 'Debian-exim',
	 );

  my $errors = 0;
  open C, '<', $config_file or fail "open config file: $config_file: $!";
  while (<C>) {
    if (!m{^\s*!}) {
      $zone .= $_;
      next;
    }
    my $bad = sub {
      print STDERR msg_prefix(), @_, "\n";
      $errors++;
      no warnings qw(exiting);
      next;
    };
    s{\s+$}{};
    s{^\!\s*(\w+)\s*}{} or $bad->("bad dkim-rotate directive syntax");
    my $kw = $1;
    if ($kw eq 'max_selector') {
      if (m{^[a-z]$}) {
	$cfg{max_selector} = ord($&) - ord('a');
      } elsif (m{^\d{1,2}} && $_ >= 1 && $_ <= 26) {
	$cfg{max_selector} = $_ + 0;
      } else {
	$bad->("bad value for $kw");
      }
    } elsif ($kw =~ m{.*_lag$} && exists $cfg{$kw}) {
      my ($qty, $unit) = m{^ (?= \.? \d ) ( \d* \.? \d* ) (\D) $}x
	or $bad->("bad syntax for $kw (expected quantity and unit)");
      $unit = $duration_units{$unit}
	// $bad->("unknown unit $unit for $kw");
      $cfg{$kw} = $qty * $unit;
    } elsif ($kw =~ m{^(:? rsa_bits )$}x) {
      $kw = $&;
      m{^\d+} || $bad->("bad value for $kw, expected number");
      $cfg{$kw} = $& + 0;
    } elsif ($kw =~ m{^(:? dkim_txt | mta_reload | dns_reload )$}x) {
      $kw = $&;
      $cfg{$kw} = $_;
    } elsif ($kw =~ m{^(:? mta_group | pub_url )$}x) {
      m{^\S+$} or $bad->("bad value for $kw, may not contain spaces");
      $cfg{$kw} = $&;
    } elsif ($kw eq 'instance_var_dir') {
      $var = $_;
    } else {
      warning "$config_file:$.: unknown keyword $kw";
    }
  }
  C->error and fail "read $config_file: $!";
  $errors and fail "config file has $errors errors\n";

  if (!defined $cfg{pub_url}) {
    $cfg{pub_url} = '-';
    warning "$config_file:".
      " pub_url not specified, cannot link to, or check, revealed keys";
  }

  $last_serial = (zone_header_serial(''))[1]; # also checks it
  $var // fail
    "need var_dir in config, when instance given as path to config";
  $cfg{max_selector} >= 2
    or fail "max_selector says only $cfg{max_selector} but >+2 needed";
}
  
sub read_state () {
  my $state_file = "$var/state";
  my $si = -1;
  if (!open S, '<', "$state_file") {
    $! == ENOENT or fail "open state file: $state_file: $!";
    $opt->mode eq 'new'
      or fail "state file $state_file does not exist (--new needed?)";

    $sel_offset = 0;
    $sel_limit = $cfg{max_selector};
    $last_serial //= 1000000;
    
    return;
  }
  my $corrupt = sub { fail "state corrupted! $state_file:$.: @_"; };
  my $i = 0;
  while (<S>) {
    s/\s+$//;
    if (s{^( sel_offset | sel_limit | last_serial )\s+}{}x) {
      my $kw = $1;
      m{^(\d+)$} or $corrupt->("bad numeric line");
      no strict qw(refs);
      $$kw = $1;
    } elsif (s{^ status \s+}{}x) {
      my $nsi = $st2si{$_} // $corrupt->("bad status $_");
      $nsi > $si or $corrupt->("status out of order");
      $si = $nsi;
    } elsif (s{^ key \s+}{}x) {
      m{^ ([a-z]) \s+
          (\d+|DNS|MTA) \s+
          ([0-9a-f]{2,100}) \s+
          (.*)
         $}x or $corrupt->("bad key line");
      my $key = { sel => $1, time_t => $2, keyname => $3, txtdata => $4 };
      $si >=0 or $corrupt->("key before status");
      defined $sel_offset and defined $sel_limit
	or $corrupt->("key before sel_offset and/or sel_limit");
      $key->{sel} eq selector_of_index($i)
	or selector_was_abolished($si2st[$si], $i)
	or $corrupt->("key selector mismatch (sequencing error)");
      my $keys = $keys[$si];
      push @$keys, $key;
      $si >= 2 || @$keys <= 1 or $corrupt->("multiple of singleton status");
      $i++;
    } else {
      warning "$state_file:$.: unknown keyword or bad syntax";
    }
  }
  S->error and fail "read $state_file: $!";
  foreach my $kw (qw(sel_offset sel_limit last_serial)) {
    no strict qw(refs);
    $$kw // $corrupt->("missing $kw");
  }
}

sub save_state () {
  my $f = "$var/state";
  open S, '>', "$f.tmp" or fail "create new state file $f.tmp: $!";
  my $p = sub {
    print S @_ or fail "write to new state file $f.tmp: $!";
  };
  foreach my $kw (qw(sel_offset sel_limit last_serial)) {
    no strict qw(refs);
    $p->("$kw $$kw\n");
  }
  my $i = 0;
  foreach my $st (@si2st) {
    $p->("status $st\n");
    my $si = $st2si{$st} // confess "$st ?";
    foreach my $key (@{ $keys[$si] }) {
      $key->{sel} eq selector_of_index($i)
	or selector_was_abolished($st, $i)
	or confess "state mangled - selectors varied $st $i $sel_limit "
	." $key->{sel} != ".selector_of_index($i);
      $p->("key");
      foreach my $kw (qw(sel time_t keyname txtdata)) {
	$p->(" $key->{$kw}");
      }
      $p->("\n");
      $i++;
    }
  }
  close S or fail "close new state file $f.tmp: $!";
  rename "$f.tmp", $f or fail "install $f.tmp as new state file $f: $!";
}

sub prepare_pub () {
  my %already;
  mkdir "$var/pub", 0777 or $!==EEXIST or fail "mkdir $var/pub: $!";

  foreach (glob "$var/pub/??") { $already{$_} = 1; }
  foreach my $i (0..0xff) {
    my $hh = sprintf "%02x", $i;
    my $p = "$var/pub/$hh";
    next if $already{$p};
    mkdir $p, 0755 or fail "mkdir $p: $!";
  }

  prepare_pub_readme();
}

sub acquire_lock () {
  mkdir "$var", 0777 or $!==EEXIST or fail "mkdir $var: $!";

  my $lock_file = "$var/lock";
  open LOCK, '+>', $lock_file or fail "open lock file $lock_file: $!";
  flock LOCK, LOCK_EX or fail "acquire lock: $lock_file: $!";
}

sub check_priv () {
  my $p = "$var/priv";
  rmdir "$p.new" or $!==ENOENT or fail "clean up old $p.new: $!";
  if (stat $p) {
    fail "$p has bad permissions - globally +x !" if (stat _)[2] & 001;
    return;
  }
  mkdir "$p.new", 0700 or fail "make $p.new: $!";
  if ($cfg{mta_group} ne '-') {
    my @cmd = (qw(chgrp --), $cfg{mta_group}, "$p.new");
    $!=$0=0; system @cmd and child_failed "@cmd";
    chmod 0750, "$p.new" or fail "chmod $p.new to 0750: $!";
  }
  rename "$p.new", $p or fail "move $p.new into place as $p: $!";
}

sub clean_garbage_priv () {
  my %names;

  keys_forall(sub { $names{$_->{keyname}}++; });

  #print STDERR Dumper(\%names);

  foreach my $path (glob "$var/priv/*") {
    $_ = $path;
    m{ / ([^/.][^/]+) $}xs or next;
    $_ = $1;
    next if s{\.pem$}{} && $names{$_};
    unlink $path or fail "tidy up garbage: remove $path: $!";
  }
}

#-------------------- updates/reloads --------------------

sub run_reload_command ($) {
  my ($kind) = @_;
  my $cmd = $cfg{lc($kind)."_reload"};
  $!=$?=0;
  system $cmd and child_failed "$kind reload ($cmd)";
}

sub generate_output_file ($$$) {
  my ($kind, $f, $data) = @_;
  $f = "$var/$f";
  open O, '>', "$f.tmp" or fail "write new $kind output file $f.tmp: $!";
  print O $data and close O or fail "write data to $f.tmp: $!";
  rename "$f.tmp", $f or fail "install $f.tmp as new $f: $!";
}

sub outstanding_update_reload ($) {
  my ($kind) = @_;
 FOUND:
  for (;;) {
    last FOUND if $opt->{mode} eq 'reinstall';
    keys_forall(sub {
      no warnings qw(exiting);
      last FOUND if $_->{time_t} =~ m{\b $kind \b}x;
    });
    return;
  };

  my $autogen = "----- autogenerated by ".prog_name." -----";

  if ($kind eq 'DNS') {

    $last_serial++;
    $last_serial &= 0xffffffff;
    $last_serial = 1 if !$last_serial; # 0 is weird
    save_state();

    my $zone_out = '';
    $zone_out .= ";$autogen\n";
    $zone_out .= "; this part templated from $config_file:\n";
    $zone_out .= (zone_header_serial($last_serial))[0];
    $zone_out .= "\n"; # in case of missing final newline
    $zone_out .= ";$autogen\n";
    $zone_out .= "; this part is the automaintained data:\n";
    my $i = 0;
    foreach my $st (qw(-1 +0 +N)) {
      my $si = $st2si{$st} // confess "$st ?"; 
      foreach my $key (@{ $keys[$si] }) {
	my $s = selector_of_index($i);
	$zone_out .= "$s IN TXT";
	my $data = $key->{txtdata};
	while (length $data) {
	  no warnings qw(substr);
	  my $part = substr $data, 0, 255;
	  $data = substr $data, 255;
	  $part =~ s{[^ !#-\x5b\x5d-~]}{ sprintf "\\%03o", ord $& }gse;
	  $zone_out .= " \"$part\"";
	}
	$zone_out .= "\n";
	$i++;
      }
    }
    $zone_out .= ";fin.\n";

    generate_output_file($kind, 'zone', $zone_out);

  } elsif ($kind eq 'MTA') {

    my ($key, $dummy_st, $warning) = active_key_info();
    warning $warning if $warning;

    #use Data::Dumper;
    #print STDERR Dumper(\@si2st,\%st2si,\@keys, $key_1,$key0,$keysN,$keysX);
    
    my $exim_out = "#$autogen\n";
    if ($warning) {
      $exim_out .= "# warning! $warning\n";
    }
    if ($key) {
      my $exim_kv = sub {
	my ($k, $v) = @_;
	$exim_out .= "$k: $v\n";
      };
      $exim_kv->("selector", $key->{sel});
      $exim_kv->("privkey", key_priv_priv_file($key));

      my $key_reveal_leaf = key_priv_pub_leaf($key);
      my $url_base = pub_url_of('');
      if (defined $url_base) {
	my $readme_url = pub_url_of('README.txt');
	my $privkey_url = pub_url_of($key_reveal_leaf);
	$exim_kv->("key_reveal_leaf", $key_reveal_leaf);
	$exim_kv->("url", $url_base);
	$exim_kv->("readme_url", $readme_url);
	$exim_kv->("key_reveal_url", $privkey_url);
	$exim_kv->("header_note",
		   sprintf "NOTE REGARDING DKIM KEY COMPROMISE %s %s",
		   $readme_url, $privkey_url);
      }
    }

    generate_output_file($kind, 'exim', $exim_out);

  } else {

    confess "$kind ?";

  }

  run_reload_command $kind;

  my $now = time;
  keys_forall(sub {
    if ($_->{time_t} =~ s{\,? \b $kind \b \,? }{}x) {
      $_->{time_t} ||= $now;
    }
  });

  save_state();
}

sub outstanding_updates_reloads {
  outstanding_update_reload('DNS');
  outstanding_update_reload('MTA');
  keys_forall(sub {
    my $tt = $_->{time_t};
    return '' if $tt !~ m/\D/;
    confess "$tt not installed! ($_->{txtdata})";
  });
}

#-------------------- key generation --------------------

sub generate_key () {
  my $script =  <<'END';
  # This script:
  #  * prints a line KEYNAME
  #  * then outputs the public key data in base64 PEM format
  #  * leaves the private key in priv/KEYNAME.pem

    set -e
    cd "$1"
    rsa_bits=$2
    set +e
    (
      set -e
      exec 2>sh-errors
      set -x
      cd priv

      openssl genrsa -out new.priv.pem $rsa_bits
      chmod 644 new.priv.pem # directory permissions protect (checked)
      openssl rsa -in new.priv.pem -out new.pub.pem -pubout -outform PEM
      openssl base64 -a -d -in new.pub.pem -out new.pub.bin
      md5sum <new.pub.bin >new.pub.hash
      read <new.pub.hash keyname
      keyname=${keyname%% *}
      echo $keyname
      cat new.pub.pem
      mv new.priv.pem $keyname.pem

    )
    if [ $? = 0 ]; then
      set -e
      rm sh-errors priv/new.*
      exit
    fi

    set -e
    cat sh-errors >&2
    echo >&2 'key generation failed'
    exit 1
END

  open G, "-|", qw(sh -ec), $script, prog_name."(sh)", $var, $cfg{rsa_bits}
    or fail "fork for key generation: $!";
  my $keyname = <G>;
  local $/;
  undef $/;
  my $pubkey = <G>;
  G->error and fail "read from key gen child: $!";
  $!=$?=0;
  close G or child_failed 'key generation script';

  $keyname =~ m{^[0-9a-f]+$} or confess "key gen keyname=$keyname !";
  $keyname = $&;

  $pubkey =~ s{^-----.*-----$}{}mg or confess "key gen not PEM $pubkey ?";
  $pubkey =~ s{\s}{}g;

  my $txtdata = "$cfg{dkim_txt}; ";
  if ($cfg{pub_url} ne '-') {
    $txtdata .= "n=IMPORTANT NOTE ABOUT FORGED DKIM SIGNATURES ";
    $txtdata .= encode_qp("$cfg{pub_url}/README.txt", '');
    $txtdata .= "; ";
  }
  $txtdata .= "p=$pubkey";

  return { time_t => 'DNS', keyname => $keyname, txtdata => $txtdata };
}

#-------------------- status printing --------------------

sub print_status () {
  my $i = 0;
  my $o = '';

  my $st;

  my $pline_inner = sub {
    my ($s, $st, $info) = @_;
    $o .= sprintf
      (
       "%-19s  %1s %2s  %s\n",
       $instance, $s, $st, $info,
      );
  };

  my $pline = sub {
    my ($st, $info, $sel) = @_;
    
    if ($i == $cfg{max_selector} && $st ne '+X') {
      $o .= sprintf
	"%-19s  ----- scheduled for abolition: -----\n", $instance;
    }

    $sel //= selector_of_index($i);
    $pline_inner->($st eq '+X' ? "($sel)" : " $sel ", $st, $info);
    $i++;
  };

  foreach $st (@si2st) {

    foreach my $key (@{ $keys[$st2si{$st}] }) {
      my $time_t = $key->{time_t};
      $pline->($st, sprintf
	(
	 "%-11s %s",

	 ($st eq '-1' ? 'generated' :
	  $st eq '+0' ? 'active' :
	  $st eq '+N' ? 'percolating' :
	  $st eq '+X' ? 'revoking' : confess "$st ?"),

	 ($time_t =~ m/[A-Z]/ ? "but! needs $time_t update/reload" :
	  $st eq '+0' ? '' : "since ".show_time $time_t)
	),
	      $key->{sel});
    }
  }

  $st = '';

  while ($i < $sel_limit) {
    $pline->('', 'free');
  }
  while ($i < $cfg{max_selector}) {
    local $sel_limit = $cfg{max_selector};
    local $sel_offset = 0;
    $pline->('', 'scheduled for adoption');
  }

  print $o and flush STDOUT or fail "write stdout: $!\n";
}

#-------------------- main algorithm steps --------------------

sub perhaps_reveal () {
  for (;;) {
    my $key = $keysX->[-1];
    last unless key_time_elapsed('+X', $key, 'dns_lag', 'reveal');
    my $priv_file = key_priv_priv_file($key);
    my $pub_leaf = key_priv_pub_leaf($key);
    my $pub_file = "$var/pub/$pub_leaf";
    if (utime $dummy_time_t, $dummy_time_t, $priv_file) {
      link $priv_file, $pub_file
	or $!==EEXIST or fail "make public link $pub_file for $priv_file: $!";
      unlink $priv_file
	or fail "remove stale priv key $priv_file: $!";
    } elsif ($!==ENOENT) {
      # must have done this already
    } else {
      fail "obliterate mtime/atime: $priv_file: $!";
    }
    pop @$keysX;
    save_state();
    progress '+X','R',$key, "revealed.";
    check_revealed $pub_leaf;
    last if !@$keysX;
  }
}

sub perhaps_deadvertise () {
  for (;;) {
    last unless
      key_time_elapsed('+N', $keysN->[-1], 'email_lag', 'deadvertise');
    my $key = pop @$keysN;
    $key->{time_t} = 'DNS';
    unshift @$keysX, $key;
    save_state();
    progress '+N','+X',$key, "deadvertised.";
  }
}

sub perhaps_adjust_selector_limit () {
  my $new_limit = $cfg{max_selector};
  return if $sel_limit == $new_limit;

  if ($sel_offset) {
    warning "cannot yet adjust selector count: offset $sel_offset != 0";
    return;
  }
  my $n = count_keys_advertised();
  if ($n > $new_limit) {
    warning "cannot yet adjust selector count: $n keys, want $new_limit";
    return;
  }

  $sel_limit = $new_limit;
  save_state();
  print STDERR msg_prefix."selector limit adjusted to $new_limit\n";
}

sub perhaps_advance_to_new_current_key () {
  return unless key_time_elapsed('-1', $key_1->[0], 'dns_lag', 'advance/use');
  if ($opt->mode !~ m{major|new}) {
    progress_no '-1', $key_1->[0], 'advance/use', "not --major run";
    return;
  }

  my $old_key = pop @$key0;
  if ($old_key) {
    $old_key->{time_t} = 'MTA';
    unshift @$keysN, $old_key;
    progress '+0','+N',$old_key, "advanced; now emails percolating.";
  }
  my $new_key = pop @$key_1;
  $new_key->{time_t} = 'MTA';
  unshift @$key0, $new_key;
  save_state();
  progress '-1','+0',$new_key, "advanced; now in use.";
}

sub perhaps_generate () {
  if (@$key_1) {
    progress_no '-1',$key_1->[0], "generate", "already exists.";
    return;
  }
  my $count_keys = count_keys_advertised();
  if ($count_keys >= $sel_limit) {
    progress_no '-1',undef,
      "generate", "no available selector ($count_keys >= $sel_limit)";
    return;
  }
  # While the offset is nonzero, we still rotate using all the selectors,
  # as that gets us more quickly to the state where we can adjust.
  if ($count_keys >= $cfg{max_selector} && $sel_offset==0) {
    progress_no '-1',undef,
      "generate", "selector abolition ($count_keys >= $cfg{max_selector})";
    return;
  }

  my $key = generate_key();

  $sel_offset--;
  $sel_offset += $sel_limit if $sel_offset < 0;

  $key->{sel} = selector_of_index(0);

  unshift @$key_1, $key;
  $key->{time_t} .= ',MTA' if !@$key0; # need to install it too

  save_state();
  progress '','-1',$key, "generated.";
}

#-------------------- main program --------------------

sub process_instance ($$$) {
  ($instance, $config_file, $var) = @_;

  %cfg = ();
  foreach my $v (qw($zone $sel_offset $sel_limit $last_serial)) {
    no strict qw(refs);
    $$v = undef;
  }
  @$_ = () foreach @keys;

  read_config();

  if ($opt->mode eq 'status') {
    read_state();
    print_status();
    return;
  }

  acquire_lock();
  read_state();
  check_priv();
  clean_garbage_priv();
  prepare_pub();

  if ($opt->mode eq 'reinstall') {
    outstanding_updates_reloads();
    my ($key, $st, $dummy_warning) = active_key_info();
    $st //= '';
    progress $st,'',$key, 'MTA and DNS reinstalled and reloaded';
    return;
  }

  outstanding_updates_reloads();
  perhaps_reveal();
  perhaps_deadvertise();
  perhaps_adjust_selector_limit();

  perhaps_advance_to_new_current_key();
  outstanding_updates_reloads('MTA');
  perhaps_generate();
  outstanding_updates_reloads();
} 

sub process_all_instances () {
  foreach my $config_file (glob $opt->etc_dir."/*.zone") {
    next unless $config_file =~ m{^.*/([a-z][-_.0-9a-z]*)\.zone$}s;
    process_instance($1, $config_file, $opt->var_dir."/$1");
  }
}

if (@ARGV) {
  foreach (@ARGV) {
    if (m{/}) {
      process_instance($_, $_, undef);
    } else {
      process_instance($_, $opt->etc_dir."/$_.conf", $opt->var_dir."/$_");
    }
  }
} else {
  process_all_instances();
}
