started to add some more tests, based on the 1.6 tech profile. should really...

started to add some more tests, based on the 1.6 tech profile. should really add document references to each test

rdap-conformance

@@ -3,9 +3,13 @@
 # use it and/or modify it under the same terms as Perl itself.
 use File::Basename qw(basename);
 use Getopt::Long;
+use HTTP::Request::Common;
 use List::MoreUtils qw(any);
+use Net::DNS::Domain;
+use Net::DNS;
 use Net::RDAP;
 use Pod::Usage;
+use Term::ANSIColor;
 use Text::Wrap;
 use URI;
 use strict;
@@ -29,7 +33,25 @@ $ENV{'NET_RDAP_UA_DEBUG'} = $opt->{'debug'};
 
 printf(STDERR "Testing %s, type '%s'...\n", $ARGV[0], $opt->{'type'});
 
-my $response = Net::RDAP->new->fetch(URI->new($ARGV[0]));
+my $url = URI->new($ARGV[0]);
+fail("URL must use HTTPS") unless ('https' eq $url->scheme);
+
+warning('TLS best practices validation is not currently available');
+
+my $rdap = Net::RDAP->new;
+
+my $response = $rdap->ua->request(HEAD($url));
+
+my $msg = sprintf('HEAD request to %s returned %03d', $url->as_string, $response->code);
+if (200 == $response->code) {
+	pass($msg);
+
+} else {
+	fail($msg);
+
+}
+
+my $response = $rdap->fetch($url);
 
 my $errors = 0;
 
@@ -100,45 +122,166 @@ sub check_rdap_conformance {
 sub check_gtld_conformance {
 	my $response = shift;
 
-	# TODO
+	my $host = $url->host.'.';
+
+	my $resolver = Net::DNS::Resolver->new('debug' => $opt->{'debug'});
+	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)));
+
+	} elsif ('NOERROR' ne $answer->header->rcode) {
+		fail(sprintf('%s received in answer to TLSA query for %s', $answer->header->rcode, uc($url->host)));
+
+	} else {
+		my @rrs = grep { 'TLSA' eq $_->type } $answer->answer;
+		if (scalar(@rrs) < 1) {
+			fail(sprintf('No records found in answer TLSA query for %s', uc($url->host)));
+
+		} else {
+			pass('%d TLSA record(s) found for %s', scalar(@rrs), uc($url->host));
+
+			warning('TLSA record validation is not currently available');
+		}
+	}
+
+	my $v4count = scalar(grep { 'A' eq $_->type } $resolver->query($host, 'A')->answer);
+	my $v6count = scalar(grep { 'AAAA' eq $_->type } $resolver->query($host, 'AAAA')->answer);
+
+	pass('RDAP service is available over IPv4') if ($v4count > 0);
+	pass('RDAP service is available over IPv6') if ($v6count > 0);
+	fail('RDAP service is not available over both IPv4 and IPv6') unless ($v4count > 0 && $v6count > 0);
+
+	my @sigs = scalar(grep { 'RRSIG' eq $_->type } $resolver->query($host, 'RRSIG')->answer);
+	if (scalar(@sigs) > 0) {
+		pass(sprintf('%s appears to be signed using DNSSEC', uc($url->host)));
+
+		warning('DNSSEC validation is not currently available');
+
+	} else {
+		fail(sprintf('%s does not appear to be signed using DNSSEC', uc($url->host)));
+
+	}
+
+	my @links = $response->links;
+	if (scalar(@links) < 1) {
+		fail('response must contain at least one link');
+
+	} else {
+		my @related = grep { 'related' eq $_->rel } @links;
+		if (scalar(@related) < 1) {
+			fail("At least one link with the 'related' relationship must be present, pointing to the Registrar's RDAP URL of the queried domain name object.");
+
+		} else {
+			pass("At least one link with the 'related' relationship is present");
+
+			# TODO: follow link(s), check that at least one points to a valid RDAP domain resource matching the queried domain
+		}
+	}
+
+	my @notices = $response->notices;
+	if (scalar(@notices) < 1) {
+		fail('At least one notice must be present, containing the Terms of Service');
+
+	} else {
+		pass('At least one notice is present');
+		my @notices_with_links = grep { scalar($_->links) > 0 } @notices;
+		if (scalar(@notices_with_links) < 1) {
+			fail('Terms of service notice must contain at least one link');
+
+		} else {
+			pass('Terms of service notice contains at least one link');
+
+		}
+	}
 }
 
 sub check_domain_conformance {
 	my $response = shift;
 
-	# TODO
+	my @segments = $url->path_segments;
+	my $domain = Net::DNS::Domain->new(pop(@segments));
+
+	if ('domain' eq $response->class) {
+		pass('domain lookup returned a domain response');
+
+	} else {
+		fail(sprintf("domain lookup returned a '%s' response", $response->class));
+
+	}
+
+	if (lc($domain->name) == lc($response->name->name)) {
+		pass('domain name in response matches name in lookup');
+
+	} else {
+		fail(sprintf("domain name in response ('%s') does not match name in lookup ('%s')", lc($domain->name), lc($domain->name->name)));
+
+	}
+
+	my @labels = $domain->label;
+	my $tld = pop(@labels);
+
+	fail(sprintf('%s not found in RDAP IANA registry', uc($tld))) if (!Net::RDAP::Registry->get_url($domain));
+
+	# TODO: 1.11.3. An IANA's Bootstrap registry for Domain Name Space entry MUST be populated with an HTTPS URL only.
+
+	# TODO: 2.1. The RDAP server MUST support Internationalized Domain Name (IDN) RDAP lookup queries using A-label and MAY support U-label format [RFC5890] for domain names and name server objects.
+
+	# TODO: 2.2. An RDAP server that receives a query string with a mixture of A-labels and U-labels SHOULD reject the query.
+
+	# TODO: 3.1. If the domain name is an IDN, the top-level domain object in the RDAP response MUST contain the U-label format of the domain in the unicodeName member [RFC7483],
+
+	# TODO: 3.2. The status member [RFC7483] MUST be a valid status type per the IANA's RDAP JSON Values registry (https://www.iana.org/assignments/rdap-json-values/rdap-json-values.xhtml) of status type.
+
+	# TODO: 3.3. The status member of a domain object in the RDAP response MUST match the EPP Status codes in the SRS as of the updated date of the RDAP response.
+
+	# TODO: 3.4. Entities MUST use jCard [RFC7095, 3.3.1.3] structured addresses
 }
 
 sub check_entity_conformance {
 	my $response = shift;
 
-	# TODO
+	warning('Entity (registrar) record validation is not currently available');
 }
 
 sub check_nameserver_conformance {
 	my $response = shift;
 
-	# TODO
+	warning('Nameserver record validation is not currently available');
+
+	# TODO: 4.1. The draft-lozano-rdap-nameservers-sharing-name Internet Draft MAY be used to support multiple host objects for the same name server name.
+
+	# TODO: 4.2. RDAP servers MUST support nameserver lookup queries based on the name server's name as specified in 3.1.4 of RFC7482.
+
+	# TODO: 4.3. The name server's name MUST be specified in the ldhName in A-label format.
+
+	# TODO: 4.4. The unicodeName member MAY be present in the response to a nameserver lookup, if the name server has an IDN label.
+
+	# TODO: 4.5. 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.
 }
 
 sub check_help_conformance {
 	my $response = shift;
 
-	# TODO
+	warning('Help validation is not currently available');
 }
 
 sub pass {
 	my $fmt = shift;
-	printf(STDERR "PASS (%04d): %s\n", (caller)[2], sprintf($fmt, @_));
+	printf(STDERR "%s (%04d): %s\n", colored('PASS', 'bold green'), (caller)[2], sprintf($fmt, @_));
+}
+
+sub warning {
+	my $fmt = shift;
+	printf(STDERR "%s (%04d): %s\n", colored('WARN', 'bold yellow'), (caller)[2], sprintf($fmt, @_));
 }
 
 sub fail {
 	my $error = shift;
 	$error = mkerror($error, @_) if (!$error->isa('Net::RDAP::Error'));
-	printf(STDERR "FAIL (#%04d): %s\n\n", $error->errorCode, $error->title);
+	printf(STDERR "%s (#%04d): %s\n", colored('FAIL', 'bold red'), $error->errorCode, $error->title);
 	my @description = $error->description;
 	if (scalar(@description) > 0) {
-		print	"Description:\n\n".
+		print	"\nDescription:\n\n".
 			fill("    ", "    ", join("\n", @description)).
 			"\n\n";
 	}