libArchive.pm.in 28.5 KB
Newer Older
1
2
3
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
34
35
36
37
38
39
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group.
# All rights reserved.
#
# XXX Need to deal with locking at some point ...
#
package libArchive;

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

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

# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
use English;
use File::stat;
use File::Basename;
use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday);

# Configure variables
my $TB		= "@prefix@";
# XXX
my $ARCHIVEDIR  = "/usr/testbed/exparchive";
my $TESTMODE    = @TESTMODE@;
my $TBOPS       = "@TBOPSEMAIL@";
my $ELABINELAB  = @ELABINELAB@;
my $MD5		= "/sbin/md5";
my $MKDIR       = "/bin/mkdir";
my $CHMOD       = "/bin/chmod";
my $TAR		= "/usr/bin/tar";
my $RM		= "/bin/rm";
my $CVSBIN      = "/usr/bin/cvs";
40
my $inittag     = 'root';
41
my $debug       = 1;
42
my $cvsopt      = ($debug ? "" : "-q");
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

# Little helper and debug function.
sub mysystem($)
{
    my ($command) = @_;

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

#
# Create a new archive. Returns -1 if any error. Otherwise return
# the new record index.
# 
58
sub ArchiveCreate(;$)
59
{
60
61
    my ($tag) = @_;
    
62
63
    my $idx;
    my $dir;
64
65
66
67
68
69
70
71

    $tag = $inittag
	if (!defined($tag));

    # CVS tags cannot must start with a letter.
    if ($tag =~ /^\d+/) {
	$tag = "T" . $tag;
    }
72
73
74
75
76
77

    #
    # Need to create the directory for it, once we have the index.
    # 
    my $query_result =
	DBQueryWarn("insert into file_archives set ".
78
		    "  idx=NULL, current_tag='$tag', revision='1.1', ".
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
		    "  date_created=UNIX_TIMESTAMP(now())");

    return -1
	if (!$query_result);

    $idx = $query_result->insertid;
    $dir = "$ARCHIVEDIR/$idx";

    #
    # Create the directory and store the absolute path into the new record.
    # This should probably be a privledged operation at some point.
    # 
    mysystem("$MKDIR $dir") == 0 or goto bad;
    mysystem("$CHMOD 775 $dir") == 0 or goto bad;

    DBQueryWarn("update file_archives set directory='$dir' where idx='$idx'")
	or goto bad;

    #
    # Make two subdirs. One to hold the CVS control tree, and the other
    # to hold the currently checked out version of the tree. 
    #
    my $cvsdir = "$dir/repo";
    my $root   = "$dir/root";
    my $temp   = "$dir/tmp";

    if (! mkdir("$cvsdir", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $cvsdir: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$cvsdir")) {
	print STDERR "ArchiveCreate: Could not chmod directory $cvsdir: $!\n";
	goto bad;
    }
    if (! mkdir("$root", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $root: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$root")) {
	print STDERR "ArchiveCreate: Could not chmod directory $root: $!\n";
	goto bad;
    }
    if (! mkdir("$temp", 0777)) {
	print STDERR "ArchiveCreate: Could not mkdir $temp: $!\n";
	goto bad;
    }
    if (! chmod(0777, "$temp")) {
	print STDERR "ArchiveCreate: Could not chmod directory $temp: $!\n";
	goto bad;
    }
    # Init the CVS control files.
130
    mysystem("$CVSBIN $cvsopt -d $cvsdir init") == 0
131
132
133
	or goto bad;
    # Create an stub directory and import it as "root"
    mysystem("cd $dir; mkdir ignore; cd ignore; ".
134
135
	     "$CVSBIN $cvsopt -d $cvsdir import ".
	     "-m 'Initialize' root $tag ${tag}_init")
136
137
	== 0 or goto bad;
    # Now check it out.
138
    mysystem("cd $dir; $CVSBIN $cvsopt -d $cvsdir checkout root")
139
140
141
142
	== 0 or goto bad;

    # Now enter an initial tag for the tree. Nothing actually gets tagged.
    DBQueryWarn("insert into archive_tags set ".
143
		"  tag='$tag', archive_idx='$idx', revision='1.1', ".
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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;
    
    return $idx;

  bad:
#    mysystem("$RM -rf $dir")
#        if (defined($dir));
    DBQueryFatal("delete from file_archives where idx='$idx'")
	if (defined($idx));
    return -1;
}

#
# Add a file to an archive. Returns -1 if any error. Otherwise return 0.
# All this does is copy the file (and its directory structure) into the
# temporary store. Later, after all the files are in the tree, must
# commit it to the repo. 
#
sub ArchiveAdd($$)
{
    my ($archive_idx, $pathname) = @_;

    if (! -e $pathname || ! -r $pathname) {
	print STDERR "ArchiveFile: $pathname cannot be read!\n";
	return -1;
    }

    if (! -f $pathname) {
	print STDERR "ArchiveFile: $pathname must be a plain file!\n";
	return -1;
    }
    #
    # Check that the path does not contain an links to files outside
    # the directory space the user is allowed to access.
    #
    my $realpath = `realpath $pathname`;
    if ($realpath =~ /^([-\w\/\.\+\@,]+)$/) {
	$realpath = $1;
    }
    else {
	print STDERR "ArchiveFile: ".
	    "Bad data returned by realpath: $realpath\n";
    }
    #
    # The file must reside in /proj, /groups, or /users. 
    #
    if (! ($realpath =~ /^\/proj/) &&
	! ($realpath =~ /^\/groups/) &&
	! ($realpath =~ /^\/users/)) {
	print STDERR "ArchiveFile: ".
	    "$realpath does not resolve to an allowed directory!\n";
	return -1;
    }
    
    # Strip leading / from the pathname, and taint check it. 
    if ($pathname =~ /^[\/]+([-\w\/\.\+\@,]+)$/) {
	$pathname = $1;
    }
    else {
	print STDERR "ArchiveFile: Illegal characters in pathname $pathname\n";
	return -1;
    }

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveFile: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveFile: $directory cannot be written!\n";
	return -1;
    }
    my $cvsdir  = "$directory/repo";
    my $rootdir = "$directory/root";
    my $tmpdir  = "$directory/tmp";
    
    #
    # See if the file is already in the archive. We currently deal with
    # just files; directories are gonna be a pain in the butt.
    #
    my $target_path = "$tmpdir/$pathname";

    #
    # The file should not already exist in the temporary store. 
    #
    if (-e $target_path) {
	print STDERR "ArchiveFile: ".
235
	    "WARNING: $pathname already exists in archive '$archive_idx'!\n";
236
237
238
239
240
241
    }

    #
    # Not in the archive. Copy the file in. We use tar cause we
    # want to retain the directory structure and mode bits, etc.
    #
242
    mysystem("$TAR cf - -C / $pathname | tar xf - -C $tmpdir");
243
244
245
246
247
248
249
250
    if ($?) {
	print STDERR "ArchiveFile: Could not copy in /$pathname\n";
	return -1;
    }
    return 0;
}

#
251
252
253
254
255
# Bring the current contents of the temporary store into the archive as a
# checkpoint (or a savepoint I guess). Implementationlly, its really a
# branch off the current import revision, since it does not become a new
# head revision until the entire branch (all the savepoints) is committed
# later, say when the experiment is swapped out.
256
#
257
sub ArchiveSavePoint($;$)
258
{
259
    my ($archive_idx, $savetag) = @_;
260
261
262
263
264
265

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
266
	print STDERR "ArchiveSavePoint: ".
267
268
269
270
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
271
	print STDERR "ArchiveSavePoint: $directory cannot be written!\n";
272
273
274
275
276
	return -1;
    }
    my $cvsdir  = "$directory/repo";
    my $rootdir = "$directory/root";
    my $tmpdir  = "$directory/tmp";
277
278
279
280
281
282
283

    # Need to remember where we came from!
    my $cwd;
    chomp($cwd = `pwd`);
    # Must do the taint check too.
    if ($cwd =~ /^([-\w\.\/]+)$/) {
	$cwd = $1;
284
    }
285
286
287
    else {
	print STDERR "ArchiveSavePoint: Bad data in $cwd!\n";
	return -1;
288
    }
289

290
    if (! chdir("$tmpdir")) {
291
	print STDERR "ArchiveSavePoint: ".
292
293
294
295
	    "Cannot chdir to $tmpdir!\n";
	return -1;
    }

296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
    # Get the current tag for the archive.
    my ($archive_tag, $archive_revision);
    if (GetArchiveCurrentTags($archive_idx,
			      \$archive_tag, \$archive_revision) < 0) {
	print STDERR "ArchiveSavePoint: ".
	    "Archive '$archive_idx' does not have a current tag!\n";
	goto bad;
    }

    # Make up a savetag if one not provided.
    if (!defined($savetag)) {
	my ($seconds, $microseconds) = gettimeofday();
	
	$savetag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
	$savetag .= $microseconds;
	$savetag .= "_savepoint";
    }

    # CVS tags cannot must start with a letter.
    if ($savetag =~ /^\d+/) {
	$savetag = "T" . $savetag;
    }
    
319
320
321
322
323
    #
    # Use cvs import command. This is nice cause it handles all the
    # subdirs and stuff in one shot, instead of trying to deal with
    # each file and directory individually.
    #
324
325
326
327
328
329
330
331
332
333
    # NOTE: Need to specify the current "vendor" branch to import on,
    # or else cvs always uses 1.1.1. After each commit to the head, we
    # bump this so that the savepoints are logically distinct and clearly
    # associated with its head branch. 
    #
    my $rev  = "${archive_revision}.1";
    my $bopt = "-b $rev";
    
    mysystem("$CVSBIN $cvsopt -d $cvsdir import $bopt ".
	   "-m 'SavePoint' root $archive_tag $savetag");
334
335
336
    if ($?) {
	print STDERR "ArchiveCommit: ".
	    "Could not import from $tmpdir!\n";
337
	goto bad;
338
    }
339
340
341
342

    #
    # And record the new tag. 
    # 
343
    DBQueryWarn("insert into archive_tags set ".
344
		"  tag='$savetag', revision='${archive_revision}', ".
345
		"  archive_idx='$archive_idx', ".
346
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;
347

348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
  okay:
    chdir($cwd);
    return 0;

  bad:
    chdir($cwd);
    return -1;
}

#
# Commit the current contents of the temporary store to the archive.
# Returns -1 if any error. Otherwise return 0.
#
sub ArchiveCommit($;$$)
{
    my ($archive_idx, $newtag, $altdir) = @_;

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveCommit: $directory cannot be written!\n";
	return -1;
    }
    my $cvsdir  = "$directory/repo";
    my $rootdir = "$directory/root";
    my $tmpdir  = (defined($altdir) ? $altdir : "$directory/tmp");

    # Need to remember where we came from!
    my $cwd;
    chomp($cwd = `pwd`);
    # Must do the taint check too.
    if ($cwd =~ /^([-\w\.\/]+)$/) {
	$cwd = $1;
    }
    else {
	print STDERR "ArchiveSavePoint: Bad data in $cwd!\n";
	return -1;
    }

    if (! chdir("$tmpdir")) {
	print STDERR "ArchiveCommit: ".
	    "Cannot chdir to $tmpdir!\n";
	return -1;
    }

    # Get the current tags for the archive.
    my ($archive_tag, $archive_revision, $previous_tag);
    if (GetArchiveCurrentTags($archive_idx, \$archive_tag,
			      \$archive_revision, \$previous_tag) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not have a current tag!\n";
	goto bad;
    }

    #
    # Lets see if there has been any action since the last commit.
    # Check for new tags. 
    #
    my $query_result =
	DBQueryWarn("select tag from archive_tags ".
		    "where archive_idx='$archive_idx' ".
		    "order by date_created desc limit 1");
    goto bad
	if (!$query_result || !$query_result->numrows);
    
    my ($tmptag) = $query_result->fetchrow_array();
    if ($tmptag eq $archive_tag) {
	print "ArchiveCommit: Archive is clean; no need to commit.\n";
	goto okay;
    }

    if (!defined($newtag)) {
	my ($seconds, $microseconds) = gettimeofday();
	
	$newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
	$newtag .= $microseconds;
	$newtag .= "_commit";
    }

    # CVS tags cannot must start with a letter.
    if ($newtag =~ /^\d+/) {
	$newtag = "T" . $newtag;
    }
438
439
440
441
442
443

    # Clean the temp dir for next phase.
    mysystem("/bin/rm -rf $tmpdir/*");
    if ($?) {
	print STDERR "ArchiveCommit: ".
	    "Could not remove contents of $tmpdir!\n";
444
	goto bad;
445
446
447
    }

    #
448
    # Form a new head revision and branch tag.
449
    #
450
451
452
453
454
455
456
457
458
    my $next_revision;
    if ($archive_revision =~ /^(\d*)\.(\d*)$/) {
	$next_revision = $1 . "." . ($2 + 1);
    }
    else {
	print STDERR "ArchiveCommit: ".
	    "Could not parse revision $archive_revision!\n";
	goto bad;
    }
459
460

    #
461
462
    # If this is the first commit of the archive, then just checkout
    # and commit to a new head revision. 
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
    if ($archive_revision eq "1.1") {
	mysystem("$CVSBIN $cvsopt -d $cvsdir checkout root");
	if ($?) {
	    print STDERR "ArchiveCommit: ".
		"Could not checkout $archive_tag!\n";
	    goto bad;
	}
    }
    else {
	#
	# Need to merge. Do a fresh checkout, merging the current import branch
	# into the head revsion.
	#
	# Yuck. Need to clear the -b (default branch) or else the merge
	# commit fails for some reason that makes no sense to me, but
	# must make sense to someone at CVS headquarters.
	#
	mysystem("$CVSBIN $cvsopt -d $cvsdir ".
		 "checkout -r $archive_revision root");
	if ($?) {
	    print STDERR "ArchiveCommit: ".
		"Could not checkout revision $archive_revision!\n";
	    goto bad;
	}
	
	mysystem("$CVSBIN $cvsopt -d $cvsdir admin -b root");
	if ($?) {
	    print STDERR "ArchiveCommit: ".
		"Could not clear the default branch!\n";
	    goto bad;
	}
	
	mysystem("$CVSBIN $cvsopt -d $cvsdir update -A ".
		 "-j $previous_tag -j $archive_tag root");
	if ($?) {
	    print STDERR "ArchiveCommit: ".
		"Could not checkout and merge $archive_tag into head.!\n";
	    goto bad;
	}
503
504
    }

505
506
507
508
509
    #
    # And then commit it back to the head revision, using bumped rev number.
    #
    mysystem("$CVSBIN $cvsopt -d $cvsdir commit -f -R -r $next_revision ".
	     "-m 'Commit merge of ${archive_tag} with head'");
510
511
512
    if ($?) {
	print STDERR "ArchiveCommit: ".
	    "Could not commit merge back to the repository!\n";
513
	goto bad;
514
    }
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533

    #
    # Ack! We need to advance the default branch to match the head revision.
    # I think CVS is totally screwed up on this! 
    #
    mysystem("rcs -b${next_revision}.1 ".
	     "`$CVSBIN $cvsopt -d $cvsdir -q log -R`");

    DBQueryWarn("insert into archive_tags set ".
		"  tag='$newtag', revision='${archive_revision}', ".
		"  archive_idx='$archive_idx', ".
		"  date_created=UNIX_TIMESTAMP(now())") or goto bad;

    DBQueryWarn("update file_archives set ".
		"  current_tag='$newtag',revision='$next_revision', ".
		"  previous_tag='$archive_tag' ".
		"where idx='$archive_idx'") or goto bad;

    # Clean the temp dir for later.
534
535
536
537
    mysystem("/bin/rm -rf $tmpdir/*");
    if ($?) {
	print STDERR "ArchiveCommit: ".
	    "Could not remove contents of $tmpdir!\n";
538
	goto bad;
539
540
541
    }

    # And lets tag the tree for good measure with a commit tag.
542
    mysystem("$CVSBIN $cvsopt -d $cvsdir rtag -r $next_revision $newtag root");
543
544
    if ($?) {
	print STDERR "ArchiveCommit: ".
545
546
	    "Could not rtag with $newtag!\n";
	goto bad;
547
548
549
550
551
552
    }

    # And now into the root dir to checkout a current copy.
    if (! chdir("$rootdir")) {
	print STDERR "ArchiveCommit: ".
	    "Cannot chdir to $rootdir!\n";
553
	goto bad;
554
    }
555
    mysystem("$CVSBIN $cvsopt -d $cvsdir checkout -r $next_revision root");
556
557
558
    if ($?) {
	print STDERR "ArchiveCommit: ".
	    "Could not checkout head revision!\n";
559
	goto bad;
560
    }
561
562
  okay:
    chdir($cwd);
563
    return 0;
564
565
566
567

  bad:
    chdir($cwd);
    return -1;
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
}

#
# Archive the Archive, moving it into the expinfo directory.
# I intend this to be run only when an experiment is terminated.
# No need to have two copies.
#
sub ArchiveArchive($$)
{
    my ($archive_idx, $dirpath) = @_;
    my $target = "$dirpath/Archive";

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveCommit: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveFile: $directory cannot be written!\n";
	return -1;
    }
593
    my $cvsdir  = "$directory/repo";
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609

    if (! -e $target) {
	if (! mkdir("$target", 0777)) {
	    print STDERR "ArchiveArchive: Could not mkdir $target: $!\n";
	    return -1;
	}
	if (! chmod(0777, "$target")) {
	    print STDERR "ArchiveArchive: ".
		"Could not chmod directory $target: $!\n";
	    return -1;
	}
    }    

    #
    # Tar up the whole thing and move it across.
    #
610
    mysystem("$TAR cf - -C $cvsdir . | tar xf - -C $target");
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
    if ($?) {
	print STDERR "ArchiveArchive: Could not copy in $directory\n";
	return -1;
    }
    return 0;
}

#
# Destroy an archive. The DB state is retained unless optional flag says
# to clean it.
#
sub ArchiveDestroy($;$)
{
    my ($archive_idx, $clean) = @_;

    #
    # See if the archive exists and if it does, get the pathname to it.
    #
    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveDestroy: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveDestroy: $directory does not exist!\n";
	return 0;
    }

    mysystem("/bin/rm -rf $directory");
    if ($?) {
	print STDERR "ArchiveDestroy: ".
	    "Could not remove contents of $directory!\n";
	return -1;
    }
    if (defined($clean) && $clean) {
	(DBQueryWarn("delete from archive_tags ".
		     "where archive_idx='$archive_idx'") &&
	 DBQueryWarn("delete from file_archives ".
		     "where idx='$archive_idx'")) || return -1;
    }
    return 0;
}

#
# Get the directory for an archive, given its index. Returns -1 on error,
# zero otherwise. 
#
sub GetArchiveDirectory($$)
{
    my ($idx, $rvalp) = @_;
    
    my $query_result =
	DBQueryWarn("select directory from file_archives where idx='$idx'");

    return -1
	if (!$query_result || !$query_result->numrows);
    my ($dir) = $query_result->fetchrow_array();

    $$rvalp = $dir
	if (defined($rvalp));
    return 0;
}

#
# Get the current tag for an archive, given its index. Returns -1 on error,
# zero otherwise. Place tag in the return pointer.
#
679
sub GetArchiveCurrentTags($$;$$)
680
{
681
    my ($archive_idx, $tagp, $revnump, $prevp) = @_;
682
683
    
    my $query_result =
684
685
	DBQueryWarn("select current_tag,revision,previous_tag ".
		    "    from file_archives ".
686
687
688
689
		    "where idx='$archive_idx'");

    return -1
	if (!$query_result);
690
    my ($tag,$revision,$previous) = $query_result->fetchrow_array();
691
    
692
693
694
695
696
697
    $$tagp = $tag
	if (defined($tagp));
    $$revnump = $revision
	if (defined($revnump));
    $$prevp = $previous
	if (defined($prevp));
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
    return 0;
}

#
# Get the archive index for an experiment. The index is kept in the historical
# experiment_stats table, not the current experiments table. That is cause
# we keep the archive and its DB info around forever with the stats.
#
sub TBExperimentArchiveIDX($$)
{
    my ($pid, $eid) = @_;

    my $query_result =
	DBQueryWarn("select s.archive_idx from experiments as e ".
		    "left join experiment_stats as s on s.exptidx=e.idx ".
		    "where e.pid='$pid' and e.eid='$eid'");

    return -1
	if (!$query_result || $query_result->numrows == 0);

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

    return -1
	if (!defined($idx));
    
    return $idx;
}

#
# Create a new archive for an experiment. This has to update the
# experiment_stats table with the newly created archive index.
# Then we have to set the current tag for the experiment in the
# resources table for the experiment.
# Returns zero on success, -1 on failure.
#
sub TBCreateExperimentArchive($$)
{
    my ($pid, $eid) = @_;

    # Grab experiment indicies we need,
    my $query_result =
	DBQueryWarn("select e.idx,s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }

    my ($exptidx,$rsrcidx) = $query_result->fetchrow_array();
747
748
749
750
751
752
753
754
    my $archive_tag = "T${rsrcidx}";

    #
    # Create the new archive and get back the new index. 
    #
    my $archive_idx = ArchiveCreate($archive_tag);
    return -1
	if ($archive_idx < 0);
755
756
757
758
759
760

    if (! (DBQueryWarn("update experiment_stats set ".
		       "      archive_idx='$archive_idx' ".
		       "where pid='$pid' and eid='$eid' and ".
		       "      exptidx='$exptidx'") &&
	   DBQueryWarn("update experiment_resources set ".
761
		       "      archive_tag='$archive_tag' ".
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
		       "where idx='$rsrcidx'"))) {
	ArchiveDestroy($archive_idx, 1);
	return -1;
    }
    return 0;
}

#
# Add a file to an experiment archive.
#
sub TBExperimentArchiveAddFile($$$)
{
    my ($pid, $eid, $pathname) = @_;

    my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
    return -1
	if ($archive_idx < 0);

    return ArchiveAdd($archive_idx, $pathname);
}

#
784
# SavePoint an experiment archive. 
785
#
786
787
788
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
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
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
sub TBExperimentArchiveSavePoint($$$)
{
    my ($pid, $eid, $tagext) = @_;

    my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
    return -1
	if ($archive_idx < 0);

    #
    # Derive a tag that indicates what experiment resource entry it came from.
    #
    my $query_result =
	DBQueryWarn("select s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }
    my ($rsrcidx) = $query_result->fetchrow_array();

    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_${tagext}";

    return ArchiveSavePoint($archive_idx, $newtag);
}

#
# Setup for a swapmod. A pain in the butt!
#
sub TBExperimentArchivePreSwapMod($$)
{
    my ($pid, $eid) = @_;

    my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
    return -1
	if ($archive_idx < 0);

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchivePreSwapMod: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchivePreSwapMod: $directory cannot be written!\n";
	return -1;
    }
    my $tmpdir     = "$directory/tmp";
    my $preswapdir = "${tmpdir}.preswap";

    #
    # Derive a tag that indicates what experiment resource entry it came from.
    #
    my $query_result =
	DBQueryWarn("select s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }
    my ($rsrcidx) = $query_result->fetchrow_array();

    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_preswapmod";

    #
    # Do a savepoint just for grins,
    #
    return -1
	if (ArchiveSavePoint($archive_idx, $newtag) != 0);

    #
    # Make a copy of the current tree, since its easier to rollback
    # if I just wait before doing a commit (until swapmod really finishes).
    #
    if (-e $preswapdir) {
	system("/bin/rm -rf $preswapdir");
	if (-e $preswapdir) {
	    print STDERR
		"ArchivePreSwapMod: Could not delete old preswap dir!\n";
	    return -1;
	}
    }
    if (! mkdir("$preswapdir", 0777)) {
	print STDERR "ArchivePreSwapMod: Could not mkdir $preswapdir: $!\n";
	return -1;
    }
    if (! chmod(0777, "$preswapdir")) {
	print STDERR "ArchivePreSwapMod: ".
	    "Could not chmod directory $preswapdir: $!\n";
	goto bad;
    }
    
    mysystem("$TAR cf - -C $tmpdir . | tar xf - -C $preswapdir");
    if ($?) {
	print STDERR "ArchivePreSwapMod: Could not copy to $preswapdir\n";
	goto bad;
    }
    return 0;

  bad:
    # Be sure to remove the new directory!
    if (-e $preswapdir) {
	system("/bin/rm -rf $preswapdir");
	if (-e $preswapdir) {
	    print STDERR
		"ArchivePreSwapMod: Could not delete new preswap dir!\n";
	}
    }
    return -1;
}

#
# Rollback from a failed swapmod.
#
sub TBExperimentArchiveRollBack($$)
{
    my ($pid, $eid) = @_;

    my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
    return -1
	if ($archive_idx < 0);

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchiveRollBack: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchiveRollBack: $directory cannot be written!\n";
	return -1;
    }
    my $tmpdir     = "$directory/tmp";
    my $preswapdir = "${tmpdir}.preswap";

    # In case we bailed out really early in the swapmod path.
    return 0
	if (! -e $preswapdir);

    #
    # Restore the old (preswap) tree to the current tree.
    #
    if (-e $tmpdir) {
	system("/bin/rm -rf $tmpdir");
	if (-e $tmpdir) {
	    print STDERR
		"ArchiveRollBack: Could not delete old preswap dir!\n";
	    return -1;
	}
    }
    system("/bin/mv -f $preswapdir $tmpdir");
    if ($?) {
	print STDERR "ArchiveRollBack: ".
	    "Could not mv $preswapdir to $tmpdir\n";
	return -1;
    }
    return 0;
}

#
# Swapmod completed okay. Need to commit the old preswap directory and
# move forward. 
#
sub TBExperimentArchiveSwapModCommit($$)
955
956
957
{
    my ($pid, $eid) = @_;

958
959
960
961
962
963
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
990
991
992
993
994
995
996
997
998
999
1000
    my $archive_idx = TBExperimentArchiveIDX($pid, $eid);
    return -1
	if ($archive_idx < 0);

    my $directory;
    if (GetArchiveDirectory($archive_idx, \$directory) < 0) {
	print STDERR "ArchivePreSwapMod: ".
	    "Archive '$archive_idx' does not exist in the DB!\n";
	return -1;
    }
    if (! -d $directory || ! -w $directory) {
	print STDERR "ArchivePreSwapMod: $directory cannot be written!\n";
	return -1;
    }
    my $tmpdir     = "$directory/tmp";
    my $preswapdir = "${tmpdir}.preswap";

    #
    # Derive a tag that indicates what experiment resource entry it came from.
    #
    my $query_result =
	DBQueryWarn("select s.rsrcidx from experiments as e ".
		    "left join experiment_stats as s on e.idx=s.exptidx ".
		    "where e.pid='$pid' and e.eid='$eid'");
    if (!$query_result || !$query_result->numrows) {
	return -1;
    }
    my ($rsrcidx) = $query_result->fetchrow_array();

    my ($seconds, $microseconds) = gettimeofday();
    my $newtag  = POSIX::strftime("T20%y%m%d-%H%M%S-", localtime());
    $newtag .= int($microseconds / 1000);
    $newtag .= "_swapmod";

    return -1
	if (ArchiveCommit($archive_idx, $newtag, $preswapdir) != 0);

    if (!DBQueryWarn("update experiment_resources set ".
		     "      archive_tag='$newtag' ".
		     "where idx='$rsrcidx'")) {
	return -1;
    }

For faster browsing, not all history is shown. View entire blame