#!/usr/bin/perl
#
use 5.024;
use strict;
use warnings;
use autodie;
use Digest::SHA qw(sha1_hex);
use Fcntl qw(:flock);
use File::Basename;
use Getopt::Long;
use POSIX qw(strftime WNOHANG);
use Pod::Usage;
use HTTP::Daemon;
use HTTP::Response;
use HTTP::Status;
use Net::IP;

GetOptions(
	"listen=s" => \(my $LISTEN = "ptr4.openbsd.amsterdam"),
	"port=i" => \(my $PORT = "80"),
	"help" => \(my $HELP),
	"man" => \(my $MAN),
) or pod2usage(2);
pod2usage(1) if $HELP; 
pod2usage(-verbose => 2) if $MAN; 

=head1 NAME

=head1 SYNOPSIS

ptrd.pl [options]

=head1 OPTIONS

=over 4

=item B<-l> | --listen

Address or hostname to listen on, default ptr4.openbsd.amsterdam.

=item B<-p> | --port

Port to listen on, default 80

=back

=head1 DESCRIPTION

B<This program> is a Perl HTTP Daemon designed to listen for incoming PTR records of OpenBSD Amsterdam VMs.

A token needs to be requested before the PTR record can be set.

=cut

my %O = (
	'listen-host' => $LISTEN,
	'listen-port' => $PORT,
	'listen-clients' => 10,
	'listen-max-req-per-child' => 10000,
);

my $d = HTTP::Daemon->new(
	LocalAddr => $O{'listen-host'},
	LocalPort => $O{'listen-port'},
	Reuse => 1,
) or die "Can't start http listener at $O{'listen-host'}:$O{'listen-port'}";
_log("Started HTTP listener at $LISTEN from " . dirname($0));

my %chld;
my $workdir = dirname($0);
my $error = 0;

$SIG{INT}  = \&signal_handler;
$SIG{TERM} = \&signal_handler;

open my $fh_tlds, '<', "${workdir}/tlds-alpha-by-domain.txt";
chomp(my @tlds = <$fh_tlds>);
close $fh_tlds;

if ($O{'listen-clients'}) {
	$SIG{CHLD} = sub {
		# checkout finished children
		while ((my $kid = waitpid(-1, WNOHANG)) > 0) {
			delete $chld{$kid};
		}
	};
}

while (1) {
	if ($O{'listen-clients'}) {
		# prefork all at once
		for (scalar(keys %chld) .. $O{'listen-clients'} - 1 ) {
			my $pid = fork;

			if (!defined $pid) { # error
				die "Can't fork for http child $_: $!";
			}
			if ($pid) { # parent
				$chld{$pid} = 1;
			} else { # child
				$_ = 'DEFAULT' for @SIG{qw/ INT TERM CHLD /};
				http_child($d);
				exit;
			}
		}
		sleep 1;
	} else {
		http_child($d);
	}
}

sub http_child {
	my $d = shift;
	my $i;

	while (++$i < $O{'listen-max-req-per-child'}) {
		my $c = $d->accept or last;
		my $r = $c->get_request(1) or last;
		$c->autoflush(1);
	
		my $ipv4_range = new Net::IP("46.23.80.0/20");
		my $ipv6_range = new Net::IP("2a03:6000::/29");

		my $client_ip = $c->peerhost;
		my $ip = new Net::IP($client_ip);
		my ($first, $token, $hostname) = split(/\//, $r->uri->as_string);
		my $tld = (defined($hostname) ? substr($hostname, rindex($hostname, '.')+1) : '');
		$hostname = (!defined($hostname) ? $token : lc($hostname));

		if ($ip->overlaps($ipv4_range) or $ip->overlaps($ipv6_range)) {

			if ($token eq 'token') {
				my $token = sha1_hex(int(rand(32)));
				open my $fh_token, '>', "${workdir}/tokens/${token}";
				print $fh_token "$client_ip\n";
				close $fh_token;

				_log("$client_ip $token");
				_http_response($c, {content_type => 'text/plain'}, "$token");

			} elsif (-e  "${workdir}/tokens/$token" and grep(/^${tld}$/i, @tlds) and ($hostname =~ /(?=^.{4,253}$)(^((?!-)[a-zA-Z0-9-]{1,63}(?<!-)\.)+[a-zA-Z]{2,63}$)/)) {

				open my $fh, '>', "${workdir}/records/${client_ip}";
				if ($ip->overlaps($ipv4_range)) {
					my $ptr = substr($client_ip, rindex($client_ip, '.')+1);
					print $fh sprintf("%s\t\tIN\tPTR\t%s.\n", $ptr, $hostname);

				} elsif ($ip->overlaps($ipv6_range)) {
					my $dig = qx(dig +short \@46.23.80.23 -x ${client_ip});
					if (!$dig) {
						$error = 1;
					} else {
						my $ptr = substr($ip->reverse_ip(), 0, 47);
						print $fh sprintf("%s\tIN\tPTR\t%s.\n", $ptr, $hostname);
					}
				}
				close $fh;

				if ($error == 1) {
					_log("$client_ip $token $hostname - PTR doesn't exist");
					_http_response($c, {content_type => 'text/plain'}, "Error PTR [$client_ip] doesn't exist, please contact the administrator.");
					$error = 0;
				} else {
					_log("$client_ip $token $hostname");
					_http_response($c, {content_type => 'text/plain'}, "Received PTR [$client_ip -> $hostname] will be processed asap.");
				}

			} elsif (!-e "${workdir}/tokens/$token" and defined($token)and $token ne 'token') {
				_log("$client_ip RC_REQUEST_TIMEOUT $hostname");
				_http_error($c, RC_REQUEST_TIMEOUT);

			} else {
				_log("$client_ip RC_BAD_REQUEST $hostname");
				_http_error($c, RC_BAD_REQUEST);
			}

		} else {
			#print sprintf("%s %s: %s RC_FORBIDDEN\n", $date, $0, $client_ip);
			_log("$client_ip RC_FORBIDDEN");
			_http_error($c, RC_FORBIDDEN);
		}

		$c->close();
		undef $c;
	}
}

sub _http_error {
	my ($c, $code, $msg) = @_;
	$c->send_error($code, $msg);
}

sub _http_response {
	my $c = shift;
	my $header = shift;
	my $content = shift;
	$c->send_response(
		HTTP::Response->new(
			RC_OK,
			undef,
			[
				'Content-Type' => $header->{content_type},
				'Cache-Control' => 'no-store, no-cache, must-revalidate, post-check=0, pre-check=0',
				'Pragma' => 'no-cache',
				'Expires' => 'Wed, 29 Feb 1984 13:37:00 GMT',
			],
			"$content\r\n",
		)
	);
}

sub _log {
	my ($msg) = @_;
	open my $fh, '>>', '/var/log/ptrd.log';
	flock $fh, LOCK_EX;
	print $fh sprintf("%s %s: %s \n", strftime("%b %d %H:%M:%S", localtime), basename($0), $msg);
	close $fh;
}

sub signal_handler {
	_log("Caught a signal $!");
	die "Caught a signal $!";
}