nalloc.in 12.4 KB
Newer Older
1
#!/usr/bin/perl -w
Leigh Stoller's avatar
Leigh Stoller committed
2
#
3
# Copyright (c) 2000-2017 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/>.
# 
# }}}
Leigh Stoller's avatar
Leigh Stoller committed
23
#
Leigh Stoller's avatar
Leigh Stoller committed
24
use strict;
25
use English;
26
use Getopt::Std;
Mac Newbold's avatar
Mac Newbold committed
27

28 29
#
# nalloc - allocate nodes to an experiment. Takes a pid, and eid, and
Leigh Stoller's avatar
Leigh Stoller committed
30
# a list of nodes. Only nodes that are free can be allocated.
31
#
32 33 34
# Exit status is important! Exit with -1 if an error, else the number
# of nodes that could not be allocated. Otherwise zero.
#
Leigh Stoller's avatar
Leigh Stoller committed
35 36
sub usage()
{
37
    print("Usage: nalloc [-d] [-f] [-p] <pid> <eid> <node> <node> <...>\n".
Leigh Stoller's avatar
Leigh Stoller committed
38
	  "		-p enables partial allocation mode\n".
39
	  "		-f forces allocation, overriding admission control\n" .
Leigh Stoller's avatar
Leigh Stoller committed
40
	  "		-d enables debugging output\n");
Leigh Stoller's avatar
Leigh Stoller committed
41 42
    exit(-1);
}
43
my $optlist = "dfp";
Leigh Stoller's avatar
Leigh Stoller committed
44
my $debug   = 0;
45
my $force   = 0;
Leigh Stoller's avatar
Leigh Stoller committed
46 47
my $partial = 0;

48 49 50
#
# Configure variables
#
Leigh Stoller's avatar
Leigh Stoller committed
51 52
my $TB          = "@prefix@";
my $consetup    = "$TB/libexec/console_setup";
53
my $makeconf    = "$TB/sbin/dhcpd_makeconf";
54
my $PGENISUPPORT= @PROTOGENI_SUPPORT@;
Leigh Stoller's avatar
Leigh Stoller committed
55 56 57 58

#
# Testbed Support libraries
#
59 60
use lib '@prefix@/lib';
use libdb;
Leigh Stoller's avatar
Leigh Stoller committed
61
use libtestbed;
Leigh Stoller's avatar
Leigh Stoller committed
62 63 64 65
use Experiment;
use Project;
use User;
use Node;
66
use EmulabFeatures;
67
use Reservation;
68

Leigh Stoller's avatar
Leigh Stoller committed
69 70 71 72
#
# Turn off line buffering on output
#
$| = 1; 
73

Leigh Stoller's avatar
Leigh Stoller committed
74 75
# For perf analysis.
#TBDebugTimeStampsOn();
76

Leigh Stoller's avatar
Leigh Stoller committed
77 78 79 80
#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
Leigh Stoller's avatar
Leigh Stoller committed
81 82
my %options = ();

Leigh Stoller's avatar
Leigh Stoller committed
83 84 85 86
if (! getopts($optlist, \%options)) {
    usage();
}
if (defined($options{"d"})) {
87 88
    $debug = 1;
}
89 90 91
if (defined($options{"f"})) {
    $force = 1;
}
Leigh Stoller's avatar
Leigh Stoller committed
92
if (defined($options{"p"})) {
93 94
    $partial = 1;
}
95
if (@ARGV < 2) {
Leigh Stoller's avatar
Leigh Stoller committed
96
    usage();
97
}
Leigh Stoller's avatar
Leigh Stoller committed
98 99 100
my $pid		= shift;
my $eid		= shift;
my @node_names	= @ARGV;
Mac Newbold's avatar
Mac Newbold committed
101

Leigh Stoller's avatar
Leigh Stoller committed
102 103 104
#
# Locals
# 
105 106 107 108 109 110 111 112 113 114
my $error	   = 0;
my $noalloc	   = 0;
my @oldnodes	   = ();
my @nodes	   = ();
my $need_consetup  = 0;
my @need_history   = ();
my @need_clearbl   = ();
my @need_pxeconfig = ();
my $errormsg       = "";
my $admission_ctrl = 0;
115

Leigh Stoller's avatar
Leigh Stoller committed
116
TBDebugTimeStamp("nalloc started");
Leigh Stoller's avatar
Leigh Stoller committed
117

118
#
Leigh Stoller's avatar
Leigh Stoller committed
119 120
# Experiment must exist.
# 
Leigh Stoller's avatar
Leigh Stoller committed
121 122 123 124
my $experiment = Experiment->Lookup($pid, $eid);
if (! $experiment) {
    die("*** $0:\n".
	"    No such experiment $pid/$eid in the Emulab Database.\n");
Leigh Stoller's avatar
Leigh Stoller committed
125
}
Leigh Stoller's avatar
Leigh Stoller committed
126 127 128 129 130 131
my $exptidx = $experiment->idx();
my $project = $experiment->GetProject();
if (!defined($project)) {
    die("*** $0:\n".
	"    Could not get project for experiment $experiment!\n");
}
132

Leigh Stoller's avatar
Leigh Stoller committed
133 134
#
# User must have permission to modify the experiment.
135
#
Leigh Stoller's avatar
Leigh Stoller committed
136 137 138 139
my $this_user = User->ThisUser();
if (! defined($this_user)) {
    die("*** $0:\n".
	"    You ($UID) do not exist in the Emulab DB!\n");
140
}
Leigh Stoller's avatar
Leigh Stoller committed
141 142 143
if (!$experiment->AccessCheck($this_user, TB_EXPT_MODIFY)) {
    die("*** $0:\n".
	"    You do not have permission to allocate nodes in $pid/$eid\n");
144 145
}

146 147 148
$admission_ctrl = TBGetSiteVar( "general/admission_control" );
$admission_ctrl = defined( $admission_ctrl ) && $admission_ctrl;

149 150
#
# Before locking any tables, do a quick check to make sure the project
Leigh Stoller's avatar
Leigh Stoller committed
151
# is allowed to allocate the nodes, by type/class, plus other checks.
152 153
#
foreach my $n (@node_names) {
Leigh Stoller's avatar
Leigh Stoller committed
154 155 156 157
    my $node = Node->Lookup($n);
    if (!defined($node)) {
	die("*** $0:\n".
	    "    No such node $n!\n");
Leigh Stoller's avatar
Leigh Stoller committed
158
    }
Leigh Stoller's avatar
Leigh Stoller committed
159 160 161 162
    # Project allowed to allocate this node type/class?
    if (!$this_user->IsAdmin() && !$node->AllocCheck($project)) {
	die("*** $0:\n".
	    "    You are not allowed to allocate $n to project $pid!\n");
163 164
    }

Leigh Stoller's avatar
Leigh Stoller committed
165 166 167 168 169
    # XXX
    # If the node has a tipline, then indicate that we want to call
    # console_setup. We want to avoid calling console_setup if all we
    # got is a zillion virtual nodes on the command line; wasted work.
    #
Leigh Stoller's avatar
Leigh Stoller committed
170 171
    my $tipserver;
    if ($node->TipServer(\$tipserver) == 0 && defined($tipserver)) {
Leigh Stoller's avatar
Leigh Stoller committed
172 173 174
	$need_consetup++;
    }
}
Leigh Stoller's avatar
Leigh Stoller committed
175
TBDebugTimeStamp("nalloc checked all node permissions");
176

177 178 179 180 181 182 183 184 185
# Save a list of nodes already pre-reserved to the project: requests
# for them can be ignored for admission control purposes.
my @trivial_nodes = ();
my $query_result = DBQueryFatal( "SELECT node_id FROM nodes WHERE " .
				 "reserved_pid='$pid'" );
while( my($node_id) = $query_result->fetchrow_array() ) {
    push( @trivial_nodes, $node_id );
}

186 187
my $endtime = Reservation->ExpectedEnd( $experiment );

188 189 190
# Argh, MySQL locking rules are horrendous!  These locks are required by
# low-level library routines; this is a horrible violation of abstraction;
# and it's all MySQL's fault...
191
if( $PGENISUPPORT ) {
192
    DBQueryFatal("lock tables reserved write, users read, groups read, projects read, future_reservations read, nodes as n read, reserved as r read, experiments as e read, experiment_stats as stats read, next_reserve as nr read, `geni-cm`.geni_slices as s read, project_reservations as pr read, reservation_version write");
193
} else {
194
    DBQueryFatal("lock tables reserved write, users read, groups read, projects read, future_reservations read, nodes as n read, reserved as r read, experiments as e read, experiment_stats as stats read, next_reserve as nr read, project_reservations as pr read, reservation_version write");
195
}
Leigh Stoller's avatar
Leigh Stoller committed
196
TBDebugTimeStamp("nalloc locked tables");
mac's avatar
mac committed
197

Leigh Stoller's avatar
Leigh Stoller committed
198
# Make a list of nodes to reserve.
199
foreach my $n (@node_names) {
Leigh Stoller's avatar
Leigh Stoller committed
200 201 202 203 204
    my $node = Node->Lookup($n);
    if (!defined($node)) {
	die("*** $0:\n".
	    "    No such node $n!\n");
    }
205 206 207
    # Force reload after table lock.
    $node->FlushReserved();
    
Leigh Stoller's avatar
Leigh Stoller committed
208 209
    my $reserved_experiment = $node->ReservationID();
    if ($reserved_experiment) {
210
	# Someone has already reserved this node
Leigh Stoller's avatar
Leigh Stoller committed
211 212
	if ($reserved_experiment == $experiment->idx()) {
	    print "$node already reserved to $experiment.\n";
Leigh Stoller's avatar
Leigh Stoller committed
213
	    # Do not increment error code since that throws off caller.
214
	    next;
Leigh Stoller's avatar
Leigh Stoller committed
215
	}
Leigh Stoller's avatar
Leigh Stoller committed
216 217 218 219 220
	my $oldreserved_experiment = $node->OldReservationID();
	if ($oldreserved_experiment &&
	    $oldreserved_experiment eq $experiment->idx()) {
	    print "$node already reserved in holding reservation.\n";
	    push(@oldnodes, $node);
221
	    next;
Leigh Stoller's avatar
Leigh Stoller committed
222 223
	}
	else {
Leigh Stoller's avatar
Leigh Stoller committed
224
	    print "Someone else has already reserved node $node.\n";
225
	    $noalloc++;
226
	    next;
227
	}
228
    }
229

Leigh Stoller's avatar
Leigh Stoller committed
230 231 232
    #
    # Add info the list of nodes to reserve; done in a single query below.
    # 
Leigh Stoller's avatar
Leigh Stoller committed
233
    push(@nodes, $node);
Mac Newbold's avatar
Mac Newbold committed
234
}
Leigh Stoller's avatar
Leigh Stoller committed
235
TBDebugTimeStamp("nalloc checked all nodes");
236

Leigh Stoller's avatar
Leigh Stoller committed
237
if ($debug) {
Leigh Stoller's avatar
Leigh Stoller committed
238
    print "List Ready: @nodes\nError=$error\n";
Leigh Stoller's avatar
Leigh Stoller committed
239
}
240

241 242
# Admission control check -- advisory only, unless sitevar
# general/admission_control is turned on.
243 244

if ($debug) {
245 246 247 248 249
    if( $admission_ctrl ) {
	print "Running admission control verification...\n";
    } else {
	print "Running advisory admission control verification...\n";
    }
250 251 252
}

my %types = ();
253
my %unavail_types = ();
254
foreach my $node (@nodes) {
255 256
    $types{ $node->type() } = 1
	unless( grep( $_ eq $node->node_id(), @trivial_nodes ) );
257 258 259
}
foreach my $type ( keys( %types ) ) {
    my $reservations = Reservation->LookupAll( $type );
260 261
    if( !Reservation->IsFeasible( $reservations, \$errormsg ) ) {
	print "Existing admission control violation for type $type: $errormsg\n";
262 263
	print "Omitting $type admission control verification.\n";
	$unavail_types{ $type } = 1;
264 265 266 267
    }
}

foreach my $type ( keys( %types ) ) {
268 269
    next if( $unavail_types{ $type } );
    
270
    my $reservations = Reservation->LookupAll( $type );
271
    my $count = 0;
272
    foreach my $node (@nodes) {
273 274
	$count++ if( $node->type() eq $type &&
		     !grep( $_ eq $node->node_id(), @trivial_nodes ) );
275
    }
276 277 278 279 280 281 282 283 284 285
    
    my $res = Reservation->CreateImmediate( $pid, $eid,
					    $this_user->uid(),
					    $endtime, $type, $count );
    if ($debug) {
	print "$res\n";
    }
    
    push( @$reservations, $res );
    
286 287
    if( !Reservation->IsFeasible( $reservations, \$errormsg ) ) {
	print "Admission control violation for type $type: $errormsg\n";
288 289 290 291 292 293

	if( $debug ) {
	    foreach my $res (@$reservations) {
		print "$res\n";
	    }
	}
294
	
295 296 297 298
	if( $force ) {
	    print "Forcing allocation anyway...\n";
	    print STDERR "WARNING: SCHEDULED RESERVATIONS ARE NOW INFEASIBLE!\n";
	    # FIXME notify admins about violation
299 300 301 302 303 304 305 306 307 308 309
	}
	$unavail_types{ $type } = 1;
    }
}

if( $admission_ctrl && !$force ) {
    my @goodnodes = ();

    foreach my $node (@nodes) {
	if( !exists( $unavail_types{ $node->type() } ) ) {
	    push( @goodnodes, $node );
310
	} else {
311 312 313
	    # FIXME if some but not all nodes of a given type are
	    # admissable, it would be nice to try harder
	    $noalloc++;
314
	}
315
    }
316 317

    @nodes = @goodnodes;
318 319
}

320 321 322 323 324 325 326 327
foreach my $node (@nodes) {
    # Freshly allocated nodes need a history entry.
    push(@need_history, $node);
    # ... and need to have their bootlogs purged.
    push(@need_clearbl, $node);
    # ... and may need to recreate its pxelinux conf
    push(@need_pxeconfig, $node);
}
328

Leigh Stoller's avatar
Leigh Stoller committed
329
# Now make the reservations in the DB.
330
if ((!$noalloc || $partial) && (@nodes || @oldnodes) && !$error) {
Leigh Stoller's avatar
Leigh Stoller committed
331 332
    print "Reserving nodes...\n"
	if ($debug);
333

334 335 336 337 338
    # Must do this while we have the tables locked and before we apply
    # any updates, otherwise concurrent readers might fail to detect
    # inconsistencies.
    DBQueryFatal( "UPDATE reservation_version SET version=version+1" );
    
Leigh Stoller's avatar
Leigh Stoller committed
339 340 341 342 343 344 345 346 347 348 349 350 351 352
    # Generate strings for a single query. Could use perl map().
    if (@nodes) {
	my @values = ();
	foreach my $node (@nodes) {
	    my $node_id = $node->node_id();
	    
	    push(@values,
		 "('$node_id',$exptidx,'$pid','$eid','$node_id','','')");
	}
	if (! DBQueryWarn("replace into reserved ".
			  " (node_id,exptidx,pid,eid,vname,old_pid,old_eid) ".
			  "values ". join(",",@values))) {
	    $error++;
	}
353
    }
Leigh Stoller's avatar
Leigh Stoller committed
354
    
355 356 357 358
    # Do this instead of creating new entries so as not to lose any
    # other info in the reserved table entries. I think this might be;
    # wrong; might need to rethink this.
    foreach my $node (@oldnodes) {
Leigh Stoller's avatar
Leigh Stoller committed
359 360
	my $node_id = $node->node_id();
	
361
	if (!DBQueryWarn("update reserved " .
362 363
			 "set exptidx=$exptidx,pid='$pid',eid='$eid', ".
			 "    old_exptidx=0, old_pid='', old_eid='' ".
Leigh Stoller's avatar
Leigh Stoller committed
364
			 "where node_id='$node_id'")) {
365 366 367
	    $error++;
	}
    }
mac's avatar
mac committed
368
}
Leigh Stoller's avatar
Leigh Stoller committed
369
TBDebugTimeStamp("nalloc allocated all nodes");
mac's avatar
mac committed
370

Leigh Stoller's avatar
Leigh Stoller committed
371
# Unlock tables.
372 373
DBQueryFatal("unlock tables");

374
# Okay, now safe to do this
375

Leigh Stoller's avatar
Leigh Stoller committed
376 377 378 379 380 381
# Update node_activity table; no need to do this with tables locked.
if (!$error && (!$noalloc || $partial) && @nodes) {
    print "Resetting node activity\n"
	if ($debug);

    # It isn't an error if this fails...
382 383 384
    DBQueryWarn("update node_activity set ".
		"  last_ext_act=now(), last_report=now() ".
		"where ".
Leigh Stoller's avatar
Leigh Stoller committed
385 386
		join(" or ",
		     map("node_id='" . $_->node_id() . "'", @nodes)));
Leigh Stoller's avatar
Leigh Stoller committed
387

388 389 390
    foreach my $node (@nodes) {
	$node->NewRootPasswd();
    }
Leigh Stoller's avatar
Leigh Stoller committed
391 392 393
    foreach my $node (@need_history) {
	$node->SetNodeHistory(TB_NODEHISTORY_OP_ALLOC,
			      $this_user, $experiment);
394
    }
395 396 397 398 399

    # Clear boot logs - maybe this should be done before alloc?
    #  - only a small window of opportunity at any rate.
    # This is sort of wasteful as it should be the same set of nodes
    # as in the node history loop above, but that could change at some point.
Leigh Stoller's avatar
Leigh Stoller committed
400 401
    foreach my $node (@need_clearbl) {
	$node->ClearBootLog();
402
    }
403 404 405 406

    # And since the node is now allocated, we need to redo its pxelinux
    # config file so it won't be stuck in pxewait
    foreach my $node (@need_pxeconfig) {
407 408 409
	if ($node->boot_method() eq "pxelinux") {
	    TBPxelinuxConfig($node);
	}
410
    }
Leigh Stoller's avatar
Leigh Stoller committed
411
}
Leigh Stoller's avatar
Leigh Stoller committed
412
TBDebugTimeStamp("updated node_activity, history, and bootlogs");
mac's avatar
mac committed
413

Leigh Stoller's avatar
Leigh Stoller committed
414 415
# Now setup consoles if needed.
if ($need_consetup && !$error && @nodes) {
Leigh Stoller's avatar
Leigh Stoller committed
416 417 418
    my @nodeids = map($_->node_id(), @nodes);
    
    system("$consetup @nodeids") == 0 or
419
	print STDERR "WARNING: $consetup @nodes failed!\n";
Leigh Stoller's avatar
Leigh Stoller committed
420
    TBDebugTimeStamp("nalloc finished console setup");
Mac Newbold's avatar
Mac Newbold committed
421 422
}

423
$EmulabFeatures::verbose = 0;
424 425 426 427 428 429 430 431 432 433 434
if (EmulabFeatures->FeatureEnabled("ExternalNodeManagement",
				   undef, undef,
				   $experiment)) {
    print "ExternalNodeManagement feature is set: Disabling Emulab ".
	  "management of nodes in $experiment ...\n";
    # Shut off dhcp response for nodes in this experiment.
    if (system("$makeconf -i -r")) {
	print STDERR "WARNING: Failed to reconfigure dhcp!\n";
    }
}

435 436 437 438 439 440 441
#
# Exit with -1 if an error, else the number of nodes that could not
# be allocated.
#
my $exitval = ($error ? -1 : $noalloc);
if ($debug) { print "Returning with value $exitval\n"; }
exit($exitval);