hydra/src/Hydra/programs/Scheduler.pl

429 lines
14 KiB
Perl
Raw Normal View History

#! @perl@ -w
use strict;
use XML::Simple;
2008-11-25 11:09:15 +00:00
use Hydra::Schema;
use IPC::Run;
use POSIX qw(strftime);
2008-11-25 11:09:15 +00:00
my $db = Hydra::Schema->connect("dbi:SQLite:dbname=hydra.sqlite", "", "", {});
$db->storage->dbh->do("PRAGMA synchronous = OFF;");
2008-11-05 04:52:52 +00:00
sub isValidPath {
my $path = shift;
return system("nix-store --check-validity $path 2> /dev/null") == 0;
}
sub captureStdoutStderr {
my $stdin = ""; my $stdout; my $stderr;
my $res = IPC::Run::run(\@_, \$stdin, \$stdout, \$stderr);
return ($res, $stdout, $stderr);
}
2008-11-12 23:14:57 +00:00
sub getStorePathHash {
my ($storePath) = @_;
my $hash = `nix-store --query --hash $storePath`
or die "cannot get hash of $storePath";
chomp $hash;
die unless $hash =~ /^sha256:(.*)$/;
$hash = $1;
$hash = `nix-hash --to-base16 --type sha256 $hash`
or die "cannot convert hash";
chomp $hash;
return $hash;
}
2008-11-04 18:23:28 +00:00
sub fetchInput {
2008-11-06 18:26:29 +00:00
my ($input, $alt, $inputInfo) = @_;
2008-11-04 18:23:28 +00:00
my $type = $input->type;
if ($type eq "path") {
2008-11-17 13:36:58 +00:00
my $uri = $alt->value;
my $timestamp = time;
my $sha256;
my $storePath;
# Some simple caching: don't check a path more than once every N seconds.
(my $cachedInput) = $db->resultset('Cachedpathinputs')->search(
{srcpath => $uri, lastseen => {">", $timestamp - 60}},
{rows => 1, order_by => "lastseen DESC"});
if (defined $cachedInput && isValidPath($cachedInput->storepath)) {
$storePath = $cachedInput->storepath;
$sha256 = $cachedInput->sha256hash;
$timestamp = $cachedInput->timestamp;
} else {
print "copying input ", $input->name, " from $uri\n";
$storePath = `nix-store --add "$uri"`
or die "cannot copy path $uri to the Nix store";
chomp $storePath;
$sha256 = getStorePathHash $storePath;
($cachedInput) = $db->resultset('Cachedpathinputs')->search(
{srcpath => $uri, sha256hash => $sha256});
# Path inputs don't have a natural notion of a "revision",
# so we simulate it by using the timestamp that we first
# saw this path have this SHA-256 hash. So if the
# contents of the path changes, we get a new "revision",
# but if it doesn't change (or changes back), we don't get
# a new "revision".
if (!defined $cachedInput) {
$db->txn_do(sub {
$db->resultset('Cachedpathinputs')->create(
{ srcpath => $uri
, timestamp => $timestamp
, lastseen => $timestamp
, sha256hash => $sha256
, storepath => $storePath
});
});
} else {
$timestamp = $cachedInput->timestamp;
$db->txn_do(sub {
$cachedInput->lastseen(time);
$cachedInput->update;
});
}
}
2008-11-12 23:14:57 +00:00
$$inputInfo{$input->name} =
{ type => $type
, uri => $uri
, storePath => $storePath
, sha256hash => $sha256
, revision => strftime "%Y%m%d%H%M%S", gmtime($timestamp)
2008-11-12 23:14:57 +00:00
};
2008-11-04 18:23:28 +00:00
}
2008-11-25 18:13:55 +00:00
elsif ($type eq "svn") {
my $uri = $alt->value;
my $sha256;
my $storePath;
# First figure out the last-modified revision of the URI.
my @cmd = (["svn", "ls", "-v", "--depth", "empty", $uri],
"|", ["sed", 's/^ *\([0-9]*\).*/\1/']);
my $stdout; my $stderr;
die "cannot get head revision of Subversion repository at `$uri':\n$stderr"
unless IPC::Run::run(@cmd, \$stdout, \$stderr);
my $revision = $stdout; chomp $revision;
die unless $revision =~ /^\d+$/;
(my $cachedInput) = $db->resultset('Cachedsubversioninputs')->search(
{uri => $uri, revision => $revision});
if (defined $cachedInput && isValidPath($cachedInput->storepath)) {
$storePath = $cachedInput->storepath;
$sha256 = $cachedInput->sha256hash;
} else {
# Then download this revision into the store.
print "checking out Subversion input ", $input->name, " from $uri revision $revision\n";
$ENV{"NIX_HASH_ALGO"} = "sha256";
$ENV{"PRINT_PATH"} = "1";
(my $res, $stdout, $stderr) = captureStdoutStderr(
"nix-prefetch-svn", $uri, $revision);
die "cannot check out Subversion repository `$uri':\n$stderr" unless $res;
($sha256, $storePath) = split ' ', $stdout;
$db->txn_do(sub {
$db->resultset('Cachedsubversioninputs')->create(
{ uri => $uri
, revision => $revision
, sha256hash => $sha256
, storepath => $storePath
});
});
}
$$inputInfo{$input->name} =
{ type => $type
, uri => $uri
, storePath => $storePath
, sha256hash => $sha256
, revision => $revision
};
}
2008-11-06 18:26:29 +00:00
elsif ($type eq "string") {
die unless defined $alt->value;
$$inputInfo{$input->name} = {type => $type, value => $alt->value};
}
2008-11-25 18:34:24 +00:00
elsif ($type eq "boolean") {
die unless defined $alt->value && ($alt->value eq "true" || $alt->value eq "false");
$$inputInfo{$input->name} = {type => $type, value => $alt->value};
}
2008-11-04 18:23:28 +00:00
else {
2008-11-25 18:13:55 +00:00
die "input `" . $input->name . "' has unknown type `$type'";
2008-11-04 18:23:28 +00:00
}
}
2008-11-07 14:51:44 +00:00
sub checkJob {
my ($project, $jobset, $inputInfo, $nixExprPath, $jobName, $jobExpr, $extraArgs) = @_;
2008-11-06 18:26:29 +00:00
2008-11-07 14:51:44 +00:00
# Instantiate the store derivation.
(my $res, my $drvPath, my $stderr) = captureStdoutStderr(
"nix-instantiate", $nixExprPath, "--attr", $jobName, @{$extraArgs});
die "cannot evaluate the Nix expression for job `$jobName':\n$stderr" unless $res;
2008-11-07 14:51:44 +00:00
chomp $drvPath;
2008-11-04 18:23:28 +00:00
# Call nix-env --xml to get info about this job (drvPath, outPath, meta attributes, ...).
($res, my $infoXml, $stderr) = captureStdoutStderr(
qw(nix-env --query --available * --attr-path --out-path --drv-path --meta --xml --system-filter *),
"-f", $nixExprPath, "--attr", $jobName, @{$extraArgs});
die "cannot get information about the job `$jobName':\n$stderr" unless $res;
2008-11-07 14:51:44 +00:00
2008-11-10 10:18:50 +00:00
my $info = XMLin($infoXml, ForceArray => 1, KeyAttr => ['attrPath', 'name'])
2008-11-07 14:51:44 +00:00
or die "cannot parse XML output";
2008-11-10 10:18:50 +00:00
my $job = $info->{item}->{$jobName};
die if !defined $job;
2008-11-07 14:51:44 +00:00
my $description = defined $job->{meta}->{description} ? $job->{meta}->{description}->{value} : "";
die unless $job->{drvPath} eq $drvPath;
my $outPath = $job->{outPath};
2008-11-10 13:33:12 +00:00
$db->txn_do(sub {
if (scalar($db->resultset('Builds')->search(
{ project => $project->name, jobset => $jobset->name
, attrname => $jobName, outPath => $outPath })) > 0)
{
print "already scheduled/done\n";
2008-11-10 13:33:12 +00:00
return;
}
print "adding to queue\n";
2008-11-11 12:54:37 +00:00
my $build = $db->resultset('Builds')->create(
{ finished => 0
, timestamp => time()
2008-11-10 13:33:12 +00:00
, project => $project->name
, jobset => $jobset->name
, attrname => $jobName
, description => $description
2008-11-12 16:42:07 +00:00
, nixname => $job->{name}
2008-11-10 13:33:12 +00:00
, drvpath => $drvPath
, outpath => $outPath
, system => $job->{system}
});
2008-11-11 12:54:37 +00:00
$db->resultset('Buildschedulinginfo')->create(
{ id => $build->id
, priority => 0
, busy => 0
, locker => ""
});
2008-11-10 13:33:12 +00:00
foreach my $inputName (keys %{$inputInfo}) {
my $input = $inputInfo->{$inputName};
2008-11-11 12:54:37 +00:00
$db->resultset('Buildinputs')->create(
{ build => $build->id
2008-11-10 13:33:12 +00:00
, name => $inputName
, type => $input->{type}
, uri => $input->{uri}
, revision => $input->{revision}
2008-11-10 13:33:12 +00:00
, value => $input->{value}
, dependency => $input->{id}
, path => ($input->{storePath} or "") # !!! temporary hack
2008-11-12 23:14:57 +00:00
, sha256hash => $input->{sha256hash}
2008-11-10 13:33:12 +00:00
});
}
});
2008-11-07 14:51:44 +00:00
};
sub setJobsetError {
my ($jobset, $errorMsg) = @_;
eval {
$db->txn_do(sub {
$jobset->errormsg($errorMsg);
$jobset->errortime(time);
$jobset->update;
});
};
}
2008-11-07 14:51:44 +00:00
sub checkJobAlternatives {
my ($project, $jobset, $inputInfo, $nixExprPath, $jobName, $jobExpr, $extraArgs, $argsNeeded, $n) = @_;
if ($n >= scalar @{$argsNeeded}) {
2008-11-09 00:48:36 +00:00
eval {
checkJob($project, $jobset, $inputInfo, $nixExprPath, $jobName, $jobExpr, $extraArgs);
};
if ($@) {
print "error evaluating job `", $jobName, "': $@";
setJobsetError($jobset, $@);
}
2008-11-07 14:51:44 +00:00
return;
}
my $argName = @{$argsNeeded}[$n];
#print "finding alternatives for argument $argName\n";
2008-11-07 14:51:44 +00:00
my ($input) = $jobset->jobsetinputs->search({name => $argName});
2008-11-07 15:29:52 +00:00
my %newInputInfo = %{$inputInfo}; $inputInfo = \%newInputInfo; # clone
2008-11-07 14:51:44 +00:00
if (defined $input) {
foreach my $alt ($input->jobsetinputalts) {
#print "input ", $input->name, " (type ", $input->type, ") alt ", $alt->altnr, "\n";
fetchInput($input, $alt, $inputInfo);
my @newArgs = @{$extraArgs};
2008-11-07 14:51:44 +00:00
if (defined $inputInfo->{$argName}->{storePath}) {
push @newArgs, "--arg", $argName,
2008-11-25 16:13:22 +00:00
"{path = builtins.storePath " . $inputInfo->{$argName}->{storePath} . ";" .
" rev = \"" . $inputInfo->{$argName}->{revision} . "\";}";
2008-11-25 18:34:24 +00:00
} elsif ($inputInfo->{$argName}->{type} eq "string") {
push @newArgs, "--argstr", $argName, $inputInfo->{$argName}->{value};
2008-11-25 18:34:24 +00:00
} elsif ($inputInfo->{$argName}->{type} eq "boolean") {
push @newArgs, "--arg", $argName, $inputInfo->{$argName}->{value};
2008-11-07 14:51:44 +00:00
}
checkJobAlternatives(
$project, $jobset, $inputInfo, $nixExprPath,
$jobName, $jobExpr, \@newArgs, $argsNeeded, $n + 1);
2008-11-07 14:51:44 +00:00
}
}
else {
(my $prevBuild) = $db->resultset('Builds')->search(
2008-11-11 12:54:37 +00:00
{finished => 1, project => $project->name, jobset => $jobset->name, attrname => $argName, buildStatus => 0},
{join => 'resultInfo', order_by => "timestamp DESC", rows => 1});
2008-11-07 14:51:44 +00:00
if (!defined $prevBuild) {
# !!! reschedule?
die "missing input `$argName'";
}
# The argument name matches a previously built job in this
# jobset. Pick the most recent build. !!! refine the
# selection criteria: e.g., most recent successful build.
if (!isValidPath($prevBuild->outpath)) {
die "input path " . $prevBuild->outpath . " has been garbage-collected";
}
$$inputInfo{$argName} =
{ type => "build"
, storePath => $prevBuild->outpath
, id => $prevBuild->id
};
my @newArgs = @{$extraArgs};
2008-11-25 16:13:22 +00:00
push @newArgs, "--arg", $argName, "{path = builtins.storePath " . $prevBuild->outpath . ";}";
2008-11-07 14:51:44 +00:00
checkJobAlternatives(
$project, $jobset, $inputInfo, $nixExprPath,
$jobName, $jobExpr, \@newArgs, $argsNeeded, $n + 1);
2008-11-07 14:51:44 +00:00
}
}
2008-11-07 14:51:44 +00:00
sub checkJobSet {
my ($project, $jobset) = @_;
my $inputInfo = {};
2008-11-26 13:39:15 +00:00
$db->txn_do(sub {
$jobset->lastcheckedtime(time);
$jobset->update;
});
2008-11-07 14:51:44 +00:00
# Fetch the input containing the Nix expression.
(my $exprInput) = $jobset->jobsetinputs->search({name => $jobset->nixexprinput});
die unless defined $exprInput;
die "not supported yet" if scalar($exprInput->jobsetinputalts) != 1;
fetchInput($exprInput, $exprInput->jobsetinputalts->first, $inputInfo);
# Evaluate the Nix expression.
2008-11-04 18:23:28 +00:00
my $nixExprPath = $inputInfo->{$jobset->nixexprinput}->{storePath} . "/" . $jobset->nixexprpath;
print "evaluating $nixExprPath\n";
(my $res, my $jobsXml, my $stderr) = captureStdoutStderr(
"nix-instantiate", $nixExprPath, "--eval-only", "--strict", "--xml");
die "cannot evaluate the Nix expression containing the jobs:\n$stderr" unless $res;
2008-11-04 18:23:28 +00:00
my $jobs = XMLin($jobsXml,
2008-11-10 10:27:52 +00:00
ForceArray => ['value', 'attr'],
2008-11-04 18:23:28 +00:00
KeyAttr => ['name'],
SuppressEmpty => '',
ValueAttr => [value => 'value'])
or die "cannot parse XML output";
die unless defined $jobs->{attrs};
2008-11-07 14:51:44 +00:00
# Iterate over the attributes listed in the Nix expression and
# perform the builds described by them. If an attribute is a
# function, then fill in the function arguments with the
# (alternative) values supplied in the jobsetinputs table.
2008-11-04 18:23:28 +00:00
foreach my $jobName (keys(%{$jobs->{attrs}->{attr}})) {
print "considering job $jobName\n";
2008-11-04 18:23:28 +00:00
2008-11-07 14:51:44 +00:00
my @argsNeeded = ();
2008-11-04 18:23:28 +00:00
my $jobExpr = $jobs->{attrs}->{attr}->{$jobName};
2008-11-07 14:51:44 +00:00
# !!! fix the case where there is only 1 attr, XML::Simple fucks up as usual
2008-11-04 18:23:28 +00:00
if (defined $jobExpr->{function}->{attrspat}) {
foreach my $argName (keys(%{$jobExpr->{function}->{attrspat}->{attr}})) {
#print "needs input $argName\n";
2008-11-07 14:51:44 +00:00
push @argsNeeded, $argName;
}
2008-11-04 18:23:28 +00:00
}
2008-11-09 00:48:36 +00:00
eval {
checkJobAlternatives(
$project, $jobset, {}, $nixExprPath,
$jobName, $jobExpr, [], \@argsNeeded, 0);
2008-11-09 00:48:36 +00:00
};
2008-11-25 18:34:24 +00:00
if ($@) {
print "error checking job ", $jobName, ": $@";
setJobsetError($jobset, $@);
}
2008-11-06 18:26:29 +00:00
}
2008-11-04 18:23:28 +00:00
}
sub checkJobs {
2008-11-18 12:48:58 +00:00
foreach my $project ($db->resultset('Projects')->search({enabled => 1})) {
print "considering project ", $project->name, "\n";
2008-11-04 18:23:28 +00:00
foreach my $jobset ($project->jobsets->all) {
print "considering jobset ", $jobset->name, " in ", $project->name, "\n";
2008-11-18 12:48:58 +00:00
eval {
checkJobSet($project, $jobset);
};
if ($@) {
print "error evaluating jobset ", $jobset->name, ": $@";
2008-11-25 18:13:55 +00:00
setJobsetError($jobset, $@);
}
}
2008-11-04 18:23:28 +00:00
}
}
while (1) {
checkJobs;
print "sleeping...\n";
sleep 10;
}