#! /usr/bin/perl -w

###----- Licensing notice ---------------------------------------------------
###
### This program is free software: you can redistribute it and/or modify it
### under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or (at
### your option) any later version.
###
### This program is distributed in the hope that it will be useful, but
### WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
### Public License for more details.
###
### You should have received a copy of the GNU General License along with
### mLib.  If not, write to the Free Software Foundation, Inc., 59 Temple
### Place - Suite 330, Boston, MA 02111-1307, USA.

###--------------------------------------------------------------------------
### External modules.

use autodie;
use strict;

use Carp;
use IO::Handle;
use MIME::Base32;
use MIME::Base64;
use POSIX;
use Time::Local;

###--------------------------------------------------------------------------
### Other preliminaries.

(our $PROG = $0) =~ s!^.*/!!;
our $VERSION = '@VERSION@';

## Check arguments.  This is easy: there aren't any.
sub usage (*) { my ($f) = @_; print $f "usage: $PROG\n"; }
if (@ARGV) {
  my $arg = $ARGV[0];
  if (@ARGV > 1) { }
  elsif ($arg eq "-h" || $arg eq "--help")
    { usage STDOUT; exit 0; }
  elsif ($arg eq "-v" || $arg eq "--version")
    { print "$PROG, version $VERSION\n"; exit 0; }
  usage STDERR; exit 2;
}

sub maybe_mkdir ($;$) {
  my ($dir, $mode) = @_;
  ## Create a directory DIR with permissions MODE, defaulting to 0777, before
  ## umask.  Ignore errors complaining that the directory already exists.

  eval { mkdir $dir, $mode // 0777; }; die if $@ && $@->errno != EEXIST;
}

sub maybe_unlink ($) {
  my ($file) = @_;
  ## Delete FILE.  Ignore errors complaining that the FILE doesn't exist.

  eval { unlink $file; }; die if $@ and $@->errno != ENOENT;
}

sub present_time ($) {
  my ($t) = @_;
  ## Format T as a human-readable time.

  return strftime "%Y-%m-%d %H:%M:%S %z", localtime $t;
}

sub dump_file ($$) {
  my ($fout, $file) = @_;
  ## Copy the contents of FILE to the stream FOUT.

  open my $fin, "<", $file;
  my $buf;
  while (sysread $fin, $buf, 65536) { print $fout $buf; }
  close $fin;
}

sub parse_stamp ($) {
  my ($stamp) = @_;
  ## Parse an ISO8601 zulu-time stamp to POSIX `time_t'.

  my ($y, $mo, $d, $h, $mi, $s) =
    $stamp =~ m{^ (\d{4}) - (\d{2}) - (\d{2}) T
		  (\d{2}) : (\d{2}) : (\d{2}) Z $}x
      or die "bad timestamp `$stamp'";
  return timegm $s, $mi, $h, $d, $mo - 1, $y - 1900;
}

sub present_stamp ($) {
  my ($t) = @_;
  ## Format a POSIX `time_t' as a string.

  my ($s, $mi, $h, $d, $mo, $y, $wd, $yd, $dstp) = gmtime $t;
  return sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ",
    $y + 1900, $mo + 1, $d, $h, $mi, $s;
}

sub running (&@) {
  my ($body, @prog) = @_;
  ## Run the BODY, printing a banner above and below, including a proposed
  ## program name and arguments PROG, and the exit status.

  my $label = sprintf "RUN %s ", join " ", @prog;
  print $label . ">" x (77 - length $label) . "\n";
  my @r;
  if (wantarray) { @r = $body->(); }
  else { @r = scalar $body->(); }
  print "<" x 77 . "\n";
  if (!$?) { }
  elsif ($?%256) { printf "command killed by signal %d\n", $?%256; }
  else { printf "command exited with status %d\n", int($?/256); }
  die "command failed" if $?;
  return @r;
}

sub run (@) {
  my (@prog) = @_;
  ## Run PROG.

  running { system @prog; } @prog;
}

## Set the current time.
our $NOW;
if (!defined $ENV{"DKIM_KEYS_TIMENOW"}) {
  $NOW = time;
} else {
  $NOW = parse_stamp $ENV{"DKIM_KEYS_TIMENOW"};
  printf "pretending time is %s\n", present_time $NOW;
}

printf "%s BEGINS at %s\n", $PROG, present_time $NOW;

###--------------------------------------------------------------------------
### BER decoding.

## BER tag classes.
sub C_UNV () { return 0; }		# universal
sub C_APP () { return 1; }		# application
sub C_CTX () { return 2; }		# contextual
sub C_PRV () { return 3; }		# private

## BER universal tag numbers.
sub TY_INT () { return 2; }		# INTEGER
sub TY_BITSTR () { return 3; }		# BIT STRING
sub TY_OCTSTR () { return 4; }		# OCTET STRING
sub TY_NULL () { return 5; }		# NULL
sub TY_OID () { return 6; }		# OBJECT IDENTIFIER
sub TY_SEQ () { return 16; }		# SEQUENCE
sub TY_SET () { return 17; }		# SET

sub ber_decoid ($) {
  my ($oid) = @_;
  ## Decode an encoded OID body.  Return the OID in text format, as a list
  ## of integers separated by `.'.

  my ($h, @d) = unpack "C w*", $oid;
  if ($h >= 0x80) { die "malformed BER (invalid OID)"; }
  return join ".", int($h/40), $h%40, @d;
}

sub ber_decnext (\$) {
  my ($str_inout) = @_;
  ## Decode the next value from a BER-encoded string, updating STR_INOUT to
  ## hold the remaining material.  Returns four items (C, K, T, X), where C
  ## is the tag class; K is a flag which is truish if the encoding is
  ## constructed or falsish if primitive; T is the tag number; and X is the
  ## encoded body.

  my ($h0, $r) = unpack "C a*", $$str_inout;
  my ($c, $k, $t) = (($h0 >> 6)&0x03, ($h0 >> 5)&0x01, ($h0 >> 0)&0x1f);
  if ($t == 0x1f) { ($t, $r) = unpack "w a*", $r; }

  (my $n, $r) = unpack "C a*", $r;
  if ($n == 0x80) { die "indefinite encodings not supported"; }
  elsif ($n == 0xff) { die "malformed BER (invalid length)"; }
  elsif ($n > 0x80) {
    $n &= 0x7f;
    my @n = unpack +(sprintf "C%d", $n), $r;
    $r = substr $r, $n;
    $n = 0; for my $i (@n) { $n = 256*$n + $i; }
  }
  $$str_inout = substr $r, $n; return ($c, $k, $t, substr $r, 0, $n);
}

sub read_pem ($$) {
  my ($file, $label) = @_;
  ## Read a PEM-encoded message from FILE, with LABEL quoted in the boundary
  ## markers, and return the binary contents.

  my $body = "";
  open my $f, "<", $file;
  LINE: while (<$f>)
   { last LINE if /^-----BEGIN \Q$label\E-----$/; }
  LINE: while (<$f>)
    { last LINE if /^-----END \Q$label\E-----$/; $body .= $_; }
  close $f;

  return decode_base64 $body;
}

sub ident ($) {
  my ($pub) = @_;
  ## Parse the (raw BER) RSA public key data PUB, returning a key identifier.
  ## This is the least significant 80 bits of the modulus, Base32-encoded,
  ## which comes out at 16 characters.

  my ($c, $k, $t);

  ## Outer SEQUENCE.
  ($c, $k, $t, my $x) = ber_decnext $pub;
  $c == C_UNV && $k && $t == TY_SEQ
    or die "malformed key (expected seq)";

  ## Inner SEQUENCE.
  ($c, $k, $t, my $y) = ber_decnext $x;
  $c == C_UNV && $k && $t == TY_SEQ
    or die "malformed key (expected seq)";

  ## Key type OID; must be `rsaEncryption'.
  ($c, $k, $t, my $o) = ber_decnext $y;
  $c == C_UNV && !$k && $t == TY_OID
    or die "malformed key (expected oid)";
  ber_decoid($o) eq "1.2.840.113549.1.1.1"
    or die "malformed key (wrong oid)";

  ## Parameters; must be NULL.
  ($c, $k, $t, my $z) = ber_decnext $y;
  $c == C_UNV && !$k && $t == TY_NULL && $z eq ""
    or die "malformed key (expected null)";

  ## End inner SEQUENCE.
  $y eq "" or die "malformed key (trailing junk)";

  ## BIT STRING holding the actual public key data.  I have no idea what
  ## they were thinking when they came up with this.
  ($c, $k, $t, my $u) = ber_decnext $x;
  $c == C_UNV && !$k && $t == TY_BITSTR
    or die "malformed key (expected bitstr)";
  (my $n, $u) = unpack "C a*", $u;
  $n == 0 or die "malformed key (odd-length bitstr)";

  ## Inner SEQUENCE.
  ($c, $k, $t, $y) = ber_decnext $u;
  $c == C_UNV && $k && $t == TY_SEQ
    or die "malformed key (expected seq)";

  ## INTEGER holding the modulus.
  ($c, $k, $t, $n) = ber_decnext $y;
  $c == C_UNV && !$k && $t == TY_INT
    or die "malformed key (expected int)";

  ## INTEGER holding the public exponent, which we don't care about.
  ($c, $k, $t, my $e) = ber_decnext $y;
  $c == C_UNV && !$k && $t == TY_INT
    or die "malformed key (expected int)";

  ## Close the inner SEQUENCE, BIT STRING, outer SEQUENCE, and the
  ## top-level.
  $y eq "" or die "malformed key (trailing junk)";
  $u eq "" or die "malformed key (trailing junk)";
  $x eq "" or die "malformed key (trailing junk)";
  $pub eq "" or die "malformed key (trailing junk)";

  ## Extract the low bits of the modulus and encode them.
  length $n >= 10 or die "malformed key (too small)";
  return lc encode_base32 substr($n, -10), "";
}

###--------------------------------------------------------------------------
### Configuration.

## Conversion functions take two arguments, PARSEP and VAL.  If PARSEP is
## truish, then VAL is a value read from the configuration file, and the
## function should parse it and return the Perl internal value.  If PARSE is
## falsish, then do the reverse conversion.

sub conf_token ($$) {
  my ($parsep, $val) = @_;
  ## Do-nothing conversion function for text.

  return $val;
}

sub conf_stamp ($$) {
  my ($parsep, $val) = @_;
  ## Convert ISO8601 zulu-time stamps to POSIX `time_t'.

  if ($parsep) { return parse_stamp $val; }
  else { return present_stamp $val; }
}

{
  ## Map between unit names and scales.
  my %unitmap; my @unitmap;

  for my $item ([7*24*60*60, qw{wk w wks week weeks}],
		[24*60*60, qw{dy d dys day days}],
		[60*60, qw{hr h hrs hour hours}],
		[60, qw{min m mins minute minutes}],
		[1, "", qw{s sec secs second seconds}]) {
    my ($scale, @names) = @$item;
    for my $name (@names) { $unitmap{$name} = $scale; }
    push @unitmap, [$scale, $names[0]];
  }

  sub conf_duration ($$) {
    my ($parsep, $val) = @_;
    ## Convert time durations with units.

    if ($parsep) {
      my ($x, $u) = $val =~ m{^ \s* (\.\d+ | \d+ (?: \. \d*)?)
				\s* (| \S+) $}x
	or die "bad duration `$val'";
      my $scale = $unitmap{$u} or die "bad duration `$val'";
      return $x*$scale;
    } else {
      my $x = 1; my $u = "s";
      UNIT: for my $item (@unitmap) {
	my ($scale, $unit) = @$item;
	if ($val >= $scale) { $x = $val/$scale; $u = $unit; last UNIT; }
      }
      return sprintf "%.4g %s", $x, $u;
    }
  }
}

sub read_config ($$) {
  my ($spec, $file) = @_;
  ## Read configuration from FILE, as described by SPEC.  Return a hash
  ## mapping names to values.
  ##
  ## The SPEC is a hashref mapping configuration keys to [CONV, DFLT] pairs,
  ## where CONV is a conversion function (as described above) and DFLT is the
  ## default value.

  my %c;
  open my $f, "<", $file;
  LINE: while (<$f>) {
    chomp; next LINE unless /^\s*[^#]/;
    my ($k, $v) = m{^ \s* ([^=\s]+) \s* = (.*) $}x
      or die "bad assignment `$_'";
    $v =~ s/^\s+//; $v =~ s/\s+$//;
    my $def = $spec->{$k} or die "unknown setting `$k'";
    exists $c{$k} and die "duplicate setting `$k'";
    $c{$k} = $def->[0](1, $v);
  }
  close $f;
  for my $k (keys %$spec) {
    if (exists $c{$k}) { }
    elsif ($spec->{$k}->@* > 1) { $c{$k} = $spec->{$k}[1]; }
    else { die "missing setting for `$k'"; }
  }
  return \%c;
}

sub write_config ($$$) {
  my ($spec, $file, $conf) = @_;
  ## Write configuration back FILE from CONF, as described by SPEC.  See
  ## `read_config' for the format of SPEC.

  open my $f, ">", "$file.new";
  KEY: for my $k (keys %$spec) {
    defined $conf->{$k} or next KEY;
    printf $f "%s = %s\n", $k, $spec->{$k}[0](0, $conf->{$k});
  }
  close $f;
  rename "$file.new", $file;
}

###--------------------------------------------------------------------------
### Configuration.

my %CONF_SPEC = ("ddns-zone" => [\&conf_token],
		 "ddns-server" => [\&conf_token, undef],
		 "ddns-key" => [\&conf_token],
		 "ddns-ttl" => [\&conf_duration, 4*60*60],
		 "dns-delay" => [\&conf_duration, 2*24*60*60],
		 "instance" => [\&conf_token],
		 "publish-uri" => [\&conf_token],
		 "active-duration" => [\&conf_duration, 24*60*60],
		 "cycle-period" => [\&conf_duration, 3*24*60*60],
		 "mail-persistence" => [\&conf_duration, 7*24*60*60],
		 "dns-persistence" => [\&conf_duration, 3*24*60*60]);

our %C = %{read_config \%CONF_SPEC, "dkim-keys.conf"};

###--------------------------------------------------------------------------
### State model.

## There are six states that a key can be in.  Keys always advance through
## these states in order.  Except in `NEW' and `PUBLISH', the key's
## private-key file is reliably named `ST/TS.ID.priv', and this is the
## primary means to determine which state the key is actually in.
##
##   * `NEW'.  This is rather complicated, and there are multiple steps and
##     a fiddly cleanup procedure.
##
##	 1. Create `NEW/new.priv'.  Cleanup: delete it.
##	 2. Create `NEW/new.pub'.  Determine key id.  Cleanup: delete both.
##	 3. Rename to `NEW/TS.ID.priv'.  Cleanup: continue to ANNOUNCE.
##	 4. Rename `MEW/new.pub' to `active/ID.pub'.  (If it's not there,
##	    then this has been done already.)
##	 5. Announce the key in the DNS.
##	 6. Promote the key to ANNOUNCE: rename `NEW/TS.ID.priv' to
##	    `ANNOUNCE/TS.ID.priv'.
##
##   * `ANNOUNCE'.  The key has been announced in the DNS, and we're waiting
##     for the announcement to propagate before we deploy the key.  A
##     placeholder HTML file is written to `publish/I/D.html'.  Unless we're
##     in catch-up mode, keys will remain in `ANNOUNCE' state for DNS-DELAY
##     seconds.  The timestamp is the time at which we expect the key to
##     become active.
##
##   * `DEPLOY'.  The key is ready for use in the upcoming cycle; the private
##     key file is in `active/ID.priv', and the key is named in the
##     `dkim-keys.state' file.  The timestamp is the time at which we expect
##     the key to become active.  The key will be active for ACTIVE-DURATION
##     seconds.
##
##   * `RETIRE'.  The key has been deployed and replaced, and will no longer
##     be used for signing.  However, messages bearing its signatures are
##     potentially still in flight, so the key is still visible in DNS.  Keys
##     will remain in `RETIRE' state for MAIL-PERSISTENCE seconds.  The
##     timestamp is the time at which we expect that the key can be
##     withdrawn.
##
##   * `WITHDRAW'.  The key is no longer needed by verifiers because all
##     messages signed under it have either been delivered or abandoned.  The
##     key is withdrawn from DNS, and we're waiting for the withdrawal to
##     propagate.  Keys remain in `WITHDRAW' state for DNS-PERSISTENCE
##     seconds.  The timestamp is the time at which we expect that the key
##     can be published.
##
##   * `PUBLISH'.  The key is no longer available to verifiers, because it is
##     no longer visible in DNS.  It is therefore now safe to publish the
##     private key.  This is the final state, and we stop tracking keys in
##     `PUBLISH' state.  The `active/ID.priv' and `active/ID.pub' files are
##     deleted; the placeholder `publish/I/D.html' is replaced with a file
##     holding the actual key data.  The private key file is deleted.

## Mapping between state names and indices.
our @STNAME;
our %STIX = ();
for my $st (qw{ NEW ANNOUNCE DEPLOY RETIRE WITHDRAW PUBLISH })
  { $STIX{$st} = scalar @STNAME; push @STNAME, $st; }

###--------------------------------------------------------------------------
### Schedule objects.

{ package Scheduler;
  ## A `Scheduler' object keeps track of things to do in the future.  Most
  ## notably, it accumulates DNS update tasks so that they can be performed
  ## in a single transaction, and a list of miscellaneous subs to run.
  ##
  ## Operations which create new files should be done immediately.
  ## Operations which delete files (or rename them -- such as committing
  ## state transitions by renaming the `.priv' file) should be deferred using
  ## `add_cleanup'.

  sub new {
    my ($pkg) = @_;
    ## Create and return a new `Scheduler'.

    return bless { dns_update => { }, cleanups => [] }, $pkg;
  }

  sub add_record {
    my ($me, $label, $type, $data) = @_;
    ## Add a DNS record for LABEL, with the given TYPE and DATA.
    ##
    ## This is collected as part of the single DNS update transaction.  Any
    ## existing record for the LABEL and TYPE is deleted, which is probably
    ## terrible for general use, but works just fine in this program.

    $me->{dns_update}{$label}{$type} = $data;
  }

  sub delete_record {
    my ($me, $label, $type) = @_;
    ## Delete the DNS record(s) for LABEL with the given TYPE.

    $me->{dns_update}{$label}{$type} = undef;
  }

  sub add_cleanup {
    my ($me, $op) = @_;
    ## Arrange to run OP at the end of the program.

    push $me->{cleanups}->@*, $op;
  }

  sub execute {
    my ($me) = @_;
    ## Perform the scheduled activities.

    ## Do the DNS update.
    my $updates = "";
    for my $label (keys $me->{dns_update}->%*) {
      for my $type (keys $me->{dns_update}{$label}->%*) {
	my $data = $me->{dns_update}{$label}{$type};
	$updates .= "update delete $label IN $type\n";
	if (!defined $data) {
	  print "delete dns record $label $type\n";
	} else {
	  $updates .= "update add $label IN $type $data\n" if defined $data;
	  print "create dns record $label $type $data\n";
	}
      }
    }
    if ($updates eq "") {
      print "no dns updates\n";
    } else {
      my @nsucmd = ("nsupdate");
      push @nsucmd, "-k", $::C{"ddns-key"} if defined $::C{"ddns-key"};
      ::running {
	@nsucmd = ("cat") if $ENV{"DKIM_KEYS_NODNS"} // 0;
	open my $f, "|-", @nsucmd;
	my $server = $::C{"ddns-server"}; my $ttl = $::C{"ddns-ttl"};
	print $f "server $server\n" if defined $server;
	print $f "ttl $ttl\n" if defined $ttl;
	print $f $updates;
	print $f "send\n";
	print $f "answer\n";
	close $f
      } @nsucmd;
    }

    ## Run the deferred cleanup operations.
    for my $op ($me->{cleanups}->@*) { $op->(); }
  }
}

sub schedule_cleanup (&$) {
  my ($op, $sched) = @_;
  ## Get SCHED to run OP during its cleanup.
  ##
  ## This just has slightly nicer syntax than calling `SCHED->add_cleanup'.

  $sched->add_cleanup($op);
}

###--------------------------------------------------------------------------
### Key management.

sub generate_key ($) {
  my ($file) = @_;
  ## Make a new RSA key and save it in PEM format in FILE.
  ##
  ## No particular effort is taken to ensure that FILE is updated atomically.

  my $oldmask = umask 0037;
  print "generate new key\n";
  run "openssl", "genrsa", "-out", $file, "3072";
  chmod 0640, $file;
  umask $oldmask;
}

sub extract_public_key ($$) {
  my ($pub, $priv) = @_;
  ## Store the public key corresponding to PRIV in the file PUB.
  ##
  ## No particular effort is taken to ensure that PUB is updated atomically.

  print "extract public key\n";
  run "openssl", "rsa", "-pubout", "-in", $priv, "-out", $pub;
  return read_pem($pub, "PUBLIC KEY");
}

{ package Key;
  ## A `Key' object keeps track of a DKIM key's lifecycle stages.
  ##
  ## Key objects are blessed hashrefs with the following public slots.
  ##
  ##   * `id' is the key's identifier, as a lowercase Base32 string.
  ##   * `st' is the key's state, as an uppercase string.
  ##   * `t' is the key's timestamp, as an integer count of seconds.
  ##
  ## It also has private slots.
  ##
  ##   * `file0' is the filename holding the private key.
  ##   * `file' is the filename that the private key /would/ have if the
  ##	 currently scheduled operations were executed.
  ##   * `pub' is the key's public key, in binary BER format.

  ## External modules.
  use autodie;
  use strict;

  use Carp;
  use MIME::Base64;

  sub publish_components {
    my ($me) = @_;
    ## Split the key ID into pieces.  This is how we map key IDs into the
    ## filesystem and URI space: if we return n pieces, that's n - 1 levels
    ## of directory, with leaves at the bottom.

    my $id = $me->{id};
    return (substr($id, 0, 3), substr($id, 3, 5), substr($id, 8));
  }

  sub publish_uri {
    my ($me) = @_;
    ## Return the URI at which the key will be published.

    my @cc = $me->publish_components;
    return $::C{"publish-uri"} . join("/", @cc) . ".html";
  }

  sub publish_filename {
    my ($me) = @_;
    ## Return the filename at which the key publication HTML file is stored.

    my @cc = $me->publish_components;
    my $name = "publish";
    for my $c (@cc) { ::maybe_mkdir $name, 0751; $name .= "/" . $c; }
    return $name . ".html";
  }

  sub new {
    my ($pkg, $t) = @_;
    ## Return a new `Key' object with initial timestamp T.
    ##
    ## The `pub' slot is set on exit.

    ## Make the new key.
    ::maybe_mkdir "NEW", 0700;
    ::generate_key "NEW/new.priv";

    ## Extract the public key and determine its id.
    my $pub = ::extract_public_key "NEW/new.pub", "NEW/new.priv";
    my $id = ::ident $pub;

    ## Rename the private key.  It won't go away now: we're committed to this
    ## one.
    print "commit to new key $id\n";
    my $file = sprintf "NEW/%s.%s.priv", ::present_stamp($t), $id;
    rename "NEW/new.priv", $file;

    ## Report the public key as active.
    print "activated new public key $id\n";
    ::maybe_mkdir "active";
    rename "NEW/new.pub", "active/$id.pub";

    ## It's now a proper key.
    my $me = $pkg->load($file);
    $me->{pub} = $pub;
    return $me;
  }

  sub load {
    my ($pkg, $file) = @_;
    ## Return a key object for the given FILE.  We probably don't actually
    ## bother reading the file.

    ## Check that the file is sane.
    -r $file or confess "key file `$file' not found";
    $file =~ m{^ (\w+) /
		 (\d{4} - \d{2} - \d{2} T \d{2} : \d{2} : \d{2} Z) \.
		 ([abcdefghijklmnopqrstuvwxyz234567]+) \.priv $}x
		   or confess "bad key name `$file'";

    ## Build the object.as the primary
    my $st = $1; my $tm = $2; my $id = $3;
    return bless {
      st => $st, id => $id, t => ::parse_stamp($tm),
      file => $file, file0 => $file
    }, $pkg;
  }

  sub set_state {
    my ($me, $sched, $newst, $newtime) = @_;
    ## Change the state of the key to be NEWST, with timestamp NEWTIME.
    ## Arrange to commit this state change by renaming the private key to
    ## `ST/TS.ID.priv'.

    return if $newst eq $me->{st} && $newtime eq $me->{t};
    my $id = $me->{id};
    printf "prepare key %s state %s %s -> %s %s\n",
      $id, $me->{st},
      ::present_time($me->{t}), $newst, ::present_time($newtime);
    my $from = $me->{file};
    my $to = $newst . "/" . ::present_stamp($newtime) . "." . $id . ".priv";
    ::maybe_mkdir $newst;
    ::schedule_cleanup {
      print "key $id rename $from -> $to\n";
      rename $from, $to;
    } $sched;
    $me->{st} = $newst; $me->{t} = $newtime; $me->{file} = $to;
  }

  sub announce {
    my ($me, $sched, $t_publish) = @_;
    ## Announce the public key in DNS as `ID.ZONE', and create a placeholder
    ## HTML file in `publish/I/D.html' explaining that the key will be
    ## published before T_PUBLISH.

    ## Initial preparation.
    print "announce new key\n";
    my $id = $me->{id};

    ## If we don't already have the public key then this must be a leftover
    ## key from a previous aborted run.  Create the public key file and
    ## retrieve the key.  Either way, we don't need it any more after this,
    ## so save the memory.
    my $pub = $me->{pub}; delete $me->{pub};
    unless (defined $pub) {
      ::maybe_mkdir "active";
      $pub = ::extract_public_key "active/$id.pub", $me->{file0};
    }

    ## Prepare the record data.
    my $key = sprintf
      "v=DKIM1; s=email; t=s; k=rsa; h=sha256; " .
      "n=Not suitable for non-repudiation!  " .
	"Private key revealed at %s by %s; " .
      "p=%s",
      $me->publish_uri,
      ::present_time($t_publish),
      encode_base64($pub, "");

    ## A TXT record data consists of a sequence of strings of length at most
    ## 255 each.  The split positions are not significant.  Split the data
    ## into sufficiently small pieces, preferring to split at semantic
    ## boundaries.
    my @key = ();
    while (length $key > 255) {
      my $chunk = substr $key, 0, 255, "";
      if ($chunk =~ m{^ (.* \;\s+) ([^\s;] [^;]*) $}x)
	{ $chunk = $1; $key = $2 . $key; }
      push @key, $chunk;
    }
    push @key, $key;
    $key = join " ", map qq'"$_"', @key;

    ## Add the record.
    $sched->add_record($id . "." . $::C{"ddns-zone"}, "TXT", $key);
  }

  sub deploy {
    my ($me, $sched) = @_;
    ## Make the key suitable for deployment.  Hard link the private key to
    ## `active/ID.priv'.

    my $id = $me->{id};
    print "deploy private key $id\n";
    ::maybe_mkdir "active";
    ::maybe_unlink "active/$id.priv.new";
    link $me->{file0}, "active/$id.priv.new";
    rename "active/$id.priv.new", "active/$id.priv";
  }

  sub withdraw {
    my ($me, $sched) = @_;
    ## Withdraw the key data from DNS so that legitimate reliers won't
    ## believe signatures any more.

    my $id = $me->{id}; my $zone = $::C{"ddns-zone"};
    print "withdraw key $id from dns\n";
    $sched->delete_record("$id.$zone", "TXT");
  }

  sub delete {
    my ($me, $sched) = @_;
    ## Delete the key from everywhere except the publication tree.

    my $id = $me->{id}; print "delete key $id\n";
    ::schedule_cleanup {
      print "delete published key $id\n";
      ::maybe_unlink "active/$id.pub";
      ::maybe_unlink "active/$id.priv";
      unlink $me->{file};
    } $sched;
  }
}

###--------------------------------------------------------------------------
### Publication archive.

sub publication_time ($;$$) {
  my ($k, $newst, $newtime) = @_;
  ## Return the approximate publication time of key K.  If NEWST and NEWTIME
  ## are given, then they override the key's state and timestamp.

  $newst //= $k->{st}; $newtime //= $k->{t};
  defined (my $newix = $STIX{$newst})
    or confess "unexpected state `$newst'";
  my $t_publish = $newtime + $C{"cycle-period"};
  if ($newix < $STIX{PUBLISH})
    { $t_publish += $C{"dns-persistence"}; }
  if ($newix < $STIX{WITHDRAW})
    { $t_publish += $C{"mail-persistence"}; }
  if ($newix < $STIX{RETIRE})
    { $t_publish += $C{"active-duration"} + $C{"cycle-period"}; }
  return $t_publish;
}

sub publish_placeholder ($;$$) {
  my ($k, $newst, $newtime) = @_;
  ## Write a placeholder HTML file at the URI that key K's private key will
  ## be published later.  If NEWST and NEWTIME are given, then the override
  ## the key's state and timestamp in the computation of the publication
  ## time.

  ## Determine the things we need to know.
  my $id = $k->{id}; my $inst = $C{"instance"};
  my $file = $k->publish_filename;
  my $t_publish = publication_time $k, $newst, $newtime;
  my $th_publish = present_time $t_publish;

  ## Produce the placeholder file.
  print "publish placeholder for $id\n";
  open my $f, ">", "$file.new";
  print $f <<EOF;
<!DOCTYPE html>
<html>
<head>
  <title>$inst DKIM key $id</title>
</head>
<body>
<h1>$inst DKIM key <code>$id</code></h1>
<p>This is a placeholder page.
The private key <code>$id</code> is scheduled for publication
on or before $th_publish.
$inst DKIM private keys are published in order to make them
unsuitable as evidence after the fact.

<p>The public key is
<pre>
EOF
  dump_file $f, "active/$id.pub";
  print $f <<EOF;
</pre>
</body>
</html>
EOF
  close $f;
  rename "$file.new", $file;
}

sub publish_key ($) {
  my ($k) = @_;
  ## Publish key K's private key.

  ## Determine the things we need to know.
  my $id = $k->{id}; my $inst = $C{"instance"};
  my $file = $k->publish_filename;

  ## Produce the publication file.
  print "publish private key for $id\n";
  open my $f, ">", "$file.new";
  print $f <<EOF;
<!DOCTYPE html>
<html>
<head>
  <title>$inst DKIM key $id</title>
</head>
<body>
<h1>$inst DKIM key <code>$id</code></h1>
<p>The key <code>$id</code> was used as a key to authenticate
that email passed through the $inst server.
$inst DKIM keys are published after they are no longer in active use,
to make them unsuitable as evidence after the fact.

<p>The private and public keys are
<pre>
EOF
  dump_file $f, "active/$id.priv";
  dump_file $f, "active/$id.pub";
  print $f <<EOF;
</pre>
</body>
</html>
EOF
  close $f;
  rename "$file.new", $file;
}

###--------------------------------------------------------------------------
### State transitions.

sub set_key_state ($$$$) {
  my ($k, $sched, $newst, $newtime) = @_;
  ## Advance K to state NEWST, and set its timestamp to NEWTIME.  Arrange for
  ## SCHED to complete the transition.

  ## Preliminary checking.
  my $oldst = $k->{st}; my $id = $k->{id};
  defined (my $ix = $STIX{$oldst})
    or confess "unexpected key state `$oldst'";
  defined (my $newix = $STIX{$newst})
    or confess "unexpected new state `$newst'";
  $ix <= $newix
    or confess "attempted state regression `$oldst' -> `$newst'";

  ## Advance the key through each intermediate state in turn.
  while ($ix < $newix) {
    $ix++; my $curst = $STNAME[$ix];
    print "advance key $id state $oldst -> $curst\n";
    if ($curst eq "ANNOUNCE") {
      $k->announce($sched, publication_time $k, $newst, $newtime);
      publish_placeholder $k, $newst, $newtime;
    }
    elsif ($curst eq "DEPLOY") { $k->deploy($sched); }
    elsif ($curst eq "RETIRE") { ; }
    elsif ($curst eq "WITHDRAW") { $k->withdraw($sched); }
    elsif ($curst eq "PUBLISH") { publish_key $k; }
    else { confess "unexpected state $curst" }
  }

  ## Finally commit the key in its new state.
  if ($newst eq "PUBLISH") { $k->delete($sched); }
  else { $k->set_state($sched, $newst, $newtime); }
}

sub keys_in_state ($) {
  my ($st) = @_;
  ## Return a list of the keys in state ST.

  my @k; my $d;
  eval { opendir $d, $st; };
  if ($@) {
    die if $@->errno != ENOENT;
  } else {
    FILE: for my $f (readdir $d) {
      next FILE if $f eq "." || $f eq "..";
      next FILE if $st eq "NEW" && ($f eq "new.priv" || $f eq "new.pub");
      push @k, Key->load("$st/$f");
    }
  }
  return @k;
}

###--------------------------------------------------------------------------
### Main program.

## Our first order of business is to ensure that there are keys lined up for
## the current deployment cycle.  The candidates are the keys which are
## currently in `NEW', `ANNOUNCE', and `DEPLOY' states.  We arrange to use
## these in ascending order of their current timestamps.  This might cause
## keys to become active earlier than before.

my @candidates;				# candidates for future deployment
my @to_retire;				# keys which are too old
my $cutoff = $NOW - $C{"active-duration"}; # threshold between the two
my $sched = Scheduler->new;		# a `Scheduler' instance

## Work through the `NEW' keys and advance them on to `ANNOUNCE'.  Pick up
## all of the unretired keys so that we can plan how to use them.

sub notice_candidate ($) {
  my ($k) = @_;
  ## Notice a key and add it to one of the lists above.  If K's deployment
  ## time window is entirely in the past then add it to `@to_retire';
  ## otherwise, add it to `@candidates'.

  if ($k->{t} < $cutoff) { push @to_retire, $k; }
  else { push @candidates, $k; }
}

for my $k (keys_in_state "NEW")
  { $k->announce($sched, publication_time $k); notice_candidate $k; }
for my $st (qw{ ANNOUNCE DEPLOY })
  { for my $k (keys_in_state $st) { notice_candidate $k; } }
@candidates = sort { $a->{t} <=> $b->{t} } @candidates;

## Determine the current start time of the oldest key we can deploy.  If this
## is earlier than now then things are chugging along OK and we continue with
## the current plan.  Otherwise, we need to arrange keys for immediate use.
my $t0 = @candidates && $candidates[0]{t} <= $NOW ? $candidates[0]{t} : $NOW;
my $nk = 0;

## Start producing the state file for the mail server.  Make sure that the
## current cycle is covered.
my $info = "";
my $t = $t0; my $t_limit = $NOW + $C{"cycle-period"};
while ($t < $t_limit) {
  my $k = @candidates ? shift @candidates : Key->new($t);
  set_key_state $k, $sched, "DEPLOY", $t; $t += $C{"active-duration"};
  $info .= sprintf "info.%d: k = %s u = %s tpub = \"%s\"\n",
    $nk, $k->{id}, $k->publish_uri, present_time publication_time $k;
  $nk++;
}

## Write the new state file.
maybe_mkdir "active";
open my $mcf, ">", "active/dkim-keys.state.new";
printf $mcf "### dkim-keys deployment state, from %s up to %s\n\n",
  present_time($t0), present_time($t);
printf $mcf "params: t0 = %d step = %d n = %d\n",
  $t0, $C{"active-duration"}, $nk;
print $mcf $info;
close $mcf; rename "active/dkim-keys.state.new", "active/dkim-keys.state";

## And now make sure there are enough new keys announced to cover the next
## cycle.
$t_limit = $NOW + 2*$C{"cycle-period"};
while ($t < $t_limit) {
  my $k = @candidates ? shift @candidates : Key->new($t);
  set_key_state $k, $sched, "ANNOUNCE", $t; $t += $C{"active-duration"};
}

## If there are keys to retire, then arrange that.
for my $k (@to_retire) {
  set_key_state $k, $sched, "RETIRE",
    $k->{t} + $C{"active-duration"} + $C{"mail-persistence"};
}

## If there are keys to withdraw, then arrange that too.
for my $k (keys_in_state "RETIRE") {
  if ($k->{t} <= $NOW)
    { set_key_state $k, $sched, "WITHDRAW", $NOW + $C{"dns-persistence"}; }
}

## And, finally, if there are keys to be published, then arrange that.
for my $k (keys_in_state "WITHDRAW")
  { if ($k->{t} <= $NOW) { set_key_state $k, $sched, "PUBLISH", -1; } }

## The planning is done.  It's now time to do all the things.
print "running cleanup actions\n";
$sched->execute;

###--------------------------------------------------------------------------
### Manual.

=head1 NAME

dkim-keys - manage short-lived DKIM keys

=head1 SYNOPSIS

B<dkim-keys>

=head1 DESCRIPTION

=head2 Background

DKIM, RFC6376, is a mechanism for authenticating email messages.  An
originating mail server signs each message that it sends using a private
signing key, and adds a header to the message containing the signature and a
reference to where the public verification key can be found in the DNS.
A receiving mail server can parse the header, retrieve the verification key,
verify the signature, and be convinced that the message at least passed
through the originating server.  This is intended to reduce the effectiveness
of forged email messages for fraud and spam.

A DKIM signature must cover email headers I<and> the body, to prevent an
adversary from altering them in order to construct a forgery.  This creates
a problem which the designers of DKIM failed to foresee.  Messages bearing
DKIM signatures can remain verifiable long after delivery, providing
convincing evidence that a particular mail server transmitted a particular
message, and, moreover, at a particular time, and that was sent by a
particular user.  This may be undesirable, to say the least.

In 2020, Matthew Green wrote an article describing this problem on his
I<Cryptography Engineering> blog, and suggesting a solution: that DKIM
signing keys should cycle rapidly, each key being used only for a short time,
say a day, and, once all messages bearing signatures from a particular key
have been delivered or abandoned, the I<private> signing key should be
published.  Once this is done, the DKIM signature on an old message becomes
worthless as evidence of anything, since anyone with a little technical
ability can forge convincing-looking messages bearing a valid signature from
the key.

This is what B<dkim-keys> does.

=head2 Inovking B<dkim-keys>

The B<dkim-keys> doesn't usually take any command-line arguments.  It does
recognize B<--help> (B<-h>) and B<--version> (B<-v>) options, for
consistency's sake.  It reports an error if other command-line arguments are
given.

=head2 Operation

The B<dkim-keys> program works in the current directory.  It expects to find
a configuration file B<dkim-keys.conf>.  It will create directories for its
own use as necessary.

=head2 State model

Each key has an I<identifier>, notated I<id> here.  For RSA keys, which are
the only kind currently implemented, this is the least significant 80 bits of
the modulus, encoded in lowercase Base32.  (This means that the identifier
can easily be determined from just the public key.)  There are no padding
characters because 80 is a multiple of five.  The key identifier is used in
the DKIM selector when the key is in use.

Keys advance through six states.

=over

=item *

A key in the B<NEW> state has just been created, and nobody else knows
anything about it.  Under normal circumstances, keys immediately advance to
B<ANNOUNCE>, but the B<NEW> state is separate for technical reasons.

=item *

A key in the B<ANNOUNCE> state has a record listed in the DNS, and we're
waiting for the DNS records to propagate before the key can be used.

=item *

A key in the B<DEPLOY> state is ready for use by a mail server to sign
outgoing messages.  There are usually multiple keys in this state so that the
mail server can cycle from one to the next at the appropriate time without
any further action from B<dkim-keys>.

=item *

A key in the B<RETIRE> state has completed its time in service.  It may have
been used to sign outgoing messages which are still on their way to being
delivered or abandoned, so legitimate verifiers need access to the public
key, but it won't be used to sign new messages.

=item *

A key in the B<WITHDRAW> state should no longer be of use to receiving
servers.  All messages signed using the key have either been delivered or
abandoned.  The public key record is withdrawn from the DNS, and we're
waiting for this withdrawal to propagate before the private key can be
published.  At this stage, a forgery made using the key might be accepted by
a receiving server which still has access to stale DNS records, so the
private key can't quite be published yet.

=item *

A key in the B<PUBLISH> state is published for all to see.  Nobody should
beleive it for anything, and nobody should have any reason to.

=back

=head2 Configuration file

The configuration syntax is simple and line-based.  Lines consisting only of
whitespace, and lines whose first whitespace character is C<#>, are ignored.
Other lines must be I<assignments> of the form I<key> B<=> I<value>.  The
recognized keys and their values are as follows.

=over

=item B<instance>

A name for the instance of B<dkim-keys>.  This is used in the published HTML
files.  There is no default.

=item B<publish-uri>

The base URL at which keys will be published.  The web server should be
configured to publish the contents of the B<publish> directory at this URL.
There is no default.

=item B<ddns-zone>

The DNS I<zone> in which the public keys will be listed.  A key with a given
I<id> will be listed in a B<TXT> record at I<id>B<.>I<zone>.  In a simple
system, I<zone> might be B<_domainkey.example.org>, so the B<example.org>
outgoing mail server need only set B<s=>I<id>B<;> B<d=example.org> in its
DKIM headers.  In a more complex case, the I<zone> might be referred to using
B<DNAME> for multiple domains.

There is no default for this setting.

=item B<ddns-server>

The server to which DNS updates will be submitted.  By default, the source
server listed in the zone B<SOA> record will be used.

=item B<ddns-key>

The file containing the TKIP key to use for authenticating the DNS update.
There is no default for this setting.

=item B<ddns-ttl>

The TTL to set on DKIM key records, as a duration (see below).  The default
is four hours.

=item B<dns-delay>

The time required for a newly published DNS record to fully propagate, as a
duration (see below).  Conservatively, this will be the sum of the zone
refresh, expiry, and minimum-TTL times: a secondary server must have time to
try updating, give up, and expire the zone, and a downstream recursive
resolver must time out a previously cached negative result for the record,
before the record can be considered fully propagated.

This setting determines how long a key remains in the B<ANNOUNCE> state.  The
default is two days.

=item B<active-duration>

The time for which a key will be in active use signing outgoing messages, as
a duration (see below).  The default is one day.

=item B<cycle-period>

The maximum interval between runs of B<dkim-keys>, as a duration (see below).
This determines the how many keys are queued up in the B<DEPLOY> state.  The
default is three days, with the expectation that the script will actually run
daily.

=item B<mail-persistence>

The time before which outgoing email messages can safely be expected to have
been delivered or abandoned, as a duration (see below).  This mostly depends
on the outgoing server configuration, but there can conceivably be additional
delay at the receiving end.

This setting determines how long a key remains in the B<RETIRE> state.  The
default is one week.

=item B<dns-persistence>

The time required for a withdrawn DNS record to fully propagate, as a
duration (see below).  Conservatively, this will be the sum of the zone
refresh and expiry times, and the record TTL: a secondary server must have
time to try updating, give up, and expire the zone, and a downstream
recursive resolver must time out a previously cached record, before it can be
considered fully withdrawn.

This setting determines how long a key remains in the B<WITHDRAW> state.  The
default is three days.

=back

A duration is a (possibly fractional) decimal number, followed by an optional
unit.

=over

=item *

B<s>, B<sec>, B<secs>, B<second>, B<seconds>

=item *

B<min>, B<m>, B<mins>, B<minute>, B<minutes>

=item *

B<hr>, B<h>, B<hrs>, B<hour>, B<hours>

=item *

B<dy>, B<d>, B<dys>, B<day>, B<days>

=item *

B<wk>, B<w>, B<wks>, B<week>, B<weeks>

=back

If no unit is given, the default is seconds.

=head2 Output

The B<active> directory contains public and private key files, and a
B<dkim-keys.state> file for the mail server.

B<active/>I<id>B<.pub> contains the public key for the key with identifier
I<id> (in OpenSSL PEM format), and B<active/>I<id>B<.priv> is the private key
(a hard link to the I<state>B</>I<timestamp>B<.>I<id>B<.priv> file).

The B<active/dkim-keys.state> file is formatted as follows.  It contains
blank lines and (sparse) comments beginning with C<#>.  It contains a line

=over

B<params:> B<t0 => I<t0> B<step => I<step> B<n => I<n>

=back

where I<t0>, I<step>, and I<n> are integers in decimal notation.  It also
contains lines

=over

B<info.>I<i>B<:> B<k => I<id> B<u => I<url> B<tpub => I<tpub>

=back

where I<i> is an integer, I<id> is a key identifier, I<url> is a url (not
containing spaces), and I<tpub> is an ISO8601 time stamp with explicit time
zone offset, in double quotes.  There will be exactly I<n> B<info> lines, one
for each I<i> from 0 (inclusive) up to but not including I<n>.  These lines
may appear in any order.

The B<params> line identifies one of the B<info> lines, as follows.  I<t0> is
a POSIX timestamp, counting nonleap seconds since the start of January 1970.
I<step> is the length of time, in seconds, for which a key is active (taken
from the B<active-duration> configuration setting).  If the current POSIX
time is I<t>, then the mail server should use the B<info.>I<i> data, where
I<i> = floor((I<t> - I<t0>)/I<step>).  If I<i>, as computed in this way, is
less than zero or greater than or equal to I<n>, then the data is invalid:
the mail server should report temporary failure.  Specifically, if I<i> is
less than zero then the data is apparently from the future: this is most
likely if the system clock has been stepped, and the situation can be
corrected by running B<dkim-keys> again.  If I<i> is greater than or equal to
I<n> then the file is out-of-date: B<dkim-keys> has not run to completion
sufficiently recently, or is otherwise broken.

The B<info> line fields are as follows.  The I<id> is the identifier of the
signing key to use, and to include in the DKIM B<s=> selector tag; the actual
private key will be B<active/>I<id>B<.priv>.  The I<url> is the URL at which
the private key will be published (derived from the key identifier and the
B<publish-uri> configuration setting) and I<tpub> is a time by which
publication should have occurred; the latter two items are intended to be
included in a message header.

Exim, for example, might be configured as follows.

	dkim_selector = \
	  ${lookup {params} lsearch \
		  {${lookup {${domain:$h_From:}} partial0-lsearch \
			  {/etc/mail/dkim-sign.conf} \
		    {/var/lib/dkim-keys/$value/active/dkim-keys.state}}} \
	    {${if and {{>= {$tod_epoch} {${extract {t0}{$value}}}} \
		       {< {$tod_epoch} \
			  {${eval:${extract {t0}{$value}} + \
				  ${extract {n}{$value}}*${extract {step}{$value}}}}}} \
	      {${lookup {info.${eval:($tod_epoch - ${extract {t0}{$value}})/ \
				     ${extract {step}{$value}}}}
		      lsearch \
		      {${lookup {${domain:$h_From:}} partial0-lsearch \
			      {/etc/mail/dkim-sign.conf} \
			{/var/lib/dkim-keys/$value/active/dkim-keys.state}}} \
		{${extract {k}{$value}}}fail}} \
	      fail}}\
	    fail}
	dkim_private_key = \
	  ${lookup {${domain:$h_From:}} partial0-lsearch \
		  {/etc/mail/dkim-sign.conf} \
	    /var/lib/dkim-keys/$value/active/$dkim_selector.priv}

=head2 Working state

In the working directory, there is a subdirectory for each state.  Private
keys are stored (in OpenSSL PEM) format) in files named
I<state>B</>I<timestamp>B<.>I<id>B<.priv> where I<state> is the key's state,
as listed above, in uppercase, I<timestamp> is a timestamp in ISO8601 `zulu'
format, and I<id> is the key's identifier, used as the DKIM selector.  The
meaning and value of the timestamp changes as the key advances from one state
to the next: see the source code for details.

=head1 SEE ALSO

=over

=item *

D. Crocker, T. Hansen, M. Kucherawy, RFC6376: I<DomainKeys Identified Mail
(DKIM) Signatures>, L<https://www.rfc-editor.org/rfc/rfc6376.html>.

=item *

Matthew Green, I<Ok Google: Please publish your DKIM secret keys>,
L<https://blog.cryptographyengineering.com/2020/11/16/ok-google-please-publish-your-dkim-secret-keys/>

=item *

L<nsupdate(1)>.

=back

=head1 AUTHOR

Mark Wooding, <mdw@distorted.org.uk>.

=cut

###----- That's all, folks --------------------------------------------------