#!/usr/local/bin/perl -w
#-
# Copyright (c) 2013-2017 Universitetet i Oslo
# 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 <d.e.smorgrav@usit.uio.no>
#

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

use Authen::SASL qw(Perl);
use Getopt::Std;
use Net::DNS;
use Net::LDAP;
use Net::LDAP::Control::Paged;
use Net::LDAP::Constant qw(LDAP_CONTROL_PAGED);
use POSIX;
use Regexp::Common qw(pattern);
use Socket qw(AF_INET AF_INET6
    SOCK_DGRAM SOCK_STREAM
    getaddrinfo getnameinfo
    AI_CANONNAME NI_NUMERICHOST NI_NUMERICSERV);
use Try::Tiny;

our $VERSION = '20170424';

# 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_b;			# LDAP base
our $opt_d;			# LDAP domain
our $opt_F;			# Never flush
our $opt_f;			# Persistence directory
our $opt_h;			# Hostname
our $opt_n;			# Dry run
our $opt_P;			# Page size
our $opt_p;			# Preserve existing addresses
our $opt_s;			# LDAP server
our $opt_t;			# Table name
our $opt_u;			# LDAP user
our $opt_v;			# Verbose mode

our %rrs;

our $filedir;			# Persistence directory
our $host;			# Hostname
our $domain;			# DNS and LDAP domain
our $user;			# LDAP user
our @servers;			# LDAP servers
our $base;			# LDAP search base

our $sasl;			# SASL context
our $ldap;			# LDAP connection

#
# 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 . "'" : $_;
    } @_;
}

#
# Run an LDAP search and return the result as an array of lines.
#
sub ldap_search($;@) {
    my ($filter, @attrs) = @_;

    verbose("# Looking for $filter in $base");
    my $page = new Net::LDAP::Control::Paged(size => $opt_P || 250);
    my %records;
    while (1) {
	my $res = $ldap->search(base => $base,
				filter => $filter,
				attrs => @attrs ? \@attrs : undef,
				control => [ $page ]);
	if ($res->code()) {
	    die("failed to search LDAP directory: " . $res->error . "\n");
	}
	%records = (%records, %{$res->as_struct()});
	my $control = $res->control(LDAP_CONTROL_PAGED)
	    or last;
	my $cookie = $control->cookie
	    or last;
	verbose("# next page (", int(keys %records), ")");
	$page->cookie($cookie);
    }
    verbose("# last page (", int(keys %records), ")");
    return \%records;
}

#
# Look up a group by common name
#
sub ldap_lookup_group($;@) {
    my ($cn, @attrs) = @_;

    return ldap_search("(\&(objectclass=group)(name=$cn))", @attrs);
}

#
# Look up a specific object in the LDAP directory
#
sub ldap_lookup_dn($;@) {
    my ($dn, @attrs) = @_;

    my $res = ldap_search("(distinguishedname=$dn)", @attrs)
	or return undef;
    return $$res{$dn};
}

our %group_cache;

#
# Look up a group recursively in the LDAP directory and return a
# deduplicated list of the DNS names of its members.
#
sub ldap_resolve_group_r($$);
sub ldap_resolve_group_r($$) {
    my ($dn, $obj) = @_;
    my %hostnames;

    verbose("# resolving $dn");
    map({ $hostnames{$_} = 1 } @{$$obj{dnshostname}});
    foreach my $dn (@{$$obj{member}}) {
	my $obj = ldap_lookup_dn($dn, qw(objectclass member dnshostname))
	    or next;
	map({ $hostnames{$_} = 1 } ldap_resolve_group_r($dn, $obj));
    }
    return keys(%hostnames);
}

sub ldap_resolve_group($) {
    my ($group) = @_;

    # Look it up
    if (!$group_cache{$group}) {
	my $res = ldap_lookup_group($group, qw(member));
	while (my ($dn, $obj) = each %$res) {
	    map({ $group_cache{$group}->{lc($_)} = 1 }
		ldap_resolve_group_r($dn, $obj));
	}
    }
    return keys(%{$group_cache{$group}});
}



#
# This section was copied from srv2pf.pl and should probably go into a
# shared module.
#

our $resolver;
our %dns_cache;

#
# Recursively resolve CNAME, A and AAAA records for a given DNS name
#
sub dns_lookup($);
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);
		if ($res->type eq 'CNAME') {
		    map({ $answers{$_}++ } dns_lookup($res->cname));
		} elsif ($rrs{$res->type}) {
		    $answers{$res->address}++;
		}
	    }
	}
	$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;
    map({ $answers{$_->target}++ } $query->answer);
    return keys %answers;
}



#
# Look up all hosts in a list and return a deduplicated list of their
# addresses.
#
sub dns_lookup_hosts(@) {
    my (@members) = @_;

    my %addresses;
    map({ map({ ++$addresses{$_} } dns_lookup($_)) } @members);
    return keys(%addresses);
}

#
# Look up a group of hosts in the LDAP directory, resolve their
# addresses, and create or update matching PF tables.
#
sub ldap2pf($) {
    my ($group) = @_;

    # Perform LDAP and DNS lookup
    my @addresses = dns_lookup_hosts(ldap_resolve_group($group));
    @addresses = (sort(grep { /\./ } @addresses),
		  sort(grep { /:/ } @addresses));
    if ($opt_F && !@addresses) {
	verbose("# not flushing $group");
	return undef;
    }

    # Store addresses to file
    if ($filedir) {
	my $file = "$filedir/$group";
	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', $group, '-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: ldap2pf [-46Fnpv] [-b base] [-d domain] [-f path] [-h host]\n",
	  "           [-P page size] [-s servers] [-u user] group ...\n");
    exit(1);
}

#
# Main program - set defaults, validate and apply command-line
# arguments, then iterate over specified groups.
#
MAIN:{
    $ENV{PATH} = '';
    usage() unless @ARGV;
    if (!getopts('46b:d:Ff:h:nps:u:v') || @ARGV < 1) {
	usage();
    }

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

    # Filename
    if ($opt_f) {
	die("invalid file name\n")
	    unless $opt_f =~ m/^($RE{path}{pfcs})$/o;
	$filedir = $1;
	die("$filedir is not a directory\n")
	    unless -d $filedir;
    }

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

    # Hostname
    $host = $opt_h // [ POSIX::uname() ]->[1];
    die("invalid hostname: $host")
	unless $host =~ m/^($RE{net}{domain})$/o;
    $host = lc($1);
    verbose("# host: $host");

    # Domain
    if ($opt_d) {
	die("invalid domain: $domain\n")
	    unless $opt_d =~ m/^($RE{net}{domain})$/o;
	$domain = lc($1);
    } else {
        die("unable to derive domain from hostname\n")
            unless $host =~ m/^[^.]+\.($RE{net}{domain})$/o;
	$domain = $1;
    }
    verbose("# domain: $domain");

    # User
    $user = $opt_u // POSIX::getlogin();
    die("invalid user: $user\n")
	unless $user =~ m/^([\w-]+(?:\@$RE{net}{domain})?)$/o;
    $user = $1;
    $user = "$user\@$domain"
	unless $user =~ m/\@/;
    verbose("# user: $user");

    # LDAP servers
    if ($opt_s) {
	@servers = split(',', $opt_s);
    } else {
	@servers = srv_lookup($domain, 'ldap');
	die("unable to retrieve LDAP servers from DNS\n")
	    unless @servers;
    }
    foreach (@servers) {
	die("invalid server: $_\n")
	    unless m/^($RE{net}{domain})\.?$/o;
	$_ = $1;
    }
    verbose("# servers: ", join(' ', @servers));

    # Search base
    if ($opt_b) {
	die("invalid base: $opt_b\n")
	    unless $opt_b =~ m/^(DC=[0-9a-z-]+(?:,DC=[0-9a-z-]+)*)$/o;
	$base = $1;
    } else {
	$base = join(',', map({ "DC=$_" } split(/[.]/, $domain)));
    }
    verbose("# base: $base");

    # Connect to LDAP server
    foreach (@servers) {
	verbose("# Attempting to connect to $_");
	try {
	    $sasl = new Authen::SASL(mechanism => 'GSSAPI',
				     callback => {
					 user => $user,
					 password => '',
				     });
	    $sasl = $sasl->client_new('ldap', $_);
	    $ldap = new Net::LDAP($_, onerror => 'die')
		or die("$@\n");
	    $ldap->bind(sasl => $sasl);
	} catch {
	    verbose("# unable to connect to LDAP server: $_\n");
	    $ldap = undef;
	};
	last if $ldap;
    }
    die("failed to connect to an LDAP server\n")
	unless $ldap;

    # Process groups from command line
    foreach (@ARGV) {
	if (!m/^(\w(?:[\w-]*\w)?)$/) {
	    warn("invalid argument: $_\n");
	    next;
	}
	ldap2pf($1);
    }

    # Work around bug in Net::LDAP
    $SIG{__DIE__} = sub { exit 0 };
}

__END__

=encoding utf8

=head1 NAME

B<ldap2pf> - Create and update PF tables from LDAP groups

=head1 SYNOPSIS

B<ldap2pf> [B<-46Fnpv>] S<[B<-b> I<base>]> S<[B<-d> I<domain>]> S<[B<-f> I<path>]> S<[B<-h> I<host>]> S<[B<-P> I<page size>]> S<[B<-s> I<servers>]> S<[B<-u> I<user>[I<@domain>]]> I<group> I<...>

=head1 DESCRIPTION

The B<ldap2pf> utility creates and updates PF address tables based on
group memberships in an LDAP directory.

For each group name specified on the command line, the B<ldap2pf>
utility searches the LDAP directory for group objects bearing that
name.  It then resolves the membership of these groups recursively,
collects the I<DNSHostName> attributes of all member objects, and
looks up I<A> and / or I<AAAA> DNS records for these names.

If no errors occured during this process, a PF address table with the
same name as the LDAP group is either created or updated to match the
list of IP addresses that were discovered.  If the table already
exists, its contents are replaced with the list that was obtained from
the LDAP directory, 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<-b> I<base>

The search base for LDAP lookups.  The default is derived from the
LDAP domain.

=item B<-d> I<domain>

The LDAP domain.  The default is derived from the host name.

=item B<-F>

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

=item B<-f> I<path>

The path to a directory in which to store each table as a separate
file, named for the group it represents.  The default is to not store
the tables to disk.

=item B<-h> I<host>

The client's host name.  The default is whatever L<uname(3)> returns.

=item B<-n>

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

=item B<-P> I<page size>

The page size to use for LDAP requests.  The default is 250.

=item B<-p>

Preserve existing table entries even if they are no longer members of
the corresponding group.  Implies B<-F>.

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

=item B<-s> I<servers>

A comma-separated list of LDAP server names.  The default is to
perform an I<SRV> lookup.

=item B<-u> I<user>[I<@domain>]

The user name used to bind to the LDAP server, with or without domain
qualifier.  The default is the name of the current user.

=item B<-v>

Show progress and debugging information.

=back

=head1 IMPLEMENTATION NOTES

The B<ldap2pf> utility was designed for use with Microsoft Active
Directory servers, and assumes that the server supports and requires
GSSAPI authentication and that a valid Kerberos ticket is available.

=head1 EXAMPLES

Update a table named I<mx> used to allow traffic to and from the
organisation's mail servers:

    % grep -w mx /etc/pf.conf
    table <mx> persist
    pass in on egress proto tcp from any to <mx> port { smtp, smtps }
    pass out on dmz proto tcp from any to <mx> port { smtp, smtps }
    pass in on dmz proto tcp from <mx> to any port { smtp, smtps }
    pass out on egress proto tcp from <mx> to any port { smtp, smtps }
    pass in on int proto tcp from int:network to <mx> port { smtp, smtps }
    pass out on dmz proto tcp from int:network to <mx> port { smtp, smtps }
    % sudo env KRB5CCNAME=/var/db/ro_user.cc ldap2pf -pv -u ro_user mx
    # host: client.example.com
    # domain: example.com
    # user: ro_user@example.com
    # looking up SRV for _ldap._tcp.example.com
    # servers: dc01.example.com dc02.example.com
    # base: DC=example,DC=com
    # Attempting to connect to dc01.example.com
    # Looking for (&(objectclass=group)(name=mx)) in DC=example,DC=com
    # last page (1)
    # resolving CN=mx,OU=roles,OU=hostpolicies,DC=example,DC=com
    # Looking for (distinguishedname=CN=mx01,OU=hosts,DC=example,DC=com) in DC=example,DC=com
    # last page (1)
    # resolving CN=mx01,OU=hosts,DC=example,DC=com
    # Looking for (distinguishedname=CN=mx02,OU=hosts,DC=example,DC=com) in DC=example,DC=com
    # last page (1)
    # resolving CN=mx02,OU=hosts,DC=example,DC=com
    # looking up mx01.example.com
    # mx01.example.com.    3600    IN      AAAA    2001:db8:0:42::2501
    # mx01.example.com.    3600    IN      A       198.51.100.251
    # looking up mx02.example.com
    # mx02.example.com.    3600    IN      AAAA    2001:db8:0:42::2502
    # mx02.example.com.    3600    IN      A       198.51.100.252
    /sbin/pfctl -t mx -T add 198.51.100.251 198.51.100.252 2001:db8:0:42:0:0:0:2501 2001:db8:0:42:0:0:0:2502
    No ALTQ support in kernel
    ALTQ related functions disabled
    4/4 addresses added.

=head1 SEE ALSO

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

=head1 AUTHOR

The B<ldap2pf> utility was written by Dag-Erling Smørgrav
<d.e.smorgrav@usit.uio.no> for the University of Oslo.

=cut
