#! /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 File::Copy;
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 $serviceaction = 'reload';
my ($current_cert, $new_cert, $tsigname, $tsigkey, $server, $verbose, $tsig);
my ($service, $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,
	   "service=s" => \$service,
	   "serviceaction=s" => \$serviceaction)
    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);
}

if (!defined $service) {
    say STDERR "service to restart missing.";
    pod2usage(1);
}

$state_file = STATE_DIR.$dnsname;

$current_cert_tlsa = gen_tlsa($dnsname, $current_cert);
$new_cert_tlsa = gen_tlsa($dnsname, $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(0);
} 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));
} 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));
} 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(0);
	} else {
	    copy($new_cert, $current_cert);
	    system '/usr/sbin/rcctl', $serviceaction, $service;
	    $update = new Net::DNS::Update($domain);
	    $update->push(update => rr_del($current_cert_tlsa->string));
	    unlink $state_file if (-f $state_file);
	}
    } else {
	say $state->{state},': not yet propagated to auths, wait'
	    if ($verbose);
	exit(0);
    }
} else {
    say STDERR "don't know how to handle ", '"', $state->{state}, '" ',
	'("', $state->{msg}, '")';
    exit(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);

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, $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 1 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
    -service		service to restart or reload
    -serviceaction	rrctl action

=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