395 lines
10 KiB
Perl
Executable File
395 lines
10 KiB
Perl
Executable File
#! /usr/bin/perl
|
|
# Copyright (c) 2017 Florian Obser <florian@narrans.de>
|
|
#
|
|
# Permission to use, copy, modify, and distribute this software for any
|
|
# purpose with or without fee is hereby granted, provided that the above
|
|
# copyright notice and this permission notice appear in all copies.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
use strict;
|
|
use warnings;
|
|
use 5.010;
|
|
use autodie;
|
|
|
|
use Data::Dumper;
|
|
use Digest::SHA;
|
|
use Getopt::Long;
|
|
use MIME::Base64;
|
|
use Net::DNS;
|
|
use Net::DNS::RR::TSIG;
|
|
use Pod::Usage;
|
|
|
|
use constant WAIT_BEGIN => 1;
|
|
use constant WAIT_END => 2;
|
|
use constant END_FOUND =>3;
|
|
|
|
use constant STATE_DIR => '/var/tlsaroll/';
|
|
|
|
my $port = 53;
|
|
my $ttl = 3600;
|
|
my $help = 0;
|
|
my $tsigalgo = 'hmac-sha256';
|
|
my $tlsausage = 1;
|
|
my $exit_code = 1;
|
|
my ($current_cert, $new_cert, $tsigname, $tsigkey, $server, $verbose, $tsig);
|
|
my ($domain, $dnsname, $state_file);
|
|
my ($current_cert_tlsa, $new_cert_tlsa, $state, $update, $wait_until, $now);
|
|
|
|
GetOptions("help|?" => \$help,
|
|
"verbose" => \$verbose,
|
|
"port=i" => \$port,
|
|
"server=s" => \$server,
|
|
"ttl=i" => \$ttl,
|
|
"tsigname=s" => \$tsigname,
|
|
"tsigkey=s" => \$tsigkey,
|
|
"tsigalgo=s" => \$tsigalgo,
|
|
"domain=s" => \$domain,
|
|
"dnsname=s" => \$dnsname,
|
|
"tlsausage=i" => \$tlsausage)
|
|
or die("Error in command line arguments\n");
|
|
|
|
pod2usage(1) if ($help or scalar(@ARGV) != 2);
|
|
|
|
($current_cert, $new_cert) = @ARGV;
|
|
|
|
if (!defined $server) {
|
|
say STDERR "DNS Server missing.";
|
|
pod2usage(1);
|
|
}
|
|
|
|
if (!defined $domain) {
|
|
say STDERR "Domain missing.";
|
|
pod2usage(1);
|
|
}
|
|
|
|
if (!defined $dnsname) {
|
|
say STDERR "DNS name missing.";
|
|
pod2usage(1);
|
|
}
|
|
|
|
$state_file = STATE_DIR.$dnsname;
|
|
|
|
$current_cert_tlsa = gen_tlsa($dnsname, $tlsausage, $current_cert);
|
|
$new_cert_tlsa = gen_tlsa($dnsname, $tlsausage, $new_cert);
|
|
|
|
$new_cert_tlsa = undef if (defined $new_cert_tlsa && $new_cert_tlsa->cert eq
|
|
$current_cert_tlsa->cert);
|
|
|
|
say 'current: ', $current_cert_tlsa->string if ($verbose);
|
|
say 'new....: ', $new_cert_tlsa->string
|
|
if (defined $new_cert_tlsa && $verbose);
|
|
|
|
$state = get_tlsa_state_at_signer($server, $port, $dnsname, $current_cert_tlsa,
|
|
$new_cert_tlsa);
|
|
|
|
say($state->{'state'}, "\n", ('-' x length($state->{'state'})), "\n\t",
|
|
$state->{'msg'}) if ($verbose);
|
|
|
|
if ($state->{state} eq 'OK') {
|
|
# nothing to do
|
|
unlink $state_file if (-f $state_file);
|
|
$exit_code = 2;
|
|
} elsif ($state->{state} eq 'NXDOMAIN') {
|
|
# no TLSA record what so ever, add record for current cert
|
|
unlink $state_file if (-f $state_file);
|
|
$update = new Net::DNS::Update($domain);
|
|
$update->push(update => rr_add($current_cert_tlsa->string));
|
|
$exit_code = 0;
|
|
} elsif ($state->{state} eq 'NEED2ND') {
|
|
# we generated a new cert, add tlsa record
|
|
unlink $state_file if (-f $state_file);
|
|
$update = new Net::DNS::Update($domain);
|
|
$update->push(update => rr_add($new_cert_tlsa->string));
|
|
$exit_code = 2;
|
|
} elsif ($state->{state} eq '2TLSA') {
|
|
$now = time();
|
|
$wait_until = get_wait_until($server, $port, $domain, $dnsname,
|
|
$current_cert_tlsa, $state_file);
|
|
if (defined $wait_until) {
|
|
if ($wait_until > $now) {
|
|
say 'need to wait until '.localtime($wait_until) if ($verbose);
|
|
$exit_code = 2;
|
|
} else {
|
|
$update = new Net::DNS::Update($domain);
|
|
$update->push(update => rr_del($current_cert_tlsa->string));
|
|
unlink $state_file if (-f $state_file);
|
|
$exit_code = 0;
|
|
}
|
|
} else {
|
|
say $state->{state},': not yet propagated to auths, wait'
|
|
if ($verbose);
|
|
$exit_code = 2;
|
|
}
|
|
} else {
|
|
say STDERR "don't know how to handle ", '"', $state->{state}, '" ',
|
|
'("', $state->{msg}, '")';
|
|
$exit_code=1;
|
|
}
|
|
|
|
if ($update && defined $tsigname && defined $tsigkey) {
|
|
$tsig = Net::DNS::RR::TSIG->create($tsigname, $tsigkey);
|
|
$tsig->algorithm($tsigalgo);
|
|
$update->push( additional => $tsig);
|
|
}
|
|
|
|
handle_update($server, $port, $domain, $update) if (defined $update);
|
|
|
|
say "exit: ", $exit_code;
|
|
exit($exit_code);
|
|
|
|
sub handle_update {
|
|
my ($server, $port, $domain, $update) = @_;
|
|
my ($resolver, $reply);
|
|
|
|
say $update->string if ($verbose);
|
|
$resolver = new Net::DNS::Resolver;
|
|
$resolver->nameservers($server);
|
|
$resolver->port($port);
|
|
|
|
$reply = $resolver->send($update);
|
|
|
|
if ($reply) {
|
|
if ( $reply->header->rcode eq 'NOERROR') {
|
|
say "Update succeeded" if($verbose);
|
|
} else {
|
|
say STDERR 'Update failed: ', $reply->header->rcode;
|
|
exit(1);
|
|
}
|
|
} else {
|
|
say 'Update failed: ', $resolver->errorstring;
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
sub get_tlsa_state_at_signer {
|
|
my ($server, $port, $name, $current_cert_tlsa, $new_cert_tlsa) = @_;
|
|
my ($resolver, $packet, $found_current, $found_new);
|
|
|
|
$found_current = $found_new = 0;
|
|
|
|
$resolver = new Net::DNS::Resolver(tcp_timeout => 10, udp_timeout => 10,
|
|
debug => 0);
|
|
$resolver->nameservers($server);
|
|
$resolver->port($port);
|
|
|
|
$packet = $resolver->send($name, 'TLSA');
|
|
|
|
if ($packet) {
|
|
if ( $packet->header->rcode eq 'NOERROR') {
|
|
$found_current = scalar(grep({ $_->type eq 'TLSA' && $_->cert eq
|
|
$current_cert_tlsa->cert }
|
|
$packet->answer));
|
|
|
|
$found_new = scalar(grep({ $_->type eq 'TLSA' && $_->cert eq
|
|
$new_cert_tlsa->cert }
|
|
$packet->answer))
|
|
if (defined $new_cert_tlsa);
|
|
|
|
if (defined $current_cert_tlsa && defined $new_cert_tlsa) {
|
|
if ($found_current && $found_new) {
|
|
return { state => '2TLSA',
|
|
msg => 'TLSAs for both certs published, wait '.
|
|
'for TTL' };
|
|
} elsif($found_current) {
|
|
return { state => 'NEED2ND',
|
|
msg => 'publish 2nd TLSA record' };
|
|
} else {
|
|
return { state => 'ERROR', msg => 'should not happen: '.
|
|
'only new TLSA or neither found' };
|
|
}
|
|
} elsif(defined $current_cert_tlsa) {
|
|
if($found_current) {
|
|
return { state => 'OK', msg => 'nothing to do' };
|
|
}
|
|
} else {
|
|
return { state => 'ERROR',
|
|
msg => 'should not happen: either no certs or only '.
|
|
'new cert defined' };
|
|
}
|
|
} elsif ( $packet->header->rcode eq 'NXDOMAIN') {
|
|
return { state => $packet->header->rcode,
|
|
msg => $packet->header->rcode };
|
|
} else {
|
|
return { state=>'ERROR', msg => $packet->header->rcode };
|
|
}
|
|
} else {
|
|
return { state=>'ERROR', msg => $resolver->errorstring};
|
|
}
|
|
}
|
|
|
|
sub gen_tlsa {
|
|
my ($label, $usage, $cert_file) = @_;
|
|
my $state = WAIT_BEGIN;
|
|
my $pem = '';
|
|
my ($fh, $line, $rr);
|
|
|
|
return undef if (!-f $cert_file);
|
|
|
|
open($fh, '<', $cert_file);
|
|
while($line = <$fh>) {
|
|
if ($state == WAIT_BEGIN) {
|
|
if ($line=~/^-----BEGIN CERTIFICATE-----/) {
|
|
$state = WAIT_END;
|
|
}
|
|
} elsif ($state == WAIT_END) {
|
|
if ($line=~/^-----END CERTIFICATE-----/) {
|
|
$state = END_FOUND;
|
|
last;
|
|
} else {
|
|
$pem.=$line;
|
|
}
|
|
}
|
|
}
|
|
close($fh);
|
|
|
|
return undef if ($state != END_FOUND);
|
|
|
|
$rr = new Net::DNS::RR(join(' ', $label, $ttl, 'IN TLSA '.$usage.' 0 1',
|
|
Digest::SHA::sha256_hex(decode_base64($pem))));
|
|
return $rr;
|
|
}
|
|
|
|
sub get_wait_until {
|
|
my ($server, $port, $domain, $dnsname, $current_cert_tlsa, $state_file) =
|
|
@_;
|
|
my ($fh, $line, $resolver, $auth, $reply, @auths, $rr, @tlsas, $max_ttl);
|
|
if (-f $state_file) {
|
|
open($fh, '<', $state_file);
|
|
$line=<$fh>;
|
|
close($fh);
|
|
chomp($line);
|
|
|
|
if ($line=~/^\d+$/) {
|
|
return $line;
|
|
} else {
|
|
unlink $state_file;
|
|
}
|
|
}
|
|
|
|
# no statefile or not correctly formated
|
|
|
|
# get auths from signer
|
|
$resolver = new Net::DNS::Resolver(recurse => 0, debug => 0);
|
|
$resolver->nameservers($server);
|
|
$resolver->port($port);
|
|
|
|
$reply = $resolver->send($domain, 'NS');
|
|
if ($reply && $reply->header->rcode eq 'NOERROR') {
|
|
@auths = grep {$_->type eq 'NS'} $reply->answer;
|
|
if (scalar (@auths) == 0) {
|
|
say STDERR 'no NS found, this cannot be right';
|
|
return undef;
|
|
}
|
|
$auth = new Net::DNS::Resolver(recurse => 0, debug => 0);
|
|
$max_ttl = -1;
|
|
foreach $rr ( @auths) {
|
|
$auth->nameservers($rr->nsdname);
|
|
$reply = $auth->send($dnsname, 'TLSA');
|
|
if ($reply && $reply->header->rcode eq 'NOERROR') {
|
|
@tlsas = grep({ $_->type eq 'TLSA' &&
|
|
$_->cert eq $current_cert_tlsa->cert }
|
|
$reply ->answer);
|
|
if (scalar(@tlsas) != 1) {
|
|
return undef;
|
|
}
|
|
$max_ttl = $tlsas[0]->ttl if ($tlsas[0]->ttl > $max_ttl);
|
|
} else {
|
|
say STDERR 'failed to get TLSA records: ', $auth->errorstring;
|
|
return undef;
|
|
}
|
|
}
|
|
$line = time() + 2 * $max_ttl;
|
|
open $fh, '>', $state_file;
|
|
say $fh $line;
|
|
close($fh);
|
|
return $line;
|
|
} else {
|
|
say STDERR 'failed to get NS records: ', $resolver->errorstring;
|
|
return undef;
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
__END__
|
|
=head1 NAME
|
|
|
|
tlsaroll - roll tlsa records
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
tlsaroll [options] currentcert newcert
|
|
|
|
Options:
|
|
-help brief help message
|
|
-verbose verbose output
|
|
-server DNS server
|
|
-port DNS port
|
|
-tsigname Name of tsig key
|
|
-tsigkey tsig key
|
|
-tsigalgo tsig algorithm
|
|
-domain DNS domain
|
|
-dnsname DNS name for TLSA record
|
|
|
|
=head1 OPTIONS
|
|
|
|
=over 8
|
|
|
|
=item B<-help>
|
|
|
|
Print a brief help message and exits.
|
|
|
|
=item B<-verbose>
|
|
|
|
Show what's going on.
|
|
|
|
=item B<-server>
|
|
|
|
DNS server to send DNS updates to.
|
|
|
|
=item B<-port>
|
|
|
|
DNS port to send DNS updates to, default 53.
|
|
|
|
=item B<-tsigname>
|
|
|
|
Name of the TSIG key.
|
|
|
|
=item B<-tsigkey>
|
|
|
|
Base64 encoding of the TSIG key.
|
|
|
|
=item B<-tsigalgo>
|
|
|
|
Algorithm of the TSGI key, default hmac-sha256.
|
|
|
|
=item B<-domain>
|
|
|
|
Domain for which the TLSA record should be handled.
|
|
|
|
=item B<-dnsname>
|
|
|
|
DNS name of the TLSA record.
|
|
|
|
=item B<-service>
|
|
|
|
The service rcctl(8) is called with.
|
|
|
|
=item B<-serviceaction>
|
|
|
|
The action rcctl is called with, default reload.
|
|
|
|
=back
|
|
|
|
=head 1 DESCRIPTION
|
|
|
|
B<This program> will update TLSA records.
|
|
|
|
=cut
|