--- /dev/null
+#! /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 --------------------------------------------------
~mdw / distorted-dkim / commitdiff