forked from lix-project/hydra
118 lines
3.5 KiB
Perl
Executable file
118 lines
3.5 KiB
Perl
Executable file
#! /var/run/current-system/sw/bin/perl -w
|
|
|
|
use strict;
|
|
use File::Path;
|
|
use File::Basename;
|
|
use Hydra::Schema;
|
|
use Hydra::Helper::Nix;
|
|
use POSIX qw(strftime);
|
|
|
|
my $db = openHydraDB;
|
|
|
|
|
|
my %roots;
|
|
|
|
sub registerRoot {
|
|
my ($path) = @_;
|
|
Hydra::Helper::Nix::registerRoot($path);
|
|
$roots{$path} = 1;
|
|
}
|
|
|
|
|
|
sub keepBuild {
|
|
my ($build) = @_;
|
|
print "keeping build ", $build->id, " (",
|
|
strftime("%Y-%m-%d %H:%M:%S", localtime($build->timestamp)), ")\n";
|
|
if (isValidPath($build->outpath)) {
|
|
registerRoot $build->outpath;
|
|
} else {
|
|
print STDERR "warning: output ", $build->outpath, " has disappeared\n";
|
|
}
|
|
}
|
|
|
|
|
|
# Go over all projects.
|
|
|
|
foreach my $project ($db->resultset('Projects')->all) {
|
|
|
|
# Go over all jobs in this project.
|
|
|
|
foreach my $job ($project->builds->search({},
|
|
{select => [{distinct => 'attrname'}], as => ['attrname']}))
|
|
{
|
|
print "*** looking for builds to keep in job ", $project->name, ":", $job->attrname, "\n";
|
|
|
|
# Keep the N most recent successful builds for each job and
|
|
# platform.
|
|
my @recentBuilds = $project->builds->search(
|
|
{ attrname => $job->attrname
|
|
, finished => 1
|
|
, buildStatus => 0 # == success
|
|
},
|
|
{ join => 'resultInfo'
|
|
, order_by => 'timestamp DESC'
|
|
, rows => 3 # !!! should make this configurable
|
|
});
|
|
|
|
keepBuild $_ foreach @recentBuilds;
|
|
|
|
}
|
|
|
|
# Go over all releases in this project.
|
|
|
|
foreach my $releaseSet ($project->releasesets->all) {
|
|
print "*** looking for builds to keep in release set ", $project->name, ":", $releaseSet->name, "\n";
|
|
|
|
(my $primaryJob) = $releaseSet->releasesetjobs->search({isprimary => 1});
|
|
my $jobs = [$releaseSet->releasesetjobs->all];
|
|
|
|
# Keep all builds belonging to the most recent successful release.
|
|
my $latest = getLatestSuccessfulRelease($project, $primaryJob, $jobs);
|
|
if (defined $latest) {
|
|
print "keeping latest successful release ", $latest->id, " (", $latest->get_column('releasename'), ")\n";
|
|
my $release = getRelease($latest, $jobs);
|
|
keepBuild $_->{build} foreach @{$release->{jobs}};
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
|
|
# Keep all builds that have been marked as "keep".
|
|
print "*** looking for kept builds\n";
|
|
my @buildsToKeep = $db->resultset('Builds')->search({finished => 1, keep => 1}, {join => 'resultInfo'});
|
|
keepBuild $_ foreach @buildsToKeep;
|
|
|
|
|
|
# For scheduled builds, we register the derivation and the output as a GC root.
|
|
print "*** looking for scheduled builds\n";
|
|
foreach my $build ($db->resultset('Builds')->search({finished => 0}, {join => 'schedulingInfo'})) {
|
|
if (isValidPath($build->drvpath)) {
|
|
print "keeping scheduled build ", $build->id, " (",
|
|
strftime("%Y-%m-%d %H:%M:%S", localtime($build->timestamp)), ")\n";
|
|
registerRoot $build->drvpath;
|
|
registerRoot $build->outpath;
|
|
} else {
|
|
print STDERR "warning: derivation ", $build->drvpath, " has disappeared\n";
|
|
}
|
|
}
|
|
|
|
|
|
# Remove existing roots that are no longer wanted. !!! racy
|
|
print "*** removing unneeded GC roots\n";
|
|
|
|
my $gcRootsDir = getGCRootsDir;
|
|
|
|
opendir DIR, $gcRootsDir or die;
|
|
|
|
foreach my $link (readdir DIR) {
|
|
next if !-l "$gcRootsDir/$link";
|
|
my $path = readlink "$gcRootsDir/$link" or die;
|
|
if (!defined $roots{$path}) {
|
|
print STDERR "removing root $path\n";
|
|
unlink "$gcRootsDir/$link" or die "cannot remove $gcRootsDir/$link";
|
|
}
|
|
}
|
|
|
|
closedir DIR;
|