#!/usr/bin/perl
#
# Copyright 2005, 2006 by Marco d'Itri <md@linux.it>
#
# 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.

use warnings;
use strict;

use YAML;
use Net::IP;
use Template;
use Storable qw(dclone);
use FindBin;

use lib "$FindBin::RealBin/lib";
use RPSLToolUtils;
use RPSLToolWhois;
use RPSLToolNet;
use RPSLToolTemplate;

##############################################################################
# These parameters can be set in YAML files.

my %default_parameters = (
	whois_server		=> 'whois.ripe.net',
	cache_root			=> '/tmp/rpsltool',
	whois_die_on_error	=> 0,
	whois_warn_on_error	=> 1,
	whois_show_cache_misses	=> 0,
);

##############################################################################
usage(1) if not $ARGV[0];

my $input = read_file($ARGV[0]);

my ($param, $variables, $peers_config);
if (is_yaml($input)) {
	($param, $variables, $peers_config) = Load(join("\n", @$input));
	die if not defined $param;
	%$param = (%default_parameters, %$param);

	die "No template has been configured.\n" if not $param->{template};
	$input = read_file($param->{template});
} else {
	$param = dclone(\%default_parameters);
}

make_boolean($param, qw(whois_die_on_error whois_warn_on_error
	whois_warn_on_recursive_error));

##############################################################################
my $peers = process_peers_config($peers_config, $param);

# open the connection to the whois server and configure the default parameters
my $whois = whois_factory($param);

do_rpsl($whois, $peers);

print_template($input, {
	param	=> $param,
	var		=> $variables,
	conf	=> $peers,
}, $whois);
exit 0;

##############################################################################
# Performs RPSL expansion.
sub do_rpsl {
	my ($whois, $peers) = @_;

	foreach my $ip (keys %$peers) {
		foreach my $afi qw(ipv4 ipv6 ipv4m ipv6m) {
			my $neigh = $peers->{$ip}->{$afi} || next;
			my $ipv6 = $afi =~ /^ipv6/;

			next if not ($neigh->{import} and @{$neigh->{import}});
			my ($routes, $aspathlist) = $whois->import($neigh->{import},
				$ipv6, $neigh->{default_aspath_filter});

			# remove unwanted routes or route-sets from the final list
			# @unimport is a list of RPSL-style network filters
			my @unimport;
			foreach my $r ($neigh->{unimport}, $neigh->{global_unimport},
					$peers->{$ip}->{global_unimport}) {
				next if not ($r and @$r);
				@unimport = @{ ($whois->import($r, $ipv6))[0] };
			}
			@$routes = @{ filter_networks($routes, \@unimport, 1) }
				if @unimport;
			# for some reason which I forgot, @routes must be cloned here
			# uniq_list does it anyway
			# $neigh->{import_routes} = [ @routes ] if @routes;

			# finally store the filters
			if (@$routes) {
				$neigh->{import_routes} = uniq_list($routes);
			}
			if (@$aspathlist) {
				# replace each ASN32 with AS_TRANS unless requested
				my @aslist = map { s/^AS//; $_; } @$aspathlist;
				@aslist = map { $_ > 65536 ? '23456' : $_ } @aslist
					if not $neigh->{asn32_supported};
				$neigh->{import_as} = uniq_list(\@aslist);
				$neigh->{aslistnum} = $neigh->{aslist}
					or die "No aslist attribute set for $ip $afi\n";
			}
		} # foreach $afi

		if (my $backup_ip = $peers->{$ip}->{backupip}) {
			$peers->{$backup_ip} = create_backup($peers->{$ip});
		}

	}
}

sub create_backup {
	my ($mainneigh) = @_;

	my $newneigh = dclone($mainneigh);
	$newneigh->{ip} = $mainneigh->{backupip};
	$newneigh->{is_backup} = 1;	# this variable is checked in the template

	# delete the elements which trigger lists generation in the template
	delete $newneigh->{$_} foreach qw(import_as import_routes backupip);
	foreach my $afi qw(ipv4 ipv6 ipv4m ipv6m) {
		my $neigh = $newneigh->{$afi} || next;

		delete $neigh->{$_} foreach qw(import_as import_routes);
	}

	return $newneigh;
}

##############################################################################
sub print_template {
	my ($input, $vars, $whois) = @_;

	$Template::Config::STASH = 'Template::Stash::XS';
	my $template = Template->new({
		POST_CHOMP => 1,
		DEBUG_UNDEF => 1,
#		DEBUG => 'parser, provider',
	}) or early_error("Template->new: $Template::ERROR");

	$template->create_vmethods;
	$template->create_net_vmethods;
	$template->create_whois_vmethods($whois);

	$input = join("\n", grep(!/^#/, @$input));

	my $output;
	$template->process(\$input, $vars, \$output) or die $template->error;

	# remove leading empty lines
	$output =~ s/^\n+//m;
	print $output;
}

##############################################################################
sub Template::create_vmethods {
	my ($template) = @_;

	my $context = $template->context;

$context->define_vmethod('scalar', 'route2cisco' => \&route2cisco);
$context->define_vmethod('scalar', 'route2acl'   => \&route2acl);
$context->define_vmethod('scalar', 'route2stdacl' => \&route2stdacl);

$context->define_vmethod('list', 'hostroutes' => sub {
    map {
		my $route = $_;
		$route =~ s/\^.+$// if /\^/;
		$route . '^' . (/:/ ? 128 : 32);
	} @{$_[0]};
});

}

##############################################################################
# converts a prefix with an optional RPSL-like length filter to an IOS
# prefix-list entry
sub route2cisco {
	my ($prefix, $len, $range) = $_[0] =~ m!
		^([0-9\.:a-fA-F]+)		# prefix
		/([0-9]+)				# length
		(?:\^ ([0-9\+\-]+) )?	# optional range
		$
	!ox;

	my $s;
	if (not $prefix or not $len) {
		die "Cannot parse this prefix: '$_'\n";
	} elsif (not $range) {
		$s .= "$prefix/$len";
	} elsif ($range eq '-') {
		$s .= "$prefix/$len gt $range";
	} elsif ($range eq '+') {
		$s .= "$prefix/$len ge $range";
	} elsif ($range =~ /^[0-9]+$/) {
		$s .= "$prefix/$len le $range";
	} elsif ($range =~ /^([0-9]+)\-([0-9]+)$/) {
		$s .= "$prefix/$len ge $1 le $2";
	} else {
		die "Cannot parse this prefix: '$_'\n";
	}

	return $s
}

# converts a prefix with an optional RPSL-like length filter to
# a network/netmask pair separated by a space
sub route2acl {
	my ($prefix, $len) = $_[0] =~ m!
		^([0-9\.:a-fA-F]+)		# prefix
		/([0-9]+)				# length
		(?:\^ [0-9\+\-]+ )?		# ignored range
		$
	!ox;

	$len = 32 if $len > 32 or $len < 0;
	my $bits = '1' x $len . '0' x (32 - $len);
	return $prefix . ' ' . join('.', unpack('CCCC', pack('B*', $bits)));
}

# same thing for network/wildcard pairs
sub route2stdacl {
	my ($prefix, $len) = $_[0] =~ m!
		^([0-9\.:a-fA-F]+)		# prefix
		/([0-9]+)				# length
		(?:\^ [0-9\+\-]+ )?		# ignored range
		$
	!ox;

	$len = 32 if $len > 32 or $len < 0;
	my $bits = '0' x $len . '1' x (32 - $len);
	return $prefix . ' ' . join('.', unpack('CCCC', pack('B*', $bits)));
}

sub usage {
	print STDERR <<END;
Usage: rpsltool CONFIG-FILE
       rpsltool TEMPLATE-FILE
END
	exit(shift);
}

