#!/usr/bin/perl
# Copyright (c) 2012 CentralNic Ltd. All rights reserved. This program is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.
use Getopt::Long;
use HTTP::Request::Common;
use JSON;
use LWP 6.00;
use MIME::Base64;
use MIME::Type;
use Mozilla::CA;
use POSIX;
use Pod::Usage;
use strict;

my $NAME = 'rdapper';
our $VERSION = '0.06';

#
# determines the order in which fields appear in output. The higher the number,
# the closer to the top the field appears:
#
my $order = {
	'handle'		=> 99999,
	'name'			=> 88888,
	'names'			=> 88887,
	'variants'		=> 77777,
	'status'		=> 66666,
	'sponsoredBy'		=> 66333,
	'registrationDate'	=> 55555,
	'registrationBy'	=> 44444,
	'expirationDate'	=> 33333,
	'lastChangedDate'	=> 22222,
	'lastChangedBy'		=> 11111,
	'transferDate'		=> 11110,
	'entities'		=> 11109,
	'nameServers'		=> 11108,
	'delegationKeys'	=> 11107,
	'postalAddress'		=> 11106,
	'phones'		=> 11105,
	'emails'		=> 11104,
	'keyTag'		=> 11103,
	'algorithm'		=> 11102,
	'digestType'		=> 11101,
	'digest'		=> 11100,
};

#
# English names for keys. These need to be internationalised at some point:
#
my $name = {
	'algorithm'		=> 'Algorithm',
	'country'		=> 'Country',
	'delegationKeys'	=> 'DNSSEC Key',
	'description'		=> 'Description',
	'digest'		=> 'Digest',
	'digestType'		=> 'Digest Type',
	'emails'		=> 'Email Address',
	'endAddress'		=> 'End Address',
	'endAutnum'		=> 'End AS',
	'entities'		=> 'Contact',
	'errorCode'		=> 'Error Code',
	'expirationDate'	=> 'Expiration Date',
	'fax'			=> 'Fax',
	'handle'		=> 'Handle',
	'ipAddresses'		=> 'IP Address',
	'ipVersion'		=> 'IP Version',
	'keyTag'		=> 'Key Tag',
	'lang'			=> 'Language',
	'lastChangedBy'		=> 'Last Changed Up',
	'lastChangedDate'	=> 'Last Changed',
	'links'			=> 'Link',
	'name'			=> 'Name',
	'names'			=> 'Name',
	'nameServers'		=> 'Nameserver',
	'notices'		=> 'Notice',
	'parentHandle'		=> 'Parent',
	'phones'		=> 'Telephone',
	'port43'		=> 'Port 43 Whois',
	'postalAddress'		=> 'Postal Address',
	'rdapConformance'	=> 'RDAP Conformance',
	'registrationBy'	=> 'Registered By',
	'registrationDate'	=> 'Registered',
	'remarks'		=> 'Remarks',
	'resoldBy'		=> 'Resold By',
	'roles'			=> 'Role',
	'sponsoredBy'		=> 'Sponsored By',
	'startAddress'		=> 'Start Address',
	'startAutnum'		=> 'Start AS',
	'status'		=> 'Status',
	'title'			=> 'Title',
	'transferDate'		=> 'Transferred',
	'type'			=> 'Type',
	'variants'		=> 'Variant',
};

#
# handlers for specific data types:
#
my $handler = {
	'delegationKeys'	=> \&handle_delegationKeys,
	'emails'		=> \&handle_emails,
	'entities'		=> \&handle_entities,
	'ipAddresses'		=> \&handle_ipAddresses,
#	'links'			=> \&handle_links,
	'lang'			=> \&handle_language,
	'names'			=> \&handle_names,
	'nameServers'		=> \&handle_nameServers,
	'notices'		=> \&handle_notices,
	'phones'		=> \&handle_phones,
	'postalAddress'		=> \&handle_postalAddress,
#	'remarks',		=> \&handle_remarks,
	'rdapConformance'	=> \&handle_rdapConformance,
	'status'		=> \&handle_status,
#	'variants'		=> \&handle_variants,
};

#
# entity roles:
#
my @roles = qw(registrant admin tech billing);

#
# command line options:
#
my $help;
my $host = 'rdap.org';
my $port;
my $type = '';
my $query;
my $raw;
my $tls;
my $lang;
my $encoding;
my $username;
my $password;
my $debug;
my $cert;
my $key;
my $keypass;
GetOptions(
	'help'		=> \$help,
	'host=s'	=> \$host,
	'port:i'	=> \$port,
	'type:s'	=> \$type,
	'query:s'	=> \$query,
	'raw'		=> \$raw,
	'tls'		=> \$tls,
	'lang:s'	=> \$lang,
	'encoding:s'	=> \$encoding,
	'username:s'	=> \$username,
	'password:s'	=> \$password,
	'debug'		=> \$debug,
	'cert:s'	=> \$cert,
	'key:s'		=> \$key,
	'keypass:s'	=> \$keypass,
);

$type = lc($type);

$query = $ARGV[0] if ($query eq '' && $ARGV[0] ne '');

if ($type eq '') {
	if (
		# IPv4 address:
		$query =~ /^(([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])\.){3}([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])$/ ||

		# IPv4 CIDR:
		$query =~ /^(([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])\.){3}([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])(\/(\d|[1-2]\d|3[0-2]))$/ ||

		# IPv6:
		$query =~ /^\s*((([0-9A-Fa-f]{1,4}:){7}([0-9A-Fa-f]{1,4}|:))|(([0-9A-Fa-f]{1,4}:){6}(:[0-9A-Fa-f]{1,4}|((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){5}(((:[0-9A-Fa-f]{1,4}){1,2})|:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){4}(((:[0-9A-Fa-f]{1,4}){1,3})|((:[0-9A-Fa-f]{1,4})?:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){3}(((:[0-9A-Fa-f]{1,4}){1,4})|((:[0-9A-Fa-f]{1,4}){0,2}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){2}(((:[0-9A-Fa-f]{1,4}){1,5})|((:[0-9A-Fa-f]{1,4}){0,3}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){1}(((:[0-9A-Fa-f]{1,4}){1,6})|((:[0-9A-Fa-f]{1,4}){0,4}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(:(((:[0-9A-Fa-f]{1,4}){1,7})|((:[0-9A-Fa-f]{1,4}){0,5}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:)))(%.+)?\s*/ ||

		# IPv6 CIDR:
		$query =~ /^\s*((([0-9A-Fa-f]{1,4}:){7}([0-9A-Fa-f]{1,4}|:))|(([0-9A-Fa-f]{1,4}:){6}(:[0-9A-Fa-f]{1,4}|((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){5}(((:[0-9A-Fa-f]{1,4}){1,2})|:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){4}(((:[0-9A-Fa-f]{1,4}){1,3})|((:[0-9A-Fa-f]{1,4})?:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){3}(((:[0-9A-Fa-f]{1,4}){1,4})|((:[0-9A-Fa-f]{1,4}){0,2}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){2}(((:[0-9A-Fa-f]{1,4}){1,5})|((:[0-9A-Fa-f]{1,4}){0,3}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){1}(((:[0-9A-Fa-f]{1,4}){1,6})|((:[0-9A-Fa-f]{1,4}){0,4}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(:(((:[0-9A-Fa-f]{1,4}){1,7})|((:[0-9A-Fa-f]{1,4}){0,5}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:)))(%.+)?\s*(\/(\d|\d\d|1[0-1]\d|12[0-8]))$/
	) {
		$type = 'ip';

	} elsif ($query =~ /^ASN?(\d+)$/i) {
		$query = $1;
		$type = 'autnum';

	} else {
		$type = 'domain';

	}
}

$port = ($port > 0 ? $port : ($tls ? 443 : 80));

if ($lang eq '') {
	if (defined($ENV{'LANG'})) {
		($lang, $encoding) = split(/\./, $ENV{'LANG'}, 2);
		$lang =~ s/_/-/;

	} else {
		$lang = 'en';

	}
}

$encoding = 'UTF-8' if ($encoding eq '');

pod2usage('-verbose' => 1) if ($host eq '' || $query eq '' || $help);

if ($raw && $debug) {
	print STDERR "Error: Can't use --raw and --debug at the same time\n";
	exit(1);
}

#
# prepare the UA:
#
my $uri = sprintf('%s://%s:%d/%s/%s', ($tls ? 'https' : 'http'), $host, $port, $type, $query);

my $ua = LWP::UserAgent->new;
$ua->agent("$NAME/$VERSION");

my %ssl_opts = (
	'verify_hostname'	=> 1,
	'SSL_ca_file'		=> Mozilla::CA::SSL_ca_file(),
);

if ($cert ne '' || $key ne '') {
	if ($cert eq '') {
		print STDERR "Error: Missing --cert option\n";
		exit 1;

	} elsif (!-r $cert) {
		print STDERR "Error: Certificate file '$cert' can't be read\n";
		exit 1;

	}

	if ($key eq '') {
		print STDERR "Error: Missing --key option\n";
		exit 1;

	} elsif (!-r $key) {
		print STDERR "Error: Key file '$key' can't be read\n";
		exit 1;

	}

	$ssl_opts{'SSL_cert_file'} = $cert;
	$ssl_opts{'SSL_key_file'}  = $key;
	$ssl_opts{'SSL_passwd_cb'} = sub { $keypass };

}

$ua->ssl_opts(%ssl_opts);

#
# prepare request:
#
my $req = GET($uri);
$req->header('Accept-Language',	$lang);
$req->header('Accept-Encoding',	$encoding);
$req->header('Accept',		'application/json');
$req->header('Authorization',	encode_base64($username.':'.$password)) if ($username ne '');

#
# send request:
#
my $res = $ua->request($req);

# this is used to prepend information to a key name:
my $prefix;

# output rows go in here:
my @rows;

# notices go in here:
my @notices;

#
# handle response:
#
if ($debug) {
	foreach my $prev ($res->redirects) {
		print $prev->request->as_string;
		print $prev->as_string;
	}
	print $res->request->as_string;
	print $res->as_string;
	exit(0);

} elsif ($res->is_error) {
	printf(STDERR "Error: %s\n", $res->status_line);
	exit(1);

} else {
	my $type = MIME::Type->new('type' => $res->header('Content-Type'));

	if (!$type->equals('application/rdap+json') && !$type->equals('application/rdap_error+json')) {
		printf(STDERR "Error: Don't know what to do with a response of content type '%s' (hint: use --debug to see the full server response)\n", $res->header('Content-Type'));
		exit(1);

	} else {
		my $json = new JSON;
		my $data = $json->decode($res->content);
	
		if ($raw) {
			print $json->pretty->encode($data);
	
		} else {
			handle_generic($data);
	
		}
	}
}

#
# output response:
#
my $max = 0;
map { $max = length($_->[0]) if (length($_->[0]) > $max) } @rows;

foreach my $row (@rows) {
	print	$row->[0] .
		' ' x ($max -length($row->[0])) .
		' : ' .
		$row->[1] .
		"\n";
}

#
# display notices:
#
foreach my $notice (@notices) {
	my $bar = '=' x (38 - (POSIX::floor(length($notice->{'title'}))/2));
	print "\n".$bar.' '.$notice->{'title'}.' '.$bar."\n\n";

	if (ref($notice->{'description'}) eq '') {
		chomp($notice->{'description'});
		print $notice->{'description'}."\n";

	} elsif (ref($notice->{'description'}) eq 'ARRAY') {
		map { print $_."\n" } @{$notice->{'description'}};

	}

	print "\n";
	print "URI: ".$notice->{'uri'}."\n" if (defined($notice->{'uri'}));
}

print "\n";

#
# END:
#
exit(0);

# converts an RDAP key into a human readable name:
sub name {
	my $key = shift;
	return ($name->{$key} || $key);
}

# append a row [$name, $value] to the output array:
sub append_row {
	my $row = shift;
	$row->[0] = $prefix.' '.$row->[0] if ($prefix ne '');
	push(@rows, $row);
}

# handler for generic (top-level) data:
sub handle_generic {
	my ($data, $prefix) = @_;

	if (ref($data) ne 'HASH') {
		append_row([name(ref($data)), encode_json($data)]);

	} else {
		foreach my $key (reverse sort { $order->{$a} <=> $order->{$b} } keys(%{$data})) {
			if (defined($handler->{$key})) {
				&{$handler->{$key}}($data->{$key});

			} elsif (ref($data->{$key}) eq '') {
				append_row([name($key), $data->{$key}]);

			} else {
				append_row([name($key), encode_json({$key => $data->{$key}})]);

			}
		}
	}
}

#
# handlers for specific keys:
#

sub handle_delegationKeys {
	my $keys = shift;

	foreach my $key (@{$keys}) {
		$prefix = name('delegationKeys');
		handle_generic($key);
		$prefix = '';
	}
}

sub handle_entities {
	my $entities = shift;

	my $roles = {};
	foreach my $entity (@{$entities}) {
		next if (!defined($entity->{'roles'}));

		foreach my $role (@{$entity->{'roles'}}) {
			$roles->{$role} = $entity;
		}
		delete($entity->{'roles'});
	}

	foreach my $role (@roles) {
		next if (!defined($roles->{$role}));
		$prefix = sprintf('%s Contact', ucfirst($role));
		handle_generic($roles->{$role});
		$prefix = '';
	}
}

sub handle_emails {
	my $addrs = shift;

	foreach my $addrs (@{$addrs}) {
		append_row([$name->{'emails'}, $addrs]);
	}
}

sub handle_ipAddresses {
	my $addrs = shift;

	foreach my $addrs (@{$addrs}) {
		append_row([$name->{'ipAddresses'}, $addrs]);
	}
}

sub handle_language {
	# do nothing
}

sub handle_names {
	my $names = shift;

	append_row([$name->{'names'}, sort(join(', ', grep { $_ ne '' } @{$names}))]);
}

sub handle_nameServers {
	my $ns = shift;

	foreach my $host (sort { $a->{'name'} cmp $b->{'name'} } @{$ns}) {
		append_row([$name->{'nameServers'}, $host->{'name'}]);
	}
}

sub handle_phones {
	my $phones = shift;

	foreach my $type (keys(%{$phones})) {
		if ($type eq 'fax') {
			append_row([$name->{'fax'}, $phones->{$type}]);

		} else {
			append_row([sprintf('%s (%s)', $name->{'phones'}, $type), $phones->{$type}]);

		}
	}
}

sub handle_postalAddress {
	my $address = shift;

	foreach my $line (@{$address}) {
		append_row([$name->{'postalAddress'}, $line]);
	}

}

sub handle_rdapConformance {
	# do nothing
}

sub handle_status {
	my $codes = shift;

	foreach my $code (@{$codes}) {
		append_row([$name->{'status'}, $code]);
	}
}

sub handle_notices {
	my $notices = shift;

	foreach my $notice (@{$notices}) {
		push(@notices, $notice);
	}
}

__END__
=pod

=head1 NAME

rdapper - a command-line RDAP client.

=head1 DESCRIPTION

rdapper is a command-line client for the Registration Data Access Protocol
(RDAP), the successor protocol to Whois (RFC 3912). RDAP is currently being
developed by the WEIRDS IETF working group, and has not yet been finalized.

This tool will send an RDAP query to an RDAP server over HTTP or HTTPS, parse
the JSON response, and display it in human-readable form.

=head1 INSTALLING

To install this program type the following commands in the source directory:

   perl Makefile.PL
   make
   make install

=head1 USAGE

    rdapper [OPTIONS] QUERY

=head1 OPTIONS

=over

=item --host=HOST (default: rdap.org)

Specify the host to query. If not set, rdapper uses C<rdap.org> (see below).

=item --TYPE=TYPE

Specify the type of object being queried. Possible values are: domain, 
entity, nameserver, autnum, ip. Rdapper will automatically detect IPv4 
and IPv6 addresses and AS numbers, and will fall back to domain queries 
for everything else.

=item --tls

Force use of TLS.

=item --username=USERNAME

Specify a username to be used with Basic Authentication.

=item --password=PASSWORD

Specify a password to be used with Basic Authentication.

=item --cert=CERTIFICATE

Specify a client SSL certificate to present to the server.

=item --key=KEY

Specify a private key matching the certificate given in C<--password>.

=item --keypass=PASSPHRASE

Specify a passphrase to decrypt the private key given by C<--key>.

=item --raw

Causes rdapper to emit pretty-printed JSON rather than text output.

=item --debug

Causes rdapper to display the HTTP request and response rather than the text
output.

=item --lang=LANGUAGE

Specify a language. This is sent to the server using the C<Accept-Language>
header. If unset, the language will be taken from your C<$LANG> environment
variable (or C<en> if that is not defined).

=item --encoding=ENCODING

Specify an encoding. This is sent to the server using the C<Accept-Encoding>
header. If unset, the encoding will be taken from your C<$LANG> environment
variable (or C<UTF-8> if that is not defined).

=back

=head1 USE OF RDAP.ORG

Unless instructed otherwise (via the --host argument), rdapper will send 
all queries to rdap.org: this server is an aggregator of RDAP services, 
and will provide an HTTP redirect where available.

=head1 SEE ALSO

=over

=item L<http://tools.ietf.org/wg/weirds/>

=item L<https://www.centralnic.com/>

=item L<http://rdap.org/>

=back

=head1 COPYRIGHT

rdapper is Copyright 2012 CentralNic Ltd. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same terms as
Perl itself.

=cut
