wanassign.in 16.8 KB
Newer Older
1
#!/usr/bin/perl -wT
Leigh B. Stoller's avatar
Leigh B. Stoller committed
2 3
#
# EMULAB-COPYRIGHT
Leigh B. Stoller's avatar
Leigh B. Stoller committed
4
# Copyright (c) 2000-2003, 2007 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
5 6
# All rights reserved.
#
7 8 9 10 11 12 13 14 15 16 17 18
use English;
use Getopt::Std;
use Socket;
use IO::Handle;     # thousands of lines just for autoflush :-(

#
# XXX The iface stuff needs fixing. ti0/eth0. Look for strings below!
# 

sub usage()
{
    print STDOUT
19
	"Usage: wanassign [-d] <pid> <eid>\n";
20 21
    exit(-1);
}
22
my  $optlist = "d";
23 24 25 26 27 28

#
# Configure variables
#
my $TB		= "@prefix@";
my $wansolve    = "$TB/libexec/wanlinksolve";
29
my $wansolveargs= "-m 4 -v";
30
my $waninfo     = "$TB/libexec/wanlinkinfo";
31
my $waninfoargs = "-b -m -p";
32 33 34 35 36 37 38

#
# Testbed Support libraries
#
use lib "@prefix@/lib";
use libdb;
use libtestbed;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
39
use Node;
40

41 42 43
# Functions
sub runwansolver();

44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
# Locals
my $debug	= 0;
my $failed	= 0;
my $query_result;

#
# Turn off line buffering on output
#
$| = 1;

# un-taint path
$ENV{'PATH'} = "/bin:/usr/bin:/usr/local/bin:$TB/libexec:$TB/sbin:$TB/bin";
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
if (@ARGV != 2) {
    usage();
}
if (defined($options{"d"})) {
    $debug = 1;
}
my $pid = $ARGV[0];
my $eid = $ARGV[1];

#
# Untaint args.
#
if ($pid =~ /^([-\@\w]+)$/) {
    $pid = $1;
}
else {
    die("Bad data in pid: $pid.");
}
if ($eid =~ /^([-\@\w]+)$/) {
    $eid = $1;
}
else {
    die("Bad data in eid: $eid.");
}

#
# Type map. Map between class and type (node_types table). The table
# is indexed by type, and stores the class.
#
my %typemap		= ();

#
# Hashed array of vnodes and vlans. 
# 
my %virtnodes		= ();
my %virtlans		= ();

#
# Reverse mapping from link pairs to the lan they belong to.
#
my %rlanmap		= ();

#
109
# The mappings we get from the solver.
110 111 112
#
my %mappings;

113 114 115
# Use latest data flag. From the experiments table.
my $uselatestwadata	 = 0;

116 117 118 119
# Wan solver weights. Also from the experiments table.
my $wa_delay_solverweight = 1.0;
my $wa_bw_solverweight    = 7.0;
my $wa_plr_solverweight   = 500.0;
120
my $multiplex_factor;
121

122 123 124
# The BOSS name in the widearea info tables.
my $boss = TBDB_WIDEAREA_LOCALNODE;

125 126 127 128
# Nodes reserved out.
my $DEADPID = NODEDEAD_PID();
my $DEADEID = NODEDEAD_EID();

129 130 131 132 133 134 135 136 137
# Signal error.
sub fatal($)
{
    my ($msg) = @_;
    
    die("*** $0:\n".
	"    $msg\n");
}

138 139 140 141
#
# A node record (poor man struct). We create a hashed array of these,
# indexed by the vnode name.
#
142 143
sub newnode ($$$$$) {
    my ($vname,$type,$isvirt,$isremote,$fixed) = @_;
144 145 146 147 148 149 150 151 152

    printdb("  $vname $type isremote:$isremote isvirt:$isvirt " .
	    ($fixed ? $fixed : "") . " " .
            ($physnode ? $physnode : " ") . "\n");

    $virtnodes{$vname} = {
	VNAME    => $vname,
	TYPE     => $type,
	FIXED    => $fixed,	# tb-fix-node. This is the node name.
153 154
	ISREMOTE => $isremote,
	ISLINKED => 0,		# Member of a link (all we care about).
155 156 157 158 159
	ISVIRT   => $isvirt,    # is a multiplexed node.
	SOLUTION => undef,      # the solver solution. Might be same as FIXED.
	MAPPING  => undef,      # Final mapping. 
    };
}
160 161 162 163 164 165 166 167
sub isremotenode($)	    { return $virtnodes{$_[0]}->{ISREMOTE}; }
sub isfixednode($)	    { return $virtnodes{$_[0]}->{FIXED}; }
sub isvirtnode($)	    { return $virtnodes{$_[0]}->{ISVIRT}; }
sub virtnodetype($)         { return $virtnodes{$_[0]}->{TYPE}; }
sub incvirtnodelinked($)    { return ++$virtnodes{$_[0]}->{ISLINKED}; }
sub virtnodelinked($)       { return $virtnodes{$_[0]}->{ISLINKED}; }
sub virtnodemapping($)      { return $virtnodes{$_[0]}->{MAPPING}; }
sub setvirtnodemapping($$)  { return $virtnodes{$_[0]}->{MAPPING} = $_[1]; }
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184

#
# A lan record (poor man struct). We create a hashed array of these,
# indexed by the vlan name. 
#
sub newvlan ($) {
    my ($vname) = @_;

    $virtlans{$vname} = {
	VNAME    => $vname,
	ISREMOTE => 0,
	MEMBERS  => [],
	COUNT    => 0,
	PARAMS   => {},
    };
}

185
#
186
# Get the various bits we need from the experiments table.
187 188
#
$query_result =
189
    DBQueryFatal("select uselatestwadata,wa_delay_solverweight, ".
190
		 "  wa_bw_solverweight,wa_plr_solverweight,multiplex_factor ".
191
		 " from experiments ".
192
		 "where pid='$pid' and eid='$eid'");
193
($uselatestwadata,$wa_delay_solverweight,
194 195
 $wa_bw_solverweight,$wa_plr_solverweight,$multiplex_factor)
    = $query_result->fetchrow_array();
196 197 198
if ($uselatestwadata) {
    printdb("Using latest widearea data.\n");
}
199 200 201 202 203 204 205 206 207
printdb("Solver weights:\n");
printdb("  Delay:    $wa_delay_solverweight\n");
printdb("  BW:       $wa_bw_solverweight\n");
printdb("  PLR:      $wa_plr_solverweight\n");

# Add the args for the solver.
$wansolveargs .= " -1 $wa_delay_solverweight";
$wansolveargs .= " -2 $wa_bw_solverweight";
$wansolveargs .= " -3 $wa_plr_solverweight";
208

209 210 211
#
# Get type map.
#
212
$query_result =
213 214 215 216 217 218 219 220 221 222 223 224
    DBQueryFatal("select type,class from node_types");

while (my ($type,$class) = $query_result->fetchrow_array()) {
    $typemap{$type} = $class;

    # A class is also a valid type. You know its a class cause type=class.
    if (!defined($typemap{$class})) {
	$typemap{$class} = $class;
    }
}

#
225 226
# Load up virt_nodes. We only care about the virtual nodes that are members
# of links, but we have to read virt_lans to figure that out.
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
#
printdb("Reading virt_nodes ...\n");

$query_result =
    DBQueryFatal("select distinct vname,vn.type,fixed, ".
		 " nt.isremotenode,nt.isvirtnode from virt_nodes as vn ".
		 "left join node_types as nt on ".
		 " nt.type=vn.type or nt.class=vn.type ".
		 "where pid='$pid' and eid='$eid'");

while (my ($vname,$type,$fixed,$isremote,$isvirt) =
       $query_result->fetchrow_array) {
    if (! defined($fixed)) {
	$fixed = 0;
    }

    #
    # if its a vtype, no entry in node_types. vtypes break virtual nodes.
    # Need to look inside the vtype and make sure no mixing of remote and
    # physnodes. Later ...
    #
    if (! defined($isremote)) {
	$isremote = 0;
    }
    if (! defined($isvirt)) {
	$isvirt = 0;
    }
    if ($fixed) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
255 256
	my $node = Node->Lookup($fixed);
	if (! defined($node)) {
257 258
	    fatal("Fixed node error ($vname): No such physnode $fixed!");
	}
259
    }
260
    newnode($vname, $type, $isvirt, $isremote, $fixed);
261 262 263
}

#
264 265 266 267 268
# XXX. At present, we cannot support specific types when using the wan
#      solver (note, all other nodes have already been allocated by
#      assign_wrapper, this includes remote nodes that not members of links).
#      The reason is that the wan solver knows nothing about types, all 
#      it cares about is the metrics. 
269
#
270
# The following code checks to make sure no specific types.
271 272 273
#
foreach my $vnode (keys(%virtnodes)) {
    if (isremotenode($vnode)) {
274
	my $type = virtnodetype($vnode);
275

276
	# See above, type=class for classes!
277 278
	if ($typemap{$type} ne $type) {
	    fatal("Cannot request specific types ($type) for widearea links!");
279
	}
280 281 282 283
    }
}

#
284 285
# Load up the virt lans to find the link characteristics, and to determine
# the actual nodes we care about (those that are members of widearea links).
286 287 288 289 290
#
printdb("Reading virt_lans ...\n");
$query_result =
    DBQueryFatal("select vname,member,delay,bandwidth,lossrate," .
		 "rdelay,rbandwidth,rlossrate " .
291 292 293 294 295 296 297
		 "from virt_lans where pid='$pid' and eid='$eid' and ".
		 "     widearea=1");

if (! $query_result->numrows) {
    print "There are no remote links. This is okay!\n";
    exit(0);
}
298 299 300 301 302 303 304 305 306 307

while (my ($vname,$member,
	   $delay,$bandwidth,$lossrate,
	   $rdelay,$rbandwidth,$rlossrate) = $query_result->fetchrow_array) {
    my ($node) = split(":",$member);

    if (!defined($virtlans{$vname})) {
	newvlan($vname);
    }
    my $virtlan = $virtlans{$vname};
308 309 310
    
    $virtlan->{ISREMOTE} = 1;
    $virtlan->{COUNT}   += 1;
311
    push(@{$virtlan->{MEMBERS}}, $member);
312
    incvirtnodelinked($node);
313 314 315 316 317 318 319 320 321 322 323 324 325 326

    #
    # Create a data structure for the parameters.
    # 
    $virtlan->{PARAMS}{$member} = {
	DELAY       => $delay,
	BW          => $bandwidth,
	PLR         => $lossrate,
	RDELAY      => $rdelay,
	RBW         => $rbandwidth,
	RPLR        => $rlossrate,
    };
}

327 328 329 330 331 332 333 334 335 336 337 338
#
# Kill off any nodes that are not part of widearea links. They
# just get in the way below. Since local nodes can be connected to
# remote nodes in a link, the table might still include non remote
# nodes. 
#
foreach my $vnode (keys(%virtnodes)) {
    if (!virtnodelinked($vnode)) {
	delete($virtnodes{$vnode});
    }
}

339 340 341 342 343 344 345 346 347 348
#
# Check the table, looking for remote nodes in lans.
#
foreach my $vname (keys(%virtlans)) {
    my $virtlan = $virtlans{$vname};
    my @members = @{$virtlan->{MEMBERS}};

    printdb("  $vname isremote:$virtlan->{ISREMOTE} @members\n");

    if ($virtlan->{ISREMOTE} && $virtlan->{COUNT} > 2) {
349
	fatal("Lan $vname has a remote member. Not allowed!");
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365
    }

    # Just debugging.
    foreach my $member (@members) {
	my %params = %{$virtlan->{PARAMS}{$member}};

	printdb("    $member - ");
	foreach my $param (keys(%params)) {
	    printdb("$param:$params{$param} ");
	}
	printdb("\n");
    }

    #
    # Create a reverse mapping from the link members to the lans they
    # are part of. Indexed by names (without ports) since the wansolver
366 367
    # only cares about nodes. This is how we map back a pair of vnodes
    # to the lans the nodes are members of.
368 369 370 371 372 373 374 375 376 377 378 379 380
    #
    foreach my $member1 (@members) {
	my ($node1) = split(":",$member1);
	
	foreach my $member2 (@members) {
	    my ($node2) = split(":",$member2);

	    # No self referential links!
	    if ($node1 eq $node2) {
		next;
	    }

	    if (defined($rlanmap{"$node1:$node2"})) {
381 382
		fatal("Cannot have multiple links bewteen widearea nodes ".
		      "$node1:$node2");
383 384 385 386 387 388 389
	    }
	    $rlanmap{"$node1:$node2"} = $virtlan;
	}
    }
}

#
390
# Run the solver
391
#
392
runwansolver();
393 394 395

#
# Print out the mapping for the caller (assign_wrapper) in a more normalized
396
# format. The caller is responsible for allocating the nodes. 
397
#
398 399
print STDOUT "Node Mapping:\n";

400
foreach my $vnode (sort(keys(%virtnodes))) {
401
    # Local nodes are always allocated in assign_wrapper. 
402 403 404
    if (!isremotenode($vnode)) {
	next;
    }
405
    my $mapping  = virtnodemapping($vnode);
406 407 408

    print STDOUT "$vnode mapsto $mapping\n";
}
409 410
# This print matters. Its how assign_wrapper knows it completed okay.
print STDOUT "Success!\n";
411 412 413 414 415 416 417 418 419 420 421 422 423

exit $failed;

sub printdb {
    if ($debug) {
	print STDERR $_[0];
    }
};

#
# This big ball of goo runs the wan solver.
#
sub runwansolver() {
424
    open(INPUT, ">wanlinkinfo.input") or
425
	fatal("Could not open wanlinkinfo.input: $!");
426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442
    
    #
    # Need the count of remotenodes, plus the boss node if there are
    # connections to the local testbed. We fix the mapping for the boss node.
    # Even worse, it requires knowing the name of the boss.
    #
    my $seenboss    = 0;
    my $remotecount = 0;
	
    foreach my $vnode (sort(keys(%virtnodes))) {
	if (isremotenode($vnode)) {
	    $remotecount++;
	}
	elsif (!$seenboss) {
	    $seenboss = $vnode;
	    $remotecount++;
	}
443 444 445 446 447 448 449 450
    }

    #
    # Start the info program, and pipe in the results. The sad fact is that
    # we have to read the first section to get physical node names for tagging
    # the fixed nodes, but I'm not gonna worry about that right now since the
    # solver will just croak anyway. 
    #
451 452 453
    if ($uselatestwadata) {
	$waninfoargs .= " -l";
    }
454 455 456
    if (! $seenboss) {
	$waninfoargs .= " -r";
    }
457 458 459
    if (defined($multiplex_factor)) {
	$waninfoargs .= " -c $multiplex_factor";
    }
460
    open(INFO, "$waninfo $waninfoargs |") or
461
	fatal("Could not start $waninfo: $!");
462 463

    while (<INFO>) {
464
	print INPUT $_;
465 466 467
    }

    close(INFO) or
468 469
	fatal("$waninfo: " . ($? ? "exited with status $?."
			         : "error closing pipe: $!"));
470 471 472 473 474 475

    #
    # Now send it the second section.
    #
    # Number of v nodes first.
    #
476
    print INPUT "$remotecount\n";
477 478

    #
479
    # Then a list of v nodes. 
480 481 482
    #
    foreach my $vnode (sort(keys(%virtnodes))) {
	if (isremotenode($vnode)) {
483
	    my $tag = $vnode;
484 485 486 487 488

	    #
	    # Check for fixed mappings. 
	    #
	    if (isfixednode($vnode)) {
489
		$tag = "$tag " . isfixednode($vnode);
490
	    }
491
	    print INPUT "$tag\n";
492
	}
493
	elsif ($vnode eq $seenboss) {
494
	    print INPUT "$boss $boss\n";
495 496 497 498
	}
    }

    #
499
    # Now create the delay,bw,and plr matricies. We need to map all local
500 501 502 503 504
    # nodes onto a single row/column. For that, we use the $seenboss value; all
    # local node names are mapped into that name in the matrix (2D hash).
    #
    my %latmatrix	= ();
    my %bwmatrix	= ();
505
    my %plrmatrix     	= ();
506 507 508 509 510 511 512 513 514

    foreach my $vnode1 (keys(%virtnodes)) {
	my $rowname = (!isremotenode($vnode1) ? $seenboss : $vnode1);
	
	foreach my $vnode2 (keys(%virtnodes)) {
	    my $virtlan = $rlanmap{"$vnode1:$vnode2"};
	    my $colname = (!isremotenode($vnode2) ? $seenboss : $vnode2);

	    if ($colname eq $rowname) {
515 516 517
		$latmatrix{$rowname}{$colname}  = -1;
		$bwmatrix{$rowname}{$colname}   = -1;
		$plrmatrix{$rowname}{$colname}  = -1;
518 519 520 521 522 523 524 525 526 527
		next;
	    }
	    if (!defined($virtlan)) {
		# Beware, multiple pairs map to the same spot. Ick.
		if (!defined($latmatrix{$rowname}{$colname})) {
		    $latmatrix{$rowname}{$colname} = -1;
		}
		if (!defined($bwmatrix{$rowname}{$colname})) {
		    $bwmatrix{$rowname}{$colname} = -1;
		}
528 529 530
		if (!defined($plrmatrix{$rowname}{$colname})) {
		    $plrmatrix{$rowname}{$colname} = -1;
		}
531 532 533 534 535 536
		next;
	    }
	    $latmatrix{$rowname}{$colname} =
		findlinkvalue($virtlan, "delay", $vnode1, $vnode2);
	    $bwmatrix{$rowname}{$colname} =
		findlinkvalue($virtlan, "bw", $vnode1, $vnode2);
537 538
	    $plrmatrix{$rowname}{$colname} =
		findlinkvalue($virtlan, "plr", $vnode1, $vnode2);
539 540 541 542 543 544 545 546 547
	}
    }

    #
    # Now print out the matricies.
    # 
    foreach my $vnode1 (sort(keys(%latmatrix))) {
	foreach my $vnode2 (sort(keys(%{ $latmatrix{$vnode1}}))) {
	    printdb("$vnode1:$vnode2($latmatrix{$vnode1}{$vnode2})  ");
548
	    print INPUT "$latmatrix{$vnode1}{$vnode2}  ";
549
	}
550
	print INPUT "\n";
551 552 553 554 555 556
	printdb("\n");
    }

    foreach my $vnode1 (sort(keys(%bwmatrix))) {
	foreach my $vnode2 (sort(keys(%{ $bwmatrix{$vnode1}}))) {
	    printdb("$vnode1:$vnode2($bwmatrix{$vnode1}{$vnode2})  ");
557
	    print INPUT "$bwmatrix{$vnode1}{$vnode2}  ";
558
	}
559
	print INPUT "\n";
560 561
	printdb("\n");
    }
562 563 564 565 566 567 568 569 570

    foreach my $vnode1 (sort(keys(%plrmatrix))) {
	foreach my $vnode2 (sort(keys(%{ $plrmatrix{$vnode1}}))) {
	    printdb("$vnode1:$vnode2($plrmatrix{$vnode1}{$vnode2})  ");
	    print INPUT "$plrmatrix{$vnode1}{$vnode2}  ";
	}
	print INPUT "\n";
	printdb("\n");
    }
571
    close(INPUT) or
572
	fatal("Error closing input file: $!");
573 574 575 576 577 578 579

    #
    # Need to start the wansolver. 
    # We use perl IPC goo to create a child we can both write to and read from
    # (normal perl I/O provides just unidirectional I/O to a process).
    # 
    if (! socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)) {
580
	fatal("socketpair failed: $!");
581 582 583 584 585 586 587 588 589 590 591 592
    }
    CHILD->autoflush(1);
    PARENT->autoflush(1);

    my $childpid = fork();
    if (! $childpid) {
	close CHILD;

	#
	# Dup our descriptors to the parent, and exec the program.
	# The parent then talks to it read/write.
	#
593 594 595
	open(STDIN,  "<&PARENT") || fatal("Cannot redirect stdin");
	open(STDOUT, ">&PARENT") || fatal("Cannot redirect stdout");
	open(STDERR, ">&PARENT") || fatal("Cannot redirect stderr");
596 597 598 599 600 601 602 603 604 605 606

	#
	# Start the solver. We will pipe in the stuff later.
	# Tee does not work here. 
	# 
        exec("cat wanlinkinfo.input | nice $wansolve $wansolveargs");
	#exec("cat /tmp/wansolved");
	die("*** $0:\n".
	    "    exec of $wansolve failed: $!\n");
    }
    close PARENT;
607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622

    #
    # Wait for the child to give us some output. We want to be careful not to
    # let it run too long.
    #
    local $SIG{ALRM} = sub { kill("TERM", $childpid); };
    alarm 120;

    #
    # Read back the solution. 
    #
    while (<CHILD>) {
	printdb($_);

	if ($_ =~ /(\S+)\smapsTo\s(\S+)/) {
	    # XXX
623
	    if ($1 eq $boss) {
624 625 626 627
		next;
	    }
	    my ($pnode)  = split(":", $2);

628
	    if ($pnode eq $boss) {
629
		fatal("Oops, $1 was assigned to boss. That won't work!");
630
	    }
631
	    setvirtnodemapping($1, $pnode);
632 633 634 635 636 637 638
	}
    }
    close(CHILD);

    waitpid($childpid, 0);
    alarm 0;
    if ($?) {
639 640
	fatal((($? == 15) ? "$wansolve timed out looking for a solution."
	                  : "$wansolve failed with status: $?"));
641 642 643
    }

    if ($failed) {
644
	fatal("$wansolve failed to produce a valid result");
645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669
    }
}

#
# Given a lan, and a pair of nodes, find the link entries and return
# the desired one-way parameter.
#
sub findlinkvalue($$$$)
{
    my ($virtlan, $param, $vnode1, $vnode2) = @_;
    my ($member1, $member2);

    foreach my $member (@{$virtlan->{MEMBERS}}) {
	my ($node) = split(":",$member);

	if ($node eq $vnode1) {
	    $member1 = $member;
	    next;
	}
	if ($node eq $vnode2) {
	    $member2 = $member;
	    next;
	}
    }
    if (!defined($member1) || ! defined($member2)) {
670
	fatal("Could not find members for link $vnode1:$vnode2!");
671 672 673 674 675 676 677 678 679 680
    }
    my %param1 = %{$virtlan->{PARAMS}{$member1}};
    my %param2 = %{$virtlan->{PARAMS}{$member2}};

    if ($param eq "bw") {
	return $param1{BW};
    }
    elsif ($param eq "delay") {
	return $param1{DELAY} + $param2{RDELAY};
    }
681 682 683
    elsif ($param eq "plr") {
	return 1 - (1 - $param1{PLR}) * (1 - $param2{RPLR});
    }
684
    else {
685
	fatal("Bad param $param in findlinkvalue!");
686 687
    }
}