mapper.in 32.6 KB
Newer Older
1 2
#!/usr/bin/perl -w
#
3
# Copyright (c) 2000-2018 University of Utah and the Flux Group.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
# 
# {{{EMULAB-LICENSE
# 
# This file is part of the Emulab network testbed software.
# 
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
# 
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public
# License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this file.  If not, see <http://www.gnu.org/licenses/>.
# 
# }}}
23 24 25 26
#
use strict;
use English;
use Getopt::Std;
Leigh B Stoller's avatar
Leigh B Stoller committed
27
use Data::Dumper;
28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
use POSIX qw(setsid ceil);
use POSIX ":sys_wait_h";

#
# This function as the main assign loop.  It converts the virtual
# topology into a top input including LAN and delay translation.  It
# then snapshots the current testbed physical state and runs assign,
# looping a couple times if assign fails.  When assign successfully
# completes it will interpret the results.  Attempt to match any
# existing portmap entries and then update the delays and vlans table.
#
# XXX Internally created nodes (jailhost,delay,sim) are not treated
#     consistently. Needs more thought.
#
# Return codes: We catch all errors with the END block below, and if
# anyone calls die() (exit value is 255) we add in the CANRECOVER bit.
# Failures in assign always cause the caller to stop retrying. 
#
# The CANRECOVER bit indicates 'recoverability' (no db or physical
47
# state was modified by the time the error occurred). This is relevant
48 49 50 51 52 53 54 55 56 57 58
# to only modify operations (update).
#
my $WRAPPER_SUCCESS		 = 0x00;
my $WRAPPER_FAILED		 = 0x01;	# Failed (Add other values)
my  $WRAPPER_FAILED_CANRECOVER   = 0x40;        # Can recover from update
my  $WRAPPER_FAILED_FATALLY      = 0x80;	# Do not use this.
# Set this once we modify DB state; forces no recover in fatal().
my $NoRecover = 0;

sub usage ()
{
59
    print STDERR "Usage: $0 [-v] [-u [-f] | -n] [-z] pid eid\n";
60 61 62 63
    print STDERR " -v   - Enables verbose output\n";
    print STDERR " -u   - Enables update mode\n";
    print STDERR " -f   - Fix current resources during update mode\n";
    print STDERR " -n   - Run assign, but do not reserve/modify resources.\n";
64
    print STDERR " -r   - Regression mode.\n";
65 66
    print STDERR " -x   - Turn on the prepass\n";
    print STDERR " -m   - Set the multiplex factor; overrides experiment.\n";
67 68
    print STDERR " -p   - Do a precheck for mapability on an empty testbed - ".
		 "implies -n\n";
69
    print STDERR " -l   - Use rspec v2 instead of the text file format\n";
70
#    print STDERR " -z   - Force new ptopgen\n";
71
    print STDERR " -Z   - Force old ptopgen\n";
72
    print STDERR " -A   - Tell ptopgen all nodes are free; only with -n\n";
73 74
    exit($WRAPPER_FAILED);
}
75
my $optlist    = "dvunfprqczxm:ko:abltzZACFNL:S:G";
76 77 78
my $verbose    = 0;
my $debug      = 0;
my $fixmode    = 0;
79
my $fixlannodes= 0;
80 81 82
my $updating   = 0;
my $impotent   = 0;
my $precheck   = 0;
83
my $allnodesfree = 0;
Leigh B Stoller's avatar
Leigh B Stoller committed
84
my $toponly    = 0;
85
my $prepass    = 0;
86
my $alloconly  = 0;
87
my $commitmode = 0;
88
my $gblinkcheck= 0;
89
my $outfile;
90
my $mfactor;
91
my $packoption;
92
my $regression = 0;
93
my $noassign   = 0;  # Only with regression mode, use previous solution.
94 95
my $noregfree  = 0;  # Only with regression mode, leave physical state at end.
my $usecurrent = 0;  # Only with regression mode, use current solution.
96
my $assignfile;
97 98 99
my $quiet      = 0;
my $clear      = 0;
my $warnings   = 0;
100
my $maxrun     = 3;  # Maximum number of times we run assign.
101
my $gotlock    = 0;
102
my $seriallock = 0;
103
my $userspec   = 0;
104
my $usecontrol = 0;
105
my $use_old_ptopgen  = 0;
106
my $vtop;
107
my $retval;
108 109 110 111 112

#
# Configure variables
#
my $TB		= "@prefix@";
113
my $MAINSITE    = @TBMAINSITE@;
114
my $DBNAME	= "@TBDBNAME@";
115 116 117 118
my $TBOPS       = "@TBOPSEMAIL@";
my $ASSIGN      = "$TB/libexec/assign";
my $WRAPPER2    = "$TB/libexec/assign_wrapper2";
my $PTOPGEN     = "$TB/libexec/ptopgen";
119
my $PTOPGEN_NEW = "$TB/libexec/ptopgen_new";
120
my $VTOPGEN     = "$TB/bin/vtopgen";
121
my $NFREE       = "$TB/bin/nfree";
Leigh B Stoller's avatar
Leigh B Stoller committed
122
my $PREDICT     = "$TB/sbin/predict";
123
my $XERCES	= "@HAVE_XERCES@";
124 125 126 127 128 129

#
# Load the Testbed support stuff. 
#
use lib "@prefix@/lib";
use libdb;
Leigh B Stoller's avatar
Leigh B Stoller committed
130
use emutil;
131 132 133 134
use libtestbed;
use libtblog;
use libvtop;
use libadminctrl;
135
use libEmulab;
136
use User;
137
use EmulabFeatures;
138
use Reservation;
139 140 141 142 143 144

# Protos
sub fatal(@);
sub debug($);
sub chat($);
sub RunAssign($$);
145
sub FinalizeRegression($);
146
sub AssignLoop();
147
sub MapperWrapper(;$);
148
sub PrintSolution();
Leigh B Stoller's avatar
Leigh B Stoller committed
149
sub DumpReservationInfo($$);
150 151 152 153 154 155

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

# Turn off line buffering on output
156 157 158 159 160 161 162 163 164 165
$| = 1;

#
# We want warnings to cause assign_wrapper to exit abnormally.
# 
# FIXME: Is this still needed.  "warn" is only used once.  Also this
#  will cause perl internal warnings (such as "Use of uninitialized
#  value ..."  to cause assign_wrapper to fail. -- kevina
#
$SIG{__WARN__} = sub { tbwarn $_[0];$warnings++; };
166 167 168 169 170 171 172 173 174 175 176 177 178

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
my %options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
if (@ARGV < 2) {
    usage();
}
if (defined($options{"v"})) {
179
    TBDebugTimeStampsOn();
180 181
    $verbose++;
}
182 183 184
if (defined($options{"a"})) {
    $alloconly++;
}
185 186 187
if (defined($options{"b"})) {
    $commitmode++;
}
188 189 190
if (defined($options{"A"})) {
    $allnodesfree++;
}
191 192 193
if (defined($options{"d"})) {
    $debug++;
}
194 195 196
if (defined($options{"u"})) {
    $updating = 1;
}
Leigh B Stoller's avatar
Leigh B Stoller committed
197 198 199 200
if (defined($options{"t"})) {
    $toponly = 1;
    $quiet   = 1;
}
201 202 203
if (defined($options{"n"})) {
    $impotent = 1;
}
204 205 206 207 208 209
if (defined($options{"N"})) {
    $noassign = 1;
}
if (defined($options{"L"})) {
    $assignfile = $options{"L"};
}
210 211 212
if (defined($options{"f"})) {
    $fixmode = 1;
}
213 214 215
if (defined($options{"F"})) {
    $fixlannodes = 1;
}
216 217 218
if (defined($options{"G"})) {
    $gblinkcheck = 1;
}
219 220 221 222 223
if (defined($options{"S"})) {
    $packoption = $options{"S"};
    fatal("Bad -S option; must be pack or balance")
	if (! ($packoption eq "balance" || $packoption eq "pack"));
}
224 225 226
if (defined($options{"p"})) {
    $precheck = 1;
}
227 228 229
if (defined($options{"x"})) {
    $prepass = 1;
}
230 231 232
if (defined($options{"o"})) {
    $outfile = $options{"o"};
}
233 234 235
if (defined($options{"m"})) {
    $mfactor = $options{"m"};
}
236 237 238 239 240
if (defined($options{"r"})) {
    if ($DBNAME eq "tbdb") {
	fatal("Cannot use regression mode on main DB");
    }
    $regression = 1;
Leigh B Stoller's avatar
Leigh B Stoller committed
241 242
    $clear      = 1
	if (!defined($options{"t"}));
243
    $fixmode    = 1;
244
    TBDebugTimeStampsOn();
245
    $usecurrent = 1
246
	if (defined($options{"z"}));
247 248
    $noregfree = 1
	if (defined($options{"k"}));
249 250 251 252 253 254 255
}
if (defined($options{"q"})) {
    $quiet = 1;
}
if (defined($options{"c"})) {
    $clear = 1;
}
256 257 258
if (defined($options{"C"})) {
    $usecontrol = 1;
}
259
if (defined($options{"l"})) {
260 261 262 263 264
    if ($XERCES) {
	$userspec = 1;
    } else {
	fatal("Rspec v2 support requires that Xerces be installed");
    }
265
}
266 267 268
if (defined($options{"Z"})) {
    $use_old_ptopgen = 1;
}
269
if (defined($options{"z"})) {
270 271
#    $use_old_ptopgen = 0;
#    $PTOPGEN = $PTOPGEN_NEW;
272
}
273 274 275
if ($allnodesfree && !$impotent) {
    fatal("Not allowed to use -A without -n (impotent) option");
}
276 277 278 279 280 281 282

my $pid = $ARGV[0];
my $eid = $ARGV[1];
my $experiment = Experiment->Lookup($pid, $eid);
if (!defined($experiment)) {
    fatal("Could not lookup experiment object $pid,$eid!")
}
283 284
my $project = $experiment->GetProject();

285 286 287 288 289 290 291 292 293 294 295
#
# Verify that this person can muck with the experiment.
#
my $this_user = User->ThisUser();
if (! defined($this_user)) {
    tbdie("You ($UID) do not exist!");
}
if (!TBAdmin() &&
    ! $experiment->AccessCheck($this_user, TB_EXPT_DESTROY)) {
    fatal("You do not have permission to map this experiment!");
}
296
my $real_user = User->RealUser();
297

298 299 300
# multiplex_factor default.
$mfactor = $experiment->multiplex_factor()
    if (!defined($mfactor) && defined($experiment->multiplex_factor()));
301 302
$packoption = $experiment->packing_strategy()
    if (!defined($packoption) && defined($experiment->packing_strategy()));
Leigh B Stoller's avatar
Leigh B Stoller committed
303 304
# NS file can say to run the prepass.
my $useprepass = $experiment->useprepass();
305 306 307 308 309

my $newassign =
    EmulabFeatures->FeatureEnabled("NewAssign",
				   $this_user,
				   $experiment->GetGroup(), $experiment);
310 311 312 313 314 315 316 317 318 319 320 321 322
if (!$usecontrol) {
    $usecontrol =
	EmulabFeatures->FeatureEnabled("ControlNetVlans",
				       $this_user,
				       $experiment->GetGroup(), $experiment);
    if ($usecontrol) {
	chat("Telling ptopgen to use control network vlans\n");
    }
}
if ($usecontrol && $MAINSITE) {
    $debug   = 1;
    $verbose = 1;
}
323

324 325 326 327 328 329 330
# XXX Hacky!
if ($MAINSITE && $TB ne "/usr/testbed") {
    $debug   = 1;
    $verbose = 1;
    $fixlannodes = $fixmode;
}

331
libvtop::Init($this_user, $experiment->GetGroup(), $experiment);
332
    
333 334 335 336 337 338
#
# These are the flags to the vtop creation code. 
#
my $vtopflags = 0;
$vtopflags |= $libvtop::VTOP_FLAGS_VERBOSE
    if ($verbose);
339 340
$vtopflags |= $libvtop::VTOP_FLAGS_QUIET
    if ($quiet);
341 342 343
$vtopflags |= $libvtop::VTOP_FLAGS_UPDATE
    if ($updating);
$vtopflags |= $libvtop::VTOP_FLAGS_FIXNODES
344
    if ($fixmode || $usecurrent);
345 346
$vtopflags |= $libvtop::VTOP_FLAGS_FIXLANNODES
    if ($fixlannodes);
347 348
$vtopflags |= $libvtop::VTOP_FLAGS_IMPOTENT
    if ($impotent);
349 350
$vtopflags |= $libvtop::VTOP_FLAGS_ALLOCONLY
    if ($alloconly);
351 352
$vtopflags |= $libvtop::VTOP_FLAGS_COMMITMODE
    if ($commitmode);
353 354
$vtopflags |= $libvtop::VTOP_FLAGS_REGRESSION
    if ($regression);
355

356
if (IsMultiPCArchitecture() && !$assignfile) {
357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372
    my @architectures = PCArchitectures();

    $vtop = libvtop->Create($experiment, $this_user, $vtopflags, $real_user);
    if (!defined($vtop)) {
	fatal("Could not create vtop structure for $experiment");
    }
    $vtop->CreateVtop() == 0
	or fatal("Could not create vtop for $experiment");

    #
    # If all nodes are explicitly typed, we run the mapper normally.
    #
    if ($vtop->AllNodesTyped()) {
	$retval = MapperWrapper();
    }
    else {
373 374
	my $ordered = 0;
	
375 376 377 378 379 380 381 382 383
	#
	# If all of the typed nodes are of one type, then try assign with
	# that type first. In other words, set the order in which to try the
	# different types, according to how many nodes of that architecture.
	#
	my %architectures = map { $_ => 0 } @architectures;

	foreach my $type (keys(%{ $vtop->types() })) {
	    $type = NodeType->Lookup($type);
384

385 386 387 388 389
	    # If no architecture defined for this type, then we do not count.
	    if (defined($type->architecture())) {
		$architectures{$type->architecture()} +=
		    $vtop->types()->{$type->type()};
	    }
390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406
	    $ordered += $vtop->types()->{$type->type()};
	}
	#
	# If no types specified, and thus no implied ordering, then we
	# fall back to the ordering specified in the sitevar.
	#
	if (!$ordered) {
	    my $string   = GetSiteVar("general/architecture_priority");
	    my @archs    = split(",", $string);
	    my $count    = scalar(@archs);

	    print "Forcing architecture ordering: @archs\n";
	    
	    foreach my $arch (@archs) {
		# Set decreasing count for sort below.
		$architectures{$arch} = $count--;
	    }
407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425
	}
	# sort the array.
	@architectures = sort { $architectures{$b} <=>
				    $architectures{$a} } keys(%architectures);

	#
	# Run through each architecture.
	#
	foreach my $architecture (@architectures) {
	    $retval = MapperWrapper($architecture);
	    last
		if (!$retval);
	    #
	    # If we managed to reserve any nodes, we have to free them
	    # before moving onto the next architecture. 
	    #
	    if ($vtop->newreservednodes()) {
		my @newreservednodes = $vtop->newreservednodes();
		if (system("$NFREE -x $pid $eid @newreservednodes")) {
426 427
		    # Clear this so that we do not try again in fatal();
		    $vtop->clearnewreserved();
428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
		    fatal("Could not release new nodes after $architecture");
		}
		# Kill this, we are done with it now that nodes are released
		# (do not want to release them again). 
		$vtop = undef;
	    }
	}
    }
    if (ref($retval)) {
	fatal(@{ $retval });
    }
}
else {
    my $retval = MapperWrapper();
    if (ref($retval)) {
	fatal(@{ $retval });
    }
}
446 447 448 449 450 451
if ($regression) {
    if (0) {
	$updating   = 1;
	$fixmode    = 1;
	$clear      = 0;
	$vtopflags |=
452 453
	    ($libvtop::VTOP_FLAGS_UPDATE|$libvtop::VTOP_FLAGS_FIXLANNODES|
	     $libvtop::VTOP_FLAGS_FIXNODES);
454

455 456 457
	MapperWrapper();
    }
    FinalizeRegression(0);
458
}
459 460
PrintSolution()
    if ($outfile);
461
exit(0);
462

463
sub MapperWrapper(;$)
464
{
465 466
    my ($architecture) = @_;
    
Leigh B Stoller's avatar
Leigh B Stoller committed
467 468
    chat("Starting the new and improved mapper wrapper.\n")
	if (!$toponly);
469 470
    chat("Forcing untyped nodes to $architecture\n")
	if (defined($architecture));
471

Leigh B Stoller's avatar
Leigh B Stoller committed
472 473 474 475 476
    # Need to do this cause libvtop will add them again.
    # Must be done before nodes are released.
    $experiment->DeleteInternalProgramAgents()
	if ($regression);

477
    TBDebugTimeStamp("Create libvtop started");
478
    $vtop = libvtop->Create($experiment, $this_user, $vtopflags, $real_user);
479 480 481 482
    if (!defined($vtop)) {
	fatal("Could not create vtop structure for $experiment");
    }
    TBDebugTimeStamp("Create libvtop ended");
Leigh B Stoller's avatar
Leigh B Stoller committed
483

Leigh B Stoller's avatar
Leigh B Stoller committed
484
    TBDebugTimeStamp("vtopgen started");
485
    $vtop->CreateVtop($architecture) == 0
Leigh B Stoller's avatar
Leigh B Stoller committed
486 487 488
	or fatal("Could not create vtop for $experiment");
    TBDebugTimeStamp("vtopgen finished");
    
489
    if (!$impotent && !$alloconly && !$toponly && ($updating || $clear)) {
490 491 492 493 494 495 496 497 498 499
	if ($clear) {
	    chat("Freeing reserved nodes ...\n");
	    system("export NORELOAD=1; $NFREE -x -a $pid $eid") == 0
		or fatal("Could not release nodes.");
	}
	chat("Clearing physical state before updating.\n");
	$experiment->RemovePhysicalState();
	exit(0)
	    if ($clear && !$regression);
    }
500 501 502 503 504
    if (!$toponly && $gblinkcheck) {
	if ($vtop->gblinks() && $vtop->mgblinks()) {
	    fatal("Not allowed to mix <=1Gb and >1Gb links");
	}
    }
505
    return AssignLoop();
506
}
507 508 509 510

#
# The assign loop. 
#
511 512 513 514
sub AssignLoop()
{
    my $currentrun     = 1;
    my $canceled       = 0;
515
    my $progress       = 0;
516 517 518
    my $tried_precheck = 0;
    # Admission control counts
    my %admission_control = ();
519

520 521 522 523 524
    # XXX plab hack - only run assign once on plab topologies, since
    # they're easy to map and the physical topology does not change
    # frequently.
    if ($vtop->plabcount() && $vtop->plabcount == $vtop->virtnodecount()) {
	$maxrun = 2;
525 526
    }

527 528
    TBDebugTimeStamp("mapper loop started");
    while (1) {
529
	chat("Mapper loop $currentrun\n");
530

531
	my $prefix = "$pid-$eid-$$";
532 533

	#
534
	# When precheck is on, we only do one run in impotent mode and exit.
535
	#
536 537 538 539 540
	if ($precheck) {
	    $prefix  .= ".empty";
	    $impotent = 1;
	    chat("Trying assign on an empty testbed.\n");
	}
541

542 543 544
	#
	# Serialize with the pool daemon if using shared nodes.
	#
545
	if ((!($impotent || $regression)) && $vtop->sharednodecount()) {
546
	    while (1) {
547 548 549 550
		#
		# Use a countup/countdown counter, so that multiple mappers
		# can run, but not while the pool_daemon is running.
		#
551
		my $lock_result =
552 553 554 555
		    DBQueryFatal("update emulab_locks set value=value+1 ".
				 "where name='pool_daemon' and value>=0");

		$gotlock = $lock_result->affectedrows;
556 557 558 559 560

		last
		    if ($gotlock);
		
		chat("Waiting for pool daemon lock ...\n");
561
		sleep(10);
562 563
	    }
	}
564
	# Hack for Kirk.
565
	if (!($impotent || $regression) &&
566
	    ($pid eq "MobiCom2017" || $project->IsNonLocal())) {
567
	    while (1) {
568
		if (libEmulab::EmulabCountLock("mapperlock", 3) == 0) {
569 570 571 572 573 574 575 576
		    $seriallock = 1;
		    last;
		}
		chat("Waiting for mapper lock ...\n");
		sleep(5);
	    }
	}
	
577 578 579 580
	#
	# RunAssign returns  0 if successful.
	#           returns -1 if failure, but assign says to stop trying.
	#           returns  1 if failure, but assign says to try again.
581 582
	#           returns  2 if assign succeeds, but no nodes allocated.
	#           returns  3 if assign succeeds, but some nodes allocated.
583 584 585
	#
	my $retval = RunAssign($precheck, $prefix);

586
	if ($gotlock) {
587 588 589
	    DBQueryFatal("update emulab_locks set value=value-1 ".
			 "where name='pool_daemon'");
	    $gotlock = 0;
590
	}
591
	if ($seriallock) {
592
	    libEmulab::EmulabCountUnlock("mapperlock");
593 594
	    $seriallock = 0;
	}
595

596 597 598 599 600 601 602 603 604 605 606
	# Success!
	last
	    if ($retval == 0);

	if ($retval < 0 || $regression) {
	    #
	    # Failure in assign.
	    #
	    FinalizeRegression(1)
		if ($regression);

607 608 609
	    return [{type  => 'primary', severity => SEV_ERROR,
		     error => ['unretriable_assign_error']},
		    "Unretriable error. Giving up."];
610
	}
611
    
612 613 614
	#
	# When precheck is off, we do a precheck run if the first try fails
	# to find a solution. This avoids looping on an unsolvable topology.
615 616 617
	# But, if the reason we are here is cause we could not allocate nodes,
	# then we found a solution, and so trying on an empty testbed is
	# pointless; it will obviously find a solution again.
618
	#
619 620 621
	if (!$precheck && !$tried_precheck && ($retval == 2 || $retval == 3)) {
	    $tried_precheck = 1;
	}
622 623 624 625 626 627
	if (!$precheck && !$tried_precheck) {
	    chat("Trying assign on an empty testbed to verify mapability.\n");
	    my $save_impotent = $impotent;
	    $impotent  = 1;
	    my $retval = RunAssign(1, $prefix . ".empty");
	    if ($retval != 0) {
628 629
		return [{type=>'extra', cause=>'user', severity=>SEV_ERROR,
			 error=>['infeasible_resource_assignment']}, 
Leigh B Stoller's avatar
Leigh B Stoller committed
630
			"*** This experiment cannot be instantiated on this ".
631 632 633 634 635 636
			"testbed. You have most likely asked for hardware ".
			"this testbed does not have, such as nodes of a type ".
			"it does not contain, or nodes with too many network ".
			"interfaces.  You will need to modify this experiment ".
			"before it can be swapped in - re-submitting the ".
			"experiment as-is will always result in failure."];
637 638 639 640
	    }
	    chat("Assign succeeded on an empty testbed.\n");
	    $impotent = $save_impotent;
	    $tried_precheck = 1;
641
	}
642 643 644 645
	# We try a minimum number of times, cause the node pool is
	# always changing. But once we hit the maxrun, we continue
	# only if progress on the last loop.
	if ($currentrun >= $maxrun && !$progress) {
646 647 648
	    return [{type => 'primary', severity => SEV_ERROR,
		     error => ['reached_assign_run_limit']},
		    "Reached run limit. Giving up."];
649
	}
650 651 652
	# See if we made progress or not.
	# Keep going if we allocated some nodes.
	$progress = ($retval == 3);
653

654 655 656 657
	# A little bit of backoff after failure. 
	my $sval = int(rand($currentrun * 3)) + 3;
	chat("Waiting $sval seconds and trying again...\n");
	sleep($sval);
658 659
	$currentrun++;
    }
660
    GatherAssignStats($pid, $eid, %{ $vtop->exptstats() })
Leigh B Stoller's avatar
Leigh B Stoller committed
661
	if (! ($impotent || $alloconly || $regression || $toponly));
662 663
    TBDebugTimeStamp("mapper loop finished");
    return 0;
664 665 666 667 668 669 670 671 672
}

#
# The guts of an assign run.
#
sub RunAssign($$)
{
    my ($precheck, $prefix) = @_;

673
    my $typelimitfile = $prefix .".limits";
674 675
    my $ptopfile = $prefix . ".ptop";
    my $vtopfile = $prefix . ".vtop";
676 677 678 679
    if ($userspec) {
	$ptopfile .= ".xml";
	$vtopfile .= ".xml";
    }
680
    my $assignexitcode = 0;
Leigh B Stoller's avatar
Leigh B Stoller committed
681 682
    my $assignlog  = "assign.log";
    my $resinfolog = "resinfo.log";
683

Leigh B Stoller's avatar
Leigh B Stoller committed
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702
    #
    # Now generate a vtop file and dump it to a file.
    #
    if (! open(VTOPFILE, "> $vtopfile")) {
	tberror("Could not open $vtopfile: $!\n");
	return -1;
    }
    my $reslibvtop;
    if ($userspec == 1) {
	$reslibvtop = $vtop->PrintRspec(*VTOPFILE);
    }
    else {
	$reslibvtop = $vtop->PrintTop(*VTOPFILE);
    }
    if ($reslibvtop != 0) {
	tberror("Could not print vtop file for $experiment\n");
	return -1;
    }
    close(VTOPFILE);
703
    system("/bin/cp -fp $vtopfile ${pid}-${eid}.vtop") if ($debug);
Leigh B Stoller's avatar
Leigh B Stoller committed
704 705 706
    return 0
	if ($toponly);

707
    if (! ($impotent || $regression)) {
708 709 710 711 712 713 714 715 716 717 718 719 720
	if ($experiment->Update({"maximum_nodes" => $vtop->maximum_nodes(),
				 "minimum_nodes" => $vtop->minimum_nodes(),
				 "virtnode_count"=> $vtop->virtnodecount() })){
	    tberror("Could not update min/max/virt nodes for $experiment\n");
	    return -1;
	}
    }
    # New solution each time.
    $vtop->ClearSolution();

    goto skipassign
	if ($vtop->nodecount() == $vtop->genicount());

721 722 723 724 725 726
    # Debugging hack.
    if ($regression || $noassign || $assignfile) {
	$assignlog = $assignfile
	    if ($assignfile);
	
	if (! -e $assignlog) {
727 728 729 730 731 732 733
	    chat("No existing assign results file!\n");
	    return -1;
	}
	chat("Using existing assign results file\n");
	goto skiprun;
    }
    
734 735 736 737
    #
    # Do admission control test, and gather the info.
    #
    my %admission_control;
738 739 740 741 742 743
    if (!$regression) {
	if (!TBAdmissionControlCheck(undef, $experiment, \%admission_control)){
	    tberror("Failed admission control checks!\n");
	    return -1;
	}
    }
744

745
    # Bound the results to avoid future reservation conflicts.
746
    Reservation->FlushAll();
Leigh B Stoller's avatar
Leigh B Stoller committed
747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772
    my $reservation_bounds = Reservation->MaxSwapInMap($experiment);
    # Dump to file.
    DumpReservationInfo($resinfolog, $reservation_bounds);
    foreach my $type (keys(%$reservation_bounds)) {
	if (exists($admission_control{$type})) {
	    if ($reservation_bounds->{$type} < $admission_control{$type}) {
		$admission_control{$type} = $reservation_bounds->{$type};
	    }
	}
	else {
	    $admission_control{$type} = $reservation_bounds->{$type};
	}
	#
	# Look to see if topology specifies nodes with this specific
	# type. If so, we can tell right away that the user is asking for
	# more then is available.
	#
	# This only works for nodes with hard types. Auxtypes and vtypes
	# will still need to go through assign. Might be able to handle
	# auxtypes though.
	#
	if (exists($vtop->types()->{$type})) {
	    my $bound  = $reservation_bounds->{$type};
	    my $wanted = $vtop->types()->{$type};

	    if ($wanted > $bound) {
773 774 775 776 777 778 779
		tberror({type => 'primary', cause => 'temp',
			 severity => SEV_ERROR,
			 error => ['admission_control_failure']},
		"*** Resource reservation violation: ".
		"$wanted nodes of type $type requested, but only $bound ".
		"available because of existing resource reservations ".
		"to other projects.\n");
Leigh B Stoller's avatar
Leigh B Stoller committed
780 781
		# Unretriable error
		return -1;
782 783 784 785
	    }
	}
    }
    
786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801
    #
    # Append this admission control results to ptopgen.
    #
    if (scalar(keys(%admission_control))) {
	open(TYPELIMIT, ">$typelimitfile") or
	    return -1;

	foreach my $typeclass (keys(%admission_control)) {
	    my $count = $admission_control{$typeclass};

	    print TYPELIMIT "$typeclass $count\n";
	}
	close(TYPELIMIT);
    }


802 803 804 805 806 807 808 809 810 811 812
    #
    # Snapshot physical resources.
    #
    # if updating (-u), include any resources that may already be
    # allocated to experiment in the PTOP results.
    #
    my $ptopargs = "-p $pid ";
    $ptopargs   .= "-e $eid "
	if ($updating);
    $ptopargs   .= "-u "
	if ($updating && $experiment->elabinelab());
813 814
    $ptopargs   .= "-m $mfactor "
	if (defined($mfactor));
815 816
    $ptopargs   .= "-C "
	if ($usecontrol);
817 818 819 820 821 822
    $ptopargs   .= "-v "
	if ($vtop->virtnodecount());
    $ptopargs   .= "-r "
	if ($vtop->remotenodecount());
    $ptopargs   .= "-S "
	if ($vtop->simnodecount());
823 824
    $ptopargs   .= "-h "
	if ($vtop->sharednodecount());
825 826
    $ptopargs   .= "-b "
	if ($vtop->bstorecount());
827
    $ptopargs	.= "-a "
828
    	if ($precheck || $allnodesfree);
829 830
    $ptopargs	.= "-c " . $experiment->delay_capacity() . " "
    	if (defined($experiment->delay_capacity()));
831 832 833
    if ($userspec == 1) {
	$ptopargs .= "-x -g 2 ";
    }
834 835
    if ($use_old_ptopgen == 1) {
	$ptopargs .= "-Z ";
836
    }
837 838
    $ptopargs .= "-z "
	if ($project->IsNonLocal() || $vtop->sharednodecount());
839 840 841 842 843 844
    if ($gblinkcheck) {
	if ($vtop->mgblinks() == 0) {
	    $ptopargs .= "-G ";
	}
    }
    $ptopargs .= "-l $typelimitfile "
845
	if (scalar(keys(%admission_control)));
846 847 848 849 850

    chat("ptopargs: '$ptopargs'\n");
    TBDebugTimeStamp("ptopgen started");
    system("$PTOPGEN $ptopargs > $ptopfile");
    if ($?) {
851 852
	tberror("Failure in ptopgen\n");
	return -1;
853
    }
854
    system("/bin/cp -fp $ptopfile ${pid}-${eid}.ptop") if ($debug);
855 856 857
    TBDebugTimeStamp("ptopgen finished");

    # Run assign
858
    my $cmd  = "assign";
859 860
    $cmd .= "-new"
	if ($newassign);
861
    my $args = "";
862 863 864 865 866 867
    if ($XERCES) {
	$args .= "-f rspec " 
	    if ($userspec == 1);
	$args .= "-f text "
	    if ($userspec == 0);
    }
868
    $args .= "$ptopfile $vtopfile";
869
    $args = "-P $args"
870
	if (!$vtop->sharednodecount());
871 872
    $args = "-F $args"
	if (!$updating);
873
    $args = "-uod -c .75 $args"
874
	if ($vtop->virtnodecount() || $vtop->simnodecount());
875 876
    $args = "-H 3 $args"
	if ($vtop->virtnodecount() < 200);
877 878
    $args = "-n $args"
    	if ($precheck);
879 880
    $args = "-S $packoption $args"
    	if (defined($packoption));
881 882
    $args = "-s 123456 $args"
	if ($regression);
883
    $args = "-R $args PN=1.0"
Leigh B Stoller's avatar
Leigh B Stoller committed
884
	if (0 && $vtop->sharednodecount());
885
    
886
    # The prepass speeds up assign on big topos with virtual nodes.
Leigh B Stoller's avatar
Leigh B Stoller committed
887
    if ($prepass || $useprepass) {
888 889 890 891
    	$cmd = "assign_prepass";
    	$args = "-m $mfactor $args"
    	    if (defined($mfactor));
    }
892 893 894 895 896 897
    chat("assign command: '$cmd $args'\n");

    #
    # Fork a child to run assign. Parent spins watching the cancel flag
    # and waiting for assign to finish.
    #
898
    TBDebugTimeStamp("assign started");
899 900 901 902 903 904 905 906 907 908 909 910 911 912 913
    if (my $childpid = fork()) {
	while (1) {
	    sleep(2);

	    if (waitpid($childpid, &WNOHANG) == $childpid) {
		$assignexitcode = $? >> 8;
		last;
	    }

	    # Check cancel flag.
	    if ($experiment->canceled()) {
		if ((my $pgrp = getpgrp($childpid)) > 0) {
		    kill('TERM', -$pgrp);
		    waitpid($childpid, 0);

914 915 916
		    tberror({cause => 'canceled', severity => SEV_IMMEDIATE,
			     error => ['cancel_flag']},
			    "Cancel flag set; aborting assign run!\n");
917 918 919 920 921 922 923 924 925 926 927 928
		    return -1;
		}
		# Loop again to reap child above before exit.
	    }
	}
    }
    else {
	#
	# Change our session so the child can get a killpg without killing
	# the parent. 
	#
        POSIX::setsid();
929
	exec("nice $WRAPPER2 $cmd $args > $assignlog 2>&1");
930 931
	die("Could not start assign!\n");
    }
932
    TBDebugTimeStamp("assign finished");
933 934 935

    # Check cancel flag before continuing. 
    if ($experiment->canceled()) {
936 937 938
	tberror({cause => 'canceled', severity => SEV_IMMEDIATE,
		 error => ['cancel_flag']},
		"Cancel flag set; aborting assign run!\n");
939 940 941 942
	return -1;
    }

    # Check for possible full filesystem ...
943 944
    if (-z $assignlog) {
	tbnotice("$assignlog is zero length! Stopping ...\n");
945 946 947 948 949 950 951 952 953
	return -1;
    }

    #
    # Saving up assign.log coz each swapin/modify is different and it
    # is nice to have every mapping for debugging and archiving
    # purposes We do not call it .log though, since we do not want it
    # copied out to the user directory every swapin. See Experiment.pm
    #
954 955
    system("/bin/cp -fp $assignlog ${prefix}.assign");
    system("/bin/cp -fp $assignlog ${pid}-${eid}.assign") if ($debug);
Leigh B Stoller's avatar
Leigh B Stoller committed
956
    system("/bin/cp -fp $resinfolog ${prefix}-${resinfolog}");
957 958

    if ($assignexitcode) {
959 960
	print "Assign exited with $assignexitcode\n" if ($debug);
	
961
	system("/bin/cat $assignlog");
Leigh B Stoller's avatar
Leigh B Stoller committed
962
	
963 964 965 966 967 968 969 970
	#
	# assign returns two positive error codes (that we care about).
	# The distinction between them is somewhat murky. An exitval of
	# 1 means "retryable" while 2 means "unretryable". The former
	# means we can try again, while the later says there is no possible
	# way to map it. We pass this back to the caller so that we know
	# to exit the loop or try again.
	#
971 972 973 974 975 976 977
	return (($assignexitcode == 1) ? 1 : -1);
    }
    #
    # If we were doing the precheck, go ahead and exit now - there is no
    # useful information to parse out
    #
    if ($precheck) {
978
	chat("Precheck succeeded.\n");
979 980
	return 0;
    }
981
  skiprun:
982
    chat("Reading assign results.\n");
983
    if (!open(ASSIGNFP, $assignlog)) {
984 985 986
	print("Could not open assign logfile! $!\n");
	return -1;
    }
987
    TBDebugTimeStamp("ReadSolution started");
988
    if ($vtop->ReadTextSolution(*ASSIGNFP) != 0) {
989 990 991 992
	print("Could not parse assign logfile! $!\n");
	return -1;
    }
    close(ASSIGNFP);
993
    TBDebugTimeStamp("ReadSolution ended");
994
  skipassign:
995
    
996
    if (defined($vtop->genicount())) {
997 998 999 1000 1001 1002 1003 1004
	TBDebugTimeStamp("Map Geni Resources Started");
	if ($vtop->MapResources() != 0) {
	    print("Could not map external resources! $!\n");
	    return -1;
	}
	TBDebugTimeStamp("Map Geni Resources ended");
    }
    TBDebugTimeStamp("InterpNodes Started");
1005 1006 1007 1008
    if ($vtop->InterpNodes() != 0) {
	print("Could not interpret nodes.\n");
	return -1;
    }
1009
    TBDebugTimeStamp("InterpNodes ended, AllocNodes Started");
1010 1011
    # Check cancel flag before continuing. 
    if ($experiment->canceled()) {
1012 1013 1014
	tberror({cause => 'canceled', severity => SEV_IMMEDIATE,
		 error => ['cancel_flag']},
		"Cancel flag set; aborting assign run!\n");
1015 1016
	return -1;
    }
1017
    my $retval = $vtop->AllocNodes();
1018 1019 1020
    return $retval
	if ($retval != 0);

1021
    TBDebugTimeStamp("AllocNodes ended, InterpLinks Started");
1022 1023 1024 1025
    if ($vtop->InterpLinks() != 0) {
	print("Could not setup links\n");
	return -1;
    }
1026
    TBDebugTimeStamp("InterpLinks ended, InitializePhysNodes Started");
1027 1028 1029 1030
    if ($vtop->InitializePhysNodes() != 0) {
	print("Could not InitializePhysNodes\n");
	return -1;
    }
1031
    TBDebugTimeStamp("InitializePhysNodes ended");
1032
    if (! ($impotent || $regression || $alloconly)) {
1033 1034 1035 1036 1037 1038 1039
	TBDebugTimeStamp("ReserveSharedBandwidth started");
	if ($experiment->ReserveSharedBandwidth($updating) != 0) {
	    print("Could not reserve shared bandwidth\n");
	    return -1;
	}
	TBDebugTimeStamp("ReserveSharedBandwidth ended");
    }
1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054
    return 0;
}

#
# In regression mode we want to save  the physical state and then clear
# the physical resources. 
#
sub FinalizeRegression($)
{
    my ($error) = @_;
    my $cwd;

    chomp($cwd = `/bin/pwd`);
    if (!$error) {
	chat("Saving physical state in regression mode\n");
1055 1056 1057 1058
	if (system("/bin/rm -rf $pid-$eid.pstate")) {
	    tberror("Could not clean physical state directory\n");
	    return -1;
	}
1059 1060
	if ($experiment->BackupPhysicalState("$cwd/$pid-$eid.pstate", 1)
	    != 0) {
1061 1062 1063
	    print STDERR "Could not save physical state!\n";
	    exit(1);
	}
1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075
    
	# Generate a vtop file with all resources fixed.
	chat("Generating new vtop file with all resources fixed.\n");
	if (! open(VTOPFILE, "> $pid-$eid.fixed")) {
	    tberror("Could not open $pid-$eid.fixed: $!\n");
	    return -1;
	}
	if ($vtop->PrintTop(*VTOPFILE) != 0) {
	    tberror("Could not print fixed vtop file for $experiment\n");
	    return -1;
	}
	close(VTOPFILE);
1076
    }
Leigh B Stoller's avatar
Leigh B Stoller committed
1077 1078 1079
    # Must be done before nodes are released.
    $experiment->DeleteInternalProgramAgents();
    
1080 1081 1082
    return 0
	if ($noregfree);
    
1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096
    chat("Removing physical state in regression mode\n");
    if ($experiment->RemovePhysicalState() != 0) {
	print STDERR "Could not remove physical state!\n";
	exit(1);
    }

    if ($vtop->newreservednodes()) {
	my @newreservednodes = $vtop->newreservednodes();
	system("export NORELOAD=1; $NFREE -x $pid $eid @newreservednodes");
	if ($?) {
	    exit(1);
	}
    }
    return 0;
1097
}
1098

1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121
#
# Print a solution in rspec format.
#
sub PrintSolution()
{
    my $output = undef;
    
    if ($outfile ne "-") {
	if (! open(OUTFILE, "> $outfile")) {
	    tberror("Could not open $outfile: $!\n");
	    return -1;
	}
	$output = *OUTFILE;
    }
    if ($vtop->PrintSolution($output) != 0) {
	tberror("Could not print solution for $experiment\n");
	return -1;
    }
    close($output)
	if (defined($output));
    return 0;
}

1122 1123 1124 1125
# We will come through here no matter how we exit.
END {
    # Watch for getting here cause of a die()/exit() statement someplace.
    my $exitcode = $?;
1126

1127 1128 1129 1130 1131 1132 1133 1134
    #
    # Do not want to leave this around, it will lock the pool daemon out.
    #
    if ($gotlock) {
	DBQueryFatal("update emulab_locks set value=value-1 ".
		     "where name='pool_daemon'");
	$gotlock = 0;
    }
1135
    if ($seriallock) {
1136
	libEmulab::EmulabCountUnlock("mapperlock");
1137 1138
	$seriallock = 0;
    }
1139

1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155
    if ($exitcode && $exitcode != $WRAPPER_FAILED) {
	$exitcode = $WRAPPER_FAILED|$WRAPPER_FAILED_FATALLY;
    }
    
    if ($warnings > 0) {
	tberror("$warnings warnings.\n");

	$exitcode |= $WRAPPER_FAILED;
    }

    # Set recover bit if we are going to fail.
    $exitcode = $exitcode|$WRAPPER_FAILED_CANRECOVER
	if ($exitcode && !$NoRecover);

    # And change the exitcode to be what we want it to be.
    $? = $exitcode;
1156 1157 1158 1159
}

sub fatal(@)
{
1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172
    #
    # Free any newly reserved nodes (in update mode) so that tbswap knows
    # it is safe to recover the experiment. If we bypass this and leave
    # through the END block then NoRecover will still be set and tbswap
    # will know to swap the experiment out. 
    #
    if ($updating) {
	if (defined($vtop)) {
	    my @newreservednodes = $vtop->newreservednodes();
	    my $NoRecover = $vtop->norecover();
	
	    if (@newreservednodes) {
		$NoRecover = 0
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1173
		    if (system("$NFREE -x $pid $eid @newreservednodes") == 0);
1174 1175 1176 1177 1178 1179 1180 1181
	    }
	    else {
		# When not updating this is meaningless to tbswap.
		$NoRecover = 0;
	    }
	}
    }
    
1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198
    tberror(@_);

    # We next go to the END block above.
    exit($WRAPPER_FAILED);
}
sub debug($)
{
    if ($verbose) {
	print $_[0];
    }
}
sub chat($)
{
    if (! $quiet) {
	print $_[0];
    }
}
Leigh B Stoller's avatar
Leigh B Stoller committed
1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220

sub DumpReservationInfo($$)
{
    my ($file, $bounds) = @_;

    if (!open(RES, ">$file")) {
	print STDERR "Could not open $file for writing: $!\n";
	return;
    }
    if (! scalar(keys(%$bounds))) {
	close(RES);
	return;
    }
    foreach my $type (keys(%$bounds)) {
	my $bound  = $bounds->{$type};
	print RES "Running predict for $type:$bound\n";
	my $output = emutil::ExecQuiet("$PREDICT $type");
	print RES $output;
	print RES "--------\n";
    }
    close(RES);
}