Template.pm.in 94.8 KB
Newer Older
1 2 3
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2005-2010 University of Utah and the Flux Group.
5 6 7 8
# All rights reserved.
#
# XXX Need to deal with locking at some point ...
#
9
package Template;
10 11 12 13 14 15 16 17 18 19 20 21

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

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

# Must come after package declaration!
use libdb;
use libtestbed;
use libtblog;
22
use libArchive;
23 24
use Archive;
use Project;
25
use User;
26
use Experiment;
27
use Group;
28
use Logfile;
29
use English;
30
use HTML::Entities;
31
use overload ('""' => 'Stringify');
32 33 34

# Configure variables
my $TB		= "@prefix@";
35
my $CONTROL	= "@USERNODE@";
36
my $STAMPS      = @STAMPS@;
37
my $MD5         = "/sbin/md5";
38 39 40
my $MKDIR       = "/bin/mkdir";
my $RMDIR       = "/bin/rmdir";
my $RM		= "/bin/rm";
41
my $makegraph   = "$TB/bin/template_graph";
42
my $TEVC	= "$TB/bin/tevc";
43
my $DBCONTROL   = "$TB/sbin/opsdb_control";
44
my $RSYNC	= "/usr/local/bin/rsync";
45

46 47
# Cache of template instances to avoid regenerating them.
my %templates   = ();
48
my $debug	= 1;
49

50 51 52 53
# Flags for functions below.
sub STARTRUN_FLAGS_FIRSTRUN()	{ 0x1 ;}
sub STARTRUN_FLAGS_SWAPMOD()	{ 0x2 ;}

54 55 56 57 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
#
# Grab a new GUID for a template. We do not have to use it of course.
#
sub NewGUID($)
{
    my ($pidx) = @_;
    my $idx;
    
    DBQueryFatal("lock tables emulab_indicies write");

    my $query_result = 
	DBQueryFatal("select idx from emulab_indicies ".
		     "where name='next_guid'");
	
    if (! $query_result->num_rows) {
	$idx = 10000;
	
	DBQueryFatal("insert into emulab_indicies (name, idx) ".
		     "values ('next_guid', $idx)");
    }
    else {
	($idx) = $query_result->fetchrow_array();
    }
    my $nextidx = $idx + 1;
    
    DBQueryFatal("update emulab_indicies set idx='$nextidx' ".
		 "where name='next_guid'");

    DBQueryFatal("unlock tables");

    $$pidx = $idx;
    return 0;
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
88 89 90 91 92 93 94 95 96 97
# Little helper and debug function.
sub mysystem($)
{
    my ($command) = @_;

    print STDERR "Running '$command'\n"
	if ($debug);
    return system($command);
}

98
#
99
# Lookup a template and create a class instance to return.
100
#
101
sub Lookup($$;$)
102
{
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
    my ($class, $arg1, $arg2) = @_;
    my ($guid, $vers);

    #
    # A single arg is either an index or a "guid,vers" or "guid/vers" string.
    #
    if (!defined($arg2)) {
	if ($arg1 =~ /^([-\w]*),([-\w]*)$/ ||
	    $arg1 =~ /^([-\w]*)\/([-\w]*)$/) {
	    $guid = $1;
	    $vers = $2;
	}
	else {
	    return undef;
	}
    }
    elsif (! (($arg1 =~ /^[-\w]*$/) && ($arg2 =~ /^[-\w]*$/))) {
	return undef;
    }
    else {
	$guid = $arg1;
	$vers = $arg2;
    }
126

127 128 129 130
    # Look in cache first
    return $templates{"$guid/$vers"}
        if (exists($templates{"$guid/$vers"}));
    
131
    my $query_result =
132 133
	DBQueryWarn("select * from experiment_templates ".
		    "where guid='$guid' and vers='$vers'");
134

135 136
    return undef
	if (!$query_result || !$query_result->numrows);
137

138 139 140 141 142
    my $self             = {};
    $self->{'TEMPLATE'}  = $query_result->fetchrow_hashref();
    # Filled lazily.
    $self->{'INSTANCES'} = undef;
    bless($self, $class);
143
    
144 145 146 147
    # Add to cache. 
    $templates{"$guid/$vers"} = $self;
    
    return $self;
148
}
149 150 151 152
# accessors
sub guid($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'guid'}); }
sub vers($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'vers'}); }
sub pid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'pid'}); }
153
sub pid_idx($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'pid_idx'}); }
154
sub gid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'gid'}); }
Kevin Atkinson's avatar
 
Kevin Atkinson committed
155
sub gid_idx($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'gid_idx'}); }
156
sub eid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'eid'}); }
157
sub exptidx($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'exptidx'}); }
158
sub tid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'tid'}); }
159
sub path($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'path'}); }
160 161
sub archive_idx($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'archive_idx'}); }
162 163 164 165
sub parent_guid($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'parent_guid'}); }
sub IsRoot($) {
    return ! defined($_[0]->{'TEMPLATE'}->{'parent_guid'}); }
166 167 168 169 170 171
sub child_guid($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'child_guid'}); }
sub child_vers($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'child_vers'}); }
sub description($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'description'}); }
172 173 174 175
sub logfile($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'logfile'}); }
sub logfile_open($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'logfile_open'}); }
176 177
sub active($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'active'}); }
178 179

#
180
# Lookup a template given an experiment index.
181
#
182
sub LookupByExptidx($$)
183
{
184
    my ($class, $exptidx) = @_;
185

186 187
    # Use the Template Instance routine, and grab the template out of it.
    my $template_instance = Template::Instance->LookupByExptidx($exptidx);
188

189 190
    return undef
	if (!defined($template_instance));
191

192
    return $template_instance->template();
193 194
}

195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
#
# Lookup a template given pid,eid. This refers to the template itself,
# not an instance of the template.
#
sub LookupByPidEid($$$)
{
    my ($class, $pid, $eid) = @_;

    my $query_result =
	DBQueryWarn("select guid,vers from experiment_templates ".
		    "where pid='$pid' and eid='$eid'");

    return undef
	if (!$query_result || !$query_result->numrows);

    my ($guid,$vers) = $query_result->fetchrow_array();

    return Template->Lookup($guid, $vers);
}

215 216 217 218 219 220 221 222 223 224 225 226 227 228
#
# Return the underlying experiment object for the template itself.
#
sub GetExperiment($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return undef
	if (! ref($self));

    return Experiment->LookupByIndex($self->exptidx());
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
229
#
230
# Refresh a template instance by reloading from the DB.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
231
#
232
sub Refresh($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
233
{
234
    my ($self) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
235

236 237
    return -1
	if (! ref($self));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
238

239 240 241 242 243 244
    my $guid = $self->guid();
    my $vers = $self->vers();
    
    my $query_result =
	DBQueryWarn("select * from experiment_templates ".
		    "where guid='$guid' and vers='$vers'");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
245 246

    return -1
247 248 249
	if (!$query_result || !$query_result->numrows);
	
    $self->{'TEMPLATE'} = $query_result->fetchrow_hashref();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
250 251 252
    return 0;
}

253
#
254 255
# Create a new template. This installs the new record in the DB,
# and returns an instance. There is some bookkeeping along the way.
256
#
257
sub Create($$)
258
{
259 260
    my ($class, $argref) = @_;
    my ($guid, $vers);
261

262 263
    return undef
	if (ref($class));
264

Leigh B. Stoller's avatar
Leigh B. Stoller committed
265 266 267 268 269 270 271 272 273
    my $pid = $argref->{'pid'};
    my $gid = $argref->{'gid'};
    # Need the group object since we want to use its idx.
    my $group = Group->LookupByPidGid($pid, $gid);
    if (!defined($group)) {
	tberror("Could not map $pid/$gid to its object!");
	return undef;
    }

274 275 276 277 278 279 280 281 282 283 284 285 286
    # See if this a child of an existing template.
    if (defined($argref->{'parent_guid'})) {
	$guid = $argref->{'parent_guid'};
    }
    else {
	#
	# Grab a new GUID before we lock other tables.
	#
	if (NewGUID(\$guid) < 0) {
	    tberror("Could not get a new GUID!");
	    return undef;
	}
	$vers = 1;
287 288
    }

289 290 291
    DBQueryWarn("lock tables experiments write, ".
		"            experiment_templates write")
	or return undef;
292

293 294 295 296 297 298 299
    #
    # Find unused version number now that tables are locked. 
    #
    if (! defined($vers)) {
	my $query_result =
	    DBQueryWarn("select MAX(vers) from experiment_templates ".
			"where guid='$guid'");
300

301 302 303 304
	if (!$query_result) {
	    DBQueryWarn("unlock tables");
	    return undef;
	}
305

306 307 308
	$vers = ($query_result->fetchrow_array())[0];
	$vers++;
    }
309

310 311 312
    # We make up an eid using the guid and version. This is the eid for the
    # hidden experiment behind each template. 
    my $eid = "T${guid}-${vers}";
313 314 315

    $argref->{'pid_idx'} = $group->pid_idx();
    $argref->{'gid_idx'} = $group->gid_idx();
316

317
    #
318
    # Sanity check; make sure this eid is not in use. Tables are still locked.
319 320
    #
    my $query_result =
321 322
	DBQueryWarn("select pid,eid from experiments ".
		    "where eid='$eid' and pid='$pid'");
323

324 325 326 327 328 329 330 331 332
    if (!$query_result) {
	DBQueryWarn("unlock tables");
	return undef;
    }
    
    if ($query_result->numrows) {
	DBQueryWarn("unlock tables");
	tberror("Experiment ID $eid in project $pid is already in use!");
	return undef;
333 334
    }

335 336
    my $query = "insert into experiment_templates set ".
	join(",", map("$_='" . $argref->{$_} . "'", keys(%{$argref})));
337

338 339
    # Append the rest
    $query .= ",created=now(),guid='$guid',vers='$vers',eid='$eid'";
340

341 342 343 344 345 346 347
    if (! DBQueryWarn($query)) {
	DBQueryWarn("unlock tables");
	return undef;
    }
    DBQueryWarn("unlock tables");

    return Template->Lookup($guid, $vers);
348 349 350
}

#
351
# Stringify for output.
352
#
353
sub Stringify($)
354
{
355 356 357
    my ($self) = @_;
    my $guid   = $self->guid();
    my $vers   = $self->vers();
358

359
    return "[Template: $guid/$vers]";
360 361
}

362
#
363
# Update a template record given an array reference of slot/value pairs.
364
#
365
sub Update($$)
366
{
367
    my ($self, $argref) = @_;
368

369 370 371
    # Must be a real reference. 
    return -1
	if (! ref($self));
372

373 374
    my $guid = $self->guid();
    my $vers = $self->vers();
375

376 377 378 379
    my $query = "update experiment_templates set ".
	join(",", map("$_='" . $argref->{$_} . "'", keys(%{$argref})));

    $query .= " where guid='$guid' and vers='$vers'";
380 381 382

    return -1
	if (! DBQueryWarn($query));
383 384

    return Refresh($self);
385 386
}

387
#
388 389
# Delete a template (all tables). Note that other parts of the template
# like instances must already be gone when this is called.
390
#
391
sub Delete($)
392
{
393
    my ($self) = @_;
394

395
    # Must be a real reference. 
396
    return -1
397
	if (! ref($self));
398

399 400
    my $guid = $self->guid();
    my $vers = $self->vers();
401 402 403 404 405 406
    my $path = $self->path();

    if (defined($path) && $path ne "" && -e $path) {
	mysystem("$RM -rf $path") == 0
	    or return -1;
    }
407

408
    DeleteAllMetadata($self) == 0
409
	or return -1;
410

411 412
    DeleteInputFiles($self) == 0
	or return -1;
413

414 415 416 417 418
    my $logfile = $self->GetLogFile();
    if (defined($logfile)) {
	$logfile->Delete();
    }

419 420 421 422
    # The graph can be removed if this is the last template version.
    my $query_result =
	DBQueryWarn("select vers from experiment_templates ".
		    "where guid='$guid' and vers!='$vers'");
423 424 425
    return -1
	if (! $query_result);

426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
    if (! $query_result->numrows) {
	DBQueryWarn("delete from experiment_template_graphs ".
		    "where parent_guid='$guid'")
	    or return -1;
    }

    # Make sure the experiment_templates table is always last, in case
    # something goes wrong. 
    my @tables = ("experiment_template_parameters",
		  "experiment_templates");

    foreach my $table (@tables) {
        if ($table eq "experiment_templates") {
            DBQueryWarn("delete from $table ".
			"where guid='$guid' and vers='$vers'")
		or return -1;
        }
        else {
            DBQueryWarn("delete from $table ".
			"where parent_guid='$guid' and parent_vers='$vers'")
		or return -1;
        }
    }
    $self->{'TEMPLATE'} = undef;
450 451 452
    return 0;
}

453 454 455
#
# Logfiles. This all needs to change.
#
456
# Open a new logfile and return it.
457
#
458
sub CreateLogFile($$)
459
{
460
    my ($self, $prefix) = @_;
461 462

    # Must be a real reference. 
463
    return undef
464 465 466 467 468 469 470
	if (! ref($self));

    my $vers     = $self->vers();
    my $guid     = $self->guid();
    my $pid      = $self->pid();
    my $projroot = PROJROOT();
    my $logdir   = "$projroot/$pid/templates/logs";
471
    my $linkname = "$logdir/$prefix.${guid}-${vers}.log";
472

473
    return undef
474 475
	if (! -d $logdir && !mkdir($logdir, 0775));

476
    my $logname  = `mktemp $logdir/$prefix.${guid}-${vers}.XXXXXX`;
477 478 479
    return undef
	if ($?);
    chomp($logname);
480

481 482 483 484 485
    # Create a Logfile.
    my $logfile = Logfile->Create($self->gid_idx(), $logname);
    if (!defined($logfile)) {
	unlink($logname);
	return undef;
486
    }
487 488 489 490 491 492 493 494 495
    # This is untainted.
    $logname = $logfile->filename();

    unlink($linkname)
	if (-e $linkname);
    if (Template::mysystem("touch $logname")) {
	$logfile->Delete();
	unlink($logname);
	return undef;
496 497 498
    }
    if (! link($logname, $linkname)) {
	print STDERR "*** Cannot link $logname,$linkname: $!\n";
499 500 501
	$logfile->Delete();
	unlink($logname);
	return undef;
502
    }
503
    return $logfile;
504 505 506 507 508 509 510
}

#
# Set the experiment to use the logfile. It becomes the "current" spew.
#
sub SetLogFile($$)
{
511
    my ($self, $logfile) = @_;
512 513 514

    # Must be a real reference. 
    return -1
515
	if (! ref($self) || !ref($logfile));
516

517 518 519 520 521 522
    # Kill the old one. Eventually we will save them.
    my $oldlogfile = $self->GetLogFile();
    if (defined($oldlogfile)) {
	$oldlogfile->Delete();
    }
    return $self->Update({'logfile' => $logfile->logid()});
523 524 525 526 527
}

#
# Get the experiment logfile.
#
528
sub GetLogFile($)
529
{
530
    my ($self) = @_;
531 532

    # Must be a real reference. 
533
    return undef
534 535 536
	if (! ref($self));

    # Must do this to catch updates to the logfile variables.
537
    return undef
538 539
	if ($self->Refresh());

540
    return undef
541 542
	if (! $self->logfile());

543
    return Logfile->Lookup($self->logfile());
544 545 546 547 548 549 550 551 552 553 554 555 556
}

#
# Mark the log as open so that the spew keeps looking for more output.
# 
sub OpenLogFile($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

557 558 559 560 561
    my $logfile = $self->GetLogFile();
    return -1
	if (!defined($logfile));

    return $logfile->Open();
562 563 564 565 566 567 568 569 570 571 572 573 574
}

#
# And close it ...
#
sub CloseLogFile($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

575 576 577 578 579
    my $logfile = $self->GetLogFile();
    return -1
	if (!defined($logfile));

    return $logfile->Close();
580 581 582 583 584 585 586 587 588 589 590 591 592
}

#
# And clear it ...
#
sub ClearLogFile($)
{
    my ($self) = @_;

    # Must be a real reference. 
    return -1
	if (! ref($self));

593 594 595 596 597 598 599
    my $logfile = $self->GetLogFile();
    return -1
	if (!defined($logfile));

    $logfile->Delete() == 0
	or return -1;

600 601 602 603
    my $guid = $self->guid();
    my $vers = $self->vers();

    if (!DBQueryWarn("update experiment_templates set ".
604
		     "    logfile=NULL ".
605 606 607 608 609 610
		     "where guid='$guid' and vers='$vers'")) {
	return -1;
    }
    return $self->Refresh();
}

611
#
612
# Template permission checks. Using the experiment access check stuff.
613
#
614 615 616
# Usage: AccessCheck($guid, $uid, $access_type)
#	 returns 0 if not allowed.
#        returns 1 if allowed.
617
#
618
sub AccessCheck($$$;$)
619
{
620
    my ($self, $guid, $user, $access_type);
621 622 623 624 625 626
    my $mintrust;
    
    #
    # If called as a method, no guid argument is provided. 
    #
    $self = shift();
627

628
    if (ref($self)) {
629
	($user, $access_type) = @_;
630 631
    }
    else {
632
	($guid, $user, $access_type) = @_;
633

634 635 636 637 638 639 640 641 642
	$self = Template->Lookup($guid, 1);
	return 0
	    if (! $self);
    }
    
    if ($access_type < TB_EXPT_MIN ||
	$access_type > TB_EXPT_MAX) {
	tbdie("Invalid access type: $access_type!");
    }
643

644 645 646
    #
    # Admins do whatever they want!
    #
647
    if (TBAdmin()) {
648 649
	return 1;
    }
650

651 652 653 654 655 656 657 658 659 660
    #
    # Transition to using user objects instead of uids
    #
    if (! ref($user)) {
	my $uid = MapNumericUID($user);

	$user = User->Lookup($uid);
	return 0
	    if (! defined($user));
    }
661

662
    #
663
    # A template may be destroyed by the creator or the project/group leader.
664 665 666 667 668 669 670 671
    #
    if ($access_type == TB_EXPT_READINFO) {
	$mintrust = PROJMEMBERTRUST_USER;
    }
    else {
	$mintrust = PROJMEMBERTRUST_LOCALROOT;
    }

672 673 674 675 676 677 678
    #
    # Map to group object.
    #
    my $group = Group->Lookup($self->gid_idx());
    return 0
	if (!defined($group));

679 680 681 682 683
    #
    # Either proper permission in the group, or group_root in the project.
    # This lets group_roots muck with other people's experiments, including
    # those in groups they do not belong to.
    #
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698
    my $membership = $group->LookupUser($user);
    return 1
	if (defined($membership) &&
	    TBMinTrust($membership->trust(), $mintrust));

    my $project = $group->GetProject();
    return 0
	if (!defined($project));

    $membership = $project->LookupUser($user);
    return 1
	if (defined($membership) &&
	    TBMinTrust($membership->trust(), PROJMEMBERTRUST_GROUPROOT));

    return 0;
699 700
}

701
#
702
# Return a list of all children of the given template.
703
#
704
sub Children($$)
705
{
706
    my ($self, $resultp) = @_;
707

708 709 710
    # Must be a real reference. 
    return -1
	if (! ref($self));
711

712 713 714 715 716 717 718 719 720 721
    my $guid      = $self->guid();
    my %children  = ();
    my @allkids   = ();
    my @kids      = ();
    my @result    = ();
    
    my $query_result =
	DBQueryWarn("select vers,parent_vers from experiment_templates ".
		    "where parent_guid='$guid' ".
		    "order by vers desc");
722
    return -1
723
	if (!$query_result);
724

725 726 727
    while (my ($vers, $parent_vers) = $query_result->fetchrow_array()) {
	$children{$parent_vers} = []
	    if (!exists($children{$parent_vers}));
728

729 730 731 732 733 734 735 736 737 738 739 740 741 742
	# List of all children for the parent.
	push(@{ $children{$parent_vers} }, $vers);
    }

    # Start with direct children of this template.
    unshift(@allkids, @{ $children{$self->vers()} })
	if (exists($children{$self->vers()}));

    # Descend the tree getting all children recursively.
    while (@allkids) {
	my $kid   = pop(@allkids);

	# New kid to return
	push(@kids, $kid);
743

744 745 746 747 748 749
	# New children of kid
	unshift(@allkids, @{ $children{$kid} })
	    if (exists($children{$kid}));
    }
    # Most recent templates first.
    @kids = sort {$b <=> $a} @kids;
750

751 752 753 754 755 756 757
    # Now convert to template objects.
    foreach my $vers (@kids) {
	my $template = Template->Lookup($guid, $vers);
	return -1
	    if (! $template);
	push(@result, $template);
    }
758

759
    @$resultp = @result;
760 761 762 763
    return 0;
}

#
764 765 766 767 768
# Add an input file to the template. The point of this is to reduce
# duplication by taking an md5 of the input file, and sharing that
# record/file.
# 
sub AddInputFile($$)
769
{
770 771
    my ($self, $inputfile) = @_;
    my $input_data_idx;
772

773 774 775
    # Must be a real reference. 
    return -1
	if (! ref($self));
776

777
    my $data_string = `cat $inputfile`;
778 779 780
    return -1
	if ($?);

781 782 783 784
    my $guid = $self->guid();
    my $vers = $self->vers();
    my $pid  = $self->pid();
    my $tid  = $self->tid();
785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800

    if ($data_string) {
	# As you can see, we md5 the raw data.
	$data_string = DBQuoteSpecial($data_string);
	if (length($data_string) >= DBLIMIT_NSFILESIZE()) {
	    tberror("Input file is too big (> " . DBLIMIT_NSFILESIZE() . ")!");
	    return -1;
	}

	#
	# Grab an MD5 of the file to see if we already have a copy of it.
	# Avoids needless duplication.
	#
	my $md5 = `$MD5 -q $inputfile`;
	chomp($md5);

801 802 803 804
	DBQueryWarn("lock tables experiment_template_inputs write, ".
		    "            experiment_template_input_data write")
	    or return -1;

805 806 807 808
	my $query_result =
	    DBQueryWarn("select idx from experiment_template_input_data ".
			"where md5='$md5'");

809 810 811 812
	if (!$query_result) {
	    DBQueryWarn("unlock tables");
	    return -1;
	}
813 814

	if ($query_result->numrows) {
815
	    ($input_data_idx) = $query_result->fetchrow_array();
816 817 818 819 820 821 822
	}
	else {
	    $query_result =
		DBQueryWarn("insert into experiment_template_input_data ".
			    "(idx, md5, input) ".
			    "values (NULL, '$md5', $data_string)");
	    
823 824 825 826 827
	    if (!$query_result) {
		DBQueryWarn("unlock tables");
		return -1;
	    }
	    $input_data_idx = $query_result->insertid;
828 829
	}

830 831 832 833
	$query_result =
	    DBQueryWarn("insert into experiment_template_inputs ".
			" (idx, parent_guid, parent_vers, ".
			"  pid, tid, input_idx) values ".
834
			" (NULL, '$guid', '$vers', '$pid', '$tid', ".
835 836
			"  '$input_data_idx')");
	DBQueryWarn("unlock tables");
837
	return -1
838
	    if (!$query_result);
839 840 841 842
    }
    return 0;
}

843
#
844
# Delete all input files, say for a template create/modify that fails.
845
#
846
sub DeleteInputFiles($)
847
{
848
    my ($self) = @_;
849

850 851 852 853 854 855 856
    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $guid = $self->guid();
    my $vers = $self->vers();
    
857 858
    DBQueryWarn("lock tables experiment_template_inputs as i write, ".
		"            experiment_template_inputs as j write, ".
Leigh B. Stoller's avatar
Leigh B. Stoller committed
859
		"            experiment_template_inputs write, ".
860 861 862 863 864 865 866 867 868 869 870 871 872 873
		"            experiment_template_input_data write")
	or return -1;

    #
    # The point of this query is to see if any of the input files in this
    # template are shared with some other template, and thus should not
    # be deleted from the input_data table.
    #
    my $query_result =
	DBQueryWarn("select i.idx,i.input_idx,count(j.input_idx) as count ".
		    "   from experiment_template_inputs as i ".
		    "left join experiment_template_inputs as j on ".
		    "     j.input_idx=i.input_idx ".
		    "where i.parent_guid='$guid' and ".
874
		    "      i.parent_vers='$vers' ".
875 876 877 878 879 880 881 882 883 884 885 886 887
		    "group by j.input_idx having count > 1");

    if (! $query_result) {
	DBQueryWarn("unlock tables");
	return -1;
    }

    while (my ($input_idx, $data_idx) = $query_result->fetchrow_array()) {
	DBQueryWarn("delete from experiment_template_input_data ".
		    "where idx='$data_idx'");
    }
    $query_result = 
	DBQueryWarn("delete from experiment_template_inputs ".
888
		    "where parent_guid='$guid' and parent_vers='$vers'");
889 890 891 892 893 894 895 896
    DBQueryWarn("unlock tables");
    
    return -1
	if (! $query_result);

    return 0;
}

897
#
898
# Add a metadata record. 
899
#
900
sub NewMetadata($$$$;$)
901
{
902
    my ($self, $name, $value, $creator, $type) = @_;
903
    my $guid;
904 905
    my $version  = 1;
    my $internal = 0;
906
    my $metadata_type;
907

908
    # Must be a real reference. 
909
    return -1
910 911 912 913
	if (! ref($self));

    my $template_guid = $self->guid();
    my $template_vers = $self->vers();
914 915
    my $creator_uid   = $creator->uid();
    my $creator_dbid  = $creator->uid_idx();
916 917 918 919 920 921

    return -1
	if (NewGUID(\$guid) < 0);

    # Special ...
    $internal = 1
922
	if (defined($type));
923

924
    # Current set of allowed types;
925
    my @okay_types = ("tid", "template_description", "parameter_description",
926
		      "annotation", "instance_description", "run_description");
927 928 929 930 931 932 933 934 935 936 937 938 939

    if (defined($type)) {
	if (! grep {$_ eq $type} @okay_types) {
	    tberror("Illegal metadata type: $type");
	    return -1;
	}
	$metadata_type = "'$type'";
    }
    else {
	$metadata_type = "NULL";
    }

    my $safename  = DBQuoteSpecial($name);
940 941
    # HTML entity encode; yep, plain text only.
    my $safevalue = DBQuoteSpecial(encode_entities($value));
942 943 944

    my $query_result =
	DBQueryWarn("insert into experiment_template_metadata_items set ".
945 946
		    "   guid='$guid', vers='$version', ".
		    "   uid='$creator_uid', uid_idx='$creator_dbid', ".
947
		    "   template_guid='$template_guid', ".
948
		    "   name=$safename, value=$safevalue, created=now()");
949 950 951 952 953
    return -1
	if (!$query_result);

    DBQueryWarn("insert into experiment_template_metadata set ".
		"   parent_guid='$template_guid', ".
954
		"   parent_vers='$template_vers', ".
955 956
		"   metadata_guid='$guid', ".
		"   metadata_vers='$version', ".
957
		"   metadata_type=$metadata_type, ".
958
		"   internal=$internal")
959
	or return -1;
960 961 962 963

    # Some metadata is special ...
    if (defined($type)) {
	if ($type eq "parameter_description") {
964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989
	    DBQueryWarn("update experiment_template_parameters set ".
			"   metadata_guid='$guid', ".
			"   metadata_vers='$version' ".
			"where parent_guid='$template_guid' and ".
			"      parent_vers='$template_vers' and ".
			"      name=$safename")
		or return -1;
 	}
	elsif ($type eq "instance_description" &&
	       $name =~ /^__instance_description_(\d*)$/) {
	    my $exptidx = $1;
	    
	    DBQueryWarn("update experiment_template_instances set ".
			"  description=$safevalue ".
			"where exptidx='$exptidx'")
		or return -1;
	}
	elsif ($type eq "run_description" &&
	       $name =~ /^__run_description_(\d*)_(\d*)$/) {
	    my $exptidx = $1;
	    my $runidx  = $2;
	    
	    DBQueryWarn("update experiment_runs set ".
			"  description=$safevalue ".
			"where exptidx='$exptidx' and idx='$runidx'")
		or return -1;
990 991
	}
    }
992 993 994 995
    
    return 0;
}

996 997 998
#
# Lookup a metadata value by name, optionally returning guid/vers.
#
999
sub LookupMetadata($$;$$$)
1000
{
1001
    my ($self, $name, $pguid, $pvers, $ptype) = @_;
1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $template_guid = $self->guid();
    my $template_vers = $self->vers();

    $name = DBQuoteSpecial($name);

    my $query_result =
1013
	DBQueryWarn("select metadata_guid,metadata_vers,metadata_type ".
1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025
		    "   from experiment_template_metadata as m ".
		    "left join experiment_template_metadata_items as i on ".
		    "     m.metadata_guid=i.guid and m.metadata_vers=i.vers ".
		    "where m.parent_guid='$template_guid' and ".
		    "      m.parent_vers='$template_vers' and ".
		    "      i.name=$name");
    
    return -1
	if (!$query_result);
    return 0
	if (!$query_result->numrows);

1026 1027
    my ($metadata_guid, $metadata_vers, $metadata_type) =
	$query_result->fetchrow_array();
1028 1029 1030 1031
    $$pguid = $metadata_guid
	if (defined($pguid));
    $$pvers = $metadata_vers
	if (defined($pvers));
1032 1033
    $$ptype = $metadata_type
	if (defined($ptype));
1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052
    
    return 1;
}

#
# Modify a metadata record; these are versioned of course.
#
sub ModifyMetadata($$$$)
{
    my ($self, $name, $value, $creator) = @_;
    my $guid;
    my $version = 1;

    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $template_guid = $self->guid();
    my $template_vers = $self->vers();
1053 1054
    my $creator_uid   = $creator->uid();
    my $creator_dbid  = $creator->uid_idx();
1055 1056
    my $parent_guid;
    my $parent_vers;
1057
    my $metadata_type;
1058
    my $already_exists =
1059 1060
	$self->LookupMetadata($name,
			      \$parent_guid, \$parent_vers, \$metadata_type);
1061 1062 1063
    return -1
	if ($already_exists <= 0);

1064 1065
    my $safename  = DBQuoteSpecial($name);
    my $safevalue = DBQuoteSpecial(encode_entities($value));
1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085

    DBQueryWarn("lock tables experiment_template_metadata_items write")
	or return -1;
    
    my $query_result =
	DBQueryWarn("select MAX(vers) ".
		    " from experiment_template_metadata_items ".
		    "where guid='$parent_guid'");
    if (!$query_result) {
	DBQueryWarn("unlock tables");
	return -1;
    }
    my ($metadata_vers) = $query_result->fetchrow_array();
    $metadata_vers++;

    #
    # Insert new item.
    #
    if (!DBQueryWarn("insert into experiment_template_metadata_items set ".
		     "     guid='$parent_guid',vers='$metadata_vers', ".
1086 1087
		     "     template_guid='$template_guid', ".
		     "     uid='$creator_uid', uid_idx='$creator_dbid', ".
1088 1089
		     "     parent_guid='$parent_guid',".
		     "     parent_vers='$parent_vers'," .
1090
		     "     name=$safename, value=$safevalue, created=now()")) {
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107
	DBQueryWarn("unlock tables");
	return -1;
    }
    DBQueryWarn("unlock tables");

    if (!DBQueryWarn("update experiment_template_metadata ".
		     "  set metadata_vers='$metadata_vers' ".
		     "where metadata_guid='$parent_guid' and ".
		     "      metadata_vers='$parent_vers'")) {
	DBQueryWarn("delete from experiment_template_metadata_items ".
		    "where guid='$parent_guid',vers='$metadata_vers'");
	return -1;
    }

    #
    # XXX Some metadata is special ...
    #
1108 1109
    if (defined($metadata_type)) {
	if ($metadata_type eq "tid") {
1110
	    DBQueryWarn("update experiment_templates set tid=$safevalue ".
1111 1112 1113 1114 1115 1116
			"where guid='$template_guid' and ".
			"      vers='$template_vers'")
		or return -1;
	    
	    Refresh($self);
	    # This can fail; it is not critical.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1117
	    Template::mysystem("$makegraph $template_guid");
1118 1119
	}
	elsif ($metadata_type eq "template_description") {
Leigh B. Stoller's avatar