### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# X-BONE
#
# http://www.isi.edu/xbone
# USC Information Sciences Institute (USC/ISI)
# Marina del Rey, California 90292, USA
# Copyright (c) 1998-2005
#
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute. The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
# $RCSfile: XB_Tunnel.pm,v $
#
# $Revision: 1.76 $
# $Author: pingali $
# $Date: 2005/04/21 00:21:23 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert
package XB_Tunnel;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(up down init);
use strict;
use sigtrap;
use Net::IP::XB_IP;
use FindBin;
use XB_Params;
use XB_Route;
use XB_Log;
use XB_Utils;
use Net::IP;
###############################################################################
# UTILITY FUNCTIONS
###############################################################################
# Used by: ALL
# Description:
# Configures the given route
# Arguments:
# @args -- ifconfig command + overlay-specific info
# Returns:
# 1 if successful
# 0 if not
# Exceptions:
# "exec_command" on error, nothing to clean up by caller
sub exec_command(@) {
my (@args) = @_;
my $proc = "exec_command";
XB_Log::log "info" => "-> $proc @args";
eval {
my $rc = 0xff & system (@args);
$rc == 0 or
XB_Log::log "err" => "Configuration of host has failed. Unable ".
"create tunnel interfaces. The command is ".
"@args failed with $?" and die "ifconfig";
};
XB_Log::log "info" => "<- $proc $@";
return 1 unless $@;
XB_Log::log "err" => "$proc: caught error: $@";
die "$proc"
} # sub exec_command(@);
# Description:
# Try to demand-create new interface (for Linux only ) of type $type.
# Arguments:
# $type interface type to create a new instance of
# Returns:
# 1 on success
# undef on failure to create (but no critical error)
# Exceptions:
# "XB_Tunnel::add" on error, nothing to clean up by caller
sub add ($) {
my $if_type = shift;
my $created = undef;
# print trace line
XB_Log::log "info", "-> XB_Tunnel::add $if_type";
eval {
if($if_type eq "tunl") {
# load the module always
if (1) {
# only install ipip if not there yet
my $pipe = "lsmod |";
# pipe to lsmod
open PIPE, $pipe or XB_Log::log "err", "cannot open pipe $pipe: $!"
and die "open";
# see if ipip module already there
my $found = 0;
while(<PIPE>)
{
if(/ipip/)
{
$found = 1;
XB_Log::log "debug3", "ipip module already installed";
last;
}
}
# done with pipe
close PIPE or XB_Log::log "err", "cannot close pipe $pipe: $!"
and die "close";
# if we didn't find it, load ipip
unless($found) {
# no ipip loaded yet, load it
my @cmd = ("modprobe", "ipip");
XB_Log::log "debug3", "@cmd";
my $rc = 0xff & system(@cmd);
($rc == 0) or
XB_Log::log "err",
"Unable to prepare the host for creating tunnels. Command:\n@cmd failed: $!"
and die "insmod";
}
}
# add a new tunnel (arbitrarily assign remote and local to make it
# P-to-P; change them later)
# remote and local ADDR is physical addr
my @cmd = ("ip", "tunnel", "add", "mode", "ipip", "remote",
"192.168.0.1", "local", "192.168.0.1", "ttl", "30");
XB_Log::log "debug3", "Command:\n@cmd";
my $rc = 0xff & system(@cmd);
($rc == 0) or
XB_Log::log "err",
"Unable to create tunnel at end point. @cmd failed: $!"
and die "ip";
# check if the new tunnel created sucessfully
my @new_ifs = if_list (0);
my $new_if = shift @new_ifs;
if($new_if){
my $pipe = "ip tunnel show $new_if |";
open NPIPE, $pipe or
XB_Log::log "err",
"Unable to verify whether the tunnel was created. ".
"Error! cannot open pipe $pipe: $!"
and die "open";
while(<NPIPE>){ if (/$new_if/) { $created = 1; } }
close NPIPE or
XB_Log::log "err", "Error while cleaning up after ".
"creating tunnel endpoints. cannot close pipe ".
"$pipe: $!"
and die "close";
}
unless ($created == 1){
XB_Log::log "err", "Unable to create a tunnel at host.";
die "ip";
}
}
};
#print trace line
XB_Log::log "info", "<- XB_Tunnel::add $if_type";
return $created unless $@; #success if no exception
# exception handling
unless($@ =~ /^(open|close|insmod|ip|)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Tunnel::add: caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "XB_Tunnel::add";
}
# Description:
# Return a list of used or unused interfaces.
# Arguments:
# $which 1 to return used ( = configured or up), 0 to look for
# unused, -1 for all
# Returns:
# array of interace names
# Exceptions:
# "XB_Tunnel::if_list" on error, nothing to clean up by caller
#
sub if_list ($) {
my $which = shift;
my @ifs;
my $if="";
my $configured = undef;
my $pipe;
# print trace line
XB_Log::log "info", "-> XB_Tunnel::if_list $which";
eval{
if ($XB_Params::node_opts{os} =~ /linux/i) {
# Linux OS
$pipe = "ifconfig -a |";
# look at ifconfig output
open PIPE, $pipe or
XB_Log::log "err", "Unable to obtain network interface ".
"information while creation/deletion of tunnels. ".
"Cannnot open pipe $pipe: $!"
and die "open";
while(<PIPE>) {
# if a new interface follows in the next lines
if(/^(\w+\d+(:\d+)?)\s+/) {
my $new_if = $1;
# remember previous interface (it's one we're looking for)
if($if and $configured == $which and ($if !~ /eth\d+/) and
# on Linux, tunl0 cannot be made pointopoint, so skip it
($if ne "tunl0") and ($if ne "sit0") and ($if !~ /ip6tnl\d+/)) {
push @ifs, $if;
}
# reset state for scanning the next interface
$configured = 0;
$if = $new_if;
}
elsif(/\s+inet\s(addr:)?
(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})/x) {
# if current interface has an inet address, mark configured
if($2 or $3 or $4 or $5) { $configured = 1; }
}
}
if ($if and $configured == $which and $if ne "tunl0" and
$if ne "sit0" and ($if !~ /ip6tnl\d+/)) {push @ifs, $if;}
close PIPE or
XB_Log::log "err", "Unable to cleanup after creating tunnel. ".
"Cannot close pipe $pipe: $!"
and die "close";
XB_Log::log "debug", "ifs = @ifs";
}
elsif ($XB_Params::node_opts{os} =~ /cisco/i) {
# Cisco IOS way of doing it
my $tunnel;
my @cmd = ("show running-config | include (interface | ip address)");
my @output = XB_CiscoSSH::show_cmd @cmd;
my @result = split "\n", $output[0];
while(@result) {
my $res = shift @result;
if ($res =~ /(Tunnel\d+)/) {
my $res2 = shift @result;
$tunnel = $1;
if ($which == -1) {
push @ifs, $tunnel;
} elsif ($which == 1 and $res2 =~ /\d+/ ) {
push @ifs, $tunnel;
} elsif ($which == 0 and $res2 =~ /no\s+ip\s+address/) {
push @ifs, $tunnel;
}
}
}
}
else {
# Default (FreeBSD)
# translate $which into ifconfig parameter
if ($which == 1) { $which = "-lu"; }
elsif ($which == 0) { $which = "-ld"; }
elsif ($which == -1) { $which = "-l"; }
else { die "which"; }
# look at ifconfig output
my $pipe = "ifconfig $which |";
XB_Log::log "debug3", "open pipe $pipe";
open PIPE, $pipe or
XB_Log::log "err", "Unable to obtain the network interface information. ".
"Cannnot open pipe $pipe: $!"
and die "open";
# get results
my $if = <PIPE>;
if (defined $if){
chomp $if;
XB_Log::log "debug3", $if;
} else {
$if = "";
}
# done with pipe
close PIPE or
XB_Log::log "err", "Unable to cleanup after creating tunnel end point. ".
"cannot close pipe $pipe: $!"
and die "close";
XB_Log::log "debug3", "close pipe $pipe";
@ifs = split " ", $if;
}
};
# print trace line
XB_Log::log "info", "<- XB_Tunnel::if_list $which";
return @ifs unless $@; # success if no exception
# exception handling
unless($@ =~ /^(open|close|XB_CiscoSSH::show_cmd)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Tunnel::if_list: caught unexpected " .
"exception $@";
}
# pass defined exceptions up to caller
die "XB_Tunnel::if_list";
}
# Description:
# Return a list of used or unused interfaces of a certain type.
# Tries to create a new interface dynamically if none is available.
# Arguments:
# $type type of interface to check for
# Returns:
# array of interace names
# Exceptions:
# "XB_Tunnel::grab" on error, nothing to clean up by caller
#
sub grab ($) {
my $type = shift;
# print trace line
XB_Log::log "info", "-> XB_Tunnel::grab $type";
my @ifs;
eval {
if ($XB_Params::node_opts{os} =~ /linux/i) {
# Linux OS
# get a list of used (up) or unused (down) interfaces
# process output and remove interfaces of types we don't want
@ifs = grep /$type\d+/, if_list 0;
# get rid of unused interface with active alias (for linux tunl)
# get a list of active interfaces & aliases of the given type
my @used_ifs = grep /$type\d+/, if_list 1;
my @new_list;
foreach my $i (@ifs){
my @dup = grep /$i:\d+/, @used_ifs;
if((not defined $dup[0]) || ($dup[0] eq "")){
# no aliases found, save to use it
push @new_list, $i;
}
}
@ifs = @new_list;
if($#ifs == -1) {
# if we're looking for an unused interface, try creating one if we could
# not find one
add $type;
@ifs = grep /^$type\d+/, if_list 0;
}
}
elsif ($XB_Params::node_opts{ os} =~ /cisco/i) {
my @used_ifs = if_list (1);
my $last_used_if = pop @used_ifs;
my $number;
if (defined ($last_used_if) and ($last_used_if =~ /^\D+(\d+)/))
{ $number = $1 + "1"; }
else { $number = "0"; }
my $new_if = "Tunnel" . "$number";
if($new_if){
my @cmd = ("interface $new_if \n exit \n exit \n");
my $created = XB_CiscoSSH::cmd @cmd;
push @ifs, $new_if;
}
}
else {
# Default OS (FreeBSD)
# get a list of used (up) or unused (down) interfaces
# process output and remove interfaces of types we don't want
@ifs = grep /^$type\d+/, if_list 0;
if($#ifs == -1) {
# if we're looking for an unused interface, try creating one if we could
# not find one
my $pipe = "ifconfig $type create |";
XB_Log::log "debug3", "open pipe $pipe";
open PIPE, $pipe or
XB_Log::log "err",
"Unable to create tunnel end point. ".
"Cannnot open pipe $pipe: $!"
and die "open";
# get results
my $if = <PIPE>;
chomp $if;
push @ifs, $if;
XB_Log::log "debug3", $if;
# done with pipe
close PIPE or
XB_Log::log "err",
"Unable to cleanup after configuring the tunnels. ".
"Cannot close pipe $pipe: $!"
and die "close";
XB_Log::log "debug3", "close pipe $pipe";
}
}
};
# print trace line
XB_Log::log "info", "<- XB_Tunnel::grab $type";
return @ifs unless $@; # success if no exception
# exception handling
unless($@ =~ /^(open|close|XB_Tunnel::if_list|XB_Tunnel::add
|XB_CiscoSSH::cmd)/) {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Tunnel::grab: caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "XB_Tunnel::grab";
}
# Description:
# Check if a configured interface with the same outer (local, remote)
# address pair as ($l, $r) exists
# Arguments:
# $type type of interface to check for
# $l local address
# $r remote address
# Returns:
# tunnel interface handle of the matched gif interface; or
# undef if none matched
# Exceptions:
# "XB_Tunnel::find_outer" on error, nothing to clean up by caller
#
sub find_outer ($$$) {
my ($type, $l, $r) = @_;
my $result = undef;
# print trace line
XB_Log::log "info", "-> XB_Tunnel::find_outer $l, $r";
eval {
if ($XB_Params::node_opts{os} =~ /linux/i) {
# Linux OS
my $match = undef;
my $m = "remote";
my $o = "local";
my @uuifs;
my @uifs;
my $pipe = "ip tunnel show |";
# open a pipe to get the outer addresses of existing tunnels
open LPIPE, $pipe or
XB_Log::log "err",
"Unable to obtain tunnel interface information. ".
"Cannot open pipe $pipe: $!"
and die "open";
# look for assigned "physical" ("outer is more appropriate) addresses
while (<LPIPE>) {
if(/^(\D+\d+):\s+ip\/ip\s+$m\s+((\d+\.){3}\d+)\s+$o\s+((\d+\.){3}\d+)/){
if(($4 eq $l) && ($2 eq $r)){
$match = $1;
last;
}
}
}
close LPIPE or
XB_Log::log "err", "Unable to cleanup after obtaining interface ".
"status information. cannot close pipe $pipe: $!"
and die "close";
# do the following only if we found a match (tunlx)
if(defined $match){
# search the unused ones since the primary interface tunlx might be here
@uuifs = grep /^$match$/, if_list 0;
# search the used ones to determine the first available alais tunlx:y
@uifs = grep /^$match(:\d+)?$/, if_list 1;
# determine the first available alias name
if(defined $uuifs[0]) {
$result = $uuifs[0];
}else{
my $alias_no = 0;
foreach my $i (@uifs){
if($i =~ /$match:(\d+)/){
if($1 == $alias_no){
$alias_no++;
}else{
$result = $match.":$alias_no";
last;
}
}
}
if(! defined $result) { $result = $match.":$alias_no"; }
}
}
}
elsif ($XB_Params::node_opts{ os} =~ /cisco/i) {
my @ifs = grep {/^$type\d+/} if_list -1;
my $ln = new Net::IP ($l);
my $rn = new Net::IP ($r);
foreach my $if (@ifs) {
my ($lv, $rv);
my @cmd = ("show interface $if");
my @output = XB_CiscoSSH::show_cmd @cmd;
@output = split "\n", $output[0];
foreach my $each (0..($#output-1)) {
my $line = shift @output;
if ($line =~ /\s*Tunnel\s+source\s+((\d{1,3}\.){3}\d{1,3}),\s+destination\s+((\d{1,3}\.){3}\d{1,3})/g){
$lv = $1; $rv = $3;
}
}
my $n1 = new Net::IP($lv);
my $n2 = new Net::IP($rv);
next if (not (defined $n1 and defined $n2));
if (($n1->ip() eq $ln->ip()) and ($n2->ip() eq $rn->ip())){
$result = $if;
last;
}
}
}
else {
# Default OS (FreeBSD)
# get all interfaces (-1 = all)
my @ifs = grep { /^$type\d+/ } if_list -1;
my $ln = new Net::IP($l);
my $rn = new Net::IP($r);
foreach my $if (@ifs) {
my $pipe = "ifconfig $if |";
XB_Log::log "debug3", "open pipe $pipe";
open PIPE, $pipe or
XB_Log::log "err", "Unable to obtain tunnel interface ".
"information. Cannot open pipe $pipe: $!"
and die "open";
# look for assigned "physical" ("outer" is more appropriate)
# addresses
while (<PIPE>) {
XB_Log::log "debug3", $_;
if ( /^\s+tunnel/ ){
#tunnel inet 172.26.0.1 --> 172.26.0.2
#tunnel inet6 3ffe:801:1000:0:2b0:d0ff:fe78:c82f --> 3ffe:801:1000:0:207:e9ff:fe09:4381
chomp;
my @components = split / +/;
my $n1 = new Net::IP($components[2]);
my $n2 = new Net::IP($components[4]);
next if (not (defined $n1 and defined $n2));
if (($n1->ip() eq $ln->ip()) and ($n2->ip() eq $rn->ip())){
$result = $if;
last;
} # match
} # tunnel
} # PIPE
close PIPE or
XB_Log::log "err", "Unable to cleanup after obtained tunnel ".
"interface information. Cannot close pipe $pipe: $!"
and die "close";
XB_Log::log "debug3", "close pipe $pipe";
}
}
};
# print trace line
XB_Log::log "info", "<- XB_Tunnel::find_outer $l $r";
return $result unless $@; # success if no exception
die "XB_Tunnel::find_outer $@";
}
###############################################################################
# EXPORTED API
###############################################################################
# Description:
# Configure tunnel interface.
# Arguments: pass a hash containing these variables
# localaddr => local virtual address (inner header source)
# remoteaddr => remote virtual address (inner header destination)
# netmask => netmask for tunnel (on inner addresses)
# (ffff:...:fffc for ipv6
# 255.255.255.252 for ipv4)
# physlocaladdr => local address (outer header source)
# physremoteaddr => remote address (outer header destination)
# layer => tunnel layer ("link" or "network")
# name => <node name>
# routing_method => routing method ("static" or "dynamic")
#
# Returns:
# tunnel handle
# Exceptions:
# "XB_Tunnel::up" on error, nothing to clean up by caller
#
sub up ($){
my $inputhash = shift @_;
die if (not defined $inputhash);
my $lv = $inputhash->{'virtlocaladdr'};
my $rv = $inputhash->{'virtremoteaddr'};
my $l = $inputhash->{'physlocaladdr'};
my $r = $inputhash->{'physremoteaddr'};
my $ly = $inputhash->{'layer'};
my $oid = $inputhash->{'oid'};
my $rm = $inputhash->{'routing_method'};
my $nm_arg = $inputhash->{'netmask'};
my ($nm_opt, $nm, $family) = ("", "", "");
# print trace line
XB_Log::log "info", "-> XB_Tunnel::up $lv, $rv, $nm_arg, $l, $r, " .
"$ly, $oid, $rm";
my $tag;
eval {
if ($XB_Params::node_opts{os} =~ /linux/i) {
# Linux OS
my $dip = new Net::IP::XB_IP($nm_arg);
die ("Incorrect format: ". $nm_arg) if (not defined $dip);
if ($dip->version() == 4) {
$nm_opt = "netmask";
$nm = $nm_arg; #we assume that the correct netmask is passed
# from the OM.
} else {
XB_Log::log "err", "Linux ipv6 is not supported" and
die "Linuxv6";
}
my $alias = 1;
my $if;
# check arguments: well-formedness of IP addresses
foreach my $addr ($lv, $rv, $l, $r) {
my $n = new Net::IP($addr);
if ( not defined $n) {
XB_Log::log "err", "Syntax error in the message to the ".
"resource daemon from the overlay manager. ".
"Illegal IP address $addr specified ".
"in the command from the overlay. " and die "args";
}
}
# check arguments: layer
unless ($ly =~ /^(link|network)$/) {
XB_Log::log "err", "Syntax error in the message to the ".
"resource daemon from the overlay manager. ".
"Invalid layer $ly" and die "args";
}
# check arguments: routing method
unless ($rm =~ /^(static|dynamic)$/) {
XB_Log::log "err", "Syntax error in the message to the ".
"resource daemon from the overlay manager. ".
"Invalid routing method $rm" and die "args";
}
# check for interfaces with the same outer end points that we can reuse
$if = find_outer "tunl", $l, $r;
unless ($if) {
# no tunl interface between $l->$r found; try to find an unused one
my @ifs = grab "tunl";
$if = pop @ifs;
$alias = 0;
}
unless ($if) {
# if we still couldn't find one, we're screwed
XB_Log::log "err", "Syntax error in the message to the ".
"resource daemon from the overlay manager. ".
"No unused tunneling interfaces" and die "none";
}
# ip tunnel change (the remote and local we arbitrarily chose)
if (!$alias)
{
# don't do this if it's an alias since it's outer header is
# already up
my @cmd = ("ip", "tunnel", "change", $if, "mode", "ipip",
"remote",$r, "local", $l);
XB_Log::log "debug3", "@cmd";
my $rc = 0xff & system(@cmd);
($rc == 0) or
XB_Log::log "err", "Unable to modify tunnel properties. ".
"@cmd failed: $!" and die "ip";
}
# create tunnel tag encoding all the information needed for tunl_down
#
for my $p ($if, $lv, $rv, $ly, $oid, $rm, $nm) {
# make sure none of the arguments contains the separator
if ($p =~ /\|/) {
XB_Log::log "err",
"Unable to create state information at the ".
"node daemon. Element $p contains separator '|'"
and die "none";
}
}
$tag = join "|", ($if, $lv, $rv, $ly, $oid, $rm, $nm);
# Run the command now
exec_command "ifconfig", $if, $lv, "pointopoint", $rv,
$nm_opt, $nm, "up";
#
# add $lv as an alias to lo0 only when dynamic routing is not
# specified
if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
exec_command "ifconfig", "lo:0", $lv, "netmask", "255.255.255.255",
"up";
} #revisitation
}
elsif ($XB_Params::node_opts{os} =~ /cisco/i) {
# CISCO
my $dip = new Net::IP::XB_IP($nm_arg);
die ("Incorrect format: ". $nm_arg) if (not defined $dip);
if ($dip->version() == 4) { $nm = $nm_arg; }
else {
XB_Log::log "err", "Cisco ipv6 is not supported" and die "Ciscov6";
}
my ($if, $existing_interface, $cmd);
$if = find_outer "Tunnel", $l, $r;
if ($if) {
$existing_interface = "1";
} else {
# no Tunnel interface between $l->$r found; try to find an unused one
my @ifs = grab "Tunnel";
$if = pop @ifs;
}
unless ($if) {
# if we still couldn't find one, we're screwed
XB_Log::log "err", "no unused tunneling interfaces" and die "none";
}
# create tunnel tag encoding all the information needed for tun_down
for my $p ($if, $lv, $rv, $ly, $oid, $rm, $nm) {
# make sure none of the arguments contains the separator
if ($p =~ /\|/) {
XB_Log::log "err", "$p contains separator '|'" and die "none";
}
}
$tag = join "|", ($if, $lv, $rv, $ly, $oid, $rm, $nm);
# Run the command now
if ($existing_interface) {
$cmd = "ip route $rv 255.255.255.255 $if \n interface $if \n ip address $lv $nm secondary \n tunnel source $l \n tunnel destination $r \n tunnel mode ipip \n exit \n exit \n";
} else {
$cmd = "ip route $rv 255.255.255.255 $if \n interface $if \n ip address $lv $nm \n tunnel source $l \n tunnel destination $r \n tunnel mode ipip \n exit \n exit \n";
}
my @output = XB_CiscoSSH::cmd $cmd;
}
else {
# Default OS (FreeBSD)
# process the network mask to generate the correct mask, family
my $dip = new Net::IP::XB_IP($nm_arg);
die ("Incorrect format: " . $nm_arg) if (not defined $dip);
if ($dip->version() == 4){
$nm_opt = "netmask";
$nm = $nm_arg; #$dip->mask;
$family = "inet";
} else {
$nm_opt = "prefixlen";
$nm = 128; #$dip->masklen;
$family = "inet6";
}
# check arguments: well-formedness of IP addresses
foreach my $addr ($lv, $rv, $l, $r) {
my $n = new Net::IP($addr);
if ( not defined $n){
XB_Log::log "err", "Syntax error in the message to ".
"the resource daemon from the overlay manager. ".
"Illegal IP address $addr" and die "args";
}
}
# check arguments: layer
unless ($ly =~ /^(link|network)$/) {
XB_Log::log "err", "Syntax error in the message to ".
"the resource daemon from the overlay manager. ".
"Invalid layer $ly" and die "args";
}
# check arguments: routing method
unless ($rm =~ /^(static|dynamic)$/) {
XB_Log::log "err", "Syntax error in the message to ".
"the resource daemon from the overlay manager. " .
"Invalid routing method $rm" and die "args";
}
# check for interfaces with the same outer end points that we
# can reuse
my $if = find_outer "gif", $l, $r;
unless ($if) {
# no gif interface between $l->$r found; try to find an unused
# one
my @ifs = grab "gif";
$if = pop @ifs;
}
unless ($if) {
# if we still couldn't find one, we're screwed
XB_Log::log "err", "Syntax error in the message to ".
"the resource daemon from the overlay manager. ".
"No unused tunneling interfaces" and die "none";
}
#
# create tunnel tag encoding all the information needed for gif_down
#
for my $p ($if, $lv, $rv, $ly, $oid, $rm, $nm) {
# make sure none of the arguments contains the separator
if ($p =~ /\|/) {
XB_Log::log "err", "Syntax error in the message to ".
"the resource daemon from the overlay manager. ".
"$p contains separator '|'" and die "none";
}
}
$tag = join "|", ($if, $lv, $rv, $ly, $oid, $rm, $nm);
#
# Run the command now.
#
exec_command "ifconfig", $if, "$family", "alias", $lv, $rv,
"tunnel", $l, $r, "$nm_opt", $nm, "alias", "up";
#
# Add $lv as an alias to lo0. only if revisitation is not
# specified or if dynamic routing is enabled.
if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
# revisitation does not work with aliases created.
if ($family eq "inet"){
exec_command "ifconfig", "lo0", "$family", "alias", $lv, "netmask", "255.255.255.255", "up";
} else {
exec_command "ifconfig", "lo0", "$family", "alias", $lv, "prefixlen", "128", "up";
}
} # revisitation
}
}; #eval
# print trace line
XB_Log::log "info", "<- XB_Tunnel::up $lv, $rv, $nm, $l, $r, $ly, $oid, $rm";
return $tag unless $@; # success if no exception
# exception handling
if ($@ =~ /^(exec_command)/) {
# undo stuff
eval { down $tag; }
} elsif ($@ =~ /^(args|none)/) {
# nothingto undo, died before anything was changed
} else {
# unknown exception caught, log and pass up a defined one
XB_Log::log "warning", "XB_Tunnel::up: caught unexpected exception $@";
}
# pass defined exceptions up to caller
die "XB_Tunnel::up";
}
# Description:
# Tear down tunnel $tag.
# Arguments:
# $if tunnel tag (return value from corresponding XB_Tunnel::up)
# Returns:
# 1 on success
# Exceptions:
# "XB_Tunnel::down" on error, nothing to clean up by caller
#
sub down ($) {
my $tag = shift;
# print trace line
XB_Log::log "info", "-> XB_Tunnel::down $tag";
# check tag
my ($if, $lv, $rv, $ly, $oid, $rm, $nm) = split /\|/, $tag;
my $fail;
if ($XB_Params::node_opts{os} =~ /linux/i) {
# Linux OS
my $alias_no;
my $pif;
eval {
# check arguments: interface
unless ($if =~ /^tunl\d+(:\d+)?/) {
XB_Log::log "err", "Overlay status information corrupted. ".
"invalid interface $if" and die "args";
}
# check arguments: well-formedness of IP addresses/netmask
foreach my $addr ($lv, $rv) {
my $n = new Net::IP($addr);
if ( not defined $n) {
XB_Log::log "err", "Overlay status information corrupted. ".
"Illegal IP address $addr" and die "args";
}
}
# check arguments: layer
unless ($ly =~ /^(link|network)$/) {
XB_Log::log "err", "Overlay status information corrupted. ".
"Invalid layer $ly" and die "args";
}
# check arguments: routing method
unless ($rm =~ /^(static|dynamic)$/) {
XB_Log::log "err", "Overlay status information corrupted. ".
"Invalid routing method $rm" and die "args";
}
};
# if we've had an error before here, the tag is invalid - bail out
# now, there's nothing we can do without all the tag info
goto DONE if $@;
#
# tear the tunnel down, and ignore errors along the way
#
$fail = 0;
eval {
# delete the given alias with "ifconfig down" first, don't do
# remove the tunnel yet, need to know if it's the last one
$pif = ($if =~ /^(\D+\d+):\d+/ ? $1 : $if);
# check if any alias exit
my @uifs = grep /^$pif(:\d+)?$/, if_list 1;
$alias_no = 0;
foreach my $i (@uifs) { $alias_no++;}
XB_Log::log "debug3", "alias_no = $alias_no";
if($pif eq $if){
# this means we are the primary interface, don't bring it down unless
# there are NO other aliases
# IPv6 arg: pas 0.0.0.0 to ifconfig
$alias_no--;
if(! $alias_no) { # no other alias, bring it down
exec_command "ifconfig", $if, "0.0.0.0", "down";
}else{ # leave it up since other aliases exist
exec_command "ifconfig", $if, "0.0.0.0";
}
}
else{
# just an alias, bring it down
exec_command "ifconfig", $if, "down";
$alias_no--;
# check if last one, if yes, bring down the primary as well
if(! $alias_no)
{
exec_command "ifconfig", $pif, "0.0.0.0", "down";
}
}
};
$fail++ if $@;
#
# destroy the interface
#
eval {
# if there are no aliases left on the interface, delete it
if (!$alias_no) {
# delete the tunnel interface
my @cmd = ("ip","tunnel","del",$pif);
XB_Log::log "debug3", "@cmd";
my $rc = 0xff & system(@cmd);
($rc == 0) or XB_Log::log "err",
"Unable to delete the tunnel. ".
"@cmd failed: $!"
and die "ip tunnel del";
}
};
$fail++ if $@;
#
# delete the alias added when bringing up tunnels
eval {
if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
exec_command "ifconfig", "lo:0", $lv, "down";
}
}; #eval
$fail++ if $@;
} elsif ($XB_Params::node_opts{ os} =~ /cisco/i) {
$fail = 0;
eval {
my $cmd = "no ip route $rv 255.255.255.255 $if \n interface $if \n no ip address $lv $nm secondary \n exit \n exit \n";
my @output = XB_CiscoSSH::cmd $cmd;
};
$fail++ if $@;
my $count = 0;
eval {
my (@l, @r, $interface, @secondary);
my @cmd = ("show running-config | begin ($if)");
my @output = XB_CiscoSSH::show_cmd @cmd;
my @result = split "\n", $output[0];
foreach my $each (0..($#result-1)) {
my $line = shift @result;
if ($line =~ /\s*interface\s+(\w+)/) { $interface = $1; next; }
if (($line =~ /\s*ip\s+address\s+((\d{1,3}\.){3}\d{1,3})\s+((\d{1,3}\.){3}\d{1,3})\s*(\w*)/) and ($interface eq $if)) {
push @l, $1;
push @secondary, $5; next;
}
if($line =~ /\s*ip\s+route\s+((\d{1,3}\.){3}\d{1,3})\s+((\d{1,3}\.){3}\d{1,3})\s+$if/) { push @r, $1; next; }
}
if ((defined $r[0]) and (defined $l[0])){
$count++;
}
};
$fail++ if $@;
eval {
if ($count == 0) {
my @cmd = ("no interface $if \n exit \n");
XB_Log::log "debug3", "@cmd";
my @result = XB_CiscoSSH::cmd @cmd;
}
};
$fail++ if $@;
}
else {
# Default OS (FreeBSD)
#
# sanity check of the arguments.
#
eval {
# check arguments: interface
unless ($if =~ /^gif\d+$/) {
XB_Log::log "err", "invalid interface $if" and die "args";
}
# check arguments: well-formedness of IP addresses/netmask
foreach my $addr ($lv, $rv) {
my $n = new Net::IP($addr);
if ( not defined $n){
XB_Log::log "err", "Overlay status information corrupted. ".
"Illegal IP address $addr" and die "args";
}
}
# check arguments: layer
unless ($ly =~ /^(link|network)$/) {
XB_Log::log "err", "Overlay status information corrupted. ".
"Invalid layer $ly" and die "args";
}
# check arguments: routing method
unless ($rm =~ /^(static|dynamic)$/) {
XB_Log::log "err", "Overlay status information corrupted. ".
"Invalid routing method $rm" and die "args";
}
};
# if we've had an error before here, the tag is invalid - bail out
# now, there's nothing we can do without all the tag info
goto DONE if $@;
#
# tear the tunnel down, and ignore errors along the way
#
$fail = 0;
eval {
# delete the given alias with "ifconfig delete" first, don't do
# remove the tunnel yet, need to know if it's the last one
my $family = "inet";
my $n = new Net::IP ($lv);
if (defined $n and $n->version() == 6){
$family = "inet6";
}
exec_command "ifconfig", $if, $family, $lv, $rv, "delete";
};
$fail++ if $@;
#
# now count the remaining xbone aliases - if there aren't any left,
# we can delete the interface
#
my $count = 0;
eval {
my $pipe = "ifconfig $if |";
XB_Log::log "debug3", "open pipe $pipe";
open PIPE, $pipe or
XB_Log::log "err",
"Unable to obtain tunnel information. ".
"Cannot open pipe $pipe: $!"
and die "open";
# look for assigned virtual addresses
while (<PIPE>) {
chomp $_;
XB_Log::log "debug3", $_;
# strip the initial part of the text.
if ( /inet/ and /-->/ and not(/tunnel/)){
XB_Log::log "debug3", "matched : $_";
#inet 172.26.0.1 --> 172.26.0.2
#inet6 3ffe:801:1000:0:2b0:d0ff:fe78:c82f --> 3ffe:801:1000:0:207:e9ff:fe09:4381
my @components = split / +/;
my $n1 = new Net::IP($components[1]);
my $n2 = new Net::IP($components[3]);
XB_Log::log "debug3", "n1 = $components[1], n2 = $components[3]";
if ((defined $n1) and (defined $n2)){
$count++;
}
}
}; # while ifconfig lines...
# done with pipe
close PIPE or
XB_Log::log "err",
"Unable to cleanup after deleting tunnel interfaces. ".
"cannot close pipe $pipe: $!"
and die "close";
XB_Log::log "debug3", "close pipe $pipe";
};
$fail++ if $@;
#
# destroy the interface
#
eval {
# if there are no aliases left on the interface, delete it
if ($count == 0) {
# delete the gif interface
my @cmd = ("ifconfig", $if, "destroy");
XB_Log::log "debug3", "@cmd";
my $rc = 0xff & system(@cmd);
($rc == 0) or
XB_Log::log "err", "Unable to destroy tunnel interfaces. ".
"@cmd failed: $!"
and die "ifconfig";
}
};
$fail++ if $@;
#
# create an alias on lo0
#
eval {
# Delete the alias added when bringing up tunnels.
if ($XB_Params::REVISITATION == 0 and $rm !~ /(dynamic)/i) {
my $n = new Net::IP ($lv);
my $family = "inet";
if ( defined $n and $n->version() == 6){ $family = "inet6"; };
exec_command "ifconfig", "lo0", "$family", "-alias", $lv;
} # REVISITATION
}; #eval..
$fail++ if $@;
}
DONE:
# print trace line
XB_Log::log "info", "<- XB_Tunnel::down $tag $@";
return 1 unless $fail; # success if no exception
# exception handling, nothing to do, just pass exception up to caller
die "XB_Tunnel::down";
}
# Description:
# Initialize tunneling module. Must be called once prior to using
# any other funtion in this module.
# Arguments:
# none
# Returns:
# 1 on success
# Exceptions:
# "XB_Tunnel::init" on error, nothing to clean up by caller
#
sub init () {
# print trace line
XB_Log::log "info", "-> XB_Tunnel::init";
# check if we're on a recent KAME (FreeBSD-4.5 or later)
my @fields = split /\//,
XB_Utils::sysctl_read "net.inet6.ip6.kame_version";
unless ($fields[0] >= 20010528) {
XB_Log::log "err", "Probe for KAME version failed. Aborting."
and die "XB_Tunnel::init";
}
# print trace line
XB_Log::log "info", "<- XB_Tunnel::init";
return 1;
}
1;
syntax highlighted by Code2HTML, v. 0.9.1