[2edec46] | 1 | #!/usr/bin/perl |
---|
| 2 | |
---|
| 3 | package gateway_lib; |
---|
| 4 | |
---|
[2b35261] | 5 | # Package stuff to keep the caller's namespace clean, but allow additions if |
---|
| 6 | # they need it. |
---|
[2edec46] | 7 | require Exporter; |
---|
| 8 | @ISA=qw(Exporter); |
---|
| 9 | @EXPORT_OK=qw(set_sshd_params import_key wait_for_DNS deter_tunnelip |
---|
| 10 | configure_outgoing_iface add_route bind_tap_to_iface iface_to_addr |
---|
[97edf0d] | 11 | dest_to_iface addr_to_iface read_config config_filename); |
---|
[8d4e4fb] | 12 | |
---|
[2edec46] | 13 | |
---|
| 14 | use strict; |
---|
| 15 | |
---|
| 16 | use IO::File; |
---|
| 17 | use IO::Pipe; |
---|
[1899afd] | 18 | use IO::Socket; |
---|
[2edec46] | 19 | |
---|
| 20 | use File::Temp; |
---|
| 21 | use File::Copy; |
---|
[85462fb] | 22 | use Net::hostent; |
---|
[2edec46] | 23 | |
---|
[2b35261] | 24 | # Standard locations of these commands (FreeBSD) |
---|
[2edec46] | 25 | my $IFCONFIG = "/sbin/ifconfig"; |
---|
| 26 | my $ROUTE = "/sbin/route"; |
---|
| 27 | my $TMCC = "/usr/local/etc/emulab/tmcc"; |
---|
| 28 | my $FINDIF = "/usr/local/etc/emulab/findif"; |
---|
[8d4e4fb] | 29 | my $TMCC = "/usr/local/etc/emulab/tmcc"; |
---|
[2edec46] | 30 | |
---|
[f8fa72b] | 31 | # Linux choices |
---|
| 32 | my $BRCTL = "/usr/sbin/brctl"; |
---|
| 33 | my $IPROUTE = "/sbin/ip route "; |
---|
| 34 | |
---|
[2b35261] | 35 | # Takes an ssh config file and a reference to a hash of keys whose values must |
---|
| 36 | # be set a specific way. Replaces existing entries with the set values. |
---|
[2edec46] | 37 | sub set_sshd_params { |
---|
| 38 | my($keys, $file) = @_; |
---|
| 39 | my $f; |
---|
| 40 | my $t; |
---|
| 41 | |
---|
| 42 | $file = "/etc/ssh/sshd_config" unless $file; |
---|
| 43 | $f = new IO::File("$file") || die "Can't read $f: $!\n"; |
---|
| 44 | $t = new File::Temp() || die "Can't open tempfile: $!\n"; |
---|
| 45 | |
---|
[5e71d34] | 46 | # If the parameter is in the file (even in a comment) update the line to |
---|
| 47 | # have the new parameter. |
---|
| 48 | my %updated; |
---|
[2edec46] | 49 | while (<$f>) { |
---|
| 50 | foreach my $k (keys %{$keys}) { |
---|
[5e71d34] | 51 | if (s/^\s*#?\s*$k.*/$k $keys->{$k}/) { $updated{$k}++; } |
---|
[2edec46] | 52 | } |
---|
| 53 | print $t $_; |
---|
| 54 | } |
---|
[5e71d34] | 55 | # Any parameters not found above are output directly. |
---|
| 56 | foreach my $k (keys %{$keys}) { |
---|
| 57 | print $t "$k " . $keys->{$k} . "\n" unless $updated{$k}; |
---|
| 58 | } |
---|
[2edec46] | 59 | $f->close(); |
---|
| 60 | $t->close(); |
---|
| 61 | copy("$file", "$file.hold"); |
---|
| 62 | copy($t->filename, $file); |
---|
| 63 | # When $t goes out of scope, the tmpfile is deleted |
---|
| 64 | } |
---|
| 65 | |
---|
[2b35261] | 66 | # Append the given keyfile to the given authorised key file. |
---|
[2edec46] | 67 | sub import_key { |
---|
| 68 | my($keyfile, $authkeys) = @_; |
---|
| 69 | |
---|
| 70 | my $kf = new IO::File($keyfile) || die "Can't open $keyfile:$!\n"; |
---|
| 71 | my $ak = new IO::File(">>$authkeys") || die "Can't open $authkeys: $!\n"; |
---|
| 72 | |
---|
| 73 | while (<$kf>) { |
---|
| 74 | print $ak $_; |
---|
| 75 | } |
---|
| 76 | $kf->close(); |
---|
| 77 | $ak->close(); |
---|
| 78 | } |
---|
| 79 | |
---|
[2b35261] | 80 | # Keep trying to look up the given hostname until successful. If timeout is |
---|
| 81 | # given, die after waiting that long. If sleep is given, wait that many |
---|
| 82 | # seconds between attempts (defaults to 5). |
---|
[2edec46] | 83 | sub wait_for_DNS { |
---|
[2b35261] | 84 | my($name, $timeout, $sleep) = @_; |
---|
[2edec46] | 85 | my $start = time(); |
---|
[2b35261] | 86 | $sleep = 5 unless $sleep; |
---|
[85462fb] | 87 | my $rv; |
---|
[2edec46] | 88 | |
---|
[87b1a06] | 89 | # If the name is an IP address, skip this. |
---|
| 90 | return if $name =~ /^[\d\.]+$/; |
---|
| 91 | |
---|
[85462fb] | 92 | while (!$rv) { |
---|
| 93 | $rv = gethostbyname($name); |
---|
[2edec46] | 94 | die "Timeout waiting for DNS to get $name\n" |
---|
| 95 | if ($timeout && time() - $start > $timeout); |
---|
[85462fb] | 96 | sleep($sleep) unless $rv; |
---|
[2edec46] | 97 | } |
---|
| 98 | } |
---|
| 99 | |
---|
[2b35261] | 100 | # Get the external access parameters (interface, address, netmask, mac address, |
---|
| 101 | # and next hop router) from tmcd in Emulabs that support the DETER tunnelip |
---|
| 102 | # extension. |
---|
[2edec46] | 103 | sub deter_tunnelip { |
---|
| 104 | # To parse tmcc |
---|
| 105 | my $tmcc = new IO::Pipe || die "Can't create tmcc pipe: $!\n"; |
---|
| 106 | my $interface; # Interface with external address |
---|
| 107 | my $ip; # IP address of external interface |
---|
| 108 | my $mac; # MAC address |
---|
| 109 | my $netmask; # Netmask |
---|
| 110 | my $router; # Router for the internet |
---|
| 111 | |
---|
| 112 | |
---|
[2b35261] | 113 | # Parse out the info about tunnelips. Format is usually one line of |
---|
| 114 | # ATTR=VALUE. Multiple lines are possible. |
---|
[2edec46] | 115 | $tmcc->reader("$TMCC tunnelip"); |
---|
| 116 | while (<$tmcc>) { |
---|
| 117 | chomp; |
---|
| 118 | /TUNNELIP=([\d\.]*)/ && do { $ip = $1; }; |
---|
| 119 | /TUNNELMASK=([\d\.]*)/ && do { $netmask = $1; }; |
---|
| 120 | /TUNNELMAC=([[:xdigit:]]*)/ && do { $mac = $1; }; |
---|
| 121 | /TUNNELROUTER=([\d\.]*)/ && do { $router = $1; }; |
---|
| 122 | } |
---|
| 123 | $tmcc->close(); |
---|
| 124 | |
---|
| 125 | die "No MAC information for tunnel.\n" unless $mac; |
---|
| 126 | |
---|
| 127 | # Use the emulab findif command to get the right interface to configure |
---|
| 128 | $interface = `$FINDIF $mac`; |
---|
| 129 | chomp $interface; |
---|
| 130 | die "Can't get interface for mac address $mac: $?" if $? || !$interface; |
---|
| 131 | |
---|
| 132 | return ($interface, $ip, $netmask, $mac, $router); |
---|
| 133 | } |
---|
| 134 | |
---|
[2b35261] | 135 | |
---|
| 136 | # Configure the given interface with the given IP address and netmask. |
---|
[2edec46] | 137 | sub configure_outgoing_iface { |
---|
[2b35261] | 138 | my ($interface, $ip, $netmask) = @_; |
---|
[2edec46] | 139 | |
---|
| 140 | my @ifconfig = ($IFCONFIG, $interface, $ip); |
---|
| 141 | push(@ifconfig, 'netmask', $netmask) if $netmask; |
---|
| 142 | |
---|
| 143 | system(@ifconfig); |
---|
| 144 | die join(" ", @ifconfig) . " failed: $!\n" if $?; |
---|
| 145 | } |
---|
| 146 | |
---|
[2b35261] | 147 | # Add a route to the destination through the router. If wait is given, do not |
---|
| 148 | # attempt to add the route until DNS has the hostname in it. If timeout is |
---|
| 149 | # given, only wait that many seconds for DNS to acquire it. |
---|
[2edec46] | 150 | sub add_route { |
---|
| 151 | my($routedest, $router, $wait, $timeout) = @_; |
---|
| 152 | my @cmd; |
---|
| 153 | # Linux and FreeBSD use slightly different route syntax, so get the OS |
---|
| 154 | my $os = `uname`; |
---|
| 155 | chomp $os; |
---|
| 156 | |
---|
| 157 | $timeout = 0 unless $timeout; |
---|
| 158 | die "add_host_route needs a router and a destination\n" |
---|
| 159 | unless $router && $routedest; |
---|
| 160 | |
---|
| 161 | wait_for_DNS($routedest, $timeout) if $wait; |
---|
| 162 | |
---|
| 163 | if ( $os =~ /^Linux/ ) { |
---|
| 164 | @cmd = ($ROUTE, 'add', $routedest, 'gw', $router); |
---|
| 165 | } |
---|
| 166 | elsif ( $os =~ /^FreeBSD/ ) { |
---|
| 167 | @cmd = ($ROUTE, 'add', $routedest, $router); |
---|
| 168 | } |
---|
| 169 | else { |
---|
| 170 | die "Unknown OS: $os\n"; |
---|
| 171 | } |
---|
| 172 | system(@cmd); |
---|
| 173 | warn join(" ", @cmd) . " failed: $?\n" if $?; |
---|
| 174 | return $?; |
---|
| 175 | } |
---|
| 176 | |
---|
[2b35261] | 177 | # Connect the tap($tapno) interface to $iface at the link level. Remove any IP |
---|
| 178 | # addresses assigned to interface to avoid confusing the routing system. We're |
---|
| 179 | # very tolerant of errors as the bridge and other interfaces may already exist |
---|
| 180 | # when this is called. |
---|
[2edec46] | 181 | sub bind_tap_to_iface { |
---|
| 182 | my($tapno, $iface) = @_; |
---|
| 183 | my $bridge = "bridge$tapno"; |
---|
| 184 | my $tap = "tap$tapno"; |
---|
| 185 | my @addr = iface_to_addr($iface); |
---|
| 186 | |
---|
| 187 | # Wait for the tap |
---|
| 188 | system("$IFCONFIG $tap > /dev/null 2>/dev/null"); |
---|
| 189 | while ($?) { |
---|
| 190 | system("$IFCONFIG $tap > /dev/null 2>/dev/null"); |
---|
| 191 | } |
---|
| 192 | |
---|
[f8fa72b] | 193 | my $uname = `uname`; |
---|
| 194 | chomp $uname; |
---|
| 195 | |
---|
| 196 | if ($uname =~ /FreeBSD/) { |
---|
| 197 | system("ifconfig $bridge create"); |
---|
| 198 | warn "Cannot create bridge: $?\n" if $?; |
---|
| 199 | foreach my $a (@addr) { |
---|
| 200 | system("ifconfig $iface delete $a"); |
---|
| 201 | warn "Cannot delete address $a: $?\n" if $?; |
---|
| 202 | } |
---|
| 203 | system("ifconfig $bridge addm $iface up"); |
---|
| 204 | warn "Cannot add intefrace $iface to bridge: $?\n" if $?; |
---|
| 205 | system("ifconfig $bridge addm $tap"); |
---|
| 206 | warn "Cannot add intefrace $tap to bridge: $?\n" if $?; |
---|
| 207 | return $?; |
---|
| 208 | } |
---|
| 209 | elsif ($uname =~ /Linux/) { |
---|
| 210 | system("$IFCONFIG $iface 0.0.0.0 down"); |
---|
| 211 | system("$BRCTL addbr $bridge"); |
---|
| 212 | warn "Cannot create bridge: $?\n" if $?; |
---|
| 213 | system("$BRCTL addif $bridge $tap"); |
---|
| 214 | system("$BRCTL addif $bridge $iface"); |
---|
| 215 | system("$BRCTL stp $bridge off"); |
---|
| 216 | system("$IFCONFIG $bridge up"); |
---|
| 217 | system("$IFCONFIG $tap up"); |
---|
| 218 | system("$IFCONFIG $iface up"); |
---|
| 219 | return $?; |
---|
[2edec46] | 220 | } |
---|
| 221 | } |
---|
| 222 | |
---|
[2b35261] | 223 | # Return the IP addresses accociated with this interface (as a list) |
---|
[2edec46] | 224 | sub iface_to_addr { |
---|
| 225 | my($iface) = @_; |
---|
| 226 | my $ipipe = new IO::Pipe() || die "Can't create pipe for ifconfig: $!\n"; |
---|
| 227 | my @addr; |
---|
[f8fa72b] | 228 | my $uname = `uname`; |
---|
| 229 | my $ipre = "inet\\s+([0-9\\.]+)"; |
---|
| 230 | chomp $uname; |
---|
| 231 | |
---|
| 232 | if ($uname =~ /Linux/) { |
---|
| 233 | $ipre = "inet\\s+addr:\\s*([0-9\\.]+)"; |
---|
| 234 | } |
---|
[2edec46] | 235 | |
---|
| 236 | $ipipe->reader("$IFCONFIG $iface"); |
---|
| 237 | while(<$ipipe>) { |
---|
[f8fa72b] | 238 | /$ipre/ && push(@addr, $1); |
---|
[2edec46] | 239 | } |
---|
| 240 | $ipipe->close(); |
---|
| 241 | return @addr; |
---|
| 242 | } |
---|
| 243 | |
---|
[2b35261] | 244 | # Return the interface that packets to this host (IP or DNS) would be sent on. |
---|
[2edec46] | 245 | sub dest_to_iface { |
---|
| 246 | my($dest) =@_; |
---|
| 247 | my $rpipe = new IO::Pipe() || die "Can't create pipe for route: $!\n"; |
---|
[f8fa72b] | 248 | my $uname = `uname`; |
---|
| 249 | chomp $uname; |
---|
| 250 | my $route; |
---|
| 251 | my $dev_re; |
---|
| 252 | |
---|
| 253 | if ($uname =~ /Linux/) { |
---|
| 254 | $route = $IPROUTE; |
---|
| 255 | $dev_re = "\\s+dev\\s+(\\S+)"; |
---|
| 256 | } |
---|
| 257 | elsif ($uname =~ /FreeBSD/) { |
---|
| 258 | $route = $ROUTE; |
---|
| 259 | $dev_re = 'interface:\\s*([[:alnum:]]+)'; |
---|
| 260 | } |
---|
| 261 | |
---|
[2edec46] | 262 | |
---|
[f8fa72b] | 263 | print "$route get $dest\n"; |
---|
| 264 | $rpipe->reader("$route get $dest"); |
---|
[2edec46] | 265 | while (<$rpipe>) { |
---|
[f8fa72b] | 266 | /$dev_re/ && do { |
---|
[2edec46] | 267 | my $iface = $1; |
---|
| 268 | $rpipe->close(); |
---|
[f8fa72b] | 269 | print "matched: $iface\n"; |
---|
[2edec46] | 270 | return $iface; |
---|
| 271 | }; |
---|
| 272 | } |
---|
| 273 | $rpipe->close(); |
---|
| 274 | |
---|
| 275 | die "No route to $dest\n"; |
---|
| 276 | } |
---|
| 277 | |
---|
[2b35261] | 278 | # Return the interface bound to this IP address. If there are more than one, |
---|
| 279 | # the first one returned by ifconfig is the one returned. |
---|
[2edec46] | 280 | sub addr_to_iface { |
---|
| 281 | my($addr) = @_; |
---|
| 282 | my $ipipe = new IO::Pipe() || die "Can't create pipe for ifconfig: $!\n"; |
---|
| 283 | my $iface; |
---|
| 284 | |
---|
| 285 | $ipipe->reader("$IFCONFIG"); |
---|
| 286 | while(<$ipipe>) { |
---|
| 287 | /^([[:alnum:]]+):/ && do { |
---|
| 288 | $iface = $1; |
---|
| 289 | next; |
---|
| 290 | }; |
---|
| 291 | /inet\s+([0-9\.]+)/ && do { |
---|
| 292 | if ($1 eq $addr) { |
---|
| 293 | $ipipe->close(); |
---|
| 294 | return $iface; |
---|
| 295 | } |
---|
| 296 | }; |
---|
| 297 | } |
---|
| 298 | $ipipe->close(); |
---|
| 299 | die "Cannot match $addr to an interface\n"; |
---|
| 300 | } |
---|
| 301 | |
---|
[8d4e4fb] | 302 | sub read_config { |
---|
| 303 | my($file, $map) = @_; |
---|
| 304 | my %param; |
---|
| 305 | my %keywords; |
---|
| 306 | my $f; |
---|
| 307 | |
---|
| 308 | foreach my $k (keys %{$map}) { |
---|
| 309 | if ( $k =~ /(\S+)=[si]/ ) { |
---|
| 310 | $keywords{$1} = $map->{$k}; |
---|
| 311 | $param{$1}++; |
---|
| 312 | } |
---|
| 313 | else { |
---|
| 314 | $keywords{$k} = $map->{$k}; |
---|
| 315 | } |
---|
| 316 | } |
---|
| 317 | |
---|
| 318 | $f = new IO::File($file) || die "Can't open $file: $!\n"; |
---|
| 319 | while (<$f>) { |
---|
| 320 | /^\s*([^:]+):\s*(.*)/ && do { |
---|
| 321 | my $keyw = $1; |
---|
| 322 | my $val = $2; |
---|
| 323 | |
---|
| 324 | $keyw =~ tr [A-Z] [a-z]; |
---|
| 325 | |
---|
| 326 | if ($keywords{$keyw} ) { |
---|
| 327 | if ( $param{$keyw} ) { |
---|
| 328 | if ( ref($keywords{$keyw}) eq 'SCALAR') { |
---|
| 329 | ${$keywords{$keyw}} = $val; |
---|
| 330 | } |
---|
| 331 | elsif( ref($keywords{$keyw}) eq 'ARRAY') { |
---|
| 332 | push(@{$keywords{$keyw}}, $val); |
---|
| 333 | } |
---|
| 334 | else { |
---|
| 335 | die "Unknown variable type for $keyw\n"; |
---|
| 336 | } |
---|
| 337 | } |
---|
| 338 | else { ${$keywords{$keyw}}++; } |
---|
| 339 | } |
---|
| 340 | next; |
---|
| 341 | }; |
---|
| 342 | } |
---|
| 343 | $f->close(); |
---|
| 344 | } |
---|
| 345 | |
---|
| 346 | |
---|
[f8fa72b] | 347 | sub config_filename { |
---|
| 348 | # Find the configuration file in the usual places, if there is one in |
---|
| 349 | # /usr/local/federation/etc, use it, otherwise look in the emulab standard |
---|
| 350 | # filesystems which depends on what experiment and project we're in. |
---|
[8d4e4fb] | 351 | my $pid; |
---|
| 352 | my $eid; |
---|
| 353 | my $filename; |
---|
[f8fa72b] | 354 | my $fed_dir = "/usr/local/federation/etc/"; |
---|
| 355 | my $hn = `hostname`; |
---|
| 356 | chomp $hn; |
---|
| 357 | $hn =~ s/\..*//; |
---|
| 358 | |
---|
| 359 | return "$fed_dir/$hn.gw.conf" if -r "$fed_dir/$hn.gw.conf"; |
---|
| 360 | |
---|
[8d4e4fb] | 361 | my $tmcd = new IO::Pipe() || die "Can't create pipe: $!\n"; |
---|
| 362 | |
---|
| 363 | $tmcd->reader("$TMCC status"); |
---|
| 364 | |
---|
| 365 | while (<$tmcd>) { |
---|
| 366 | chomp; |
---|
| 367 | /ALLOCATED=([^\/]+)\/(\S+)/ && do { |
---|
| 368 | $pid = $1; |
---|
| 369 | $eid = $2; |
---|
| 370 | }; |
---|
| 371 | } |
---|
| 372 | $tmcd->close(); |
---|
| 373 | $filename = "/proj/$pid/exp/$eid/tmp/$hn.gw.conf" |
---|
| 374 | if $pid and $eid; |
---|
| 375 | |
---|
| 376 | return $filename; |
---|
| 377 | } |
---|
| 378 | |
---|
[f8fa72b] | 379 | |
---|
[9b3627e] | 380 | sub client_conf_filename { |
---|
| 381 | # Find the configuration file in the usual places, if there is one in |
---|
| 382 | # /usr/local/federation/etc, use it, otherwise look in the emulab standard |
---|
| 383 | # filesystems which depends on what experiment and project we're in. |
---|
| 384 | my $pid; |
---|
| 385 | my $eid; |
---|
| 386 | my $filename; |
---|
| 387 | my $fed_dir = "/usr/local/federation/etc/"; |
---|
| 388 | |
---|
| 389 | return "$fed_dir/client.conf" if -r "$fed_dir/client.conf"; |
---|
| 390 | |
---|
| 391 | my $tmcd = new IO::Pipe() || die "Can't create pipe: $!\n"; |
---|
| 392 | |
---|
| 393 | $tmcd->reader("$TMCC status"); |
---|
| 394 | |
---|
| 395 | while (<$tmcd>) { |
---|
| 396 | chomp; |
---|
| 397 | /ALLOCATED=([^\/]+)\/(\S+)/ && do { |
---|
| 398 | $pid = $1; |
---|
| 399 | $eid = $2; |
---|
| 400 | }; |
---|
| 401 | } |
---|
| 402 | $tmcd->close(); |
---|
| 403 | $filename = "/proj/$pid/exp/$eid/tmp/client.conf" |
---|
| 404 | if $pid and $eid; |
---|
| 405 | |
---|
| 406 | return $filename; |
---|
| 407 | } |
---|
| 408 | |
---|
[1899afd] | 409 | sub wait_for_port { |
---|
| 410 | my($addr, $port, $timeout, $sleep) = @_; |
---|
| 411 | my $start = time(); |
---|
| 412 | $sleep = 5 unless $sleep; |
---|
| 413 | die "Need both address and port\n" unless $addr && $port; |
---|
| 414 | |
---|
| 415 | my $s; |
---|
| 416 | |
---|
| 417 | while (!$s) { |
---|
[9b3627e] | 418 | # We've seen some arp pollution, so be proactive about clearing the |
---|
| 419 | # cache if we're waiting to get out. |
---|
| 420 | system("arp -d -a"); |
---|
[1899afd] | 421 | if (!($s = new IO::Socket(Domain => &AF_INET, PeerAddr => $addr, |
---|
| 422 | PeerPort => $port))) { |
---|
| 423 | if ($timeout and time() - $start > $timeout) { |
---|
| 424 | return undef; |
---|
| 425 | } |
---|
| 426 | else { sleep($sleep); } |
---|
| 427 | } |
---|
| 428 | } |
---|
| 429 | $s->close(); |
---|
| 430 | return 1; |
---|
| 431 | |
---|
| 432 | } |
---|
| 433 | |
---|
[c3a3fe3] | 434 | sub testcmd_repeat { |
---|
| 435 | my($cmd, $timeout, $sleep) = @_; |
---|
| 436 | my $start = time(); |
---|
| 437 | $sleep = 5 unless $sleep; |
---|
| 438 | |
---|
| 439 | while (1) { |
---|
| 440 | system("$cmd"); |
---|
| 441 | if ($?) { |
---|
| 442 | if ($timeout and time() - $start > $timeout) { |
---|
| 443 | return undef; |
---|
| 444 | } |
---|
| 445 | else { sleep($sleep); } |
---|
| 446 | } |
---|
| 447 | else { return 1; } |
---|
| 448 | } |
---|
| 449 | } |
---|
[1899afd] | 450 | |
---|
[85462fb] | 451 | sub get_ip { |
---|
| 452 | my($name) = @_; |
---|
| 453 | my $gwip; |
---|
| 454 | if ( my $hent = gethostbyname($name) ) { |
---|
| 455 | $gwip = inet_ntoa($hent->addr_list->[0]); |
---|
| 456 | } |
---|
| 457 | return $gwip; |
---|
| 458 | } |
---|
| 459 | |
---|
[2edec46] | 460 | 1; |
---|