Reservation.pm.in 34.5 KB
Newer Older
1 2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2016-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 23 24 25 26 27 28 29 30 31 32 33
# 
# {{{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/>.
# 
# }}}
#
package Reservation;

use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA    = "Exporter";
@EXPORT = qw ( );

use English;
34
use Date::Parse;
35 36
use emdb;
use libtestbed;
37
use emutil;
38
use EmulabConstants;
39 40
use Project;
use User;
41
use Experiment;
42
use NodeType;
43 44 45 46
use overload ('""' => 'Stringify');

# Configure variables
my $TB		= "@prefix@";
47
my $PGENISUPPORT= @PROTOGENI_SUPPORT@;
48 49

my %cache = ();
50 51 52 53 54 55 56 57
BEGIN { use emutil; emutil::AddCache(\%cache); }

sub FlushAll($)
{
    my ($class) = @_;

    %cache = ();
}
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

sub CreateCommon($$$$$$$$)
{
    my ($class, $pid, $eid, $uid, $start, $end, $type, $nodes) = @_;

    my $project;
    
    if( defined( $pid ) ) {
	$project = Project->Lookup( $pid );
	if( !defined( $project ) ) {
	    return undef;
	}
    }

    my $user;
    if( defined( $uid ) ) {
	$user = User->Lookup( $uid );
    } else {
	$user = User->ThisUser();
    }
    if( !defined( $user ) ) {
	return undef;
    }
    
    my $self               = {};
    $self->{'PID'}         = $pid;
    $self->{'PID_IDX'}     = defined( $pid ) ? $project->pid_idx() : undef;
    $self->{'EID'}         = $eid;
    $self->{'START'}       = $start;
    $self->{'END'}         = $end;
    $self->{'TYPE'}        = $type;
    $self->{'NODES'}       = $nodes;
    $self->{'UID'}         = $user->uid();
    $self->{'UID_IDX'}     = $user->uid_idx();
    $self->{'NOTES'}       = undef;
    $self->{'ADMIN_NOTES'} = undef;
94 95
    $self->{'APPROVED'}    = undef;
    $self->{'APPROVER'}    = undef;
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
	
    bless($self, $class);
    
    return $self;
}

#
# Return an object representing a hypothetical future reservation.
#
# This DOES NOT actually check the feasibility of, guarantee,
# or record the reservation.
#
sub Create($$$$$$$)
{
    my ($class, $pid, $uid, $start, $end, $type, $nodes) = @_;

    return CreateCommon( $class, $pid, undef, $uid, $start, $end, $type,
			 $nodes );
}

#
117
# Return an object representing a hypothetical existing experiment.    
118 119 120 121
#
# This DOES NOT actually check the feasibility of, guarantee,
# or record the reservation.
#
122
sub CreateExisting($$$$$$$)
123 124 125 126 127 128
{
    my ($class, $pid, $eid, $uid, $end, $type, $nodes) = @_;

    return CreateCommon( $class, $pid, $eid, $uid, 0, $end, $type, $nodes );
}
    
129 130 131 132 133 134 135 136 137 138 139 140 141 142
#
# Return an object representing a hypothetical immediate experiment.    
#
# This DOES NOT actually check the feasibility of, guarantee,
# or record the reservation.
#
sub CreateImmediate($$$$$$$)
{
    my ($class, $pid, $eid, $uid, $end, $type, $nodes) = @_;

    return CreateCommon( $class, $pid, $eid, $uid, time(), $end, $type,
			 $nodes );
}
    
143
sub Lookup($$;$$$$)
144 145
{
    my ($class, $pid, $start, $end, $type, $nodes) = @_;
146 147 148 149 150 151 152 153
    my $query_result;
    
    if( defined( $start ) ) {
	# Look up by time and project.
	my $project = Project->Lookup( $pid );
	if( !defined( $project ) ) {
	    return undef;
	}
154

155
	my $pid_idx = $project->pid_idx();
156
    
157 158
	$query_result = DBQueryWarn( "SELECT *, UNIX_TIMESTAMP(start) AS s, " .
				     "UNIX_TIMESTAMP(end) AS e, " .
159 160
				     "UNIX_TIMESTAMP(created) AS c, " .
				     "UNIX_TIMESTAMP(approved) AS a " .
161
				     "FROM future_reservations " .
162 163 164 165 166 167 168 169 170 171 172
				     "WHERE pid_idx='$pid_idx' AND " .
				     "nodes='$nodes' AND " .
				     "type='$type' AND " .
				     "start=FROM_UNIXTIME($start) AND " .
				     "end=FROM_UNIXTIME($end)" );

	return undef
	    if (!$query_result || !$query_result->numrows);
    } else {
	# Look up by ID.
	my $idx = $_[ 1 ];
173

174 175
	$query_result = DBQueryWarn( "SELECT *, UNIX_TIMESTAMP(start) AS s, " .
				     "UNIX_TIMESTAMP(end) AS e, " .
176 177
				     "UNIX_TIMESTAMP(created) AS c, " .
				     "UNIX_TIMESTAMP(approved) AS a " .
178
				     "FROM future_reservations " .
179
				     "WHERE idx='$idx'" );
180

181 182 183 184
	return undef
	    if (!$query_result || !$query_result->numrows);
    }
    
185 186 187
    my $record = $query_result->fetchrow_hashref();
    
    my $self               = {};
188
    $self->{'IDX'}         = $record->{'idx'};
189 190 191
    $self->{'PID'}         = $record->{'pid'};
    $self->{'PID_IDX'}     = $record->{'pid_idx'};
    $self->{'EID'}         = undef;
192 193 194
    $self->{'START'}       = $record->{'s'};
    $self->{'END'}         = $record->{'e'};
    $self->{'CREATED'}     = $record->{'c'};
195 196
    $self->{'TYPE'}        = $record->{'type'};
    $self->{'NODES'}       = $record->{'nodes'};
197 198 199 200
    $self->{'UID'}         = $record->{'uid'};
    $self->{'UID_IDX'}     = $record->{'uid_idx'};
    $self->{'NOTES'}       = $record->{'notes'};
    $self->{'ADMIN_NOTES'} = $record->{'admin_notes'};
201
    $self->{'APPROVED'}    = $record->{'a'};
202
    $self->{'APPROVER'}    = $record->{'approver'};
203 204 205 206 207 208
	
    bless($self, $class);
    
    return $self;
}

209
sub idx($)         { return $_[0]->{"IDX"}; }
210 211 212 213 214
sub pid($)         { return $_[0]->{"PID"}; }
sub pid_idx($)     { return $_[0]->{"PID_IDX"}; }
sub eid($)         { return $_[0]->{"EID"}; }
sub start($)       { return $_[0]->{"START"}; }
sub end($)         { return $_[0]->{"END"}; }
215
sub created($)     { return $_[0]->{"CREATED"}; }
216 217 218 219 220 221
sub type($)        { return $_[0]->{"TYPE"}; }
sub nodes($)       { return $_[0]->{"NODES"}; }
sub uid($)         { return $_[0]->{"UID"}; }
sub uid_idx($)     { return $_[0]->{"UID_IDX"}; }
sub notes($)       { return $_[0]->{"NOTES"}; }
sub admin_notes($) { return $_[0]->{"ADMIN_NOTES"}; }
222 223
sub approved($)    { return $_[0]->{"APPROVED"}; }
sub approver($)    { return $_[0]->{"APPROVER"}; }
224 225 226 227 228 229

sub Stringify($)
{
    my ($self) = @_;
    
    my $pid = $self->pid();
230 231 232 233 234
    $pid = "(free)" if( !defined( $pid ) );
    
    if( defined( $self->eid() ) ) {
	$pid = $pid . "/" . $self->eid();
    }
235 236
    my $nodes = $self->nodes();
    my $type = $self->type();
237 238 239
    my $start = defined( $self->start() ) ? localtime( $self->start() ) :
	"epoch";
    my $end = defined( $self->end() ) ? localtime( $self->end() ) : "forever";
240 241 242 243

    return "[Reservation: $pid, ${nodes}x${type}, ${start}-${end}]";
}

244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
sub SetStart($$)
{
    my ($self, $start) = @_;

    $self->{'START'} = $start;
}  

sub SetEnd($$)
{
    my ($self, $end) = @_;

    $self->{'END'} = $end;
}  

sub SetNodes($$)
{
    my ($self, $nodes) = @_;

    $self->{'NODES'} = $nodes;
}  

265 266 267 268 269 270 271 272 273 274 275 276 277 278
sub SetNotes($$)
{
    my ($self, $notes) = @_;

    $self->{'NOTES'} = $notes;
}

sub SetAdminNotes($$)
{
    my ($self, $notes) = @_;

    $self->{'ADMIN_NOTES'} = $notes;
}

279 280 281 282 283 284 285 286 287 288 289 290 291
# Mark the reservation as approved.  This DOES NOT update the database
# state: to do so requires an admission control check!  See BeginTransaction(),
# IsFeasible(), Book(), etc.
sub Approve($;$)
{
    my ($self, $user) = @_;

    $user = User->ThisUser() if( !defined( $user ) );

    $self->{'APPROVED'} = time();
    $self->{'APPROVER'} = $user->uid() if defined( $user );
}

292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331
# Retrieve the current reservation database version.  This version must
# be retrieved and saved before validity checks on attempted updates,
# and then the same version supplied to BeginTransaction() before making
# any changes.
sub GetVersion($)
{
    my $query_result = DBQueryFatal( "SELECT * FROM reservation_version" );
    my $version;
    
    if( ($version) = $query_result->fetchrow_array() ) {
	return $version;
    }

    return undef;
}

# Attempt to commit database changes.  GetVersion() must have been called
# previously, and whatever version was obtained supplied as the parameter
# here.  Any necessary availability checks must have been performed
# after GetVersion() and BeginTransaction().  If BeginTransaction()
# returned undef, then concurrent modifications have been detected,
# possibly invalidating the checks already made, and the entire operation
# must be retried from the beginning.  Otherwise, the caller is free
# to proceed with the updates and then complete with EndTransaction().
sub BeginTransaction($$)
{
    my ($self, $old_version) = @_;
    
    DBQueryFatal( "LOCK TABLES future_reservations WRITE, " .
		  "reservation_version WRITE" );
    
    my $version = GetVersion( $self );

    if( $old_version != $version ) {
	# Reservations have been altered by a concurrent operation.
	# Can't continue: the caller will have to retry.
	DBQueryFatal( "UNLOCK TABLES" );
	return undef;
    }

332 333 334 335 336 337 338
    # Eagerly update the version.  This isn't always strictly necessary,
    # but it is always safe.  And doing it now instead of at EndTransaction
    # time guards against undetected inconsistencies in the case where a
    # process applies persistent updates while it has the tables locked, but
    # then dies for some reason before it can EndTransaction.
    DBQueryFatal( "UPDATE reservation_version SET version=version+1" );
    
339 340 341 342
    # We're good.
    return 0;
}

343
sub EndTransaction($)
344 345 346 347 348 349 350 351 352
{
    DBQueryFatal( "UNLOCK TABLES" );
}

# Add a reservation record to the database (therefore committing ourselves
# to the guarantee it represents).  Because of the consequences and
# consistency requirements, this is permitted ONLY inside a
# BeginTransaction()/EndTransaction() pair, following either
# admission control satisfaction or admin override.
353
sub Book($;$)
354
{
355
    my ($self,$idx) = @_;
356 357 358 359 360 361 362 363 364 365 366

    my $pid = $self->pid();
    my $pid_idx = $self->pid_idx();
    my $nodes = $self->nodes();
    my $type = $self->type();
    my $start = $self->start();
    my $end = $self->end();
    my $uid = $self->uid();
    my $uid_idx = $self->uid_idx();
    my $notes = DBQuoteSpecial( $self->notes() );
    my $admin_notes = DBQuoteSpecial( $self->admin_notes() );
367 368
    my $approved = $self->approved();
    my $approver = $self->approver();
369

370
    my $base_query = "SET pid='$pid', " .
371 372 373 374 375 376 377
		     "pid_idx='$pid_idx', " .
		     "nodes='$nodes', " .
		     "type='$type', " .
		     "start=FROM_UNIXTIME($start), " .
		     "end=FROM_UNIXTIME($end), " .
		     "uid='$uid', " .
		     "uid_idx='$uid_idx' " .
378
		     ( defined( $notes ) ? ", notes=$notes" : "" ) .
379
		     ( defined( $admin_notes ) ?
380 381 382 383
		       ", admin_notes=$admin_notes" : "" ) .
		     ( defined( $approved ) ?
		       ", approved=FROM_UNIXTIME($approved)" : "" ) .
		     ( defined( $approver ) ? ", approver='$approver'" : "" );
384 385 386 387 388 389

    my $query_result =
	DBQueryWarn( defined( $idx ) ? "UPDATE future_reservations " .
		     $base_query . " WHERE idx='$idx'" :
		     "INSERT INTO future_reservations " . $base_query )
        or return -1;
390

391
    $self->{'IDX'} = $query_result->insertid();
392
    $self->{'CREATED'} = time();
393

394 395 396 397 398 399 400 401 402 403 404 405
    delete $cache{$type};
    
    return 0;
}

# Cancel a future reservation.  This could be enclosed within a transaction,
# but since cancellations can never cause concurrent operations to fail,
# the transaction is not mandatory.
sub Cancel($)
{
    my ($self) = @_;

406
    my $idx = $self->idx();
407 408
    my $type = $self->type();
    
409 410 411 412 413
    DBQueryWarn( "DELETE FROM future_reservations WHERE idx=$idx" )
	or return -1;

    DBQueryWarn( "DELETE FROM future_reservation_attributes WHERE " . 
		 "reservation_idx=$idx" )
414 415 416 417 418 419 420
	or return -1;

    delete $cache{$type};
    
    return 0;
}

421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456
sub SetAttribute($$$)
{
    my ($self, $key, $value) = @_;

    my $idx = $self->idx();
    $key = DBQuoteSpecial( $key );
    $value = DBQuoteSpecial( $value );
    
    DBQueryWarn( "REPLACE INTO future_reservation_attributes SET " .
		 "reservation_idx='$idx', " .
		 "attrkey='$key', " .
		 "attrvalue='$value'" )
	or return -1;

    return 0;
}

sub GetAttribute($$)
{
    my ($self, $key) = @_;

    my $idx = $self->idx();
    $key = DBQuoteSpecial( $key );

    my $query_result = DBQueryWarn( "SELECT attrvalue FROM " .
				    "future_reservation_attributes WHERE " .
				    "reservation_idx='$idx' AND " .
				    "attrkey='$key'" );
    return undef
	if( !$query_result || !$query_result->numrows );

    my ($value) = $query_result->fetchrow_array();

    return $value;
}

Gary Wong's avatar
Gary Wong committed
457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
#
# Archive any reservations whose times have passed.  This should be
# called occasionally to maintain performance (avoid clogging up the
# future_reservations table with things that don't matter any more, and
# to keep proper records in the reservation_history table), but isn't
# actually required for correctness.
#
sub Tidy($)
{
    my ($class) = @_;

    my $query_result = DBQueryWarn( "SELECT now()" );
    return undef
	if( !$query_result || !$query_result->numrows );

    my ($stamp) = $query_result->fetchrow_array();
    
    $query_result = DBQueryWarn( "SELECT COUNT(*) FROM " .
				    "future_reservations WHERE " .
				    "end < '$stamp'" );
    return undef
	if( !$query_result || !$query_result->numrows );

    my ($count) = $query_result->fetchrow_array();

    if( !$count ) {
	# no tidying required
	return 0;
    }

    DBQueryFatal( "LOCK TABLES future_reservations WRITE, " .
		  "reservation_history WRITE, " .
		  "future_reservation_attributes AS a WRITE, " .
		  "future_reservations AS r READ" );
    DBQueryFatal( "INSERT INTO reservation_history( pid, nodes, type, " .
		  "start, end, uid, notes, admin_notes ) " .
		  "SELECT pid, nodes, type, start, end, uid, notes, " .
		  "admin_notes FROM future_reservations WHERE " .
		  "end < '$stamp'" );
    DBQueryFatal( "DELETE FROM future_reservations WHERE " .
		  "end < '$stamp'" );
    DBQueryFatal( "DELETE a FROM future_reservation_attributes AS a " .
		  "LEFT OUTER JOIN future_reservations AS r ON " .
		  "a.reservation_idx=r.idx WHERE r.idx IS NULL" );
    DBQueryFatal( "UNLOCK TABLES" );

    return 1;
}

506
sub LookupAll($$;$)
507
{
508
    my ($class, $type, $include_pending) = @_;
509 510 511
    
    return $cache{$type} if( exists( $cache{$type} ) );

Gary Wong's avatar
Gary Wong committed
512 513
    Tidy( $class );
    
514 515
    my @reservations = ();

516 517 518 519 520
    my $query = $PGENISUPPORT ? "SELECT COUNT(*), e.pid, e.eid, " .
				"e.expt_swap_uid, " .
				"UNIX_TIMESTAMP( e.expt_swapped ) + " .
				"e.autoswap_timeout * 60, e.autoswap, " .
				"nr.pid, UNIX_TIMESTAMP( s.expires ), " .
521
				"s.lockdown, n.reserved_pid FROM nodes AS n " .
522 523 524 525 526 527 528 529 530
				"LEFT OUTER JOIN " .
				"reserved AS r ON n.node_id=r.node_id " .
				"LEFT OUTER JOIN experiments AS e ON " .
				"r.pid=e.pid AND r.eid=e.eid LEFT " .
				"OUTER JOIN next_reserve AS nr ON " .
				"n.node_id=nr.node_id LEFT OUTER JOIN " .
				"`geni-cm`.geni_slices AS s ON " .
				"e.eid_uuid=s.uuid " .
				"WHERE n.type='$type' GROUP BY " .
531
				"e.pid, e.eid, n.reserved_pid, nr.pid" :
532 533 534 535 536
				"SELECT COUNT(*), e.pid, e.eid, " .
				"e.expt_swap_uid, " .
				"UNIX_TIMESTAMP( e.expt_swapped ) + " .
				"e.autoswap_timeout * 60, e.autoswap, " .
				"nr.pid, NULL, " .
537
				"NULL, n.reserved_pid FROM nodes AS n " .
538 539 540 541 542 543
				"LEFT OUTER JOIN " .
				"reserved AS r ON n.node_id=r.node_id " .
				"LEFT OUTER JOIN experiments AS e ON " .
				"r.pid=e.pid AND r.eid=e.eid LEFT " .
				"OUTER JOIN next_reserve AS nr ON " .
				"n.node_id=nr.node_id WHERE n.type='$type' " .
544
				"GROUP BY e.pid, e.eid, n.reserved_pid, nr.pid";
545 546
    my $query_result = DBQueryWarn( $query );
    
547
    while( my($count, $pid, $eid, $uid, $end, $autoswap, $next_reserve,
548
	      $slice_expire, $slice_lockdown, $reserved_pid ) =
549 550 551
	   $query_result->fetchrow_array() ) {
	my $endtime;
	
552
	if( defined( $slice_expire ) ) {
553 554 555 556
	    # Node(s) allocated to a GENI slice.  Treat as unavailable
	    # if locked down, otherwise assume released at slice expiry
	    # time.
	    $endtime = $slice_lockdown ? undef : $slice_expire;
557
	} else {
558 559 560
	    # A non-GENI slice.  Use the computed autoswap duration,
	    # if autoswap is enabled.
	    $endtime = $autoswap ? $end : undef;
561
	}
562 563 564 565 566 567 568 569 570

	# If next_reserve is set, assume unavailable indefinitely.
	# FIXME can we obtain more precise predictions by doing a
	# CreateExisting() for the current experiment then something
	# else at $endtime?
	if( defined( $next_reserve ) ) {
	    $endtime = undef;
	}

571 572 573 574 575 576
	# If reserved_pid is set, assume the node is assigned to the
	# project forever.
	if( defined( $reserved_pid ) ) {
	    $endtime = undef;
	}

577 578 579 580 581 582
	# Consider nodes in reloading to be available.  One important
	# reason for doing so is that if a project has a current reservation
	# and swaps one experiment out and a replacement in, then during
	# the transition period, sufficient nodes must be considered available
	# for assignment to that project.
	if( defined( $pid ) && ( $pid ne "emulab-ops" ||
583 584
				 ( $eid ne "reloading" &&
				   $eid ne "reloadpending" ) ) ) {
585 586
	    # Handle the case where an experiment is swapped in.  The
	    # nodes aren't free right now, but at some time in the
587
	    # future they could become so.
588 589
	    my $res = CreateExisting( $class, $pid, $eid, $uid, $endtime,
				      $type, $count );
590
	    push( @reservations, $res );
591
	} elsif( !defined( $reserved_pid ) ) {
592 593
	    # Physical nodes with no reservations whatsoever... treat
	    # them as free since the beginning of time.
594
	    my $res = CreateCommon( $class, undef, undef, undef, 0, undef,
595 596 597 598 599 600
				    $type, $count );
	    push( @reservations, $res );
	}
    }
    
    $query_result = DBQueryWarn( "SELECT pid, uid, UNIX_TIMESTAMP( start ), " .
601
				 "UNIX_TIMESTAMP( end ), nodes, idx FROM " .
602 603 604 605
				 "future_reservations WHERE type='$type'" .
				 ( $include_pending ? "" :
				   " AND approved IS NOT NULL" ) );

606
    while( my ($pid, $uid, $start, $end, $nodes, $idx) =
607 608
	   $query_result->fetchrow_array() ) {
	my $res = Create( $class, $pid, $uid, $start, $end, $type, $nodes );
609
	$res->{'IDX'} = $idx;
610 611 612 613 614 615 616 617
	push( @reservations, $res );
    }

    $cache{$type} = \@reservations;
    
    return $cache{$type};
}

618
sub IsFeasible($$;$$$$$)
619
{
620 621
    my ($class, $reservations, $error, $conflicttime, $conflictcount,
	$projlist, $forecast) = @_;
622 623

    my @timeline = ();
624
    my $free = 0;
625 626 627 628
    my %used = ();
    my %reserved = ();
    my $answer = 1;
    
629
    foreach my $reservation ( @$reservations ) {
630
	my $pid = $reservation->pid();
631 632 633 634
	my $start;
	my $end;

	if( defined( $reservation->eid() ) ) {
635 636 637 638 639 640
	    if( $reservation->start() ) {
		# An unmapped experiment.  Not yet using physical nodes.
		$start = { 'pid' => $reservation->pid(),
			   't' => $reservation->start(),
			   'used' => $reservation->nodes(),
			   'reserved' => 0 };
641 642 643 644 645 646 647
	    } else {
		# A mapped experiment.  Using physical nodes now.
		if( defined( $used{ $pid } ) ) {
		    $used{ $pid } += $reservation->nodes();
		} else {
		    $used{ $pid } = $reservation->nodes();
		}
648
	    }
649
	    
650
	    # Will later release real nodes.
651 652 653 654 655 656
	    $end = { 'pid' => $reservation->pid(),
		     't' => $reservation->end(),
		     'used' => -$reservation->nodes(),
		     'reserved' => 0 };
	} elsif( defined( $reservation->pid() ) ) {
	    # A reservation.  Uses then releases reserved nodes.
657 658 659 660

	    # Ignore reservations for listed projects.
	    next if( grep( $_ eq $reservation->pid(), @$projlist ) );
		      
661 662 663 664 665 666 667 668 669 670
	    $start = { 'pid' => $reservation->pid(),
		       't' => $reservation->start(),
		       'used' => 0,
		       'reserved' => $reservation->nodes() };
	    $end = { 'pid' => $reservation->pid(),
		     't' => $reservation->end(),
		     'used' => 0,
		     'reserved' => -$reservation->nodes() };
	} else {
	    # Available resources.  Provides nodes for all time.
671
	    $free += $reservation->nodes();
672 673 674 675 676 677
	}

	push( @timeline, $start ) if( defined( $start->{'t'} ) );
	push( @timeline, $end ) if( defined( $end->{'t'} ) );
    }

678 679 680 681 682 683 684 685
    if( defined( $forecast ) ) {
	my %origin = (
	    t => 0,
	    free => $free
	    );
	push( @$forecast, \%origin );
    }

686 687 688 689
    my @events = sort { $a->{'t'} <=> $b->{'t'} } @timeline;
    
    foreach my $event ( @events ) {
	my $pid = $event->{'pid'};
690 691 692

	$used{ $pid } = 0 if( !exists( $used{ $pid } ) );
	$reserved{ $pid } = 0 if( !exists( $reserved{ $pid } ) );
693

694 695
	my $oldsum = $used{ $pid } > $reserved{ $pid } ? $used{ $pid } :
	    $reserved{ $pid };
696 697 698 699

	$used{ $pid } += $event->{ 'used' };
	$reserved{ $pid } += $event->{ 'reserved' };

700 701
	my $newsum = $used{ $pid } > $reserved{ $pid } ? $used{ $pid } :
	    $reserved{ $pid };
702 703 704

	$free += $oldsum - $newsum;

705 706 707 708 709 710 711 712 713 714 715 716
	if( defined( $forecast ) ) {
	    my %used_ = %used;
	    my %reserved_ = %reserved;
	    my %stamp = (
		t => $event->{'t'},
		used => \%used_,
		reserved => \%reserved_,
		free => $free
		);
	    push( @$forecast, \%stamp );
	}
	
717 718 719 720 721 722 723 724
	if( $free < 0 ) {
	    # Insufficient resources.
	    if( ref( $error ) ) {
		my $time = localtime( $event->{'t'} );
		my $needed = -$free;
		$$error = "Insufficient free nodes at $time " .
		    "($needed more needed).";
	    }
725 726 727
	    if( ref( $conflicttime ) ) {
		$$conflicttime = $event->{'t'};
	    }
728 729 730
	    if( ref( $conflictcount ) ) {
		$$conflictcount = -$free;
	    }
731 732 733 734 735 736

	    if( defined( $forecast ) ) {
		$answer = 0;
	    } else {
		return 0;
	    }
737 738 739
	}
    }
    
740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758
    return $answer;
}

#
# Generate a heuristic "count" of free nodes of a given type.  For each
# "free forever" physical node (i.e., a node never required for future
# reservations), the count is incremented by one.  Each node currently
# assigned to an experiment is ignored (doesn't affect the count).  Each
# node currently free but later required for a reservation increments the
# count by some fractional value depending how far into the future the
# reservation is.
#
# Reservation->FreeCount( $type, $projlist )
#
# $type must be a valid node type.
# $projlist is an optional reference to a list of PIDs, and reservations
#     for any projects in the list will be ignored (i.e., the nodes are
#     assumed free -- useful if a user wants to consider nodes reserved
#     to their own projects as available).
759
sub FreeCount($$;$) {
760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
    my ($class, $type, $projlist) = @_;

    my $reservations = LookupAll( $class, $type );
    my @forecast = ();
    my $t = time();    
    
    IsFeasible( $class, $reservations, undef, undef, undef, $projlist,
		\@forecast );

    my $free = $forecast[ 0 ]->{'free'};
    my $answer = $free;

    foreach my $f ( @forecast ) {
	if( $f->{'free'} < $free ) {
	    my $deltat = $f->{'t'} - $t;

	    $deltat = 0 if( $deltat < 0 );

	    # Weight the nodes based on how far into the future the
	    # reservation is.  The 0x10000 is chosen so that a node available
	    # for the next 24 hours only is worth about half a node available
781
	    # indefinitely.
782 783 784 785 786 787 788
	    $answer -= ( ( $free - $f->{'free'} ) * exp( -$deltat / 0x10000 ) );
	    
	    $free = $f->{'free'};
	}
    }

    return $answer;
789 790
}

791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844
#
# Generate a time series of counts of nodes of a given type.
sub Forecast($$;$) {
    my ($class, $type, $projlist) = @_;

    my $reservations = LookupAll( $class, $type );
    my @forecast = ();
    my @answer = ();
    my $t = time();
    
    IsFeasible( $class, $reservations, undef, undef, undef, undef, \@forecast );

    foreach my $f ( @forecast ) {
	my $unavailable = 0;
	my $held = 0;
	my $free = $f->{'free'};

	foreach my $pid ( keys( %{$f->{'used'}} ) ) {
	    $unavailable += $f->{'used'}->{$pid};
	}
	
	foreach my $pid ( keys( %{$f->{'reserved'}} ) ) {
	    my $r = $f->{'reserved'}->{$pid};
	    my $u = $f->{'used'}->{$pid};

	    if( $r > $u ) {
		if( grep( $_ eq $pid, @$projlist ) ) {
		    $held += $r - $u;
		} else {
		    $unavailable += $r - $u;
		}
	    }
	}
	
	my %r = (
	    t => $f->{'t'},
	    unavailable => $unavailable,
	    held => $held,
	    free => $free
	    );

	if( $r{'t'} < $t ) {
	    # event in the past; overwrite initial result in list but do
	    # not append
	    $r{'t'} = $t;
	    $answer[ 0 ] = \%r;
	} else {
	    push( @answer, \%r );
	}
    }
    
    return @answer;
}

845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930
#
# Find any future periods with smaller predicted availability than the
# present.
sub FuturePressure($$;$) {
    my ($class, $typelist, $projlist) = @_;

    my @reservations = ();
    
    foreach my $type ( @$typelist ) {
	my $typeres = LookupAll( $class, $type );

	push( @reservations, @$typeres );
    }

    my @forecast = ();
    my @answer = ();
    my $t = time();
    my $maxused = 0;    
    my $under_pressure = 0;
    my $period;
    
    IsFeasible( $class, \@reservations, undef, undef, undef, undef,
		\@forecast );

    foreach my $f ( @forecast ) {
	my $unavailable = 0;
	my $held = 0;
	my $free = $f->{'free'};

	foreach my $pid ( keys( %{$f->{'used'}} ) ) {
	    $unavailable += $f->{'used'}->{$pid};
	}
	
	foreach my $pid ( keys( %{$f->{'reserved'}} ) ) {
	    my $r = $f->{'reserved'}->{$pid};
	    my $u = $f->{'used'}->{$pid};

	    if( $r > $u ) {
		if( grep( $_ eq $pid, @$projlist ) ) {
		    $held += $r - $u;
		} else {
		    $unavailable += $r - $u;
		}
	    }
	}

	if( $f->{'t'} <= $t ) {
	    $maxused = $unavailable if( $unavailable > $maxused );
	} elsif( $under_pressure ) {
	    if( $unavailable <= $maxused ) {
		$under_pressure = 0;
		push( @answer, [ $period, $f->{'t'} ] );
	    }
	} else {
	    if( $unavailable > $maxused ) {
		$under_pressure = 1;
		$period = $f->{'t'};
	    }
	}
    }

    return @answer;
}

#
# Find the earliest unfulfilled reservation for any of the specified projects.
# (If a project is using at least as many nodes as it has reserved,
# reservation(s) will be considered fulfilled and ignored as a possible
# result.)  Optionally limited to particular node type(s), otherwise
# reservations for any node type are returned.
#
# Returns a timestamp if any unfulfilled reservation exists, otherwise undef.
sub OutstandingReservation($$;$) {
    my ($class, $projlist, $typelist ) = @_;
    my $earliest = undef;
    
    foreach ( @$projlist ) {
	# reject illegal PIDs
	return undef unless /^[-\w]+$/;
    }
    
    my $query_result = DBQueryFatal( "SELECT DISTINCT(type) FROM " .
				     "future_reservations WHERE pid IN ('" .
				     join( "','", @$projlist ) . "')" );

    while( my($type) = $query_result->fetchrow_array() ) {
931 932
	next if( defined( $typelist ) && !grep( $_ eq $type, @$typelist ) );
	
933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957
	my $reservations = LookupAll( $class, $type );

	my @forecast = ();
    
	IsFeasible( $class, $reservations, undef, undef, undef, undef,
		    \@forecast );

	foreach my $f ( @forecast ) {
	    foreach my $pid ( keys ( %{$f->{'reserved'}} ) ) {
		if( grep( $_ eq $pid, @$projlist ) &&
		    ( !exists( $f->{'used'}->{$pid} ) ||
		      $f->{'used'}->{$pid} < $f->{'reserved'}->{$pid} ) ) {
		    # Found an unfulfilled reservation.
		    my $t = $f->{'t'};

		    $earliest = $t if( !defined( $earliest ) ||
				       $t < $earliest );
		}
	    }
	}
    }

    return $earliest;
}

958 959
# Return a list of (pid, nodetype, reserved, used) hashes for any currently
# active reservations belonging to a listed project.
960 961 962 963 964 965 966 967 968
sub CurrentReservations($$) {
    my ($class, $projlist) = @_;
    my @answer = ();
    
    foreach ( @$projlist ) {
	# reject illegal PIDs
	return undef unless /^[-\w]+$/;
    }

969
    my $query_result = DBQueryFatal(
970 971 972 973 974 975
	"SELECT r.pid, r.type, SUM( r.nodes ), " .
	    "(SELECT COUNT(*) FROM reserved AS res, nodes AS n WHERE " .
	    "res.pid=r.pid AND res.node_id=n.node_id AND n.type=r.type) " .
	"FROM future_reservations AS r WHERE r.pid IN ('" .
	join( "','", @$projlist ) .
	"') AND r.approved IS NOT NULL GROUP BY r.pid, r.type" );
976

977 978 979 980
    while( my($pid, $type, $reserved, $used) =
	   $query_result->fetchrow_array() ) {
	push( @answer, { 'pid' => $pid, 'nodetype' => $type,
			 'reserved' => $reserved, 'used' => $used } );
981
    }
982
    
983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002
    return @answer;
}

# Return a list of (pid, nodetype, nodecount, starttime, endtime) hashes
# for any reservations belonging to a listed project starting within the
# next 24 hours.
sub UpcomingReservations($$) {
    my ($class, $projlist) = @_;
    my @answer = ();
    
    foreach ( @$projlist ) {
	# reject illegal PIDs
	return undef unless /^[-\w]+$/;
    }

    my $query_result = DBQueryFatal( "SELECT pid, type AS nodetype, " .
				     "nodes AS nodecount, " .
				     "UNIX_TIMESTAMP(start) AS starttime, " .
				     "UNIX_TIMESTAMP(end) AS endtime FROM " .
				     "future_reservations WHERE " .
1003
				     "approved IS NOT NULL AND " .
1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015
				     "start > NOW() AND " .
				     "start <= ADDDATE( NOW(), 1 ) AND " .
				     "pid IN ('" .
				     join( "','", @$projlist ) . "')" );

    while( my $record = $query_result->fetchrow_hashref() ) {
	push( @answer, $record );
    }

    return @answer;
}

1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031
sub ExptTypes($) {
    my ($exptidx) = @_;
    
    my $query_result = DBQueryFatal( "SELECT DISTINCT( n.type ) FROM " .
				     "reserved AS r, nodes AS n WHERE " .
				     "r.node_id=n.node_id AND " .
				     "r.exptidx='$exptidx'" );

    my @types;
    while( my($type) = $query_result->fetchrow_array() ) {
	push( @types, $type );
    }

    return @types;
}

1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055
#
# Attempt to adjust the expiration time of an existing slice.
#
# Reservation->ExtendSlice( $slice, $new_expire, $error, $impotent, $force )
#
# $slice must be a reference to a GeniSlice object.
# $new_expire is a Unix time_t for the requested new expiration time
# (can be earlier or later than the current expiration time -- in principle
# an earlier time will always succeed, but a later time might fail
# depending on resource availability).
# $error (if defined) is a reference to a scalar; if defined and extension is
# not possible, a reason will be given here.
# $impotent (if defined and true) will attempt a hypothetical extension and
# return success or failure, but make no actual change to any state.
# $force (if defined and true) will make the change to the slice expiration
# even if it violates admission control constraints.
sub ExtendSlice($$$;$$$) {

    my ($class, $slice, $new_expire, $error, $impotent, $force) = @_;

    if( $new_expire <= str2time( $slice->expires() ) ) {
	if( $impotent ) {
	    return 0;
	} else {
1056 1057 1058 1059 1060 1061 1062
	    my $result = $slice->SetExpiration( $new_expire );

	    if( $result < 0 && ref( $error ) ) {
		$$error = "Couldn't update slice expiration";
	    }

	    return $result;
1063 1064 1065 1066 1067 1068
	}
    }

    my $exptidx = $slice->exptidx();
    my $expt = Experiment->Lookup( $exptidx );
	
1069
    my @types = ExptTypes( $exptidx );
1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082
    
    while( 1 ) {
	my $version = GetVersion( $class );
	foreach my $type ( @types ) {
	    my $reservations = LookupAll( $class, $type );
	    foreach my $res ( @$reservations ) {
		if( defined( $res->pid() ) && defined( $res->eid() ) &&
		    $res->pid() eq $expt->pid() &&
		    $res->eid() eq $expt->eid() ) {
		    $res->{'END'} = $new_expire;
		    last;
		}
	    }
1083 1084
	    if( !$force && !IsFeasible( $class, $reservations, $error ) ) {
		return -1;
1085 1086 1087 1088 1089
	    }
	}
	return 0
	    if( $impotent );
	next if( !defined( BeginTransaction( $class, $version ) ) );
1090 1091 1092 1093 1094 1095 1096

	my $result = $slice->SetExpiration( $new_expire );

	if( $result < 0 && ref( $error ) ) {
	    $$error = "Couldn't update slice expiration";
	}
	
1097
	EndTransaction( $class );
1098 1099
	
	return $result;
1100 1101 1102
    }
}

1103
#
1104
# Estimate an upper bound for permissible expiry times on a slice.
1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149
#
# Reservation->MaxSliceExtension( $slice, $max, $error )
#
# Will put the unix time stamp in $$max and return 0 if the slice can be
# extended, or -1 with $$error set.
#
# Of course, this comes with no guarantees... for instance, somebody else
# could make a conflicting reservation/extension before this call returns,
# or before the caller has a chance to do anything useful with the result...
sub MaxSliceExtension($$$;$) {

    my ($class, $slice, $max, $error) = @_;

    my $cur_expire = str2time( $slice->expires() );
    my $max_expire = $cur_expire + 60 * 60 * 24 * 180;
    
    my $exptidx = $slice->exptidx();
    my $expt = Experiment->Lookup( $exptidx );
	
    my @types = ExptTypes( $exptidx );
    
    foreach my $type ( @types ) {
	my $reservations = LookupAll( $class, $type );
	foreach my $res ( @$reservations ) {
	    if( defined( $res->pid() ) && defined( $res->eid() ) &&
		$res->pid() eq $expt->pid() &&
		$res->eid() eq $expt->eid() ) {
		$res->{'END'} = $max_expire;
		last;
	    }
	}
	IsFeasible( $class, $reservations, undef, \$max_expire );
    }

    if( $max_expire <= $cur_expire ) {
	if( ref( $error ) ) {
	    $$error = "No extension possible.";
	}
	return -1;
    } else {
	$$max = $max_expire;
	return 0;
    }
}

1150 1151 1152
sub ExpectedEnd($$) {
    
    my ($class, $experiment) = @_;
1153 1154 1155 1156 1157 1158 1159 1160

    if( $experiment->autoswap() ) {
	return time() + $experiment->autoswap_timeout * 60;
    } elsif( defined( $experiment->expt_expires() ) ) {
	return str2time( $experiment->expt_expires() );
    } else {
	return undef;
    }
1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179
}

#
# Estimate an upper bound for node type count available for an experiment.
#
# Reservation->MaxSwapIn( $experiment, $type )
#
# Will return estimated number of available nodes.
sub MaxSwapIn($$$) {

    my ($class, $experiment, $type) = @_;
    my $MAX = 10000;
    my $overflow;
    
    my $reservations = LookupAll( $class, $type );
    foreach my $res ( @$reservations ) {
	if( defined( $res->pid() ) && defined( $res->eid() ) &&
	    $res->pid() eq $experiment->pid() &&
	    $res->eid() eq $experiment->eid() ) {
1180 1181 1182 1183 1184
	    # Found existing nodes already reserved to the experiment we're
	    # trying to allocate.  In this context, they should be considered
	    # as available.
	    $res->{'PID'} = undef;
	    $res->{'EID'} = undef;
1185
	    $res->SetStart( 0 );
1186
	    $res->SetEnd( undef );
1187 1188 1189
	}
    }

1190 1191 1192 1193 1194
    my $reservation = CreateImmediate( $class, $experiment->pid(),
				       $experiment->eid(),
				       $experiment->swapper(),
				       ExpectedEnd( $class, $experiment ),
				       $type, $MAX );
1195

1196
    push( @$reservations, $reservation );
1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216

    while( $reservation->nodes() > 0 &&
	   !IsFeasible( $class, $reservations, undef, undef, \$overflow ) ) {
	$reservation->SetNodes( $reservation->nodes() - $overflow );
    }

    return $reservation->nodes() > 0 ? $reservation->nodes() : 0;
}

#
# Estimate an upper bound for node counts (by type) available for an experiment.
#
# Reservation->MaxSwapInMap( $experiment )
#
# Will return a hash of estimated number of available nodes, keyed by type.
sub MaxSwapInMap($$) {

    my ($class, $experiment) = @_;
    my %counts = ();

1217 1218 1219
    my $query_result = DBQueryFatal( "SELECT DISTINCT( type ) FROM " .
				     "future_reservations" );
    while( my ($type) = $query_result->fetchrow_array() ) {
1220 1221 1222 1223 1224 1225
	$counts{ $type } = MaxSwapIn( $class, $experiment, $type );
    }

    return \%counts;
}

1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260
#
# Reservable types for reservation system. Class Method.
#
sub ReservableTypes($)
{
    my ($class)  = @_;
    my @result   = ();
    my @alltypes = NodeType->AllTypes();
    
    foreach my $type (@alltypes) {
	next
	    if ($type->class() ne "pc");
	
	my $typename = $type->type();
	
	#
	# Skip if no physical testnodes of this type.
	#
	my $query_result =
	    DBQueryWarn("select count(node_id) from nodes ".
			"where type='$typename' and ".
			"    role='" . $Node::NODEROLE_TESTNODE . "'");
	return ()
	    if (!$query_result);
	next
	    if (!$query_result->numrows);
	
	my ($count) = $query_result->fetchrow_array();
	next
	    if (!$count);
	push(@result, $type);
    }
    return @result;
}

1261 1262
# _Always_ make sure that this 1 is at the end of the file...
1;