You've already forked guix-tribes
self
08a370654a
Rewrite update-plugin-pin as a generic Perl script without aether-specific logic or Python dependencies. Default plugin paths now resolve from the plugin name, and the aether pin was refreshed end to end against pguix.
438 lines
14 KiB
Perl
Executable File
438 lines
14 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Cwd qw(abs_path);
|
|
use File::Basename qw(dirname);
|
|
use File::Spec;
|
|
use File::Temp qw(tempdir tempfile);
|
|
use Getopt::Long qw(GetOptionsFromArray);
|
|
use IPC::Open3 qw(open3);
|
|
use JSON::PP qw(decode_json encode_json);
|
|
use Symbol qw(gensym);
|
|
|
|
sub usage {
|
|
print <<'EOF';
|
|
Usage: update-plugin-pin [options] plugin [rev]
|
|
|
|
Pin a Tribes external plugin and refresh fixed-output hashes.
|
|
|
|
PLUGIN is the manifest/plugin name. REV defaults to "master" resolved from the
|
|
plugin checkout. The plugin manifest.json is the source of truth for plugin
|
|
name, version, provides, and requires metadata. By default the script expects
|
|
the plugin checkout at ../tribes-plugin-$PLUGIN and the Guix plugin file at
|
|
tribes/plugins/$PLUGIN.scm relative to the guix-tribes checkout.
|
|
|
|
Options:
|
|
--plugin-repo PATH Local plugin git checkout
|
|
--plugin-file PATH Guix plugin definition file to update
|
|
--tribes-repo PATH Local Tribes git checkout used for the host plugin API
|
|
--tribes-rev REV Tribes commit/rev for host API hashing (default: current guix-tribes pin)
|
|
--guix-repo PATH Local guix-tribes checkout
|
|
--pguix-host HOST SSH host used for Guix builds and hashing
|
|
-h, --help Show this help
|
|
EOF
|
|
}
|
|
|
|
sub fail {
|
|
die "@_\n";
|
|
}
|
|
|
|
sub read_file {
|
|
my ($path) = @_;
|
|
open my $fh, '<', $path or fail("Failed to read $path: $!");
|
|
local $/;
|
|
return <$fh>;
|
|
}
|
|
|
|
sub write_file {
|
|
my ($path, $content) = @_;
|
|
open my $fh, '>', $path or fail("Failed to write $path: $!");
|
|
print {$fh} $content or fail("Failed to write $path: $!");
|
|
close $fh or fail("Failed to close $path: $!");
|
|
}
|
|
|
|
sub command_exists {
|
|
my ($command) = @_;
|
|
|
|
for my $dir (split /:/, ($ENV{PATH} // '')) {
|
|
my $path = File::Spec->catfile($dir, $command);
|
|
return 1 if -x $path;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub require_tool {
|
|
my ($tool) = @_;
|
|
command_exists($tool) or fail("Missing required tool: $tool");
|
|
}
|
|
|
|
sub run_capture {
|
|
my (@cmd) = @_;
|
|
my $err = gensym();
|
|
my $pid = open3(undef, my $out, $err, @cmd);
|
|
local $/;
|
|
my $stdout = <$out> // '';
|
|
my $stderr = <$err> // '';
|
|
waitpid($pid, 0);
|
|
my $output = $stdout . $stderr;
|
|
my $status = $? >> 8;
|
|
return ($status, $output);
|
|
}
|
|
|
|
sub run_checked {
|
|
my (@cmd) = @_;
|
|
system(@cmd) == 0 or fail("Command failed: @cmd");
|
|
}
|
|
|
|
sub trim {
|
|
my ($value) = @_;
|
|
$value =~ s/^\s+//;
|
|
$value =~ s/\s+$//;
|
|
return $value;
|
|
}
|
|
|
|
sub scheme_string_list {
|
|
my (@values) = @_;
|
|
return '(' . join(' ', map { encode_json($_) } @values) . ')';
|
|
}
|
|
|
|
sub replace_once {
|
|
my ($text_ref, $pattern, $replacement, $label) = @_;
|
|
my $count = ($$text_ref =~ s/$pattern/$replacement/s);
|
|
$count == 1 or fail("failed to update $label");
|
|
}
|
|
|
|
sub update_plugin_definition_header {
|
|
my ($text_ref, $plugin_name, $package_name, $version) = @_;
|
|
my @lines = split /\n/, $$text_ref, -1;
|
|
my ($definition_start, $name_index, $version_index);
|
|
|
|
for my $i (0 .. $#lines) {
|
|
if (!defined $definition_start) {
|
|
if ($lines[$i] =~ /\(tribes-plugin-definition\b/) {
|
|
$definition_start = $i;
|
|
}
|
|
next;
|
|
}
|
|
|
|
if (!defined $name_index) {
|
|
if ($lines[$i] =~ /^\s*\(name "\Q$plugin_name\E"\)$/) {
|
|
$name_index = $i;
|
|
}
|
|
next;
|
|
}
|
|
|
|
if ($lines[$i] =~ /^\s*\(package-name "[^"]+"\)$/) {
|
|
next;
|
|
}
|
|
|
|
if ($lines[$i] =~ /^\s*\(version "[^"]+"\)$/) {
|
|
$version_index = $i;
|
|
last;
|
|
}
|
|
|
|
last if $lines[$i] =~ /^\s*\(/;
|
|
}
|
|
|
|
defined $name_index && defined $version_index
|
|
or fail('failed to update plugin definition version');
|
|
|
|
my ($indent) = ($lines[$version_index] =~ /^(\s*)/);
|
|
splice(
|
|
@lines,
|
|
$name_index + 1,
|
|
$version_index - $name_index,
|
|
qq(${indent}(package-name "$package_name")),
|
|
qq(${indent}(version "$version")),
|
|
);
|
|
|
|
$$text_ref = join("\n", @lines);
|
|
}
|
|
|
|
my $local_tmp = '';
|
|
my $remote_tmp = '';
|
|
|
|
my @argv = @ARGV;
|
|
my %opts = (
|
|
pguix_host => 'pguix',
|
|
);
|
|
|
|
GetOptionsFromArray(
|
|
\@argv,
|
|
'plugin-repo=s' => \$opts{plugin_repo},
|
|
'plugin-file=s' => \$opts{plugin_file},
|
|
'tribes-repo=s' => \$opts{tribes_repo},
|
|
'tribes-rev=s' => \$opts{tribes_rev},
|
|
'guix-repo=s' => \$opts{guix_repo},
|
|
'pguix-host=s' => \$opts{pguix_host},
|
|
'h|help' => \$opts{help},
|
|
) or do {
|
|
usage();
|
|
exit 1;
|
|
};
|
|
|
|
if ($opts{help}) {
|
|
usage();
|
|
exit 0;
|
|
}
|
|
|
|
my $plugin = shift @argv;
|
|
defined $plugin && length $plugin or do {
|
|
usage();
|
|
exit 1;
|
|
};
|
|
|
|
my $rev = shift(@argv) // 'master';
|
|
@argv == 0 or do {
|
|
usage();
|
|
exit 1;
|
|
};
|
|
|
|
my $script_dir = abs_path(dirname($0));
|
|
my $default_guix_repo = abs_path(File::Spec->catdir($script_dir, '..'));
|
|
my $default_tribes_repo = abs_path(File::Spec->catdir($default_guix_repo, '..', 'tribes'));
|
|
|
|
my $guix_repo = $opts{guix_repo} ? abs_path($opts{guix_repo}) : $default_guix_repo;
|
|
my $tribes_repo = $opts{tribes_repo} ? abs_path($opts{tribes_repo}) : $default_tribes_repo;
|
|
my $plugin_repo =
|
|
$opts{plugin_repo}
|
|
? abs_path($opts{plugin_repo})
|
|
: abs_path(File::Spec->catdir($guix_repo, '..', "tribes-plugin-$plugin"));
|
|
my $plugin_file =
|
|
$opts{plugin_file}
|
|
? abs_path($opts{plugin_file})
|
|
: File::Spec->catfile($guix_repo, 'tribes', 'plugins', "$plugin.scm");
|
|
my $source_file = File::Spec->catfile($guix_repo, 'tribes', 'packages', 'source.scm');
|
|
my $plugin_package_name = "tribes-plugin-$plugin";
|
|
|
|
-d File::Spec->catdir($plugin_repo, '.git') or fail("Plugin repo not found: $plugin_repo");
|
|
-d File::Spec->catdir($tribes_repo, '.git') or fail("Tribes repo not found: $tribes_repo");
|
|
-f $plugin_file or fail("Plugin file not found: $plugin_file");
|
|
-f $source_file or fail("guix-tribes source file not found: $source_file");
|
|
|
|
require_tool($_) for qw(env git rsync ssh tar perl);
|
|
|
|
my ($status, $commit_output) = run_capture('git', '-C', $plugin_repo, 'rev-parse', "$rev\^\{commit\}");
|
|
$status == 0 or fail(trim($commit_output));
|
|
my $commit = trim($commit_output);
|
|
|
|
my $tribes_rev = $opts{tribes_rev};
|
|
if (!defined $tribes_rev || $tribes_rev eq '') {
|
|
my $source_text = read_file($source_file);
|
|
$source_text =~ /\(define %tribes-commit\s+"([^"]+)"\)/
|
|
or fail("Failed to resolve %tribes-commit from $source_file");
|
|
$tribes_rev = $1;
|
|
}
|
|
|
|
($status, my $host_commit_output) =
|
|
run_capture('git', '-C', $tribes_repo, 'rev-parse', "$tribes_rev\^\{commit\}");
|
|
$status == 0 or fail(trim($host_commit_output));
|
|
my $host_commit = trim($host_commit_output);
|
|
|
|
$local_tmp = tempdir('plugin-pin.XXXXXX', TMPDIR => 1, CLEANUP => 0);
|
|
|
|
END {
|
|
if (defined $remote_tmp && $remote_tmp ne '') {
|
|
system('ssh', $opts{pguix_host}, "rm -rf '$remote_tmp'");
|
|
}
|
|
|
|
if (defined $local_tmp && $local_tmp ne '' && -d $local_tmp) {
|
|
system('rm', '-rf', $local_tmp);
|
|
}
|
|
}
|
|
|
|
my $plugin_source_dir = File::Spec->catdir($local_tmp, 'plugin-source');
|
|
my $tribes_source_dir = File::Spec->catdir($local_tmp, 'tribes-source');
|
|
mkdir $plugin_source_dir or fail("Failed to create $plugin_source_dir: $!");
|
|
mkdir $tribes_source_dir or fail("Failed to create $tribes_source_dir: $!");
|
|
|
|
my $plugin_tar = File::Spec->catfile($local_tmp, 'plugin-source.tar');
|
|
my $tribes_tar = File::Spec->catfile($local_tmp, 'tribes-source.tar');
|
|
|
|
run_checked('git', '-C', $plugin_repo, 'archive', '--output', $plugin_tar, $commit);
|
|
run_checked('git', '-C', $tribes_repo, 'archive', '--output', $tribes_tar, $host_commit);
|
|
run_checked('tar', '-xf', $plugin_tar, '-C', $plugin_source_dir);
|
|
run_checked('tar', '-xf', $tribes_tar, '-C', $tribes_source_dir);
|
|
|
|
my $manifest_file = File::Spec->catfile($plugin_source_dir, 'manifest.json');
|
|
-f $manifest_file or fail("Plugin manifest not found at $manifest_file");
|
|
|
|
my $manifest = decode_json(read_file($manifest_file));
|
|
for my $key (qw(name version provides requires)) {
|
|
exists $manifest->{$key} or fail("manifest missing required key: $key");
|
|
}
|
|
|
|
ref($manifest->{provides}) eq 'ARRAY'
|
|
&& !grep { ref($_) || !defined($_) } @{ $manifest->{provides} }
|
|
or fail('manifest provides must be a list of strings');
|
|
|
|
ref($manifest->{requires}) eq 'ARRAY'
|
|
&& !grep { ref($_) || !defined($_) } @{ $manifest->{requires} }
|
|
or fail('manifest requires must be a list of strings');
|
|
|
|
my $plugin_name = $manifest->{name};
|
|
my $version = $manifest->{version};
|
|
my $provides_joined = join("\037", @{ $manifest->{provides} });
|
|
my $requires_joined = join("\037", @{ $manifest->{requires} });
|
|
|
|
$plugin_name eq $plugin or fail("Plugin manifest name mismatch: expected $plugin, got $plugin_name");
|
|
|
|
($status, my $remote_tmp_output) = run_capture('ssh', $opts{pguix_host}, 'mktemp -d /tmp/plugin-pin.XXXXXX');
|
|
$status == 0 or fail(trim($remote_tmp_output));
|
|
$remote_tmp = trim($remote_tmp_output);
|
|
|
|
run_checked('rsync', '-az', '--delete', '--exclude', '.git', "$guix_repo/", "$opts{pguix_host}:$remote_tmp/guix-tribes/");
|
|
run_checked('rsync', '-az', '--delete', "$plugin_source_dir/", "$opts{pguix_host}:$remote_tmp/plugin-source/");
|
|
run_checked('rsync', '-az', '--delete', "$tribes_source_dir/", "$opts{pguix_host}:$remote_tmp/tribes-source/");
|
|
|
|
($status, my $source_hash_output) =
|
|
run_capture('ssh', $opts{pguix_host}, "guix hash -rx '$remote_tmp/plugin-source'");
|
|
$status == 0 or fail(trim($source_hash_output));
|
|
my $source_hash = trim($source_hash_output);
|
|
$source_hash =~ tr/\r//d;
|
|
|
|
sub remote_run_scheme {
|
|
my ($name, $body) = @_;
|
|
my ($fh, $local_path) = tempfile("$name.XXXXXX", DIR => $local_tmp, SUFFIX => '.scm');
|
|
print {$fh} $body or fail("Failed to write $local_path: $!");
|
|
close $fh or fail("Failed to close $local_path: $!");
|
|
run_checked('rsync', '-az', $local_path, "$opts{pguix_host}:$remote_tmp/$name.scm");
|
|
my ($exit, $output) =
|
|
run_capture('ssh', $opts{pguix_host}, "guix build -L '$remote_tmp/guix-tribes' -f '$remote_tmp/$name.scm' --no-grafts 2>&1");
|
|
return $output;
|
|
}
|
|
|
|
sub extract_hash {
|
|
my ($output) = @_;
|
|
my $hash;
|
|
|
|
for my $line (split /\n/, $output) {
|
|
if ($line =~ /\b(?:got|actual hash):\s*([0-9a-z]{52})/) {
|
|
$hash = $1;
|
|
}
|
|
}
|
|
|
|
defined $hash or fail("Failed to extract hash from build output.");
|
|
return $hash;
|
|
}
|
|
|
|
my $dummy_hash = '0' x 52;
|
|
|
|
my $host_setup_gexp = <<"EOF";
|
|
#~(begin
|
|
(let ((host-root (string-append work "/tribes")))
|
|
(when (file-exists? host-root)
|
|
(delete-file-recursively host-root))
|
|
(copy-recursively #+(local-file "$remote_tmp/tribes-source" #:recursive? #t)
|
|
host-root
|
|
#:follow-symlinks? #t)
|
|
(invoke "chmod" "-R" "u+w" host-root)))
|
|
EOF
|
|
|
|
my $mix_output = remote_run_scheme(
|
|
'mix-deps',
|
|
<<"EOF"
|
|
(use-modules (guix gexp) (tribes packages mix))
|
|
(fetch-mix-deps
|
|
(local-file "$remote_tmp/plugin-source" #:recursive? #t)
|
|
#:name "$plugin_package_name-mix-deps"
|
|
#:version "$version"
|
|
#:sha256 "$dummy_hash"
|
|
#:setup-gexp $host_setup_gexp)
|
|
EOF
|
|
);
|
|
my $mix_hash = extract_hash($mix_output);
|
|
|
|
my $npm_hash = '';
|
|
if (-f File::Spec->catfile($plugin_source_dir, 'assets', 'package-lock.json')) {
|
|
my $npm_output = remote_run_scheme(
|
|
'npm-deps',
|
|
<<"EOF"
|
|
(use-modules (guix gexp) (tribes packages mix))
|
|
(fetch-npm-deps
|
|
(local-file "$remote_tmp/plugin-source" #:recursive? #t)
|
|
#:name "$plugin_package_name-npm-deps"
|
|
#:version "$version"
|
|
#:sha256 "$dummy_hash"
|
|
#:assets-dir "assets"
|
|
#:setup-gexp $host_setup_gexp)
|
|
EOF
|
|
);
|
|
$npm_hash = extract_hash($npm_output);
|
|
}
|
|
|
|
my $text = read_file($plugin_file);
|
|
my @candidates;
|
|
for my $candidate ($plugin, ($plugin =~ tr/_/-/r)) {
|
|
push @candidates, $candidate unless grep { $_ eq $candidate } @candidates;
|
|
}
|
|
|
|
my ($symbol_base) =
|
|
grep { $text =~ /\(define %\Q$_\E-commit\s+"[^"]+"\)/ } @candidates;
|
|
defined $symbol_base
|
|
or fail("failed to locate plugin symbol prefix for '$plugin' in $plugin_file");
|
|
|
|
replace_once(
|
|
\$text,
|
|
qr/\(define %\Q$symbol_base\E-commit\s+"[^"]+"\)/,
|
|
qq((define %$symbol_base-commit\n "$commit")),
|
|
"%$symbol_base-commit",
|
|
);
|
|
replace_once(
|
|
\$text,
|
|
qr/\(git-version "[^"]+" %\Q$symbol_base\E-revision %\Q$symbol_base\E-commit\)/,
|
|
qq((git-version "$version" %$symbol_base-revision %$symbol_base-commit)),
|
|
"%$symbol_base-version",
|
|
);
|
|
replace_once(
|
|
\$text,
|
|
qr/\(define %\Q$symbol_base\E-source-sha256\s+"[^"]+"\)/,
|
|
qq((define %$symbol_base-source-sha256\n "$source_hash")),
|
|
"%$symbol_base-source-sha256",
|
|
);
|
|
replace_once(
|
|
\$text,
|
|
qr/\(define %\Q$symbol_base\E-mix-deps-sha256\s+"[^"]+"\)/,
|
|
qq((define %$symbol_base-mix-deps-sha256\n "$mix_hash")),
|
|
"%$symbol_base-mix-deps-sha256",
|
|
);
|
|
my $npm_replacement =
|
|
$npm_hash ne ''
|
|
? qq((define %$symbol_base-npm-deps-sha256\n "$npm_hash"))
|
|
: qq((define %$symbol_base-npm-deps-sha256\n #f));
|
|
replace_once(
|
|
\$text,
|
|
qr/\(define %\Q$symbol_base\E-npm-deps-sha256\s+(?:"[^"]+"|#f)\)/,
|
|
$npm_replacement,
|
|
"%$symbol_base-npm-deps-sha256",
|
|
);
|
|
update_plugin_definition_header(\$text, $plugin_name, $plugin_package_name, $version);
|
|
replace_once(
|
|
\$text,
|
|
qr/\(provides '\([^)]*\)\)/,
|
|
"(provides '" . scheme_string_list(@{ $manifest->{provides} }) . ')',
|
|
'plugin provides',
|
|
);
|
|
replace_once(
|
|
\$text,
|
|
qr/\(requires '\([^)]*\)\)/,
|
|
"(requires '" . scheme_string_list(@{ $manifest->{requires} }) . ')',
|
|
'plugin requires',
|
|
);
|
|
|
|
write_file($plugin_file, $text);
|
|
|
|
print "Updated $plugin_file\n";
|
|
print "plugin: $plugin\n";
|
|
print "commit: $commit\n";
|
|
print "host tribes commit: $host_commit\n";
|
|
print "version: $version\n";
|
|
print "source sha256: $source_hash\n";
|
|
print "mix deps sha256: $mix_hash\n";
|
|
print "npm deps sha256: $npm_hash\n" if $npm_hash ne '';
|
|
print 'provides: ', join(',', @{ $manifest->{provides} }), "\n";
|
|
print 'requires: ', join(',', @{ $manifest->{requires} }), "\n";
|