#!/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;