guix-tribes/scripts/update-plugin-pin

#!/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 JSON::PP qw(decode_json encode_json);

sub usage {
    print <<'EOF';
Usage: update-plugin-pin [options] plugin [rev]

Pin a Tribes external plugin and refresh fixed-output hashes.

PLUGIN is the plugin slug. REV defaults to "master" resolved from the
plugin checkout. The plugin manifest.json is the source of truth for plugin
id, slug, 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
  --build-host HOST       SSH host used for Guix builds and hashing
  -h, --help              Show this help

Hashing and Guix builds run with local `guix` unless --build-host is provided.
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 ($fh, $path) = tempfile('command-output.XXXXXX', TMPDIR => 1);

    my $pid = fork();
    defined $pid or fail("Failed to fork for @cmd: $!");

    if ($pid == 0) {
        open STDOUT, '>&', $fh or die "Failed to redirect stdout: $!\n";
        open STDERR, '>&', $fh or die "Failed to redirect stderr: $!\n";
        exec @cmd or die "Failed to exec $cmd[0]: $!\n";
    }

    close $fh or fail("Failed to close $path: $!");
    waitpid($pid, 0);
    my $wait_status = $?;
    my $status = $wait_status == -1 ? 255 : ($wait_status & 127 ? 128 + ($wait_status & 127) : $wait_status >> 8);

    open my $out, '<', $path or fail("Failed to read $path: $!");
    local $/;
    my $output = <$out> // '';
    close $out or fail("Failed to close $path: $!");
    unlink $path;

    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 replace_all {
    my ($text_ref, $pattern, $replacement, $label) = @_;
    my $count = ($$text_ref =~ s/$pattern/$replacement/sg);
    $count >= 1 or fail("failed to update $label");
}

my $local_tmp = '';
my $remote_tmp = '';

my @argv = @ARGV;
my %opts;

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},
    'build-host=s'       => \$opts{build_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 tar perl);

my $use_remote = defined($opts{build_host}) && $opts{build_host} ne '' ? 1 : 0;
require_tool('guix') unless $use_remote;

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{build_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(id slug 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_id = $manifest->{id};
my $plugin_slug = $manifest->{slug};
my $version = $manifest->{version};
my $provides_joined = join("\037", @{ $manifest->{provides} });
my $requires_joined = join("\037", @{ $manifest->{requires} });

$plugin_slug eq $plugin or fail("Plugin manifest slug mismatch: expected $plugin, got $plugin_slug");

my ($plugin_source_for_scheme, $tribes_source_for_scheme, $guix_load_path);
my $source_hash;

sub setup_remote {
    require_tool($_) for qw(rsync ssh);

    if ($remote_tmp eq '') {
        print STDERR "Using build host $opts{build_host}.\n";

        ($status, my $remote_tmp_output) = run_capture('ssh', $opts{build_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{build_host}:$remote_tmp/guix-tribes/");
        run_checked('rsync', '-az', '--delete', "$plugin_source_dir/", "$opts{build_host}:$remote_tmp/plugin-source/");
        run_checked('rsync', '-az', '--delete', "$tribes_source_dir/", "$opts{build_host}:$remote_tmp/tribes-source/");
    }

    $plugin_source_for_scheme = "$remote_tmp/plugin-source";
    $tribes_source_for_scheme = "$remote_tmp/tribes-source";
    $guix_load_path = "$remote_tmp/guix-tribes";

    ($status, my $source_hash_output) =
      run_capture('ssh', $opts{build_host}, "guix hash -rx '$plugin_source_for_scheme'");
    $status == 0 or fail(trim($source_hash_output));
    $source_hash = trim($source_hash_output);
    $source_hash =~ tr/\r//d;
}

if ($use_remote) {
    setup_remote();
} else {
    $plugin_source_for_scheme = $plugin_source_dir;
    $tribes_source_for_scheme = $tribes_source_dir;
    $guix_load_path = $guix_repo;

    ($status, my $source_hash_output) = run_capture('guix', 'hash', '-rx', $plugin_source_dir);
    $status == 0 or fail(trim($source_hash_output));
    $source_hash = trim($source_hash_output);
    $source_hash =~ tr/\r//d;
}

sub 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: $!");

    if ($use_remote) {
        run_checked('rsync', '-az', $local_path, "$opts{build_host}:$remote_tmp/$name.scm");
        my ($exit, $output) =
          run_capture('ssh', $opts{build_host}, "guix build -L '$guix_load_path' -f '$remote_tmp/$name.scm' --no-grafts 2>&1");
        return $output;
    }

    my ($exit, $output) =
      run_capture('guix', 'build', '-L', $guix_load_path, '-f', $local_path, '--no-grafts');
    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;
}

sub build_hash {
    my ($label, $build) = @_;

    my $output = $build->();
    my $hash = eval { extract_hash($output) };
    if ($@) {
        my $hint = $use_remote
          ? "Build host Guix did not complete the hash refresh."
          : "Local Guix did not complete the hash refresh. To run this step on a build host, rerun with --build-host HOST.";
        fail("Failed to extract $label hash.\n$hint\n$output");
    }

    return $hash;
}

my $dummy_hash = '0' x 52;

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");

my $package_body = $text;
if ($text =~ /\(define\* \(\Q$symbol_base\E-package-from-source\b(.*?)(?:\n\(define \Q$symbol_base\E-package\b)/s) {
    $package_body = $1;
}

sub package_reuses_host_libs {
    my ($body) = @_;

    return 1 if $body =~ /#:reuse-host-libs\?\s+#t\b/;
    return 0 if $body =~ /#:reuse-host-libs\?\s+#f\b/;

    if ($body =~ /#:reuse-host-libs\?\s+reuse-host-libs\?/) {
        return 1 if $body =~ /\(reuse-host-libs\?\s+#t\)/;
        return 0 if $body =~ /\(reuse-host-libs\?\s+#f\)/;
    }

    return 0;
}

sub package_includes_mix_deps {
    my ($body, $reuse_host_libs) = @_;

    return 1 if $body =~ /#:include-mix-deps\?\s+#t\b/;
    return 0 if $body =~ /#:include-mix-deps\?\s+#f\b/;

    if ($body =~ /#:include-mix-deps\?\s+include-mix-deps\?/) {
        return 1 if $body =~ /\(include-mix-deps\?\s+#t\)/;
        return 0 if $body =~ /\(include-mix-deps\?\s+#f\)/;
    }

    return $reuse_host_libs ? 0 : 1;
}

my $reuse_host_libs = package_reuses_host_libs($package_body);
my $include_mix_deps = package_includes_mix_deps($package_body, $reuse_host_libs);

sub host_setup_gexp {
    return <<"EOF";
#~(begin
  (let ((host-root (string-append work "/tribes")))
    (when (file-exists? host-root)
      (delete-file-recursively host-root))
    (copy-recursively #+(local-file "$tribes_source_for_scheme" #:recursive? #t)
                      host-root
                      #:follow-symlinks? #t)
    (invoke "chmod" "-R" "u+w" host-root)))
EOF
}

my $source_setup_gexp = $reuse_host_libs ? "#~(begin)" : host_setup_gexp();

sub mix_deps_output {
    return run_scheme(
        'mix-deps',
        <<"EOF"
(use-modules (guix gexp) (tribes packages mix))
(fetch-mix-deps
  (local-file "$plugin_source_for_scheme" #:recursive? #t)
  #:name "$plugin_package_name-mix-deps"
  #:version "$version"
  #:sha256 "$dummy_hash"
  #:setup-gexp $source_setup_gexp)
EOF
    );
}

sub npm_deps_output {
    return run_scheme(
        'npm-deps',
        <<"EOF"
(use-modules (guix gexp) (tribes packages mix))
(fetch-npm-deps
  (local-file "$plugin_source_for_scheme" #:recursive? #t)
  #:name "$plugin_package_name-npm-deps"
  #:version "$version"
  #:sha256 "$dummy_hash"
  #:assets-dir "assets"
  #:setup-gexp $source_setup_gexp)
EOF
    );
}

$text =~ /\(define %\Q$symbol_base\E-mix-deps-sha256\s+"([^"]+)"\)/
  or fail("failed to locate %$symbol_base-mix-deps-sha256 in $plugin_file");
my $mix_hash = $1;
if ($include_mix_deps) {
    $mix_hash = build_hash('mix deps', \&mix_deps_output);
}

my $npm_hash = '';
if (-f File::Spec->catfile($plugin_source_dir, 'assets', 'package-lock.json')) {
    $npm_hash = build_hash('npm deps', \&npm_deps_output);
}

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",
);
replace_all(
    \$text,
    qr/#:provides\s+'\([^)]*\)/,
    "#:provides '" . scheme_string_list(@{ $manifest->{provides} }),
    'plugin provides',
);
replace_all(
    \$text,
    qr/#:requires\s+'\([^)]*\)/,
    "#:requires '" . scheme_string_list(@{ $manifest->{requires} }),
    'plugin requires',
);

write_file($plugin_file, $text);

print "Updated $plugin_file\n";
print "plugin: $plugin\n";
print "plugin id: $plugin_id\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";