#!/usr/bin/perl

=head1 NAME

pfdhcplistener - listen to DHCP requests

=head1 SYNOPSIS

pfdhcplistener -i <interface> [options]

 Options:
   -d     Daemonize
   -h     Help

=cut

use warnings;
use strict;
use File::Basename qw(basename);
use Getopt::Std;
use Net::Pcap 0.16;
use Pod::Usage;
use POSIX qw(:signal_h pause :sys_wait_h SIG_BLOCK SIG_UNBLOCK);
use Fcntl qw(:flock);
use Systemd::Daemon qw{ -soft };

BEGIN {
    # log4perl init
    use constant INSTALL_DIR => '/usr/local/pf';
    use lib INSTALL_DIR . "/lib";
    use pf::log(service => 'pfdhcplistener');
}

use Try::Tiny;
use pf::util::dhcp;
use pf::constants;
use pf::constants::config qw( $NET_TYPE_INLINE_L2 $NET_TYPE_INLINE_L3 );
use pf::config qw(
    %Config
    @listen_ints
    @dhcplistener_ints
    $NO_VLAN
    %ConfigNetworks
    @inline_enforcement_nets
);
use pf::file_paths qw($var_dir);
use pf::util;
use pf::config::util;
use pf::services::util;
use pf::util::dhcp;
use pf::StatsD;
use List::MoreUtils qw(any uniq);
use NetAddr::IP;
use MIME::Base64();
use NetPacket::Ethernet qw(ETH_TYPE_IP ETH_TYPE_IPv6);
use NetPacket::IP;
use NetPacket::IPv6;
use NetPacket::UDP;
use pf::CHI::Request;
use pf::api::queue_cluster;
use pf::cluster;

# initialization
# --------------
# assign process name (see #1464)
our @REGISTERED_TASKS;
our $IS_CHILD = 0;
our $PARENT_PID;
our %CHILDREN;
our @TASKS_RUN;
our $ALARM_RECV = 0;
our $TIMEOUT = 1 * 1000; # 1 second or 1000 milliseconds
our $running = 1;

$SIG{HUP}  = \&reload_config;
$SIG{INT}  = \&normal_sighandler;
$SIG{TERM} = \&normal_sighandler;
$SIG{CHLD} = \&child_sighandler;
$SIG{ALRM} = \&alarm_sighandler;

$SIG{PIPE} = 'IGNORE';

my %args;
getopts( 'dh', \%args );

my $daemonize = $args{d};

pod2usage( -verbose => 1 ) if ( $args{h} );
our $PROGRAM_NAME = $0 = "pfdhcplistener";

my $logger = get_logger( $PROGRAM_NAME );

our %NET_TYPES_FOR_EXTERNAL_QUEUE = (
    'dhcp-listener' => 1,
    'management' => 1,
);


my $is_inline_vlan;
my $inline_sub_connection_type;
my $interface_ip;
my $interface_vlan;
my $pcap;
my $net_type;
my $process_broadcast;
my $interface;
my $send_queue = 'pfdhcplistener';

my $rate_limit_hash = {};
my $rate_limit_cache = CHI->new( driver => 'Memory', datastore => $rate_limit_hash );

sub reload_config {
    # reload the defaults every time
    $process_broadcast = $TRUE;

    # We do not process broadcast on the node which does not hold the VIP
    if ( $pf::cluster::cluster_enabled && ! pf::cluster::is_vip_running($interface) ) { 
        $process_broadcast = $FALSE;
    }
    $logger->info("Reload configuration on $interface");
}

my $pidfile = "${var_dir}/run/$PROGRAM_NAME.pid";

our $HAS_LOCK = 0;
open(my $fh, ">>$pidfile");
flock($fh, LOCK_EX | LOCK_NB) or die "cannot lock $pidfile another pfdhcplistener is running\n";
$HAS_LOCK = 1;


# standard signals and daemonize
daemonize($PROGRAM_NAME) if ($daemonize);

$PARENT_PID = $$;

my $net_addr;

# start dhcp monitor
if ( isenabled( $Config{'network'}{'dhcpdetector'} ) ) {
    Systemd::Daemon::notify( READY => 1, STATUS => "Ready", unset => 1 );
    start();
    cleanup();
}

END {
    if (!$args{h} && $HAS_LOCK) {
        unless ($IS_CHILD) {
            Systemd::Daemon::notify( STOPPING => 1 );
            deletepid();
            $logger->info("stopping pfdhcplistener");
        }
    }
}

exit(0);

=head1 SUBROUTINES

=over

=cut

=head2 setup_global

setup_global

=cut

sub setup_global {
    my ($int) = @_;
    $interface = $int;
    $net_type = $Config{"interface $interface"}{'type'};
    $interface_ip = $cluster_enabled ? pf::cluster::cluster_ip($interface) : $Config{"interface $interface"}{'ip'};
    $interface_vlan = get_vlan_from_int($interface) || $NO_VLAN;
    $send_queue = queue_for_net_type($net_type);
    $net_addr = NetAddr::IP->new($Config{"interface $interface"}{'ip'},$Config{"interface $interface"}{'mask'});

    if (grep( { $_->tag("int") eq $interface} @inline_enforcement_nets) != 0 ) {
        $logger->warn("DHCP detector on an inline interface");
        $is_inline_vlan = $TRUE;
    }
    $logger->info("DHCP detector on $interface enabled");
    return ;
}

=head2 queue_for_net_type

Determine which send queue

=cut

sub queue_for_net_type {
    my ($net_type) = @_;
    return (any { exists $NET_TYPES_FOR_EXTERNAL_QUEUE{$_} } expand_csv($net_type) ) ? 'pfdhcplistener_external' : 'pfdhcplistener' ;
}

=head2 setup_pcap

setup_pcap

=cut

sub setup_pcap {
    my ($interface) = @_;
    my $filter = make_pcap_filter(@{$Config{network}{dhcp_filter_by_message_types}});
    my $filter_t;
    my $net;
    my $mask;
    my $opt = 1;
    my $err;

    # updating process name so we know what interface we are listening on
    # WARNING: the format is expected by watchdog in pf::services. Don't change lightly.
    $PROGRAM_NAME = basename($PROGRAM_NAME) . ": listening on $interface";
    $pcap = Net::Pcap::pcap_open_live( $interface, $Config{services}{pfdhcplistener_packet_size}, 1, $TIMEOUT, \$err );

    if (!defined($pcap)) {
        $logger->logdie("Unable to initiate packet capture. Is $interface an actual network interface?");
    }
    $logger->trace("Using filter '$filter'");

    if ((Net::Pcap::compile( $pcap, \$filter_t, $filter, $opt, 0 )) == -1) {
        $logger->logdie("Unable to compile filter string '$filter'");
    }

    Net::Pcap::setfilter( $pcap, $filter_t );
    return $pcap;
}


sub process_pkt {
    my ( $user_data, $hdr, $pkt ) = @_;
        eval {
            my $l2 = NetPacket::Ethernet->decode($pkt);

            if ( ! $process_broadcast ) { 
                if ( $l2->{'dest_mac'} eq 'ffffffffffff' ) { 
                    $logger->trace("Skipping broadcast request.");
                    return;
                } 
            }       
            # Skip frames that has a VLAN tag to avoid processing frames more than
            # once when pfdhcplistener listens on both a vlan interface and its parent
            #
            # On post-2008 kernels, with network devices supporting VLAN acceleration
            # (HW tagging/stripping), ethernet frames always appear untagged to libpcap.
            # The library reconstructs the original frame by looking at the PACKET_AUXDATA
            # (pcap-linux.c: pcap_read_packet) *after* the frame has passed the bpf filters.
            # In other words, we cannot use bpf filters to ignore VLAN packets.
            #
            # Also, NetPacket::Ethernet::decode will skip the VLAN header from
            # a tagged frame and return the 'inner' ether_type of the frame.
            #
            # For this reason we check to see if $l2->{tpid} is set
            if ( defined $l2->{tpid} && $net_type ne "monitor" ) {
                $logger->trace("Skipping VLAN packets since it is probably addressed to another interface (offload decapsulated tagged packet).");
                return;
            }

            # Skip frames that aren't ETH_TYPE_IP/ETH_TYPE_IPv6
            if ( ($l2->{type} ne ETH_TYPE_IP) && ($l2->{type} ne ETH_TYPE_IPv6) ) {
                $logger->trace("Skipping non ETH_TYPE_IP (IPv4) / ETH_TYPE_IPv6 (IPv6) packet");
                return;
            }

            my $l3 = $l2->{type} eq ETH_TYPE_IP ? NetPacket::IP->decode($l2->{'data'}) : NetPacket::IPv6->decode($l2->{'data'});
            my $l4 = NetPacket::UDP->decode($l3->{'data'});
            my %args = (
                src_mac => clean_mac($l2->{'src_mac'}),
                dest_mac => clean_mac($l2->{'dest_mac'}),
                src_ip => $l3->{'src_ip'},
                dest_ip => $l3->{'dest_ip'},
                is_inline_vlan => $is_inline_vlan,
                interface => $interface,
                interface_ip => $interface_ip,
                interface_vlan => $interface_vlan,
                net_type => $net_type,
                inline_sub_connection_type => $inline_sub_connection_type,
            );

            my $statsd_interface = $interface;
            $statsd_interface =~ s/\./_/g;
            $pf::StatsD::statsd->increment("pfdhcplistener_$statsd_interface\::process_pkt_total.count" );

            # IPv4 processing
            if ( $l2->{type} eq ETH_TYPE_IP ) {
                $pf::StatsD::statsd->increment("pfdhcplistener_$statsd_interface\::process_pkt_ipv4.count" );
                my ($dhcp);

                # we need success flag here because we can't next inside try catch
                my $success;
                try {
                    $dhcp = decode_dhcp($l4->{'data'});
                    $success = 1;
                } catch {
                    $logger->warn("Unable to parse DHCP packet: $_");
                };
                return if (!$success);
                $args{dhcp} = $dhcp;
                
                my $dhcp_mac = clean_mac( substr( $dhcp->{'chaddr'}, 0, 12 ) );
                if ( $dhcp_mac ne "00:00:00:00:00:00" && !valid_mac($dhcp_mac) ) {
                    $logger->debug( sub {
                        "invalid CHADDR value ($dhcp_mac) in DHCP packet from $dhcp->{src_mac} ($dhcp->{src_ip})"
                    });
                    return;
                }
                
                # don't process a packet for which we don't have a MAC address
                unless($dhcp_mac) {
                    $logger->debug("chaddr is undefined in DHCP packet");
                    return;
                }


                # adding to dhcp hashref some frame information we care about
                $dhcp->{'src_mac'} = $args{'src_mac'};
                $dhcp->{'dest_mac'} = $args{'dest_mac'};
                $dhcp->{'src_ip'} = $args{'src_ip'};
                $dhcp->{'dest_ip'} = $args{'dest_ip'};
                $dhcp->{'chaddr'} = $dhcp_mac;

                if (!valid_mac($dhcp->{'src_mac'})) {
                    $logger->debug("Source MAC is invalid. skipping");
                    return;
                }


                if ($is_inline_vlan) {
                    my $ip = new NetAddr::IP::Lite clean_ip($l3->{'src_ip'});
                    if ($net_addr->contains($ip) || ($ip->addr eq '0.0.0.0')) {
                        $args{inline_sub_connection_type} = $NET_TYPE_INLINE_L2;
                    } else {
                        $args{inline_sub_connection_type} = $NET_TYPE_INLINE_L3;
                   }
                }

                # If its a DHCPREQUEST, we take the IP address from the option
                my $dhcp_ip;
                if ( $dhcp->{'op'} == 1 && $dhcp->{'options'}{'53'} == 3 && defined($dhcp->{'options'}{'50'}) ) {
                    $dhcp_ip = $dhcp->{'options'}{'50'};
                } elsif ( defined($dhcp->{yiaddr}) && $dhcp->{yiaddr} ne "0.0.0.0") {
                    $dhcp_ip = $dhcp->{yiaddr};
                } else {
                    $dhcp_ip = $dhcp->{ciaddr};
                }
                my $rate_limit_key;
                if(defined($dhcp_ip)) {
                    # Key is with BOOT type, DHCP type, IP and MAC
                    $rate_limit_key = $dhcp->{'op'} . "-" . $dhcp->{'options'}{'53'} . "-$dhcp_ip-" . $dhcp_mac;
                    $logger->trace("Rate limit key : $rate_limit_key");
                }

                my $rate_limiting = $Config{network}->{dhcp_rate_limiting};
                # We send the packet to be processed if:
                #  - there is no rate limit key (packet doesn't contain info to be rate-limited)
                #  - there is no rate limiting configured
                #  - there is no cache entry (packet wasn't seen in the last $rate_limiting seconds)
                if(!defined($rate_limit_key) || $rate_limiting == 0 || !$rate_limit_cache->get($rate_limit_key)) {
                    my $apiclient = api_client();
                    $apiclient->notify('process_dhcpv4', %args);
                    if(defined($rate_limit_key) && $rate_limiting != 0) {
                        $rate_limit_cache->set($rate_limit_key, 1, $rate_limiting);
                    }
                }
                else {
                    $logger->debug("[$dhcp_mac] Ignoring packet due to rate-limiting ($rate_limit_key)");
                }
            }

            # IPv6 processing
            elsif ( $l2->{type} eq ETH_TYPE_IPv6 && isenabled($Config{network}{dhcp_process_ipv6})) {
                $pf::StatsD::statsd->increment("pfdhcplistener_$statsd_interface\::process_pkt_ipv6.count" );

                # TODO: Rate-limiting for IPv6 just as for IPv4

                my $apiclient = api_client();
                $apiclient->notify('process_dhcpv6', MIME::Base64::encode($l4->{data}));
            }

            # Non IPv4 nor IPv6 packet
            else {
                $logger->debug("Skipping non IPv4 nor IPv6 DHCP packet from MAC address '$args{'src_mac'}' (IP: '$args{'src_ip'}') for IP '$args{'dest_ip'}'");
                return; 
            }
        };

        if($@) {
            $logger->error("Error processing packet: $@");
        }
    
    #reload all cached configs after each iteration
    pf::CHI::Request::clear_all();
    #Only perform stats when in debug mode
    $logger->debug( sub {
        my $pcap = $user_data->[1];
        my %stats;
        Net::Pcap::pcap_stats($pcap,\%stats);
        return join(' ','pcap_stats',map { "$_ = $stats{$_}"  } keys %stats);
    });
}

=head2 api_client

get the api client

=cut

sub api_client {
    return pf::api::queue_cluster->new(
        queue => $send_queue,
        jsonrpc_args => {
            connect_timeout_ms => 500,
            timeout_ms => 500,
        }
    );
}

sub normal_sighandler {
    $running = 0;
    if ($pcap) {
        Net::Pcap::pcap_breakloop($pcap);
    }
    $logger->trace( "pfdhcplistener: caught SIG" . $_[0] . " - terminating" );
}

=head2 runtasks

run all runtasks

=cut

sub runtasks {
    my $mask = POSIX::SigSet->new(POSIX::SIGCHLD());
    sigprocmask(SIG_BLOCK, $mask);
    while (@REGISTERED_TASKS) {
        my $task = shift @REGISTERED_TASKS;
        runtask($task);
    }
    sigprocmask(SIG_UNBLOCK, $mask);
}

=head2 runtask

creates a new child to run a task

=cut

sub runtask {
    my ($task) = @_;
    my $pid = fork();
    if ($pid) {
        $CHILDREN{$pid} = $task;
    }
    elsif ($pid == 0) {
        $SIG{CHLD} = 'DEFAULT';
        $IS_CHILD = 1;
        Log::Log4perl::MDC->put('tid', $$);
        setup_global($task);
        reload_config();
        _runtask($interface);
    }
}

=head2 _runtask

the task to is ran in a loop until it is finished

=cut

sub _runtask {
    my ($interface) = @_;
    $0 = "$0 - $interface";
    setup_pcap($interface);
    while (is_running()) {
        my $result = Net::Pcap::dispatch( $pcap, -1, \&process_pkt, [ $interface , $pcap ] );
        if ($result == -1) {
            $logger->error(Net::Pcap::pcap_geterr($pcap));
            last;
        }
    }
    exit;
}

=head2 is_running

is_running

=cut

sub is_running {
    return $running && is_parent_alive();
}

=head2 is_parent_alive

Checks to see if parent is alive

=cut

sub is_parent_alive {
    kill(0, $PARENT_PID);
}

=head2 register_task

registers the task to run

=cut

sub register_task {
    my ($taskId) = @_;
    push @REGISTERED_TASKS, $taskId;

}

=head2 waitforit

waits for signals

=cut

sub waitforit {
    while ($running) {
        #  Only pause if their are no registered tasks
        pause unless @REGISTERED_TASKS;
        runtasks();
    }
}

=head2 alarm_sighandler

the alarm signal handler

=cut

sub alarm_sighandler {
    $ALARM_RECV = 1;
}

=head2 child_sighandler

reaps the children

=cut

sub child_sighandler {
    local ($!, $?);
    while (1) {
        my $child = waitpid(-1, WNOHANG);
        last unless $child > 0;
        my $task = delete $CHILDREN{$child};
        register_task($task);
    }
}

=head2 registertasks

    Register all tasks

=cut

sub registertasks {
    for my $task (get_tasks()) {
        register_task($task);
    }
}

=head2 get_tasks

get_tasks

=cut

sub get_tasks {
    return uniq ( @listen_ints, @dhcplistener_ints);
}

=head2 start

start

=cut

sub start {
    registertasks();
    runtasks();
    waitforit();
}

=head2 cleanup

cleans after children

=cut

sub cleanup {
    kill_and_wait_for_children('INT',  30);
    signal_children('KILL');
}

=head2 kill_and_wait_for_children

signal children and waits for them to exit process

=cut

sub kill_and_wait_for_children {
    my ($signal, $waittime) = @_;
    signal_children($signal);
    $ALARM_RECV = 0;
    alarm $waittime;
    while (((keys %CHILDREN) != 0) && !$ALARM_RECV) {
        pause;
    }
}

=head2 signal_children

sends a signal to all active children

=cut

sub signal_children {
    my ($signal) = @_;
    kill($signal, keys %CHILDREN);
}


=back

=head1 BUGS AND LIMITATIONS

Probably

=head1 AUTHOR

Inverse inc. <info@inverse.ca>

Minor parts of this file may have been contributed. See CREDITS.

=head1 COPYRIGHT

Copyright (C) 2005-2020 Inverse inc.

Copyright (C) 2005 Kevin Amorin

Copyright (C) 2005 David LaPorte

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.

=cut

