libtestbed.pm.in 7.38 KB
Newer Older
1
#!/usr/bin/perl -w
Leigh B. Stoller's avatar
Leigh B. Stoller committed
2 3 4

#
# EMULAB-COPYRIGHT
5
# Copyright (c) 2000-2005 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
6 7 8
# All rights reserved.
#

9 10 11 12 13
package libtestbed;
use Exporter;

@ISA = "Exporter";
@EXPORT =
14
    qw ( SENDMAIL OPENMAIL TBTimeStamp TBBackGround TBDateTimeFSSafe
15
	 TBMakeLogname TB_BOSSNODE TB_OPSEMAIL TBGenSecretKey TBDebugTimeStamp
16
	 TBDebugTimeStampsOn TBForkCmd TB_BOSSEVENTPORT TB_EVENTSERVER);
17

18 19 20 21 22 23 24
# After package decl.
use English;
use POSIX qw(strftime);
use POSIX qw(setsid);
use Fcntl;
use IO::Handle;
use File::Basename;
25
use Time::HiRes qw(gettimeofday);
26

27 28
#my $MAILTAG  = "@OURDOMAIN@";
my $MAILTAG  = "@THISHOMEBASE@";
29
my $BOSSNODE = "@BOSSNODE@";
30
my $TIMESTAMPS = "@TIMESTAMPS@";
31
my $TBOPSEMAIL = "@TBOPSEMAIL@";
32
my $SCRIPTNAME = "Unknown";
33 34 35

# Hostname of our boss node
sub TB_BOSSNODE()	{ $BOSSNODE; }
36

37 38 39
# Testbed ops email address
sub TB_OPSEMAIL()	{ $TBOPSEMAIL; }

40 41
# This is for the swigged event library which includes this file.
sub TB_BOSSEVENTPORT()  { "@BOSSEVENTPORT@"; }
42
sub TB_EVENTSERVER()    { "@EVENTSERVER@" . "." . "@OURDOMAIN@"; }
43

44 45 46 47 48 49 50 51
# Untainted scriptname for email below.
if ($PROGRAM_NAME =~ /^([-\w\.\/]+)$/) {
    $SCRIPTNAME = basename($1);
}
else {
    $SCRIPTNAME = "Tainted";
}

52 53 54 55 56 57
#
# Turn off line buffering on output
#
STDOUT->autoflush(1);
STDERR->autoflush(1);

58 59 60 61 62 63 64 65
# A library of useful stuff.

# Send an email message via sendmail -t.
#
# I am mimicking the PHP mail interface, only because I'm old and its
# hard to remember new things. I did add a From arg since thats basically
# required to make the mail look nice (not generated by root or daemon!).
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
66
# SENDMAIL(To, Subject, Message, [From], [More Headers], [files to append])
67
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
68
sub SENDMAIL($$$;$$@)
69
{
70
    my($To, $Subject, $Message, $From, $Headers, @Files) = @_;
71
    my $tag = uc($MAILTAG);
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86

    if (! open(MAIL, "|/usr/sbin/sendmail -t")) {
	print STDERR "SENDMAIL: Could not start sendmail: $!\n";
	return 0;
    }

    #
    # Sendmail will figure this out if not given.
    # 
    if (defined($From) && $From) {
	print MAIL "From: $From\n";
    }
    if (defined($Headers)) {
	print MAIL "$Headers\n";
    }
87
    print MAIL "X-NetBed: $SCRIPTNAME\n";
88 89
    print MAIL "To: $To\n";
    print MAIL "Subject: $tag: $Subject\n";
90 91
    print MAIL "\n";
    print MAIL "$Message\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
92 93
    print MAIL "\n";

94
    if (@Files) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
95 96
	foreach my $file ( @Files ) {
	    if (open(IN, "$file")) {
97
		print MAIL "\n--------- $file --------\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
98 99 100 101 102 103 104 105 106

		while (<IN>) {
		    print MAIL "$_";
		}
		close(IN);
	    }
	}
    }
    
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 136 137
    print MAIL "\n";
    if (! close(MAIL)) {
	print STDERR "SENDMAIL: Could not finish sendmail: $!\n";
	return 0;
    }
    return 1;
}

#
# Fire up a sendmail process, and return the handle for the caller
# to print the body of the message into. This is easer in many places.
#
# OPENMAIL(To, Subject, [From], [More Headers])
#
sub OPENMAIL($$;$$)
{
    my($To, $Subject, $From, $Headers) = @_;
    local *MAIL;

    if (! open(MAIL, "|/usr/sbin/sendmail -t")) {
	print STDERR "OPENMAIL: Could not start sendmail: $!\n";
	return 0;
    }

    #
    # Sendmail will figure this out if not given.
    # 
    if (defined($From) && $From) {
	print MAIL "From: $From\n";
    }
    print MAIL "To: $To\n";
138
    print MAIL "Subject: $tag: $Subject\n";
139 140 141
    if (defined($Headers)) {
	print MAIL "$Headers\n";
    }
142
    print MAIL "X-NetBed: $SCRIPTNAME\n";
143 144 145 146 147
    print MAIL "\n";

    return(*MAIL);
}

148 149 150 151 152 153 154
#
# Return a timestamp. We don't care about day/date/year. Just the time mam.
# 
# TBTimeStamp()
#
sub TBTimeStamp()
{
155 156 157
    my ($seconds, $microseconds) = gettimeofday();
    
    return POSIX::strftime("%H:%M:%S", localtime($seconds)) . ":$microseconds";
158 159 160 161 162 163 164 165 166 167 168
}

#
# Another routine for creating a file name based on the current date and
# time. The format is slightly different so that it can be a proper filename.
#
# usage: char *TBDateTimeFSSafe()
#
sub TBDateTimeFSSafe()
{
    return POSIX::strftime("20%y%m%d-%H.%M.%S", localtime());
169 170
}

171 172 173 174 175 176 177 178 179 180 181 182 183
#
# Print out a timestamp if the TIMESTAMPS configure variable was set.
# 
# usage: void TBDebugTimeStamp(@)
#
sub TBDebugTimeStamp(@)
{
    my @strings = @_;
    if ($TIMESTAMPS) {
	print "TIMESTAMP: ", TBTimeStamp(), " ", join("",@strings), "\n";
    }
}

184 185 186 187 188 189 190 191
#
# Turn on timestamps locally. We could do this globally by using an
# env variable to pass it along, but lets see if we need that.
# 
sub TBDebugTimeStampsOn()
{
    $TIMESTAMPS = 1;
}
192

193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
#
# 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;
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
208 209
    select(undef, undef, undef, 0.2);
    
210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
    #
    # 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: $!");

    # 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: $!");

228 229 230 231 232 233
    #
    # Turn off line buffering on output
    #
    STDOUT->autoflush(1);
    STDERR->autoflush(1);

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

240 241 242
    return 0;
}

243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
#
# Create a logname and untaint it!
#
sub TBMakeLogname($)
{
    my($prefix) = @_;
    my $logname;
    
    $logname = `mktemp /tmp/${prefix}.XXXXXX`;

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

    return $logname;
}

263 264 265 266 267
#
# Get me a secret key!
#
sub TBGenSecretKey()
{
268 269
    my $key=`/bin/dd if=/dev/urandom count=128 bs=1 2> /dev/null | /sbin/md5`;
    chomp($key);
270 271 272
    return $key;
}

Kirk Webb's avatar
 
Kirk Webb committed
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 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
#
# Fork+exec a command and return its exit value.  This is similar to
# system(), but does not use a shell to invoke the command.  The function
# exits with the return value from wait().
#
# If the second optional param is passed and true, then
# a signal handler for TERM will be installed, and the
# child process will be sent a SIGTERM if this (the calling)
# process gets one. The handler exits with the exit status returned by 
# wait() after sending the signal.
#
sub TBForkCmd($;$) {
    my ($cmd, $dokill) = @_;

    my $childpid = fork();
        
    if ($childpid) {
        my $handler = sub {
            kill("TERM", $childpid);
            my $exstat = wait();
            print STDERR "*** $0:\n".
                "    Command terminated: $cmd.\n"; 
            exit($exstat);
        };
        local $SIG{TERM} = \&$handler if (defined($dokill) && $dokill);

        my $waitpid = wait();
        my $exitstatus = $?;
        if ($waitpid < 0) {
            die("*** $0:\n".
                "    Uh oh, wait() returned a negative number");
        }
        elsif ($waitpid != $childpid) {
            warn("*** $0:\n".
                "    pid returned by wait() != pid ".
                "from fork(): $waitpid $childpid");
        }
        return $exitstatus;
    }
    else {
        exec($cmd);
        die("*** $0:\n".
            "    exec of $cmd failed!\n");
    }

    # NOTREACHED
    return(0);
}

322
1;