libtestbed.pm 11.1 KB
Newer Older
1 2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2000-2015 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 27 28 29 30 31
#

#
# This is a stub library to provide a few things that libtestbed on
# boss provides.
#
package libtestbed;
use Exporter;
@ISA    = "Exporter";
Ryan Jackson's avatar
Ryan Jackson committed
32 33
@EXPORT = qw( SENDMAIL TB_BOSSNODE TB_EVENTSERVER
	      TBScriptLock TBScriptUnlock
34 35
	      TBSCRIPTLOCK_OKAY TBSCRIPTLOCK_TIMEDOUT
	      TBSCRIPTLOCK_IGNORE TBSCRIPTLOCK_FAILED TBSCRIPTLOCK_GLOBALWAIT
36
	      TBSCRIPTLOCK_SHAREDLOCK TBSCRIPTLOCK_NONBLOCKING
37 38
	      TBSCRIPTLOCK_WOULDBLOCK TBSCRIPTLOCK_INTERRUPTED
	      TBSCRIPTLOCK_INTERRUPTIBLE
39
	      TBTimeStamp TBTimeStampWithDate TBBackGround ReOpenLog
40
	    );
41 42 43

# Must come after package declaration!
use English;
44 45
# For locking below
use Fcntl ':flock';
46
use IO::Handle;
47
use Time::HiRes qw(gettimeofday);
48
use POSIX qw(:signal_h);
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67

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

# Load up the paths. Done like this in case init code is needed.
BEGIN
{
    if (! -e "/etc/emulab/paths.pm") {
	die("Yikes! Could not require /etc/emulab/paths.pm!\n");
    }
    require "/etc/emulab/paths.pm";
    import emulabpaths;
}

# Need this.
use libtmcc;

Ryan Jackson's avatar
Ryan Jackson committed
68 69 70 71 72
sub SENDMAILWith($$$$;$$@);

sub SENDMAIL($$$;$$@)
{
    my($To, $Subject, $Message, $From, $Headers, @Files) = @_;
73
    SENDMAILWith("/usr/sbin/sendmail -i -t", $To, $Subject, $Message, $From, $Headers, @Files);
Ryan Jackson's avatar
Ryan Jackson committed
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
}

sub SENDMAILWith($$$$;$$@)
{
    my($Command, $To, $Subject, $Message, $From, $Headers, @Files) = @_;
    my $tag = uc($MAILTAG);

    #
    # Untaint the path locally. Note that using a "local" fails on older perl!
    #
    my $SAVE_PATH = $ENV{'PATH'};
    $ENV{'PATH'} = "/bin:/usr/bin";
    delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

    if (! open(MAIL, "| $Command")) {
	print STDERR "SENDMAIL: Could not start sendmail: $!\n";
	goto bad;
    }

    #
    # Sendmail will figure this out if not given.
    #
    if (defined($From) && $From) {
	print MAIL "From: $From\n";
    }
    if (defined($Headers) && length($Headers) > 0) {
	print MAIL "$Headers\n";
    }
    print MAIL "X-NetBed: $SCRIPTNAME\n";
    if (defined($To)) {
	print MAIL "To: $To\n";
    }
    print MAIL "Subject: $tag: $Subject\n";
    print MAIL "\n";
    print MAIL "$Message\n";
    print MAIL "\n";

    if (@Files) {
	foreach my $file ( @Files ) {
	    if (defined($file) && open(IN, "$file")) {
		print MAIL "\n--------- $file --------\n";

		while (<IN>) {
		    print MAIL "$_";
		}
		close(IN);
	    }
	}
    }

    print MAIL "\n";
    if (! close(MAIL)) {
	print STDERR "SENDMAIL: Could not finish sendmail: $!\n";
	goto bad;
    }
    $ENV{'PATH'} = $SAVE_PATH;
    return 1;

  bad:
    $ENV{'PATH'} = $SAVE_PATH;
    return 0;
}
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200

#
# Put ourselves into the background, directing output to the log file.
# The caller provides the logfile name, which should have been created
# with mktemp, just to be safe. Returns the usual return of fork.
#
# usage int TBBackGround(char *filename).
#
sub TBBackGround($)
{
    my ($logname) = @_;

    my $mypid = fork();
    if ($mypid) {
	return $mypid;
    }
    select(undef, undef, undef, 0.2);

    #
    # We have to disconnect from the caller by redirecting both STDIN and
    # STDOUT away from the pipe. Otherwise the caller (the web server) will
    # continue to wait even though the parent has exited.
    #
    open(STDIN, "< /dev/null") or
	die("opening /dev/null for STDIN: $!");

    ReOpenLog($logname);

    #
    # Create a new session to ensure we are clear of any process group
    #
    POSIX::setsid() or
	die("setsid failed: $!");

    return 0;
}

#
# As for newsyslog. Call this on signal. newsyslog will have renamed the
# the original file already.
#
sub ReOpenLog($)
{
    my ($logname) = @_;

    # Note different taint check (allow /).
    if ($logname =~ /^([-\@\w.\/]+)$/) {
	$logname = $1;
    }
    else {
	die "Bad data in logfile name: $logname";
    }

    open(STDERR, ">> $logname") or die("opening $logname for STDERR: $!");
    open(STDOUT, ">> $logname") or die("opening $logname for STDOUT: $!");

    #
    # Turn off line buffering on output
    #
    STDOUT->autoflush(1);
    STDERR->autoflush(1);

    return 0;
}

Ryan Jackson's avatar
Ryan Jackson committed
201 202 203 204 205 206 207 208 209
#
# Return a timestamp. We don't care about day/date/year. Just the time mam.
#
# TBTimeStamp()
#
sub TBTimeStamp()
{
    my ($seconds, $microseconds) = gettimeofday();

210 211
    return POSIX::strftime("%H:%M:%S", localtime($seconds)) . "." .
	sprintf("%06d", $microseconds);
Ryan Jackson's avatar
Ryan Jackson committed
212 213 214 215
}

sub TBTimeStampWithDate()
{
216 217
    my ($seconds, $microseconds) = gettimeofday();

218 219
    return POSIX::strftime("%m/%d/20%y %H:%M:%S", localtime($seconds)) . "." .
	sprintf("%06d", $microseconds);
Ryan Jackson's avatar
Ryan Jackson committed
220 221
}

222 223 224 225 226 227 228 229
#
# Return name of the bossnode.
#
sub TB_BOSSNODE()
{
    return tmccbossname();
}

230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260
#
# Return name of the event server.
#
sub TB_EVENTSERVER()
{
    # duplicate behavior of tmcc bossinfo function
    my @searchdirs = ( "/etc/testbed","/etc/emulab","/etc/rc.d/testbed",
		       "/usr/local/etc/testbed","/usr/local/etc/emulab" );
    my $bossnode = TB_BOSSNODE();
    my $eventserver = '';

    foreach my $d (@searchdirs) {
	if (-e "$d/eventserver" && !(-z "$d/eventserver")) {
	    $eventserver = `cat $d/eventserver`;
	    last;
	}
    }
    if ($eventserver eq '') {
	my @ds = split(/\./,$bossnode,2);
	if (scalar(@ds) == 2) {
	    # XXX event-server hardcode
	    $eventserver = "event-server.$ds[1]";
	}
    }
    if ($eventserver eq '') {
	$eventserver = "event-server";
    }

    return $eventserver;
}

261 262 263 264 265 266 267 268 269 270
#
# Serialize an operation (script).
#
my $lockname;
my $lockhandle;

# Return Values.
sub TBSCRIPTLOCK_OKAY()		{ 0;  }
sub TBSCRIPTLOCK_TIMEDOUT()	{ 1;  }
sub TBSCRIPTLOCK_IGNORE()	{ 2;  }
271
sub TBSCRIPTLOCK_WOULDBLOCK()	{ 4;  }
272
sub TBSCRIPTLOCK_INTERRUPTED()	{ 8;  }
273
sub TBSCRIPTLOCK_FAILED()	{ -1; }
274 275 276
sub TBSCRIPTLOCK_GLOBALWAIT()	{ 0x01; }
sub TBSCRIPTLOCK_SHAREDLOCK()	{ 0x10; }
sub TBSCRIPTLOCK_NONBLOCKING()	{ 0x20; }
277
sub TBSCRIPTLOCK_INTERRUPTIBLE(){ 0x40; }
278

Ryan Jackson's avatar
Ryan Jackson committed
279
#
280 281
# There are two kinds of serialization.
#
282
#   * Usual Kind: Each party just waits the lock.
283 284 285 286 287 288
#   * Other Kind: Only the first party really needs to run; the others just
#                 need to wait. For example; exports_setup operates globally,
#                 so there is no reason to run it more then once. We just
#                 need to make sure that everyone waits for the one that is
#		  running to finish. Use the global option for this.
#
289
sub TBScriptLock($;$$$)
290
{
291
    my ($token, $flags, $waittime, $lockhandle_ref) = @_;
292
    local *LOCK;
293 294
    my $global = 0;
    my $shared = 0;
295
    my $interruptible = 0;
296 297 298 299 300 301 302

    if (!defined($waittime)) {
	$waittime = 30;
    }
    elsif ($waittime == 0) {
	$waittime = 99999999;
    }
303 304 305 306
    $global = 1
	if (defined($flags) && ($flags & TBSCRIPTLOCK_GLOBALWAIT()));
    $shared = 1
	if (defined($flags) && ($flags & TBSCRIPTLOCK_SHAREDLOCK()));
307 308
    $interruptible = 1
	if (defined($flags) && ($flags & TBSCRIPTLOCK_INTERRUPTIBLE()));
309 310 311 312 313 314 315 316 317 318 319
    $lockname = "/var/tmp/testbed_${token}_lockfile";

    my $oldmask = umask(0000);

    if (! open(LOCK, ">>$lockname")) {
	print STDERR "Could not open $lockname!\n";
	umask($oldmask);
	return TBSCRIPTLOCK_FAILED();
    }
    umask($oldmask);

320 321 322 323 324 325 326 327 328 329 330 331 332 333
    my $checkforinterrupt = sub {
	my $sigset = POSIX::SigSet->new;
	sigpending($sigset);

	# XXX Why isn't SIGRTMIN and SIGRTMAX defined in the POSIX module.
	for (my $i = 1; $i < 50; $i++) {
	    if ($sigset->ismember($i)) {
		print "checkForInterrupt: Signal $i is pending\n";
		return 1;
	    }
	}
	return 0;
    };

334 335
    if (! $global) {
	#
336
	# A plain old lock.
337
	#
Mike Hibler's avatar
Mike Hibler committed
338
	my $tries = 0;
339 340 341
	my $ltype = ($shared ? LOCK_SH : LOCK_EX);
	while (flock(LOCK, $ltype|LOCK_NB) == 0) {
	    return TBSCRIPTLOCK_WOULDBLOCK()
Leigh B Stoller's avatar
Leigh B Stoller committed
342
		if (defined($flags) && ($flags & TBSCRIPTLOCK_NONBLOCKING()));
343
	    
Mike Hibler's avatar
Mike Hibler committed
344 345
	    print "Another $token is in progress (${tries}s). Waiting ...\n"
		if (($tries++ % 60) == 0);
346 347 348 349 350 351 352

	    $waittime--;
	    if ($waittime == 0) {
		print STDERR "Could not get the lock after a long time!\n";
		return TBSCRIPTLOCK_TIMEDOUT();
	    }
	    sleep(1);
353 354 355 356
	    if ($interruptible && &$checkforinterrupt()) {
		print STDERR "ScriptLock interrupted by signal!\n";
		return TBSCRIPTLOCK_INTERRUPTED();
	    }
357 358
	}
	# Okay, got the lock. Save the handle. We need it below.
359 360 361 362 363 364
	if (defined($lockhandle_ref)) {
	    $$lockhandle_ref = *LOCK;
	}
	else {
	    $lockhandle = *LOCK;
	}
365 366 367 368 369 370 371 372
	return TBSCRIPTLOCK_OKAY();
    }

    #
    # Okay, a global lock.
    #
    # If we don't get it the first time, we wait for:
    # 1) The lock to become free, in which case we do our thing
Ryan Jackson's avatar
Ryan Jackson committed
373
    # 2) The time on the lock to change, in which case we wait for that
374 375 376 377 378 379
    #    process to finish, and then we are done since there is no
    #    reason to duplicate what the just finished process did.
    #
    if (flock(LOCK, LOCK_EX|LOCK_NB) == 0) {
	my $oldlocktime = (stat(LOCK))[9];
	my $gotlock = 0;
Ryan Jackson's avatar
Ryan Jackson committed
380

381 382
	while (1) {
	    print "Another $token in progress. Waiting a moment ...\n";
Ryan Jackson's avatar
Ryan Jackson committed
383

384 385 386 387 388 389 390 391 392 393
	    if (flock(LOCK, LOCK_EX|LOCK_NB) != 0) {
		# OK, got the lock
		$gotlock = 1;
		last;
	    }
	    my $locktime = (stat(LOCK))[9];
	    if ($locktime != $oldlocktime) {
		$oldlocktime = $locktime;
		last;
	    }
Ryan Jackson's avatar
Ryan Jackson committed
394

395 396 397 398 399 400
	    $waittime--;
	    if ($waittime <= 0) {
		print STDERR "Could not get the lock after a long time!\n";
		return TBSCRIPTLOCK_TIMEDOUT();
	    }
	    sleep(1);
401 402 403 404
	    if ($interruptible && &$checkforinterrupt()) {
		print STDERR "ScriptLock interrupted by signal!\n";
		return TBSCRIPTLOCK_INTERRUPTED();
	    }
405 406
	}

407
	my $count = 0;
408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427
	#
	# If we did not get the lock, wait for the process that did to finish.
	#
	if (!$gotlock) {
	    while (1) {
		if ((stat(LOCK))[9] != $oldlocktime) {
		    return TBSCRIPTLOCK_IGNORE();
		}
		if (flock(LOCK, LOCK_EX|LOCK_NB) != 0) {
		    close(LOCK);
		    return TBSCRIPTLOCK_IGNORE();
		}

		$waittime--;
		if ($waittime <= 0) {
		    print STDERR
			"Process with the lock did not finish after ".
			"a long time!\n";
		    return TBSCRIPTLOCK_TIMEDOUT();
		}
Ryan Jackson's avatar
Ryan Jackson committed
428
		sleep(1);
429 430 431 432
		if ($interruptible && &$checkforinterrupt()) {
		    print STDERR "ScriptLock interrupted by signal!\n";
		    return TBSCRIPTLOCK_INTERRUPTED();
		}
433 434 435 436 437 438 439 440
	    }
	}
    }
    #
    # Perl-style touch(1)
    #
    my $now = time;
    utime $now, $now, $lockname;
Ryan Jackson's avatar
Ryan Jackson committed
441

442 443 444 445 446 447
    if (defined($lockhandle_ref)) {
	$$lockhandle_ref = *LOCK;
    }
    else {
	$lockhandle = *LOCK;
    }
448 449 450 451 452 453
    return TBSCRIPTLOCK_OKAY();
}

#
# Unlock; Just need to close the file (releasing the lock).
#
454
sub TBScriptUnlock(;$)
455
{
456 457
    my ($lockhandle_arg) = @_;
    if (defined($lockhandle_arg)) {
458
	flock($lockhandle_arg, LOCK_UN);
459 460
	close($lockhandle_arg);
    }
461 462 463
    elsif (defined($lockhandle)) {
	flock($lockhandle, LOCK_UN);
	close($lockhandle);
Leigh B Stoller's avatar
Leigh B Stoller committed
464
	undef($lockhandle);
465
    }
466 467
}

468 469
1;