From: Mark Wooding <mdw@distorted.org.uk>
Date: Fri, 3 May 2024 06:17:21 +0000 (+0100)
Subject: Initial version.  Still needs documentation.
X-Git-Tag: 0.0.0^0
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/distorted-dkim/commitdiff_plain/c07652a1cf6fad4c591c731455a59a39211e377c?ds=inline

Initial version.  Still needs documentation.
---

c07652a1cf6fad4c591c731455a59a39211e377c
diff --git a/dkim-keys b/dkim-keys
new file mode 100755
index 0000000..fc459e6
--- /dev/null
+++ b/dkim-keys
@@ -0,0 +1,899 @@
+#! /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 qw{ :all };
+use strict;
+
+use Carp;
+use IO::Handle;
+use MIME::Base32;
+use MIME::Base64;
+use POSIX;
+use Time::Local;
+
+###--------------------------------------------------------------------------
+### Other preliminaries.
+
+(our $PROG = $0) =~ s!^.*/!!;
+
+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;
+}
+
+###--------------------------------------------------------------------------
+### Logging.
+
+maybe_mkdir "log";
+open our $LOGF, ">>", "log/dkim-keys.log";
+
+{
+  my $verbose = $ENV{"DKIM_KEYS_VERBOSE"} // 0;
+
+  sub verbose ($) {
+    my ($msg) = @_;
+    ## Print MSG to the log.  If `DKIM_KEYS_VERBOSE' is set in the
+    ## environment, then also print the message to stderr.
+
+    my $ts = present_time time;
+    print $LOGF "$ts: $msg\n";
+    print STDERR "$PROG: $msg\n" if $verbose;
+  }
+}
+
+sub gag (&) {
+  my ($body) = @_;
+  ## Execute the BODY with stdout and stderr redirected to the log.
+
+  $LOGF->flush;
+  open my $oldout, ">&", \*STDOUT; open my $olderr, ">&", \*STDERR;
+  open STDOUT, ">&", $LOGF; open STDERR, ">&", $LOGF;
+  my @r;
+  if (wantarray) { @r = &$body; }
+  else { push @r, scalar &$body; }
+  open STDOUT, ">&", $oldout; open STDERR, ">&", $olderr;
+  close $oldout; close $olderr;
+  return @r;
+}
+
+###--------------------------------------------------------------------------
+### 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 ISO8859 Zulu-time stamps to POSIX `time_t'.
+
+  if ($parsep) {
+    my ($y, $mo, $d, $h, $mi, $s) =
+      $val =~ m{^ (\d{4}) - (\d{2}) - (\d{2}) T
+		  (\d{2}) : (\d{2}) : (\d{2}) Z $}x
+	or die "bad timestamp `$val'";
+    return timegm $s, $mi, $h, $d, $mo - 1, $y - 1900;
+  } else {
+    confess "undefined stamp" unless defined $val;
+    my ($s, $mi, $h, $d, $mo, $y, $wd, $yd, $dstp) = gmtime $val;
+    return sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ",
+      $y + 1900, $mo + 1, $d, $h, $mi, $s;
+  }
+}
+
+{
+  ## 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) { exists $c{$k} or $c{$k} = $spec->{$k}[1]; }
+  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;
+}
+
+###--------------------------------------------------------------------------
+### Dynamic DNS update.
+
+{
+  my $nodns = $ENV{"DKIM_KEYS_NODNS"} // 0;
+
+  sub nsupdate ($) {
+    my ($updates) = @_;
+    ## Submit UPDATES in nsupdate(1) format.
+
+    my @nsucmd = ("nsupdate");
+    push @nsucmd, "-k", $::C{"ddns-key"} if defined $::C{"ddns-key"};
+    @nsucmd = ("sh", "-c", 'echo ";; $*" && exec cat', ".", @nsucmd)
+      if $nodns;
+    my $f; gag { open $f, "|-", @nsucmd; };
+    print $f "server $::C{'ddns-server'}\n" if defined $::C{"ddns-server"};
+    print $f "ttl $::C{'ddns-ttl'}\n" if defined $::C{"ddns-ttl"};
+    print $f $updates;
+    print $f "send\n";
+    print $f "answer\n";
+    close $f;
+
+  }
+}
+
+###--------------------------------------------------------------------------
+### 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), "";
+}
+
+sub generate_key ($) {
+  my ($file) = @_;
+
+  my $oldmask = umask 0037;
+  verbose "generate new key";
+  gag { system "openssl", "genrsa", "-out", $file, "3072"; };
+  umask $oldmask;
+}
+
+sub extract_public_key ($$) {
+  my ($pub, $priv) = @_;
+
+  verbose "extract public key";
+  gag { system "openssl", "rsa", "-pubout", "-in", $priv, "-out", $pub; };
+  return read_pem($pub, "PUBLIC KEY");
+}
+
+###--------------------------------------------------------------------------
+### Schedule objects.
+
+{ package Scheduler;
+
+  sub new {
+    my ($pkg) = @_;
+
+    return bless { dns_update => { }, cleanups => [] }, $pkg;
+  }
+
+  sub add_record {
+    my ($me, $label, $type, $data) = @_;
+
+    $me->{dns_update}{$label}{$type} = $data;
+  }
+
+  sub delete_record {
+    my ($me, $label, $type, $data) = @_;
+
+    $me->{dns_update}{$label}{$type} = undef;
+  }
+
+  sub add_cleanup {
+    my ($me, $op) = @_;
+
+    push $me->{cleanups}->@*, $op;
+  }
+
+  sub execute {
+    my ($me) = @_;
+
+    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) {
+	  ::verbose "delete dns record $label $type";
+	} else {
+	  $updates .= "update add $label IN $type $data\n" if defined $data;
+	  ::verbose "create dns record $label $type";
+	}
+      }
+    }
+    if ($updates eq "") { ::verbose "no dns updates"; }
+    else { ::nsupdate $updates; }
+
+    for my $op ($me->{cleanups}->@*) { $op->(); }
+  }
+}
+
+sub schedule_cleanup (&$) {
+  my ($op, $sched) = @_;
+
+  $sched->add_cleanup($op);
+}
+
+###--------------------------------------------------------------------------
+### Key objects.
+
+{ package Key;
+
+  ## External modules.
+  use autodie qw{ :all };
+  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) = @_;
+
+    my @cc = $me->publish_components;
+    return $::C{"publish-uri"} . join("/", @cc) . ".html";
+  }
+
+  sub new {
+    my ($pkg, $t) = @_;
+
+    ## 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.
+    ::verbose "commit to new key $id";
+    my $file = sprintf "NEW/%s.%s.priv", ::conf_stamp(0, $t), $id;
+    rename "NEW/new.priv", $file;
+
+    ## Report the public key as active.
+    ::verbose "activated new public key $id";
+    ::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) = @_;
+
+    -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'";
+    my $st = $1; my $tm = $2; my $id = $3;
+    return bless {
+      st => $st, id => $id, t => ::conf_stamp(1, $tm),
+      file => $file, file0 => $file
+    }, $pkg;
+  }
+
+  sub set_state {
+    my ($me, $sched, $newst, $newtime) = @_;
+
+    return if $newst eq $me->{st} && $newtime eq $me->{t};
+    my $id = $me->{id};
+    ::verbose sprintf "prepare key %s state %s %s -> %s %s",
+      $id, $me->{st},
+      ::present_time($me->{t}), $newst, ::present_time($newtime);
+    my $from = $me->{file};
+    my $to = $newst . "/" . ::conf_stamp(0, $newtime) . "." . $id . ".priv";
+    ::maybe_mkdir $newst;
+    ::schedule_cleanup {
+      ::verbose "key $id rename $from -> $to";
+      rename $from, $to;
+    } $sched;
+    $me->{st} = $newst; $me->{t} = $newtime; $me->{file} = $to;
+  }
+
+  sub announce {
+    my ($me, $sched, $t_publish) = @_;
+
+    ::verbose "announce new key";
+    my $id = $me->{id};
+
+    unless (defined $me->{pub}) {
+      ::maybe_mkdir "active";
+      $me->{pub} = ::extract_public_key "active/$id.pub", $me->{file0};
+    }
+
+    my $key = sprintf
+      "v=DKIM1; s=email; t=s:y; k=rsa; h=sha256; " .
+      "n=Not suitable for non-repudiation!  " .
+	"Private key revealed at %s by %s; " .
+      "p=%s",
+      $me->publish_uri,
+      ::conf_stamp(0, $t_publish),
+      encode_base64($me->{pub}, "");
+    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;
+
+    my $zone = $::C{"ddns-zone"};
+    $sched->add_record("$id.$zone", "TXT", $key);
+  }
+
+  sub deploy {
+    my ($me, $sched) = @_;
+
+    my $id = $me->{id};
+    ::verbose "deploy private key $id";
+    ::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) = @_;
+
+    my $id = $me->{id}; my $zone = $::C{"ddns-zone"};
+    ::verbose "withdraw key $id from dns";
+    $sched->delete_record("$id.$zone", "TXT");
+  }
+
+  sub delete {
+    my ($me, $sched) = @_;
+
+    my $id = $me->{id}; ::verbose "delete key $id";
+    ::schedule_cleanup {
+      ::verbose "delete published key $id";
+      ::maybe_unlink "active/$id.pub";
+      ::maybe_unlink "active/$id.priv";
+      unlink $me->{file};
+    } $sched;
+  }
+}
+
+my %CONF_SPEC = ("ddns-zone" => [\&conf_token, undef],
+		 "ddns-server" => [\&conf_token, undef],
+		 "ddns-key" => [\&conf_token, undef],
+		 "ddns-ttl" => [\&conf_duration, 4*60*60],
+		 "dns-delay" => [\&conf_duration, 2*24*60*60],
+		 "instance" => [\&conf_token, "untitled"],
+		 "publish-uri" => [\&conf_token, undef],
+		 "publish-script"  => [\&conf_token, undef],
+		 "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.
+##
+##   * `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.  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
+##     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.
+
+our @STNAME;
+our %STIX = ();
+for my $st (qw{ NEW ANNOUNCE DEPLOY RETIRE WITHDRAW PUBLISH })
+  { $STIX{$st} = scalar @STNAME; push @STNAME, $st; }
+
+sub publication_time ($;$$) {
+  my ($k, $newst, $newtime) = @_;
+
+  $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 dump_file ($$) {
+  my ($fout, $file) = @_;
+
+  open my $fin, "<", $file;
+  my $buf;
+  while (sysread $fin, $buf, 65536) { print $fout $buf; }
+  close $fin;
+}
+
+sub publish_filename ($) {
+  my ($k) = @_;
+
+  my @cc = $k->publish_components;
+  my $name = "publish";
+  for my $c (@cc) { maybe_mkdir $name, 0751; $name .= "/" . $c; }
+  return $name . ".html";
+}
+
+sub publish_placeholder ($;$$) {
+  my ($k, $newst, $newtime) = @_;
+
+  my $id = $k->{id}; my $inst = $C{"instance"};
+  my $file = publish_filename $k;
+  my $t_publish = publication_time $k, $newst, $newtime;
+  my $th_publish = present_time $t_publish;
+
+  verbose "publish placeholder for $id";
+  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) = @_;
+
+  my $id = $k->{id}; my $inst = $C{"instance"};
+  my $file = publish_filename $k;
+
+  verbose "publish private key for $id";
+  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;
+}
+
+sub set_key_state ($$$$) {
+  my ($k, $sched, $newst, $newtime) = @_;
+
+  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'";
+
+  while ($ix < $newix) {
+    $ix++; my $curst = $STNAME[$ix];
+    verbose "advance key $id state $oldst -> $curst";
+    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" }
+  }
+  if ($newst eq "PUBLISH") { $k->delete($sched); }
+  else { $k->set_state($sched, $newst, $newtime); }
+}
+
+sub keys_in_state ($) {
+  my ($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;
+}
+
+our $NOW;
+
+if (!defined $ENV{"DKIM_KEYS_TIMENOW"}) {
+  $NOW = time;
+} else {
+  $NOW = conf_stamp 1, $ENV{"DKIM_KEYS_TIMENOW"};
+  verbose "pretending time is " . conf_stamp 0, $NOW;
+}
+
+## 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 `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;
+my @to_retire;
+my $cutoff = $NOW - $C{"active-duration"};
+my $sched = Scheduler->new;
+
+sub notice_candidate ($) {
+  my ($k) = @_;
+
+  if ($k->{t} < $cutoff) { push @to_retire, $k; }
+  else { push @candidates, $k; }
+}
+
+## 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.
+for my $k (keys_in_state "NEW")
+  { $k->announce($sched, publication_time $k); notice_candidate $k; }
+for my $st (qw{ NEW 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.
+maybe_mkdir "active";
+open my $mcf, ">", "active/dkim-keys.state.new";
+printf $mcf <<EOF, present_time $t0;
+### dkim-keys deployment state, starting from %s
+
+EOF
+
+## Make sure that the current cycle is covered.
+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"};
+  printf $mcf "info.%d: k = %s u = %s tpub = \"%s\"\n",
+    $nk, $k->{id}, $k->publish_uri, present_time publication_time $k;
+  $nk++;
+}
+printf $mcf "params: t0 = %d step = %d n = %d\n",
+  $t0, $C{"active-duration"}, $nk;
+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.
+verbose "running cleanup actions";
+$sched->execute;
+
+###----- That's all, folks --------------------------------------------------