File Coverage

blib/lib/App/Rakubrew/Download.pm

Criterion	Covered	Total	%
statement	44	158	27.8
branch	0	72	0.0
condition	0	35	0.0
subroutine	15	23	65.2
pod	0	2	0.0
total	59	290	20.3

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;
    }
}