e4fe9d43c1
In nixpkgs this started to fail the hydra tests. It's not completely clear why because it seems the perlcritic rule has existed for quite some time. Anyway, this should solve the issues.
139 lines
4.0 KiB
Perl
139 lines
4.0 KiB
Perl
package Hydra::Plugin::MercurialInput;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use parent 'Hydra::Plugin';
|
|
use Digest::SHA qw(sha256_hex);
|
|
use File::Path;
|
|
use Hydra::Helper::Nix;
|
|
use Hydra::Helper::Exec;
|
|
use Fcntl qw(:flock);
|
|
|
|
sub supportedInputTypes {
|
|
my ($self, $inputTypes) = @_;
|
|
$inputTypes->{'hg'} = 'Mercurial checkout';
|
|
}
|
|
|
|
sub _parseValue {
|
|
my ($value) = @_;
|
|
(my $uri, my $id) = split ' ', $value;
|
|
$id = defined $id ? $id : "default";
|
|
return ($uri, $id);
|
|
}
|
|
|
|
sub _clonePath {
|
|
my ($uri) = @_;
|
|
my $cacheDir = getSCMCacheDir . "/hg";
|
|
mkpath($cacheDir);
|
|
return $cacheDir . "/" . sha256_hex($uri);
|
|
}
|
|
|
|
sub fetchInput {
|
|
my ($self, $type, $name, $value) = @_;
|
|
|
|
return undef if $type ne "hg";
|
|
|
|
(my $uri, my $id) = _parseValue($value);
|
|
$id = defined $id ? $id : "default";
|
|
|
|
# init local hg clone
|
|
|
|
my $stdout = ""; my $stderr = "";
|
|
|
|
my $clonePath = _clonePath($uri);
|
|
|
|
open(my $lock, ">", "$clonePath.lock") or die;
|
|
flock($lock, LOCK_EX) or die;
|
|
|
|
if (! -d $clonePath) {
|
|
(my $res, $stdout, $stderr) = captureStdoutStderr(600,
|
|
"hg", "clone", $uri, $clonePath);
|
|
die "error cloning mercurial repo at `$uri':\n$stderr" if $res;
|
|
}
|
|
|
|
# hg pull + check rev
|
|
chdir $clonePath or die $!;
|
|
(my $res, $stdout, $stderr) = captureStdoutStderr(600, "hg", "pull");
|
|
die "error pulling latest change mercurial repo at `$uri':\n$stderr" if $res;
|
|
|
|
(my $res1, $stdout, $stderr) = captureStdoutStderr(600,
|
|
"hg", "log", "-r", $id, "--template", "{node} {rev} {branch}");
|
|
die "error getting branch and revision of $id from `$uri':\n$stderr" if $res1;
|
|
|
|
my ($revision, $revCount, $branch) = split ' ', $stdout;
|
|
|
|
my $storePath;
|
|
my $sha256;
|
|
(my $cachedInput) = $self->{db}->resultset('CachedHgInputs')->search(
|
|
{uri => $uri, branch => $branch, revision => $revision});
|
|
|
|
$MACHINE_LOCAL_STORE->addTempRoot($cachedInput->storepath) if defined $cachedInput;
|
|
|
|
if (defined $cachedInput && $MACHINE_LOCAL_STORE->isValidPath($cachedInput->storepath)) {
|
|
$storePath = $cachedInput->storepath;
|
|
$sha256 = $cachedInput->sha256hash;
|
|
} else {
|
|
print STDERR "checking out Mercurial input from $uri $branch revision $revision\n";
|
|
$ENV{"NIX_HASH_ALGO"} = "sha256";
|
|
$ENV{"PRINT_PATH"} = "1";
|
|
|
|
(my $res, $stdout, $stderr) = captureStdoutStderr(600,
|
|
"nix-prefetch-hg", $clonePath, $revision);
|
|
die "cannot check out Mercurial repository `$uri':\n$stderr" if $res;
|
|
|
|
($sha256, $storePath) = split ' ', $stdout;
|
|
|
|
# FIXME: time window between nix-prefetch-hg and addTempRoot.
|
|
$MACHINE_LOCAL_STORE->addTempRoot($storePath);
|
|
|
|
$self->{db}->txn_do(sub {
|
|
$self->{db}->resultset('CachedHgInputs')->update_or_create(
|
|
{ uri => $uri
|
|
, branch => $branch
|
|
, revision => $revision
|
|
, sha256hash => $sha256
|
|
, storepath => $storePath
|
|
});
|
|
});
|
|
}
|
|
|
|
return
|
|
{ uri => $uri
|
|
, branch => $branch
|
|
, storePath => $storePath
|
|
, sha256hash => $sha256
|
|
, revision => $revision
|
|
, revCount => int($revCount)
|
|
};
|
|
}
|
|
|
|
sub getCommits {
|
|
my ($self, $type, $value, $rev1, $rev2) = @_;
|
|
return [] if $type ne "hg";
|
|
|
|
return [] unless $rev1 =~ /^[0-9a-f]+$/;
|
|
return [] unless $rev2 =~ /^[0-9a-f]+$/;
|
|
|
|
my ($uri, $id) = _parseValue($value);
|
|
|
|
my $clonePath = _clonePath($uri);
|
|
chdir $clonePath or die $!;
|
|
|
|
my $out;
|
|
IPC::Run::run(["hg", "log", "--template", "{node|short}\t{author|person}\t{author|email}\n", "-r", "$rev1::$rev2", $clonePath], \undef, \$out)
|
|
or die "cannot get mercurial logs: $?";
|
|
|
|
my $res = [];
|
|
foreach my $line (split /\n/, $out) {
|
|
if ($line ne "") {
|
|
my ($revision, $author, $email) = split /\t/, $line;
|
|
push @$res, { revision => $revision, author => $author, email => $email };
|
|
}
|
|
}
|
|
|
|
return $res;
|
|
}
|
|
|
|
|
|
1;
|