App-Rakubrew/lib/App/Rakubrew/Download.pm
package App::Rakubrew::Download;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw();
use strict;
use warnings;
use 5.010;
use HTTP::Tinyish;
use JSON;
use Config;
use Cwd qw(cwd);
use IO::Uncompress::Unzip qw( $UnzipError );
use File::Path qw( make_path remove_tree );
use File::Copy::Recursive qw( dirmove );
use File::Spec::Functions qw( updir splitpath catfile catdir );
use File::Which qw();
use App::Rakubrew::Variables;
use App::Rakubrew::Tools;
use App::Rakubrew::VersionHandling;
my $release_index_url = 'https://rakudo.org/dl/rakudo';
my $download_url_prefix = 'https://rakudo.org/dl/rakudo/';
sub download_precomp_archive {
my ($impl, $ver) = @_;
my $ht = HTTP::Tinyish->new();
my @matching_releases = grep {
$_->{backend} eq $impl && ($ver ? $_->{ver} eq $ver : 1)
} _retrieve_releases($ht);
if (!@matching_releases) {
say STDERR 'Couldn\'t find a precomp release for OS: "' . _my_platform() . '", architecture: "' . _my_arch() . '"' . ($ver ? (', version: "' . $ver . '"') : '');
say STDERR 'You can try building yourself. Use the `rakubrew build` command to do so.';
exit 1;
}
if ($ver && @matching_releases > 1) {
say STDERR 'Multiple releases found for your architecture. Don\'t know what to install. This shouldn\'t happen.';
exit 1;
}
if (!$ver) {
$ver = $matching_releases[0]->{ver};
}
my $name = "$impl-$ver";
chdir $versions_dir;
if (-d $name) {
say STDERR "$name is already installed.";
exit 1;
}
say 'Downloading ' . $matching_releases[0]->{url};
my $res = $ht->get($matching_releases[0]->{url});
unless ($res->{success}) {
say STDERR "Couldn\'t download release. Error: $res->{status} $res->{reason}";
exit 1;
}
mkdir $name;
say 'Extracting';
if (_my_platform() eq 'win') {
_unzip(\($res->{content}), $name);
}
else {
_untar($res->{content}, $name);
}
# Remove top-level rakudo-2020.01 folder and move all files one level up.
my $back = cwd();
chdir $name;
my $rakudo_dir;
opendir(DIR, '.') || die "Can't open directory: $!\n";
while (my $file = readdir(DIR)) {
if (-d $file && $file =~ /^rakudo-/) {
$rakudo_dir = $file;
last;
}
}
closedir(DIR);
unless ($rakudo_dir) {
say STDERR "Archive didn't look as expected, aborting. Extracted to: $name";
exit 1;
}
dirmove($rakudo_dir, '.');
rmdir($rakudo_dir);
chdir $back;
return $name;
}
sub available_precomp_archives {
return _retrieve_releases(HTTP::Tinyish->new());
}
sub _retrieve_releases {
my $ht = shift;
my $release_index = _download_release_index($ht);
my @matching_releases =
sort { $b->{ver} cmp $a->{ver} }
grep {
$_->{name} eq 'rakudo'
&& $_->{type} eq 'archive'
&& $_->{platform} eq _my_platform()
&& $_->{arch} eq _my_arch()
&& $_->{format} eq (_my_platform() eq 'win' ? 'zip' : 'tar.gz')
} @$release_index;
# Filter out older build revisions
@matching_releases = grep {
my $this = $_;
not grep {
+($_->{build_rev}) > +($this->{build_rev})
&& $_->{name} eq $this->{name}
&& $_->{type} eq $this->{type}
&& $_->{platform} eq $this->{platform}
&& $_->{arch} eq $this->{arch}
&& $_->{format} eq $this->{format}
&& $_->{ver} eq $this->{ver};
} @matching_releases;
} @matching_releases;
return @matching_releases;
}
sub _my_platform {
my %oses = (
MSWin32 => 'win',
darwin => 'macos',
linux => 'linux',
openbsd => 'openbsd',
);
return $oses{$^O} // $^O;
}
sub _my_arch {
my $arch;
my $mac_brand_string;
if ($Config{archname} =~ /darwin/i) {
# Some MacOS' have sysctl in /usr/sbin/ and that dir not in path.
# Seems to be the case at least on Ventura 13.5.1
# See https://github.com/Raku/App-Rakubrew/issues/77
my @mac_sysctls = File::Which::which('sysctl');
my $mac_sysctl = $mac_sysctls[0] // '/usr/sbin/sysctl';
$mac_brand_string = `$mac_sysctl -n machdep.cpu.brand_string`;
$arch =
$mac_brand_string =~ /Apple/i ? 'arm64' : # MacOS M1 / Apple Silicon
$mac_brand_string =~ /Intel/i ? 'x86_64' : # MacOS Intel
'';
}
else {
$arch =
$Config{archname} =~ /x64/i ? 'x86_64' :
$Config{archname} =~ /x86_64/i ? 'x86_64' :
$Config{archname} =~ /amd64/i ? 'x86_64' :
$Config{archname} =~ /x86/i ? 'x86' :
$Config{archname} =~ /i686/i ? 'x86' :
$Config{archname} =~ /aarch64/i ? 'arm64' : # e.g. Raspi >= 2.1 with 64bit OS
$Config{archname} =~ /arm-linux-gnueabihf/i ? 'armhf' : # e.g. Raspi >= 2, with 32bit OS
$Config{archname} =~ /s390x-linux/i ? 's390x' :
'';
}
unless ($arch) {
say STDERR 'Couldn\'t detect system architecture. Current arch is: ' . $Config{archname};
say STDERR 'Current uname -a is: ' . `uname -a`;
say STDERR 'Current machdep.cpu.brand_string is: ' . $mac_brand_string if $mac_brand_string;
exit 1;
}
return $arch;
}
sub _download_release_index {
my $ht = shift;
my $res = $ht->get($release_index_url);
unless ($res->{success}) {
say STDERR "Couldn\'t fetch release index at $release_index_url. Error: $res->{status} $res->{reason}";
exit 1;
}
return decode_json($res->{content});
}
sub _untar {
my ($data, $target) = @_;
my $back = cwd();
chdir $target;
open (TAR, '| tar -xz');
binmode(TAR);
print TAR $data;
close TAR;
chdir $back;
}
sub _unzip {
my ($data_ref, $target) = @_;
my $zip = IO::Uncompress::Unzip->new($data_ref);
unless ($zip) {
say STDERR "Reading zip file failed. Error: $UnzipError";
exit 1;
}
my $status;
for ($status = 1; $status > 0; $status = $zip->nextStream()) {
my $header = $zip->getHeaderInfo();
my ($vol, $path, $file) = splitpath($header->{Name});
if (index($path, updir()) != -1) {
say STDERR 'Found updirs in zip file, this is bad. Aborting.';
exit 1;
}
my $target_dir = catdir($target, $path);
unless (-d $target_dir) {
unless (make_path($target_dir)) {
say STDERR "Failed to create directory $target_dir. Error: $!";
exit 1;
}
}
next unless $file;
my $target_file = catfile($target, $path, $file);
unless (open(FH, '>', $target_file)) {
say STDERR "Failed to write $target_file. Error: $!";
exit 1;
}
binmode(FH);
my $buf;
while (($status = $zip->read($buf)) > 0) {
print FH $buf;
}
close FH;
}
if ($status < 0) {
say STDERR "Failed to extract archive. Error: $UnzipError";
exit 1;
}
}