#!/usr/local/bin/perl -w
#-
# Copyright (c) 2013-2017 Universitetet i Oslo
# Copyright (c) 2021 Dag-Erling Smørgrav
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote
#    products derived from this software without specific prior written
#    permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
# Author: Dag-Erling Smørgrav <des@des.no>
#

use v5.14;
use strict;
use warnings;
use open qw(:locale);
use utf8;

use Getopt::Std;
use Net::DNS;
use Regexp::Common qw(pattern);
use Try::Tiny;

our $VERSION = '20211010';

# Regexp for paths (POSIX portable filename character set)
pattern
    name => [ qw(path pfcs) ],
    create => '/?(?:[0-9A-Za-z._-]+/)*[0-9A-Za-z._-]+',
    ;

our $opt_4;			# Include IPv4 addresses
our $opt_6;			# Include IPv6 addresses
our $opt_F;			# Never flush
our $opt_f;			# Save to file
our $opt_h;			# Print help text
our $opt_n;			# Dry run
our $opt_p;			# Preserve existing addresses
our $opt_t;			# Table name
our $opt_v;			# Verbose mode

our %rrs;

our %services = (
    22	=> 'ssh',
    53	=> 'domain',
    80	=> 'http',
    123	=> 'ntp',
    443	=> 'https',
);

#
# Print a message if in verbose mode.
#
sub verbose {
    if ($opt_v) {
	my $msg = join('', @_);
	$msg =~ s/\n*$/\n/s;
	print(STDERR $msg);
    }
}

#
# Quote a command line so it can be printed in a form that can be
# executed.
#
sub quote {
    return map {
	m/[!\#\$\&\(\)\;\<\>\[\\\]\`\{\|\}\~\s]/ ? "'" . s/([\'\\])/\\$1/gr . "'" : $_;
    } @_;
}

our $resolver;
our %dns_cache;

#
# Recursively resolve CNAME, A and AAAA records for a given DNS name
#
sub dns_lookup {
    my ($dnsname) = @_;

    return $dnsname
	if $dnsname =~ m/^($RE{net}{IPv4}|$RE{net}{IPv6})$/o;
    if (!$dns_cache{$dnsname}) {
	$resolver //= Net::DNS::Resolver->new;
	verbose("# looking up $dnsname");
	my %answers;
	foreach my $rr ('CNAME', keys %rrs) {
	    next unless my $query = $resolver->query($dnsname, $rr, 'IN');
	    foreach my $res ($query->answer) {
		verbose("# ", $res->string =~ s/\s+/ /gr);
		if ($res->type eq 'CNAME') {
		    map({ $answers{$_}++ } dns_lookup($res->cname));
		} elsif ($rrs{$res->type}) {
		    $answers{$res->address}++;
		} else {
		    # can't happen
		}
	    }
	}
	$dns_cache{$dnsname} = [ keys %answers ];
    }
    return @{$dns_cache{$dnsname}}
}

#
# Look up an SRV record
#
sub srv_lookup {
    my ($name, $service, $transport) = @_;

    $transport //= "tcp";
    $resolver //= Net::DNS::Resolver->new;
    my $dnsname = "_$service._$transport.$name";
    my $type = 'SRV';
    verbose("# looking up $type for $dnsname");
    my $query = $resolver->query($dnsname, $type, 'IN')
	or return ();
    my %answers;
    foreach my $res ($query->answer) {
	verbose("# ", $res->string =~ s/\s+/ /gr);
	if ($res->type eq 'CNAME') {
	    $answers{$res->cname}++;
	} elsif ($res->type eq 'SRV') {
	    $answers{$res->target}++;
	} else {
	    # can't happen
	}
    }
    return keys %answers;
}

sub srv2pf {
    my ($table, $file, @names) = @_;

    # Targets
    my %addresses;
    foreach (@names) {
	if (m/^($RE{net}{IPv4}|$RE{net}{IPv6})$/ || m/^\[($RE{net}{IPv6})\]$/) {
	    $addresses{$1}++;
	    next;
	} elsif (m/^($RE{net}{domain}{-nospace})\.?$/) {
	    map({ $addresses{$_}++ } dns_lookup($1));
	    next;
	}
	my ($name, $service, $transport) = split(':');
	die("invalid name\n")
	    unless $name =~ m/^($RE{net}{domain}{-nospace})\.?$/;
	$name = $1;
	$service ||= "http,https";
	die("invalid service\n")
	    unless $service =~ m/^(\w+(?:,\w+)*)$/;
	my @services = split(',', $1);
	$transport ||= "tcp";
	die("invalid transport\n")
	    unless $transport =~ m/^(tcp(?:,udp)?|udp(?:,tcp))$/;
	my @transports = split(',', $1);
	foreach $service (@services) {
	    foreach $transport (@transports) {
		# SRV lookup
		map({ $addresses{$_}++ }
		    map({ dns_lookup($_) }
			srv_lookup($name, $service, $transport)));
	    }
	}
	# fallback
	map({ $addresses{$_}++ } dns_lookup($name));
    }
    my @addresses = keys %addresses;
    @addresses = (sort(grep { /\./ } @addresses),
		  sort(grep { /:/ } @addresses));
    if ($opt_F && !@addresses) {
	verbose("# not flushing $table");
	return undef;
    }

    # Store addresses to file
    if ($file) {
	my ($filetext, $tmpfiletext);
	my $tmpfile = "$file.$$";
	if (open(my $fh, "<", $file)) {
	    local $/;
	    $filetext = <$fh>;
	    close($fh);
	} else {
	    $filetext = "";
	}
	$tmpfiletext = @addresses ? join("\n", @addresses) . "\n" : "";
	if ($filetext eq $tmpfiletext) {
	    verbose("# $file has not changed");
	} elsif (!$opt_n && !open(my $fh, ">", $tmpfile)) {
	    warn("$tmpfile: $!\n");
	} else {
	    try {
		verbose("# writing the table to $tmpfile");
		if (!$opt_n && !print($fh $tmpfiletext)) {
		    die("print($tmpfile): $!\n");
		}
		verbose("# renaming $tmpfile to $file");
		if (!$opt_n && !rename($tmpfile, $file)) {
		    die("rename($tmpfile, $file): $!\n");
		}
	    } catch {
		warn($_);
		verbose("# deleting $tmpfile");
		unlink($tmpfile);
	    } finally {
		if (!$opt_n) {
		    close($fh);
		}
	    };
	}
    }

    # Create or update table
    my @pfctl_cmd = ('/sbin/pfctl');
    push(@pfctl_cmd, '-q')
	unless $opt_v;
    push(@pfctl_cmd, '-t', $table, '-T');
    if (@addresses) {
	push(@pfctl_cmd, $opt_p ? 'add' : 'replace', @addresses);
    } else {
	return if $opt_p;
	push(@pfctl_cmd, 'flush');
    }
    verbose(join(' ', quote(@pfctl_cmd)));
    if (!$opt_n) {
	system(@pfctl_cmd);
    }
}

# Print usage string and exit
sub usage {
    print(STDERR
	  "usage: srv2pf [-46Fnpv] [-f file] -t table name[:service[:transport]] [...]\n");
    exit(1);
}

MAIN:{
    $ENV{PATH} = '';
    usage() unless @ARGV;
    if (!getopts('46Ff:hnpt:v') || $opt_h || @ARGV < 1) {
	usage();
    }

    # Address families
    $rrs{A} = 1 if $opt_4 || !$opt_6;
    $rrs{AAAA} = 1 if $opt_6 || !$opt_4;

    # Table
    die("no table name specified\n")
	unless defined($opt_t);
    die("invalid table name\n")
	unless $opt_t =~ m/^(\w(?:[\w-]*\w)?)$/;
    $opt_t = $1;

    # Preserve implies no-flush
    $opt_F ||= $opt_p;

    # File
    if ($opt_f) {
	die("invalid file name\n")
	    unless $opt_f =~ m/^($RE{path}{pfcs})$/o;
	$opt_f = $1;
	$opt_f .= "/$opt_t"
	    if -d $opt_f;
    }

    srv2pf($opt_t, $opt_f, @ARGV);
}

__END__

=encoding utf8

=head1 NAME

B<srv2pf> - Create and update PF tables from DNS records

=head1 SYNOPSIS

B<srv2pf> [B<-46Fnpv>] [S<B<-f> I<file>>] S<B<-t> I<table>> S<I<name>[B<:>I<service>[B<:>I<transport>]]> [I<...>]

=head1 DESCRIPTION

The B<srv2pf> utility creates and updates PF address tables based on
DNS records.

For each name specified on the command line, the B<srv2pf> utility
performs a DNS lookup for I<SRV>, I<CNAME>, I<A> and I<AAAA> records.
The right-hand side of any I<SRV> and I<CNAME> records encountered are
resolved recursively.

If no errors occured during this process, a PF address table with the
name specified on the command line is either created or updated to
match the list of IP addresses that were found.  If the table already
exists, its contents are replaced with the list that was obtained from
DNS, unless the B<-p> option was specified, in which case the table is
treated as append-only.

The following options are available:

=over

=item B<-4>

Include IPv4 addresses in the table.  If neither B<-4> nor B<-6> is
specified, the default is to include both IPv4 and IPv6 addresses.

=item B<-6>

Include IPv6 addresses in the table.  If neither B<-4> nor B<-6> is
specified, the default is to include both IPv4 and IPv6 addresses.

=item B<-F>

Never flush a table.  If a DNS lookup does not return any results,
assume that something is wrong and terminate without updating the
table or file.

=item B<-f> I<file>

Save the addresses to a file in addition to updating the table.  If
I<file> is a directory, the addresses will be stored in a file bearing
the name of the table within that directory.  The file is written out
before the table is created or updated.  Failure to write the file
will generate an error message but will not prevent the table from
being created or updated.

=item B<-t> I<table>

The name of the table to be created or update.  This option is
mandatory.

=item B<-n>

Perform all LDAP and DNS lookups, but do not create or update any PF
tables or files.

=item B<-p>

Preserve existing table entries even if they are not encountered in
DNS lookups.  Implies B<-F>.

This does not apply to the file generated with the B<-f> option, which
will only contain the addresses retrieved from DNS.

=item B<-v>

Show progress and debugging information.

=back

Each subsequent argument is either a DNS name or IP address, or a
service specification consisting of at least two and at most three
items, separated by colons.  The first item is a DNS name.  The second
is a comma-separated list of service names, which defaults to
I<http,https>.  The third is a comma-separated list of transport
protocols, which defaults to I<tcp>.  At least one service
specification must be provided.

=head1 EXAMPLES

Update a table named I<ldap> used to allow traffic from the
organization's internal network to its LDAP servers:

    % grep -w ldap /etc/pf.conf
    table <ldap> persist
    pass in on int proto tcp from int:network to <ldap> port { ldap, ldaps }
    pass out on dmz proto tcp from int:network to <ldap> port { ldap, ldaps }
    % sudo srv2pf -pv -t ldap example.com:ldap:tcp
    # looking up SRV for _ldap._tcp.example.com
    # looking up dc01.example.com
    # dc01.example.com. 50339   IN      AAAA    2001:db8:0:42::dc1
    # dc01.example.com. 50339   IN      A       198.51.100.221
    # looking up dc02.example.com
    # dc02.example.com. 302     IN      AAAA    2001:db8:0:42::dc02
    # dc02.example.com. 128     IN      A       198.51.100.222
    # looking up example.com
    /sbin/pfctl -t ldap -T add 198.51.100.221 198.51.100.222 2001:db8:0:42::dc01 2001:db8:0:42::dc02
    No ALTQ support in kernel
    ALTQ related functions disabled
    4/4 addresses added.

=head1 SEE ALSO

L<pf(4)>, L<pfctl(8)>

=head1 AUTHOR

The B<srv2pf> utility was written by Dag-Erling Smørgrav <des@des.no>
for the University of Oslo.

=cut
