#! /usr/pkg/bin/perl -w

use warnings;
use strict;

# Set these to something else, otherwise PKIX-TA/PKIX-EE
# will always fail.
#
$ENV{"SSL_CERT_FILE"} //= "/dev/null";
$ENV{"SSL_CERT_DIR"} //= "/dev/null";

use Socket qw(IPPROTO_TCP TCP_NODELAY);
use IO::Socket;
use IO::Poll;
use Time::HiRes qw(gettimeofday tv_interval);
use Net::DNS;
use Net::SSLeay qw(ERROR_WANT_READ ERROR_WANT_WRITE);
use Danessl qw(USAGE_DANE_TA USAGE_DANE_EE);

# Delegate DNSSEC to local validating resolver!
#
my @trustedns = qw(127.0.0.1);		# Ideally 127.0.0.1
my $ip6 = 0;				# ipv6 disabled

use constant {
    NOTHOST				=> 0,
    ISHOST				=> 1,
    SSL_CTRL_SET_TLSEXT_HOSTNAME	=> 55,
};

my $hostre = qr{^(?:xn--)?[a-z\d](?:-?[a-z\d]+)*$}io;
my $domainre = qr{^(?:xn--|_)?[a-z\d](?:-?[a-z\d]+)*$}io;

# We ask for TYPE52 for portability, but might get "TLSA" in
# respose records from sufficiently modern Net::DNS versions.
# This maps us back to the requested type.
#
my %DNSTYPE = ( "TLSA"	=> "TYPE52", );

my $resolver = Net::DNS::Resolver->new(nameservers => [@trustedns]);
$resolver->defnames(0);
$resolver->dnsrch(0);
$resolver->udppacketsize(8192); # Safe for local lookups

Net::SSLeay::load_error_strings();
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();
my $sslctx = Net::SSLeay::CTX_new();
die sprintf "Error creating SSL context: %s\n", ssl_error() if (! $sslctx);

# No legacy SSL 2.0/3.0 protocols.
my $ssl_options = &Net::SSLeay::OP_ALL;
$ssl_options |= &Net::SSLeay::OP_NO_SSLv2;
$ssl_options |= &Net::SSLeay::OP_NO_SSLv3;
Net::SSLeay::CTX_set_options($sslctx, $ssl_options);

# We test with a restricted cipher suite list.  While some excluded
# cipher suites may work in some cases, servers should avoid
# relying on them, and it is better to fail the test outright
# than to fail with significant odds in real life.
#
Net::SSLeay::CTX_set_cipher_list($sslctx, join(":",
    "DEFAULT",  # ALL:+RC4:!aNULL:!eNULL:@STRENGTH
    "!RC4",     # But not RC4
    "!EXPORT",  # At least medium
    "!LOW",     # -"-
    "!MD5",     # Rules out all SSLv2 ciphers
    "!DSS",     # Nobody should be using DSS/DSA by now
    "!SEED",    # Too exotic
    "!IDEA",    # -"-
    "!RC2",     # -"-
    "!kDHr",    # -"-
    "!kDHd",    # -"-
    "!kECDHr",  # -"-
    "!kECDHe",  # -"-
));

sub poll_wait {
    my ($conn, $ev, $why) = @_;
    my $p = IO::Poll->new();

    die "$why\n" if $conn->{timeout} <= 0;

    my $t0 = [gettimeofday];
    $p->mask($conn->{sock} => $ev);
    $p->poll($conn->{timeout});
    my $elapsed = int(1000 * tv_interval($t0));
    $conn->{timeout} -= $elapsed if ($elapsed > 0);

    $ev = $p->events($conn->{sock});
    die "$why\n" if !defined($ev);
}

sub ssl_error {
    Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
}

sub sslconnect {
    my ($conn, $ssl) = @_;

    $conn->{timeout} = 10000; # 10 sec deadline timer
    LOOP: {
	return if ((my $status = Net::SSLeay::connect($ssl)) > 0);
	die "SSL shutdown on connect\n" if ($status == 0);
	my $err = Net::SSLeay::get_error($ssl, $status);
	if ($err == ERROR_WANT_READ) {
	    poll_wait($conn, POLLIN, "SSL connect timeout");
	    redo LOOP;
	} elsif ($err == ERROR_WANT_WRITE) {
	    poll_wait($conn, POLLOUT, "SSL connect timeout");
	    redo LOOP;
	} else {
	    die sprintf "SSL connect error: %d: %s\n", $err, ssl_error();
	}
    }
}

sub sslshutdown {
    my ($conn) = @_;
    my $ssl = delete $conn->{ssl};
    my $once = 0;

    $conn->{timeout} = 10000; # 10 sec deadline timer
    LOOP: {
	my $status = Net::SSLeay::shutdown($ssl);
	last LOOP if ($status == 1);
	redo LOOP if ($status == 0 && ++$once == 1);
	my $err = Net::SSLeay::get_error($ssl, $status);
	if ($err == ERROR_WANT_READ) {
	    poll_wait($conn, POLLIN, "SSL shutdown timeout");
	    redo LOOP;
	} elsif ($err == ERROR_WANT_WRITE) {
	    poll_wait($conn, POLLOUT, "SSL shutdown timeout");
	    redo LOOP;
	}
    }
    Net::SSLeay::free($ssl);
}

sub tls_version {
    my ($version) = @_;

    return "SSLv2" if ($version == 0x0002);
    return "SSLv3" if ($version == 0x0300);
    return "TLSv1" if ($version == 0x0301);
    return sprintf "TLSv1.%d", ($version - 0x0301)
	if ($version > 0x0301 && $version <= 0x03FF);
    return sprintf "unknown(%04x)", $version;
}

sub dossl {
    my ($conn, $sni) = @_;
    my $ssl = Net::SSLeay::new($sslctx);
    die sprintf "Error creating SSL handle: %s\n", ssl_error() if (! $ssl);

    Net::SSLeay::set_fd($ssl, fileno($conn->{sock}));
    # XXX: Gross!
    Net::SSLeay::ctrl($ssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, 0, $sni);
    $conn->{ssl} = $ssl;

    sslconnect($conn, $ssl);
    $conn->{ssl} = $ssl;
    my $sslinfo = $conn->{sslinfo} = {};

    $sslinfo->{version} = tls_version(Net::SSLeay::version($ssl));
    $sslinfo->{cipher} = Net::SSLeay::get_cipher($ssl);
    $sslinfo->{bits} = Net::SSLeay::get_cipher_bits($ssl);

    # This does not increment the chain cert reference counts,
    # so we encode to PEM before closing the SSL connection.
    #
    $sslinfo->{chain} = [ map { Net::SSLeay::PEM_get_string_X509($_) }
	Net::SSLeay::get_peer_cert_chain($ssl) ];
    return;
}

sub connclose {
    my ($conn) = @_;

    sslshutdown($conn) if ($conn->{ssl});
    $conn->{sock}->close();
}

sub tryssl {
    my ($host, $port, $sni) = @_;

    my $sock = eval {
	 IO::Socket::INET->new(
	    PeerHost  => $host,
	    PeerPort  => $port,
	    Proto     => "tcp",
	    Timeout   => 5,
	    Blocking  => 0,
	);
    };
    if ($@ || ! defined($sock)) {
	die "Connection failed: $!\n";
    }
    $sock->autoflush(1);
    setsockopt($sock, SOL_SOCKET, SO_KEEPALIVE, 1);
    setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, 1);

    my $conn = { sock => $sock };

    eval { dossl($conn, $sni); };
    my $err = $@;
    connclose($conn);
    die $err if $err;
    return $conn->{sslinfo};
}

sub check_dns_name {
    my ($domain, $ishost) = @_;

    my @labels = split(/\./, $domain);
    die "empty domain\n" if @labels == 0;
    die "top level domain\n" if (@labels == 1);

    my $re = $ishost ? $hostre : $domainre;
    foreach my $label (@labels) {
	die "empty label\n" if ($label eq "");
	die sprintf "invalid label: %s\n", $label
	    unless ($label =~ m{$re});
    }

    do {
	no warnings "numeric";
	die sprintf "dns name is an IPv4 address\n"
	    if (@labels <= 4
		&& (grep {$_ eq 0 + $_ && $_ < 256} @labels) == @labels);
    };
    return;
}

sub dns_lookup {
    my ($domain, $ishost, $type, $class) = @_;
    $type //= "A";
    $class //= "IN";
    my $rname = $domain;
    my $qname = $domain;

    check_dns_name($qname, $ishost);

    my @result = ();
    my $ad = 1;
    my %seen = ();

    # Recursively expand CNAME records.
    #
    for (my $i = 0; $i < 10; ++$i) {
	my $packet = Net::DNS::Packet->new($qname, $type, $class);
	$packet->header->ad(1);
	$packet = $resolver->send($packet);
	my $header = $packet->header;
	my $rcode = $header->rcode;
	if ($rcode ne "NOERROR" && $rcode ne "NXDOMAIN") {
	    die sprintf "DNS Lookup failed: %s %s %s ?: %s\n",
		$qname, $class, $type, $rcode;
	}
	$ad = 0 if ! $header->ad;
	my @answer = $packet->answer;
	last if (@answer == 0 || $rcode eq "NXDOMAIN");

	# Process answers
	foreach my $answer (@answer) {
	    my $_tmp = $answer->type;
	    my $atype = ($DNSTYPE{$_tmp} or $_tmp);
	    my $aname = $answer->name;
	    if ($atype eq $type && lc($aname) eq lc($rname)) {
		push(@result, $answer);
	    } elsif (!@result && lc($aname) eq lc($rname)
		     && $answer->isa("Net::DNS::RR::CNAME")) {
		$rname = $answer->cname;
	    }
	}
	last if (@result || lc($qname) eq lc($rname));
	$qname = $rname;
	eval { check_dns_name($qname, $ishost) };
	if ($@) {
	    die sprintf "expands to invalid alias: %s", $@;
	}
	last if ++$seen{lc($qname)} != 1;
    }
    return ($ad, $rname, @result);
}

sub parsetlsa {
    my ($rdata) = @_;

    my @bytes = split("", $rdata);
    die sprintf "Invalid TLSA RDATA length: %d\n", 0+@bytes if @bytes < 3;

    my (@usm) = splice(@bytes, 0, 3);
    my ($u, $s, $m) = map { ord($_) } @usm;
    my $d = join("", map { sprintf("%02X", ord($_)) } @bytes);

    return ($u, $s, $m, $d);
}

sub get_secure_addresses {
    my ($info) = @_;
    my $host = $info->{host};

    my ($ad, $rname, @v4) = dns_lookup($host, ISHOST, "A");
    ($ad, $rname, my @v6) = dns_lookup($host, ISHOST, "AAAA") if $ip6;

    # Consider initial name secure if a secure CNAME that resolves
    # to insecure addresses.
    #
    if (! $ad && (@v4 || @v6) && lc($host) ne lc($rname)) {
	# Discard result, keeping just the AD-bit side-effect.
	#
	($ad) = dns_lookup($host, ISHOST, "CNAME");
	$rname = $host if ($ad);
    }

    die sprintf "Address records insecure\n" if (! $ad);
    $info->{rname} = $rname if lc($rname) ne lc($host);
    $info->{v4} = [ map { $_->address } @v4 ];
    $info->{v6} = [ map { $_->address } @v6 ];
    return;
}

sub get_secure_tlsa {
    my ($info) = @_;
    my $base = $info->{host};
    my $port = $info->{port};

    my ($ad, $dummy, @tlsa) = dns_lookup("_$port._tcp.$base", NOTHOST, "TYPE52");
    if ((! $ad || @tlsa == 0) && ($base = $info->{rname})) {
	my ($ad, $dummy, @tlsa) = dns_lookup("_25._tcp.$base", NOTHOST, "TYPE52");
    }

    die "no TLSA records\n" if (@tlsa == 0);
    die "insecure TLSA records\n" if (! $ad);

    $info->{tlsabase} = $base;
    $info->{tlsa} = [ map { [
	($_->type eq "TLSA") ?
	    ($_->usage, $_->selector, $_->matchingtype, $_->cert) :
	    parsetlsa($_->rdata)
	] } @tlsa ];
    return;
}

my ($host, $port) = @ARGV;
my $info = { host => $host, port => $port };

# TLSA not queried if addresses not secure!
#
get_secure_addresses($info);
if (! @{$info->{v4}} && ! @{$info->{v6}}) {
    die "Host has no addresses\n";
}
get_secure_tlsa($info);
my $base = $info->{tlsabase};
my $sslinfo = tryssl($host, $port, $base);
my $chain = join("\n", @{$sslinfo->{chain}});

my $ok = 0;
foreach my $tlsa (@{$info->{tlsa}}) {
    my ($depth, $hostname) = eval {
	Danessl::verify(@{$tlsa}, $chain, $base,
			$info->{host}, defined($info->{rname}) ?
			$info->{rname} : ())
    };
    if ($@) {
	printf ";; Failed: %s. IN TLSA %d %d %d %s: %s",
	    $base, @$tlsa, $@;
    } else {
	$ok = 1;
	printf ";; Passed(depth %d%s): %s. IN TLSA %d %d %d %s\n",
	    $depth, $hostname ? ", hostname $hostname" : "",
	    $base, @$tlsa;
    }
}
exit($ok ? 0 : 1);