#!/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 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}(?', "${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 $!"; }