hydra/src/script/hydra_update_gc_roots.pl.in

#! @perl@ -w -I@nix@/libexec/nix

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 STDERR "  keeping build ", $build->id, " (",
        $build->system, "; ",
        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 jobsets in this project.
    foreach my $jobset ($project->jobsets->all) {
        my $keepnr = $jobset->keepnr;

	# If the jobset has been disabled for more than one week, than
	# don't keep its builds anymore.
	if ($jobset->enabled == 0 && (time() - $jobset->lastcheckedtime > (7 * 24 * 3600))) {
	    print STDERR "*** skipping disabled jobset ", $project->name, ":", $jobset->name, "\n";
	    next;
	}
        
        # Go over all jobs in this jobset.
        foreach my $job ($jobset->jobs->all) {
            print STDERR "*** looking for builds to keep in job ",
                $project->name, ":", $job->jobset->name, ":", $job->name, "\n";

            # Keep the N most recent successful builds for each job
            # and platform.
            # !!! Take time into account? E.g. don't delete builds
            # that are younger than N days.
            my @systems = $job->builds->search({ }, { select => ["system"], distinct => 1 })->all;
            foreach my $system (@systems) {
                my @recentBuilds = $job->builds->search(
                    { finished => 1
                    , buildStatus => 0 # == success
                    , system => $system->system
                    },
                    { join => 'resultInfo'
                    , order_by => 'id DESC'
                    , rows => $keepnr
                    });
                keepBuild $_ foreach @recentBuilds;
	    }
	}
    }

    # Go over all views in this project.
    foreach my $view ($project->views->all) {
        print STDERR "*** looking for builds to keep in view ", $project->name, ":", $view->name, "\n";

        (my $primaryJob) = $view->viewjobs->search({isprimary => 1});
        my $jobs = [$view->viewjobs->all];

        # Keep all builds belonging to the most recent successful view result.
        my $latest = getLatestSuccessfulViewResult($project, $primaryJob, $jobs);
        if (defined $latest) {
            print STDERR "keeping latest successful view result ", $latest->id, " (", $latest->get_column('releasename'), ")\n";
            my $result = getViewResult($latest, $jobs);
            keepBuild $_->{build} foreach @{$result->{jobs}};
        }
    }

    # Keep every build in every release in this project.
    print STDERR "*** keeping releases in project ", $project->name, "\n"
        if scalar $project->releases > 0;
    foreach my $release ($project->releases->all) {
        print STDERR "keeping release ", $release->name, "\n";
        keepBuild $_->build foreach $release->releasemembers;
    }
}


# Keep all builds that have been marked as "keep".
print STDERR "*** 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 as a GC root.
print STDERR "*** looking for scheduled builds\n";
foreach my $build ($db->resultset('Builds')->search({finished => 0}, {join => 'schedulingInfo'})) {
    if (isValidPath($build->drvpath)) {
        print STDERR "keeping scheduled build ", $build->id, " (",
            strftime("%Y-%m-%d %H:%M:%S", localtime($build->timestamp)), ")\n";
        registerRoot $build->drvpath;
        registerRoot $build->outpath if -e $build->outpath;
    } else {
        print STDERR "warning: derivation ", $build->drvpath, " has disappeared\n";
    }
}


# Remove existing roots that are no longer wanted.  !!! racy
print STDERR "*** 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;