Net-RDAP/lib/Net/RDAP/Registry.pm
package Net::RDAP::Registry;
use Carp qw(croak);
use File::Basename qw(basename);
use File::Slurp;
use File::Spec;
use File::stat;
use JSON;
use POSIX qw(getpwuid);
use Net::RDAP::UA;
use Net::RDAP::Registry::IANARegistry;
use vars qw($UA $REGISTRY);
use constant {
IP4_URL => 'https://data.iana.org/rdap/ipv4.json',
IP6_URL => 'https://data.iana.org/rdap/ipv6.json',
DNS_URL => 'https://data.iana.org/rdap/dns.json',
ASN_URL => 'https://data.iana.org/rdap/asn.json',
TAG_URL => 'https://data.iana.org/rdap/object-tags.json',
CACHE_TTL => 86400,
};
use strict;
our $UA;
our $REGISTRY = {};
=pod
=head1 NAME
L<Net::RDAP::Registry> - a module which provides an interface to the IANA RDAP
registries.
=head1 SYNOPSIS
use Net::RDAP::Registry;
use Net::IP;
use Net::ASN;
$url = Net::RDAP::Registry->get_url(Net::DNS::Domain->new('example.com'));
$url = Net::RDAP::Registry->get_url(Net::IP->new('192.168.0.1'));
$url = Net::RDAP::Registry->get_url(Net::IP->new('2001:DB8::/32'));
$url = Net::RDAP::Registry->get_url(Net::ASN->new(65536));
$url = Net::RDAP::Registry->get_url('ABC123-TAG');
=head1 DESCRIPTION
RFC 7484 describes how RDAP clients can find the authoritative RDAP
service for a given internet resource using one of several IANA
registries.
This module provides an interface to these registries, and will return
a L<URI> object corresponding to the URL for a resource obtained from
them.
L<Net::RDAP::Registry> downloads the registry files from the IANA
website and will maintain up-to-date copies of those files locally.
=head1 METHODS
$url = Net::RDAP::Registry->get_url($resource);
This method returns a L<URI> object corresponding to the authoritative
RDAP URL for the given resource. C<$resource> may be one of the
following:
=over
=item * a L<Net::IP> object representing an IPv4 or IPv6 address or
address range;
=item * a L<Net::ASN> object representing an Autonymous System;
=item * a L<Net::DNS::Domain> object representing a domain name.
=item * a string containing a tagged entity handle
=back
This method requires objects to be passed to ensure that the resource
identifiers have been properly validated.
If no URL can be found in the IANA registry, then C<undef> is returned.
=cut
sub get_url {
my ($package, $object) = @_;
if ('Net::IP' eq ref($object)) {
return $package->ip($object);
} elsif ('Net::ASN' eq ref($object)) {
return $package->autnum($object);
} elsif ('Net::DNS::Domain' eq ref($object)) {
return $package->domain($object);
} elsif ($object =~ /-/) {
return $package->entity($object);
} else {
croak("Unable to deal with '$object'");
}
}
#
# get URL for IP
#
sub ip {
my ($package, $ip) = @_;
croak(sprintf('Argument to %s->ip() must be a Net::IP', $package)) unless ('Net::IP' eq ref($ip));
my $registry = $package->load_registry(4 == $ip->version ? IP4_URL : IP6_URL);
return undef if (!$registry);
my %matches;
SERVICE: foreach my $service ($registry->services) {
VALUE: foreach my $value ($service->registries) {
my $range = Net::IP->new($value);
if ($range->overlaps($ip)) {
$matches{$value} = $package->get_best_url($service->urls);
last VALUE;
}
}
}
return undef if (scalar(keys(%matches)) < 1);
# prefer the service with the longest prefix length
my $longest = (sort { Net::IP->new($b)->prefixlen <=> Net::IP->new($a)->prefixlen } keys(%matches))[0];
return $package->assemble_url($matches{$longest}, 'ip', split(/\//, $ip->prefix));
}
#
# get URL for AS Number
#
sub autnum {
my ($package, $autnum) = @_;
croak(sprintf('Argument to %s->autnum() must be a Net::ASN', $package)) unless ('Net::ASN' eq ref($autnum));
my $registry = $package->load_registry(ASN_URL);
return undef if (!$registry);
my %matches;
SERVICE: foreach my $service ($registry->services) {
VALUE: foreach my $value ($service->registries) {
if ($value =~ /^\d+$/ && $value == $autnum->toasplain) {
# exact match, create an entry for NNNN-NNNN where both sides
# are the same (simplifies sorting later)
$matches{sprintf('%d-%d', $value, $value)} = $package->get_best_url($service->urls);
last SERVICE;
} elsif ($value =~ /^(\d+)-(\d+)$/) {
if ($1 <= $autnum->toasplain && $autnum->toasplain <= $2) {
$matches{$value} = $package->get_best_url($service->urls);
last VALUE;
}
}
}
}
return undef if (scalar(keys(%matches)) < 1);
my @ranges = keys(%matches);
# convert array of NNNN-NNNN strings to array of array refs
my @pairs = map { [ split(/-/, $_, 2) ] } @ranges;
# sort by descending order of the "width" of the range
my @sorted = sort { $b->{1} - $b->{0} <=> $a->{1} - $a->{0} } @pairs;
# prefer the narrowest (more specific) range
my $closest = sprintf('%d-%d', @{$sorted[0]});
return $package->assemble_url($matches{$closest}, 'autnum', $autnum->toasplain);
}
#
# get URL for domain
#
sub domain {
my ($package, $domain) = @_;
croak(sprintf('Argument to %s->domain() must be a Net::DNS::Domain', $package)) unless ('Net::DNS::Domain' eq ref($domain));
my $is_tld = (1 == scalar($domain->label));
my $registry = $package->load_registry(DNS_URL);
return undef if (!$registry);
my %matches;
SERVICE: foreach my $service ($registry->services) {
VALUE: foreach my $value ($service->registries) {
if ($is_tld && '' eq $value) {
#
# the RDAP server for the root zone is identified by an empty
# string (see RFC 9224 ยง 4):
#
$matches{$value} = $package->get_best_url($service->urls);
last VALUE;
} else {
if ($domain->name =~ /\.$value$/i) {
$matches{$value} = $package->get_best_url($service->urls);
last VALUE;
}
}
}
}
if (scalar(keys(%matches)) < 1) {
if ($domain->name =~ /\.(in-addr|ip6)\.arpa$/) {
# special workaround for the lack of .arpa in the RDAP registry
return $package->reverse_domain($domain);
} else {
return undef;
}
} else {
# prefer the service with the longest domain name
my $parent = (sort { length($b) <=> length($a) } keys(%matches))[0];
return $package->assemble_url($matches{$parent}, 'domain', $domain->name);
}
}
#
# construct the RDAP URL for a reverse domain. as of writing there's
# nothing in the IANA registry for the reverse tree so we work around
# that by by constructing the CIDR prefix that corresponds to the
# domain, resolving the RDAP URL for that, and then munging it to
# obtain the URL for the domain. clever, eh?
#
sub reverse_domain {
my ($package, $domain) = @_;
my @labels = reverse($domain->label);
shift(@labels); # discard 'arpa'
my $ip;
if ('ip6' eq shift(@labels)) {
# @labels is an array of hex digits, we want an array of 4-hex digit parts
my @parts;
push(@parts, join('', splice(@labels, 0, 4))) while (scalar(@labels) > 0);
# remove any trailing parts that are zero
pop(@parts) while (0 == hex($parts[-1]));
# compute prefix length
my $prefixlen = 16 * (scalar(@parts));
$ip = Net::IP->new(sprintf(
'%s:%s:%s:%s:%s:%s:%s:%s/%u',
shift(@parts) || 0,
shift(@parts) || 0,
shift(@parts) || 0,
shift(@parts) || 0,
shift(@parts) || 0,
shift(@parts) || 0,
shift(@parts) || 0,
shift(@parts) || 0,
$prefixlen,
));
} else {
pop(@labels) while (0 == $labels[-1]);
my $prefixlen = 8 * (scalar(@labels));
$ip = Net::IP->new(sprintf(
'%u.%u.%u.%u/%u',
shift(@labels) || 0,
shift(@labels) || 0,
shift(@labels) || 0,
shift(@labels) || 0,
$prefixlen,
));
}
return undef if (!$ip);
my $url = $package->ip($ip);
return undef if (!$url);
return URI->new_abs(sprintf('../../domain/%s', $domain->name), $url);
}
#
# get URL for a tagged entity
#
sub entity {
my ($package, $handle) = @_;
my @parts = split(/-/, $handle);
my $tag = pop(@parts);
my $registry = $package->load_registry(TAG_URL);
return undef if (!$registry);
foreach my $service ($registry->services) {
foreach my $value ($service->registries) {
# unlike the other registries we are only looking for an exact match, as there is no hierarchy:
return $package->assemble_url($package->get_best_url($service->urls), 'entity', $handle) if (lc($value) eq lc($tag));
}
}
return undef;
}
#
# load a registry. uses (in order of preference) an in-memory cache, a JSON file on disk,
# or a resource on the IANA website. returns a Net::RDAP::Registry::IANARegistry object
# (or undef)
#
sub load_registry {
my ($package, $url) = @_;
if (!defined($REGISTRY->{$url})) {
$package =~ s/:+/-/g;
my $file = sprintf(
'%s/%s-%s-%s',
File::Spec->tmpdir,
$package,
basename($url),
getpwuid($<),
);
#
# $UA may have been injected by Net::RDAP->ua()
#
$UA = Net::RDAP::UA->new unless(defined($UA));
$UA->mirror($url, $file, CACHE_TTL);
$REGISTRY->{$url} = Net::RDAP::Registry::IANARegistry->new(from_json(read_file($file))) if (-e $file);
}
return $REGISTRY->{$url};
}
#
# RDAP services can have multiple URLs, we pick the best by
# simply preferring the first one with the "https" scheme.
#
sub get_best_url {
my ($package, @urls) = @_;
my @https = grep { 'https' eq lc($_->scheme) } @urls;
if (scalar(@https)) {
return shift(@https);
} else {
return shift(@urls);
}
}
#
# concatenate a URL with a bunch of path segments
# this method deals with URI objects which have
# trailing slashes
#
sub assemble_url {
my ($package, $url, @segments) = @_;
$url->path_segments(grep { defined && length > 0 } ($url->path_segments, @segments));
return $url;
}
1;
__END__
=pod
=head1 COPYRIGHT
Copyright 2018-2023 CentralNic Ltd, 2024-2025 Gavin Brown. For licensing information,
please see the C<LICENSE> file in the L<Net::RDAP> distribution.
=cut