...
 
Commits (3)
......@@ -5,6 +5,8 @@ use Devel::StackTrace;
use File::Basename qw(basename);
use Getopt::Long;
use HTTP::Request::Common;
use IPC::Open3;
use JSON;
use List::MoreUtils qw(any);
use Net::DNS::Domain;
use Net::DNS;
......@@ -34,10 +36,12 @@ my $url = URI->new($ARGV[0]);
$opt->{'handle'} ||= ($url->path_segments)[-1];
$opt->{'type'} ||= ('help' eq $opt->{'handle'} ? 'help' : ($url->path_segments)[-2]);
printf(STDERR "Testing %s, type '%s'...\n", $ARGV[0], $opt->{'type'});
note(sprintf("testing %s, type '%s'", $ARGV[0], $opt->{'type'}));
my $rdap = Net::RDAP->new;
$ENV{'NET_RDAP_UA_DEBUG'} = $opt->{'debug'};
my $rdap = Net::RDAP->new(
'use_cache' => 1,
'debug' => $opt->{'debug'}
);
$rdap->ua->proxy([qw(http https)], $opt->{'proxy'}) if ($opt->{'proxy'});
my $resolver = Net::DNS::Resolver->new;
......@@ -46,6 +50,7 @@ $resolver->dnssec(1);
$resolver->adflag(1);
$resolver->nameservers($opt->{'nameserver'});
note('retrieving response from server...');
my $response = $rdap->fetch($url);
my $errors = 0;
......@@ -75,7 +80,7 @@ if ($response->isa('Net::RDAP::Error')) {
}
printf(STDERR "Completed with %d errors\n", $errors);
note(sprintf('completed with %d errors', $errors));
exit($errors);
}
......@@ -94,12 +99,60 @@ sub check_gtld_conformance {
# Implementation Guide - RDAP Protocol - 1.2: The RDAP service MUST be provided over HTTPS only.
fail("URL must use HTTPS") unless ('https' eq $url->scheme);
my $host = $url->host.'.';
# Implementation Guide - RDAP Protocol - 1.3: An RDAP server MUST use the best practices for secure use of TLS as described in​ ​RFC7525​ or its successors.
# TODO - inspect headers added by LWP to check ciphers/algorithms/key sizes, etc
warning('TLS best practices validation is not currently available');
#
# use the command-line interface to the Qualys SSLLabs scanner, server must score at least A-
#
note('running TLS configuration check - this may take a while unless a cached result is available');
my $pid = open3(undef, \*OUT, \*ERR, 'ssllabs-scan', '-quiet', '-grade', '-usecache', $host);
undef $/;
my $out = <OUT>;
my $err = <ERR>;
waitpid($pid, 0);
if (abs($? >> 8) > 0) {
fail(
'Unable to perform TLS check',
[ split(/\n/, $err) ]
);
} else {
my $json = from_json('{'.$out.'}');
#
# str is a a test score, such as "A+", "C-", "F", etc
#
my $str = uc($json->{$host});
# generate an integer based on the first character (its ASCII value, minus 64, x 3)
my $grade = 3 * (ord(substr($str, 0, 1)) - 64);
#
# increment if it's a "minus" grade
#
$grade++ if ('-' eq substr($str, 1, 1));
#
# decrement if it's a "plus" grade
#
$grade-- if ('+' eq substr($str, 1, 1));
my $msg = sprintf('TLS configuration grade is "%s"', $str);
# 4 is "A-":
if ($grade > 4) {
fail($msg);
} else {
pass($msg);
}
}
# Implementation Guide - RDAP Protocol - 1.4: An RDAP client SHOULD be able to successfully validate the TLS certificate used for the RDAP service with a ​TLSA​ record from the DNS (​RFC6698​ and RFC7671​) published by the RDAP service provider. The certificate(s) for the RDAP service associated by DNS-Based Authentication of Named Entities (DANE) SHOULD satisfy the requirements of section 1.5.
my $host = $url->host.'.';
my $answer = $resolver->query(sprintf('_443._tcp.%s.', $url->host), 'TLSA');
if (!$answer) {
fail(sprintf('No answer to TLSA query for %s', uc($url->host)));
......@@ -115,7 +168,7 @@ sub check_gtld_conformance {
} else {
pass('%d TLSA record(s) found for %s', scalar(@rrs), uc($url->host));
warning('TLSA record validation is not currently available');
note('TLSA record validation is not currently available');
}
}
......@@ -208,7 +261,7 @@ sub check_gtld_conformance {
}
warning('Full DNSSEC chain-of-trust validation is not currently available');
note('Full DNSSEC chain-of-trust validation is not currently available');
# TODO:
# Implementation Guide - RDAP Protocol - 1.10: RDAP servers MUST only use fully qualified domain names in RDAP responses.
......@@ -368,7 +421,7 @@ sub check_entity_conformance {
# Implementation Guide - Contact queries - 6.1: In contact ​entities​ [​RFC7483​], phone numbers MUST be inserted as ​tel properties with a ​voice​ type parameter, as specified in​ ​RFC6350​, the vCard Format Specification and its corresponding JSON mapping​ ​RFC7095​.
# Implementation Guide - Contact queries - 6.2: In contact ​entities​, fax numbers if used, MUST be inserted as ​tel​ properties with a fax​ type parameter, as specified in​ ​RFC6350​, the vCard Format Specification and its corresponding JSON mapping​ ​RFC7095​.
warning('Entity (registrar) record validation is not currently available');
note('Entity (registrar) record validation is not currently available');
}
sub check_nameserver_conformance {
......@@ -383,13 +436,18 @@ sub check_nameserver_conformance {
# Implementation Guide - Nameserver Queries - 4.2: The ​unicodeName​ member MAY be present in the response to a ​nameserver lookup.
# Implementation Guide - Nameserver Queries - 4.3: ​In the case of a Registry in which name servers are specified as domain attributes, the existence of a name server used as an attribute for an allocated domain name MUST be treated as equivalent to the existence of a host object.
warning('Nameserver record validation is not currently available');
note('Nameserver record validation is not currently available');
}
sub check_help_conformance {
my $response = shift;
warning('Help validation is not currently available');
note('Help validation is not currently available');
}
sub note {
my $fmt = shift;
printf(STDERR "%s (#%04d): %s\n", colored('NOTE', 'bold white'), (caller)[2], sprintf($fmt, @_));
}
sub pass {
......