Template.pm.in 95.5 KB
Newer Older
1 2
#!/usr/bin/perl -wT
#
3
# Copyright (c) 2005-2010 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
#
# XXX Need to deal with locking at some point ...
#
26
package Template;
27 28 29 30 31 32 33 34 35 36 37

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

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

# Must come after package declaration!
use libdb;
use libtestbed;
38
use libtblog_simple;
39
use libArchive;
40 41
use Archive;
use Project;
42
use User;
43
use Experiment;
44
use Group;
45
use Logfile;
46
use English;
47
use HTML::Entities;
48
use overload ('""' => 'Stringify');
49 50 51

# Configure variables
my $TB		= "@prefix@";
52
my $CONTROL	= "@USERNODE@";
53
my $STAMPS      = @STAMPS@;
54
my $MD5         = "/sbin/md5";
55 56 57
my $MKDIR       = "/bin/mkdir";
my $RMDIR       = "/bin/rmdir";
my $RM		= "/bin/rm";
58
my $makegraph   = "$TB/bin/template_graph";
59
my $TEVC	= "$TB/bin/tevc";
60
my $DBCONTROL   = "$TB/sbin/opsdb_control";
61
my $RSYNC	= "/usr/local/bin/rsync";
62

63 64
# Cache of template instances to avoid regenerating them.
my %templates   = ();
65
my $debug	= 1;
66

67 68 69 70
# Flags for functions below.
sub STARTRUN_FLAGS_FIRSTRUN()	{ 0x1 ;}
sub STARTRUN_FLAGS_SWAPMOD()	{ 0x2 ;}

71 72 73 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
#
# 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
105 106 107 108 109 110 111 112 113 114
# Little helper and debug function.
sub mysystem($)
{
    my ($command) = @_;

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

115
#
116
# Lookup a template and create a class instance to return.
117
#
118
sub Lookup($$;$)
119
{
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
    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;
    }
143

144 145 146 147
    # Look in cache first
    return $templates{"$guid/$vers"}
        if (exists($templates{"$guid/$vers"}));
    
148
    my $query_result =
149 150
	DBQueryWarn("select * from experiment_templates ".
		    "where guid='$guid' and vers='$vers'");
151

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

155 156 157 158 159
    my $self             = {};
    $self->{'TEMPLATE'}  = $query_result->fetchrow_hashref();
    # Filled lazily.
    $self->{'INSTANCES'} = undef;
    bless($self, $class);
160
    
161 162 163 164
    # Add to cache. 
    $templates{"$guid/$vers"} = $self;
    
    return $self;
165
}
166 167 168 169
# 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'}); }
170
sub pid_idx($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'pid_idx'}); }
171
sub gid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'gid'}); }
Kevin Atkinson's avatar
 
Kevin Atkinson committed
172
sub gid_idx($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'gid_idx'}); }
173
sub eid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'eid'}); }
174
sub exptidx($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'exptidx'}); }
175
sub tid($)  { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'tid'}); }
176
sub path($) { return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'path'}); }
177 178
sub archive_idx($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'archive_idx'}); }
179 180 181 182
sub parent_guid($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'parent_guid'}); }
sub IsRoot($) {
    return ! defined($_[0]->{'TEMPLATE'}->{'parent_guid'}); }
183 184 185 186 187 188
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'}); }
189 190 191 192
sub logfile($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'logfile'}); }
sub logfile_open($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'logfile_open'}); }
193 194
sub active($) {
    return ((! ref($_[0])) ? -1 : $_[0]->{'TEMPLATE'}->{'active'}); }
195 196

#
197
# Lookup a template given an experiment index.
198
#
199
sub LookupByExptidx($$)
200
{
201
    my ($class, $exptidx) = @_;
202

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

206 207
    return undef
	if (!defined($template_instance));
208

209
    return $template_instance->template();
210 211
}

212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
#
# 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);
}

232 233 234 235 236 237 238 239 240 241 242 243 244 245
#
# 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
246
#
247
# Refresh a template instance by reloading from the DB.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
248
#
249
sub Refresh($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
250
{
251
    my ($self) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
252

253 254
    return -1
	if (! ref($self));
Leigh B. Stoller's avatar
Leigh B. Stoller committed
255

256 257 258 259 260 261
    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
262 263

    return -1
264 265 266
	if (!$query_result || !$query_result->numrows);
	
    $self->{'TEMPLATE'} = $query_result->fetchrow_hashref();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
267 268 269
    return 0;
}

270
#
271 272
# Create a new template. This installs the new record in the DB,
# and returns an instance. There is some bookkeeping along the way.
273
#
274
sub Create($$)
275
{
276 277
    my ($class, $argref) = @_;
    my ($guid, $vers);
278

279 280
    return undef
	if (ref($class));
281

Leigh B. Stoller's avatar
Leigh B. Stoller committed
282 283 284 285 286 287 288 289 290
    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;
    }

291 292 293 294 295 296 297 298 299 300 301 302 303
    # 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;
304 305
    }

306 307 308
    DBQueryWarn("lock tables experiments write, ".
		"            experiment_templates write")
	or return undef;
309

310 311 312 313 314 315 316
    #
    # 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'");
317

318 319 320 321
	if (!$query_result) {
	    DBQueryWarn("unlock tables");
	    return undef;
	}
322

323 324 325
	$vers = ($query_result->fetchrow_array())[0];
	$vers++;
    }
326

327 328 329
    # 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}";
330 331 332

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

334
    #
335
    # Sanity check; make sure this eid is not in use. Tables are still locked.
336 337
    #
    my $query_result =
338 339
	DBQueryWarn("select pid,eid from experiments ".
		    "where eid='$eid' and pid='$pid'");
340

341 342 343 344 345 346 347 348 349
    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;
350 351
    }

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

355 356
    # Append the rest
    $query .= ",created=now(),guid='$guid',vers='$vers',eid='$eid'";
357

358 359 360 361 362 363 364
    if (! DBQueryWarn($query)) {
	DBQueryWarn("unlock tables");
	return undef;
    }
    DBQueryWarn("unlock tables");

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

#
368
# Stringify for output.
369
#
370
sub Stringify($)
371
{
372 373 374
    my ($self) = @_;
    my $guid   = $self->guid();
    my $vers   = $self->vers();
375

376
    return "[Template: $guid/$vers]";
377 378
}

379
#
380
# Update a template record given an array reference of slot/value pairs.
381
#
382
sub Update($$)
383
{
384
    my ($self, $argref) = @_;
385

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

390 391
    my $guid = $self->guid();
    my $vers = $self->vers();
392

393 394 395 396
    my $query = "update experiment_templates set ".
	join(",", map("$_='" . $argref->{$_} . "'", keys(%{$argref})));

    $query .= " where guid='$guid' and vers='$vers'";
397 398 399

    return -1
	if (! DBQueryWarn($query));
400 401

    return Refresh($self);
402 403
}

404
#
405 406
# Delete a template (all tables). Note that other parts of the template
# like instances must already be gone when this is called.
407
#
408
sub Delete($)
409
{
410
    my ($self) = @_;
411

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

416 417
    my $guid = $self->guid();
    my $vers = $self->vers();
418 419 420 421 422 423
    my $path = $self->path();

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

425
    DeleteAllMetadata($self) == 0
426
	or return -1;
427

428 429
    DeleteInputFiles($self) == 0
	or return -1;
430

431 432 433 434 435
    my $logfile = $self->GetLogFile();
    if (defined($logfile)) {
	$logfile->Delete();
    }

436 437 438 439
    # 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'");
440 441 442
    return -1
	if (! $query_result);

443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466
    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;
467 468 469
    return 0;
}

470 471 472
#
# Logfiles. This all needs to change.
#
473
# Open a new logfile and return it.
474
#
475
sub CreateLogFile($$)
476
{
477
    my ($self, $prefix) = @_;
478 479

    # Must be a real reference. 
480
    return undef
481 482 483 484 485 486 487
	if (! ref($self));

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

490
    return undef
491 492
	if (! -d $logdir && !mkdir($logdir, 0775));

493
    my $logname  = `mktemp $logdir/$prefix.${guid}-${vers}.XXXXXX`;
494 495 496
    return undef
	if ($?);
    chomp($logname);
497

498 499 500 501 502
    # Create a Logfile.
    my $logfile = Logfile->Create($self->gid_idx(), $logname);
    if (!defined($logfile)) {
	unlink($logname);
	return undef;
503
    }
504 505 506 507 508 509 510 511 512
    # This is untainted.
    $logname = $logfile->filename();

    unlink($linkname)
	if (-e $linkname);
    if (Template::mysystem("touch $logname")) {
	$logfile->Delete();
	unlink($logname);
	return undef;
513 514 515
    }
    if (! link($logname, $linkname)) {
	print STDERR "*** Cannot link $logname,$linkname: $!\n";
516 517 518
	$logfile->Delete();
	unlink($logname);
	return undef;
519
    }
520
    return $logfile;
521 522 523 524 525 526 527
}

#
# Set the experiment to use the logfile. It becomes the "current" spew.
#
sub SetLogFile($$)
{
528
    my ($self, $logfile) = @_;
529 530 531

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

534 535 536 537 538 539
    # Kill the old one. Eventually we will save them.
    my $oldlogfile = $self->GetLogFile();
    if (defined($oldlogfile)) {
	$oldlogfile->Delete();
    }
    return $self->Update({'logfile' => $logfile->logid()});
540 541 542 543 544
}

#
# Get the experiment logfile.
#
545
sub GetLogFile($)
546
{
547
    my ($self) = @_;
548 549

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

    # Must do this to catch updates to the logfile variables.
554
    return undef
555 556
	if ($self->Refresh());

557
    return undef
558 559
	if (! $self->logfile());

560
    return Logfile->Lookup($self->logfile());
561 562 563 564 565 566 567 568 569 570 571 572 573
}

#
# 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));

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

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

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

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

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

    return $logfile->Close();
597 598 599 600 601 602 603 604 605 606 607 608 609
}

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

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

610 611 612 613 614 615 616
    my $logfile = $self->GetLogFile();
    return -1
	if (!defined($logfile));

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

617 618 619 620
    my $guid = $self->guid();
    my $vers = $self->vers();

    if (!DBQueryWarn("update experiment_templates set ".
621
		     "    logfile=NULL ".
622 623 624 625 626 627
		     "where guid='$guid' and vers='$vers'")) {
	return -1;
    }
    return $self->Refresh();
}

628
#
629
# Template permission checks. Using the experiment access check stuff.
630
#
631 632 633
# Usage: AccessCheck($guid, $uid, $access_type)
#	 returns 0 if not allowed.
#        returns 1 if allowed.
634
#
635
sub AccessCheck($$$;$)
636
{
637
    my ($self, $guid, $user, $access_type);
638 639 640 641 642 643
    my $mintrust;
    
    #
    # If called as a method, no guid argument is provided. 
    #
    $self = shift();
644

645
    if (ref($self)) {
646
	($user, $access_type) = @_;
647 648
    }
    else {
649
	($guid, $user, $access_type) = @_;
650

651 652 653 654 655 656 657 658 659
	$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!");
    }
660

661 662 663
    #
    # Admins do whatever they want!
    #
664
    if (TBAdmin()) {
665 666
	return 1;
    }
667

668 669 670 671 672 673 674 675 676 677
    #
    # Transition to using user objects instead of uids
    #
    if (! ref($user)) {
	my $uid = MapNumericUID($user);

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

679
    #
680
    # A template may be destroyed by the creator or the project/group leader.
681 682 683 684 685 686 687 688
    #
    if ($access_type == TB_EXPT_READINFO) {
	$mintrust = PROJMEMBERTRUST_USER;
    }
    else {
	$mintrust = PROJMEMBERTRUST_LOCALROOT;
    }

689 690 691 692 693 694 695
    #
    # Map to group object.
    #
    my $group = Group->Lookup($self->gid_idx());
    return 0
	if (!defined($group));

696 697 698 699 700
    #
    # 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.
    #
701 702 703 704 705 706 707 708 709 710 711 712 713 714 715
    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;
716 717
}

718
#
719
# Return a list of all children of the given template.
720
#
721
sub Children($$)
722
{
723
    my ($self, $resultp) = @_;
724

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

729 730 731 732 733 734 735 736 737 738
    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");
739
    return -1
740
	if (!$query_result);
741

742 743 744
    while (my ($vers, $parent_vers) = $query_result->fetchrow_array()) {
	$children{$parent_vers} = []
	    if (!exists($children{$parent_vers}));
745

746 747 748 749 750 751 752 753 754 755 756 757 758 759
	# 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);
760

761 762 763 764 765 766
	# New children of kid
	unshift(@allkids, @{ $children{$kid} })
	    if (exists($children{$kid}));
    }
    # Most recent templates first.
    @kids = sort {$b <=> $a} @kids;
767

768 769 770 771 772 773 774
    # Now convert to template objects.
    foreach my $vers (@kids) {
	my $template = Template->Lookup($guid, $vers);
	return -1
	    if (! $template);
	push(@result, $template);
    }
775

776
    @$resultp = @result;
777 778 779 780
    return 0;
}

#
781 782 783 784 785
# 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($$)
786
{
787 788
    my ($self, $inputfile) = @_;
    my $input_data_idx;
789

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

794
    my $data_string = `cat $inputfile`;
795 796 797
    return -1
	if ($?);

798 799 800 801
    my $guid = $self->guid();
    my $vers = $self->vers();
    my $pid  = $self->pid();
    my $tid  = $self->tid();
802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817

    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);

818 819 820 821
	DBQueryWarn("lock tables experiment_template_inputs write, ".
		    "            experiment_template_input_data write")
	    or return -1;

822 823 824 825
	my $query_result =
	    DBQueryWarn("select idx from experiment_template_input_data ".
			"where md5='$md5'");

826 827 828 829
	if (!$query_result) {
	    DBQueryWarn("unlock tables");
	    return -1;
	}
830 831

	if ($query_result->numrows) {
832
	    ($input_data_idx) = $query_result->fetchrow_array();
833 834 835 836 837 838 839
	}
	else {
	    $query_result =
		DBQueryWarn("insert into experiment_template_input_data ".
			    "(idx, md5, input) ".
			    "values (NULL, '$md5', $data_string)");
	    
840 841 842 843 844
	    if (!$query_result) {
		DBQueryWarn("unlock tables");
		return -1;
	    }
	    $input_data_idx = $query_result->insertid;
845 846
	}

847 848 849 850
	$query_result =
	    DBQueryWarn("insert into experiment_template_inputs ".
			" (idx, parent_guid, parent_vers, ".
			"  pid, tid, input_idx) values ".
851
			" (NULL, '$guid', '$vers', '$pid', '$tid', ".
852 853
			"  '$input_data_idx')");
	DBQueryWarn("unlock tables");
854
	return -1
855
	    if (!$query_result);
856 857 858 859
    }
    return 0;
}

860
#
861
# Delete all input files, say for a template create/modify that fails.
862
#
863
sub DeleteInputFiles($)
864
{
865
    my ($self) = @_;
866

867 868 869 870 871 872 873
    # Must be a real reference. 
    return -1
	if (! ref($self));

    my $guid = $self->guid();
    my $vers = $self->vers();
    
874 875
    DBQueryWarn("lock tables experiment_template_inputs as i write, ".
		"            experiment_template_inputs as j write, ".
Leigh B. Stoller's avatar
Leigh B. Stoller committed
876
		"            experiment_template_inputs write, ".
877 878 879 880 881 882 883 884 885 886 887 888 889 890
		"            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 ".
891
		    "      i.parent_vers='$vers' ".
892 893 894 895 896 897 898 899 900 901 902 903 904
		    "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 ".
905
		    "where parent_guid='$guid' and parent_vers='$vers'");
906 907 908 909 910 911 912 913
    DBQueryWarn("unlock tables");
    
    return -1
	if (! $query_result);

    return 0;
}

914
#
915
# Add a metadata record. 
916
#
917
sub NewMetadata($$$$;$)
918
{
919
    my ($self, $name, $value, $creator, $type) = @_;
920
    my $guid;
921 922
    my $version  = 1;
    my $internal = 0;
923
    my $metadata_type;
924

925
    # Must be a real reference. 
926
    return -1
927 928 929 930
	if (! ref($self));

    my $template_guid = $self->guid();
    my $template_vers = $self->vers();
931 932
    my $creator_uid   = $creator->uid();
    my $creator_dbid  = $creator->uid_idx();
933 934 935 936 937 938

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

    # Special ...
    $internal = 1
939
	if (defined($type));
940

941
    # Current set of allowed types;
942
    my @okay_types = ("tid", "template_description", "parameter_description",
943
		      "annotation", "instance_description", "run_description");
944 945 946 947 948 949 950 951 952 953 954 955 956

    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);
957 958
    # HTML entity encode; yep, plain text only.
    my $safevalue = DBQuoteSpecial(encode_entities($value));
959 960 961

    my $query_result =
	DBQueryWarn("insert into experiment_template_metadata_items set ".
962 963
		    "   guid='$guid', vers='$version', ".
		    "   uid='$creator_uid', uid_idx='$creator_dbid', ".
964
		    "   template_guid='$template_guid', ".
965
		    "   name=$safename, value=$safevalue, created=now()");
966 967 968 969 970
    return -1
	if (!$query_result);

    DBQueryWarn("insert into experiment_template_metadata set ".
		"   parent_guid='$template_guid', ".
971
		"   parent_vers='$template_vers', ".
972 973
		"   metadata_guid='$guid', ".
		"   metadata_vers='$version', ".
974
		"   metadata_type=$metadata_type, ".
975
		"   internal=$internal")
976
	or return -1;
977 978 979 980

    # Some metadata is special ...
    if (defined($type)) {
	if ($type eq "parameter_description") {
981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006
	    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;
1007 1008
	}
    }
1009 1010 1011 1012
    
    return 0;
}

1013 1014 1015
#
# Lookup a metadata value by name, optionally returning guid/vers.
#
1016
sub LookupMetadata($$;$$$)
1017
{
1018
    my ($self, $name, $pguid, $pvers, $ptype) = @_;
1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029

    # 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 =
1030
	DBQueryWarn("select metadata_guid,metadata_vers,metadata_type ".
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042
		    "   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);

1043 1044
    my ($metadata_guid, $metadata_vers, $metadata_type) =
	$query_result->fetchrow_array();
1045 1046 1047 1048
    $$pguid = $metadata_guid
	if (defined($pguid));
    $$pvers = $metadata_vers
	if (defined($pvers));
1049 1050
    $$ptype = $metadata_type
	if (defined($ptype));
1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069
    
    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();
1070 1071
    my $creator_uid   = $creator->uid();
    my $creator_dbid  = $creator->uid_idx();
1072 1073
    my $parent_guid;
    my $parent_vers;
1074
    my $metadata_type;
1075
    my $already_exists =
1076 1077
	$self->LookupMetadata($name,
			      \$parent_guid, \$parent_vers, \$metadata_type);
1078 1079 1080
    return -1
	if ($already_exists <= 0);

1081 1082
    my $safename  = DBQuoteSpecial($name);
    my $safevalue = DBQuoteSpecial(encode_entities($value));
1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102

    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', ".
1103 1104
		     "     template_guid='$template_guid', ".
		     "     uid='$creator_uid', uid_idx='$creator_dbid', ".
1105 1106
		     "     parent_guid='$parent_guid',".
		     "     parent_vers='$parent_vers'," .
1107
		     "     name=$safename, value=$safevalue, created=now()")) {
1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124
	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 ...
    #