source: fedkit/gateway_lib.pm

#!/usr/bin/perl

package gateway_lib;

# Package stuff to keep the caller's namespace clean, but allow additions if
# they need it.
require Exporter;
@ISA=qw(Exporter);
@EXPORT_OK=qw(set_sshd_params import_key wait_for_DNS deter_tunnelip 
    configure_outgoing_iface add_route bind_tap_to_iface iface_to_addr
    dest_to_iface addr_to_iface read_config config_filename);


use strict;

use IO::File;
use IO::Pipe;
use IO::Socket;

use File::Temp;
use File::Copy;
use Net::hostent;

# Standard locations of these commands (FreeBSD)
my $IFCONFIG = "/sbin/ifconfig";
my $ROUTE = "/sbin/route";
my $TMCC = "/usr/local/etc/emulab/tmcc";
my $FINDIF = "/usr/local/etc/emulab/findif";
my $TMCC = "/usr/local/etc/emulab/tmcc";

# Linux choices
my $BRCTL = "/usr/sbin/brctl";
my $IPROUTE = "/sbin/ip route ";

$BRCTL = '/sbin/brctl' unless -x $BRCTL ;

# Takes an ssh config file and a reference to a hash of keys whose values must
# be set a specific way.  Replaces existing entries with the set values.
sub set_sshd_params {
    my($keys, $file) = @_;
    my $f;
    my $t;

    $file = "/etc/ssh/sshd_config" unless $file;
    $f = new IO::File("$file") || die "Can't read $f: $!\n";
    $t = new File::Temp() || die "Can't open tempfile: $!\n";

    # If the parameter is in the file (even in a comment) update the line to
    # have the new parameter.
    my %updated;
    while (<$f>) {
        foreach my $k (keys %{$keys}) {
            if (s/^\s*#?\s*$k.*/$k $keys->{$k}/) { $updated{$k}++; }
        }
        print $t $_;
    }
    # Any parameters not found above are output directly.
    foreach my $k (keys %{$keys}) {
        print $t "$k " . $keys->{$k} . "\n" unless $updated{$k};
    }
    $f->close();
    $t->close();
    copy("$file", "$file.hold");
    copy($t->filename, $file);
    # When $t goes out of scope, the tmpfile is deleted
}

# Append the given keyfile to the given authorised key file.
sub import_key {
    my($keyfile, $authkeys) = @_;

    my $kf = new IO::File($keyfile) || die "Can't open $keyfile:$!\n";
    my $ak = new IO::File(">>$authkeys") || die "Can't open $authkeys: $!\n";

    while (<$kf>) {
        print $ak $_;
    }
    $kf->close();
    $ak->close();
}

# Keep trying to look up the given hostname until successful.  If timeout is
# given, die after waiting that long.  If sleep is given, wait that many
# seconds between attempts (defaults to 5).  
sub wait_for_DNS {
    my($name, $timeout, $sleep) = @_;
    my $start = time();
    $sleep = 5 unless $sleep;
    my $rv;

    # If the name is an IP address, skip this.
    return if $name =~ /^[\d\.]+$/;

    while (!$rv) {
        $rv = gethostbyname($name);
        die "Timeout waiting for DNS to get $name\n" 
            if ($timeout && time() - $start > $timeout);
        sleep($sleep) unless $rv;
    }
}

# Get the external access parameters (interface, address, netmask, mac address,
# and next hop router) from tmcd in Emulabs that support the DETER tunnelip
# extension.
sub deter_tunnelip {
    # To parse tmcc
    my $tmcc = new IO::Pipe || die "Can't create tmcc pipe: $!\n";
    my $interface;              # Interface with external address
    my $ip;                     # IP address of external interface
    my $mac;                    # MAC address
    my $netmask;                # Netmask
    my $router;                 # Router for the internet


    # Parse out the info about tunnelips.  Format is usually one line of
    # ATTR=VALUE.  Multiple lines are possible.
    $tmcc->reader("$TMCC tunnelip");
    while (<$tmcc>) {
        chomp;
        /TUNNELIP=([\d\.]*)/ && do { $ip = $1; };
        /TUNNELMASK=([\d\.]*)/ && do { $netmask = $1; };
        /TUNNELMAC=([[:xdigit:]]*)/ && do { $mac = $1; };
        /TUNNELROUTER=([\d\.]*)/ && do { $router = $1; };
    }
    $tmcc->close();

    die "No MAC information for tunnel.\n" unless $mac;

    # Use the emulab findif command to get the right interface to configure
    $interface = `$FINDIF $mac`;
    chomp $interface;
    die "Can't get interface for mac address $mac: $?" if $? || !$interface;

    return ($interface, $ip, $netmask, $mac, $router);
}


# Configure the given interface with the given IP address and netmask.
sub configure_outgoing_iface {
    my ($interface, $ip, $netmask) = @_;

    my @ifconfig = ($IFCONFIG, $interface, $ip);
    push(@ifconfig, 'netmask', $netmask) if $netmask;

    system(@ifconfig);
    die join(" ", @ifconfig) . " failed: $!\n" if $?;
}

# Add a route to the destination through the router.  If wait is given, do not
# attempt to add the route until DNS has the hostname in it.  If timeout is
# given, only wait that many seconds for DNS to acquire it.
sub add_route {
    my($routedest, $router, $wait, $timeout) = @_;
    my @cmd;
    # Linux and FreeBSD use slightly different route syntax, so get the OS
    my $os = `uname`;
    chomp $os;

    $timeout = 0 unless $timeout;
    die "add_host_route needs a router and a destination\n"
        unless $router && $routedest;

    wait_for_DNS($routedest, $timeout) if $wait;

    if ( $os =~ /^Linux/ ) { 
        @cmd = ($ROUTE, 'add', $routedest, 'gw', $router);
    }
    elsif ( $os =~ /^FreeBSD/ ) {
        @cmd = ($ROUTE, 'add', $routedest, $router);
    }
    else {
        die "Unknown OS: $os\n";
    }
    system(@cmd);
    warn join(" ", @cmd) . " failed: $?\n" if $?;
    return $?;
}

# Connect the tap($tapno) interface to $iface at the link level.  Remove any IP
# addresses assigned to interface to avoid confusing the routing system.  We're
# very tolerant of errors as the bridge and other interfaces may already exist
# when this is called.
sub bind_tap_to_iface {
    my($tapno, $iface) = @_;
    my $bridge = "bridge$tapno";
    my $tap = "tap$tapno";
    my @addr = iface_to_addr($iface);

    # Wait for the tap
    system("$IFCONFIG $tap > /dev/null 2>/dev/null");
    while ($?) {
        system("$IFCONFIG $tap > /dev/null 2>/dev/null");
    }

    my $uname = `uname`;
    chomp $uname;

    if ($uname =~ /FreeBSD/) {
        system("ifconfig $bridge create");
        warn "Cannot create bridge: $?\n" if $?;
        foreach my $a (@addr) {
            system("ifconfig $iface delete $a");
            warn "Cannot delete address $a: $?\n" if $?;
        }
        system("ifconfig $bridge addm $iface up");
        warn "Cannot add intefrace $iface to bridge: $?\n" if $?;
        system("ifconfig $bridge addm $tap");
        warn "Cannot add intefrace $tap to bridge: $?\n" if $?;
        return $?;
    }
    elsif ($uname =~ /Linux/) {
        system("$IFCONFIG $iface 0.0.0.0 down");
        system("$BRCTL addbr $bridge");
        warn "Cannot create bridge: $?\n" if $?;
        system("$BRCTL addif $bridge $tap");
        system("$BRCTL addif $bridge $iface");
        system("$BRCTL stp $bridge off");
        system("$IFCONFIG $bridge up");
        system("$IFCONFIG $tap up");
        system("$IFCONFIG $iface up");
        return $?;
    }
}

# Return the IP addresses accociated with this interface (as a list)
sub iface_to_addr {
    my($iface) = @_;
    my $ipipe = new IO::Pipe() || die "Can't create pipe for ifconfig: $!\n";
    my @addr;
    my $uname = `uname`;
    my $ipre = "inet\\s+([0-9\\.]+)";
    chomp $uname;

    if ($uname =~ /Linux/) {
        $ipre = "inet\\s+addr:\\s*([0-9\\.]+)";
    }

    $ipipe->reader("$IFCONFIG $iface");
    while(<$ipipe>) {
        /$ipre/ && push(@addr, $1);
    }
    $ipipe->close();
    return @addr;
}

# Return the interface that packets to this host (IP or DNS) would be sent on.
sub dest_to_iface {
    my($dest) =@_;
    my $rpipe = new IO::Pipe() || die "Can't create pipe for route: $!\n";
    my $uname = `uname`;
    chomp $uname;
    my $route;
    my $dev_re;

    if ($uname =~ /Linux/) {
        $route = $IPROUTE;
        $dev_re = "\\s+dev\\s+(\\S+)";
    }
    elsif ($uname =~ /FreeBSD/) {
        $route = $ROUTE;
        $dev_re = 'interface:\\s*([[:alnum:]]+)';
    }


    print "$route get $dest\n";
    $rpipe->reader("$route get $dest");
    while (<$rpipe>) {
        /$dev_re/ && do {
            my $iface = $1;
            $rpipe->close();
            print "matched: $iface\n";
            return $iface;
        };
    }
    $rpipe->close();

    die "No route to $dest\n";
}

# Return the interface bound to this IP address.  If there are more than one,
# the first one returned by ifconfig is the one returned.
sub addr_to_iface {
    my($addr) = @_;
    my $ipipe = new IO::Pipe() || die "Can't create pipe for ifconfig: $!\n";
    my $iface;

    $ipipe->reader("$IFCONFIG");
    while(<$ipipe>) {
        /^([[:alnum:]]+):?/ && do {
            $iface = $1;
            next;
        };
        /inet(\s+addr:)?\s*([0-9\.]+)/ && do {
            if ($2 eq $addr) {
                $ipipe->close();
                return $iface;
            }
        };
    }
    $ipipe->close();
    die "Cannot match $addr to an interface\n";
}

sub read_config {
    my($file, $map) = @_;
    my %param;
    my %keywords;
    my $f;

    foreach my $k (keys %{$map}) {
        if ( $k =~ /(\S+)=[si]/ ) {
            $keywords{$1} = $map->{$k};
            $param{$1}++;
        }
        else {
            $keywords{$k} = $map->{$k};
        }
    }

    $f = new IO::File($file) || die "Can't open $file: $!\n";
    while (<$f>) {
        /^\s*([^:]+):\s*(.*)/ && do {
            my $keyw = $1;
            my $val = $2;

            $keyw =~ tr [A-Z] [a-z];

            if ($keywords{$keyw} ) {
                if ( $param{$keyw} ) { 
                    if ( ref($keywords{$keyw}) eq 'SCALAR') {
                        ${$keywords{$keyw}} = $val;
                    }
                    elsif( ref($keywords{$keyw}) eq 'ARRAY') {
                        push(@{$keywords{$keyw}}, $val);
                    }
                    else {
                        die "Unknown variable type for $keyw\n";
                    }
                }
                else  { ${$keywords{$keyw}}++; }
            }
            next;
        };
    }
    $f->close();
}


sub config_filename {
    # Find the configuration file in the usual places, if there is one in
    # /usr/local/federation/etc, use it, otherwise look in the emulab standard
    # filesystems which depends on what experiment and project we're in.
    my $pid;
    my $eid;
    my $filename;
    my $fed_dir = "/usr/local/federation/etc/";
    my $hn = `hostname`;
    chomp $hn;
    $hn =~ s/\..*//;

    return "$fed_dir/$hn.gw.conf" if -r "$fed_dir/$hn.gw.conf";

    my $tmcd = new IO::Pipe() || die "Can't create pipe: $!\n";

    $tmcd->reader("$TMCC status");

    while (<$tmcd>) {
        chomp;
        /ALLOCATED=([^\/]+)\/(\S+)/ && do {
            $pid = $1;
            $eid = $2;
        };
    }
    $tmcd->close();
    $filename = "/proj/$pid/exp/$eid/tmp/$hn.gw.conf"
        if $pid and $eid;

    return $filename;
}


sub client_conf_filename {
    # Find the configuration file in the usual places, if there is one in
    # /usr/local/federation/etc, use it, otherwise look in the emulab standard
    # filesystems which depends on what experiment and project we're in.
    my $pid;
    my $eid;
    my $filename;
    my $fed_dir = "/usr/local/federation/etc/";

    return "$fed_dir/client.conf" if -r "$fed_dir/client.conf";

    my $tmcd = new IO::Pipe() || die "Can't create pipe: $!\n";

    $tmcd->reader("$TMCC status");

    while (<$tmcd>) {
        chomp;
        /ALLOCATED=([^\/]+)\/(\S+)/ && do {
            $pid = $1;
            $eid = $2;
        };
    }
    $tmcd->close();
    $filename = "/proj/$pid/exp/$eid/tmp/client.conf"
        if $pid and $eid;

    return $filename;
}

sub wait_for_port {
    my($addr, $port, $timeout, $sleep) = @_;
    my $start = time();
    $sleep = 5 unless $sleep;
    die "Need both address and port\n" unless $addr && $port;

    my $s;

    while (!$s) {
        # We've seen some arp pollution, so be proactive about clearing the
        # cache if we're waiting to get out.
        system("arp -d -a");
        if (!($s = new IO::Socket(Domain => &AF_INET, PeerAddr => $addr, 
            PeerPort => $port))) {
            if ($timeout and time() - $start > $timeout) {
                return undef;
            }
            else { sleep($sleep); }
        }
    }
    $s->close();
    return 1;

}

# Fling a few ping packets at the peer in the hopes that it opens doors through
# NATs and other filters.  Practically speaking this can make a big difference.
sub ping_peer {
    my($peer) = @_;
    system("ping -c 5 $peer");
}

sub testcmd_repeat {
    my($cmd, $timeout, $sleep) = @_;
    my $start = time();
    $sleep = 5 unless $sleep;

    while (1) {
        system("$cmd");
        if ($?) {
            if ($timeout and time() - $start > $timeout) {
                return undef;
            }
            else { sleep($sleep); }
        }
        else { return 1; }
    }
}

sub get_ip { 
    my($name) = @_;
    my $gwip;
    if ( my $hent = gethostbyname($name) ) {
        $gwip = inet_ntoa($hent->addr_list->[0]);
    }
    return $gwip;
}

1;