view release on metacpan or  search on metacpan

lib/App/MechaCPAN.pm  view on Meta::CPAN

      my ( $file, $keyring ) = @_;
      run_qvf( "sq", "verify", "--signer-file", "$keyring", "$file" );
    };
  },
  sub
  {
    return
      if !eval { run(qw/rnp --version/); 1 };

    return sub
    {
      my ( $file, $keyring ) = @_;
      run_qvf( "rnp", "--keyfile", "$keyring", "--verify", "$file" );
    };
  },
);

sub _resolve_verifier
{
  state $verify_fn;

  if ( !defined $verify_fn )
  {
    foreach my $verify (@verifier)
    {
      my $fn = $verify->();
      if ( defined $fn )
      {
        $verify_fn = $fn;
        last;
      }
    }
  }

  return $verify_fn;
}

sub get_cpan_checksums
{
  my $url = shift;
  my $key = shift;

  # If verify is off, don't check any part of the CHECKSUMS
  return
    if defined $CHKSIGS && !$CHKSIGS;

  die "CHECKSUMS URL must be HTTPS, not '$url'"
    unless $url =~ m{\Ahttps://}xmsi;

  die "CHECKSUMS URL must end with CHECKSUMS, not '$url'"
    unless $url =~ m{CHECKSUMS\z}xmsi;

  # Even if verification is optional, not downloading the CHECKSUMS is fatal
  my $checksums = '';
  fetch_file( $url, \$checksums );
  $checksums = App::MechaCPAN::_verify_checksums_body($checksums);

  # If $CHKSIGS is true, we must verify that CHECKSUMS has a valid signature
  # If $CHKSIGS is undef, we will verify that CHECKSUMS has a valid signature
  #   if possible, but won't throw errors if can't.
  # In both cases, the CHECKSUMS is used to validate the checksums of the
  #   downloaded file
  # If $CHKSIGS is otherwise false, we already did an early return above
  my $verify_fn = _resolve_verifier();

  if ( !defined $verify_fn )
  {
    die "Could not find verification program and verification was required"
      if $CHKSIGS;
    logmsg "CHECKSUMS signature not checked: PGP verifier not found";
  }
  else
  {
    my $keyring  = cpan_keyring();
    my $chk_file = humane_tmpfile('CHECKSUMS');

    $chk_file->print($checksums);
    $chk_file->flush;
    $verify_fn->( "$chk_file", $keyring );
    logmsg "VALID: $url";
  }

  my $result = do
  {
    require Safe;
    my $safe = Safe->new("App::MechaCPAN::reval");

    local $@;
    my $chksum = $safe->reval($checksums);
    die "Failed to parse CHECKSUMS: $@"
      if $@;

    die "Failed to get HASH from CHECKSUMS"
      if ref $chksum ne 'HASH';

    $chksum;
  };

  # If a module name is passed ($key), then we check if it is listed in the
  # CHECKSUMS file. If it is missing, it depends on $CHKSIGS. If it is true
  # (strict verify), an error will be produced. If it is undef (best-effort)
  # then a log entry will be added, and nothing will be returned, whcih will
  # match the no-verify path above.
  if ( defined $key && !exists $result->{$key} )
  {
    die "Could not find module '$key' in CHECKSUMS"
      if $CHKSIGS;

    logmsg "Could not find '$key' in CHECKSUMS, not attempting to verify";
    return;
  }

  return $result;
}

my @inflate = (

  # System tar
  sub
  {
    my $src = shift;

lib/App/MechaCPAN.pm  view on Meta::CPAN

      $tar = defined $tar_version_str;
    }

    return
      unless $tar;

    my $unzip
      = $src =~ m/gz $humane_qr? $/xms          ? 'gzip'
      : $src =~ m/(bz2|bzip2) $humane_qr? $/xms ? 'bzip2'
      :                                           'xz';

    # Instead of relying on a shell to pipe contents from unzip to tar, both
    # gnutar and bsdtar accept the use-compress-program option. bsdtar needs
    # the -d option so it will decompress, while gnutar automatically adds it
    # but it is harmless to add.
    run( 'tar', '--use-compress-program', "$unzip -d", '-xf', $src );
    return 1;
  },

  # Archive::Tar
  sub
  {
    my $src = shift;

    require Archive::Tar;
    my $tar = Archive::Tar->new;
    $tar->error(1);

    my $ret = $tar->read( "$src", 1, { extract => 1 } );

    die $tar->error
      unless $ret;
  },
);

sub _path_escapes_dir
{
  my $path = shift;

  return 0
    if !defined $path;
  return 0
    if !length $path;

  return 1
    if File::Spec->file_name_is_absolute($path);

  for my $part ( File::Spec->splitdir($path) )
  {
    return 1
      if $part eq '..';
  }

  return 0;
}

# Inspect a tar archive's header entries (no extraction). Returns a
# human-readable reason if any entry would escape the destination dir
# (absolute paths, '..' traversal in names, or symlink/hardlink targets
# pointing outside). Returns undef if the archive is safe.
sub _validate_archive_is_safe
{
  my $src = shift;

  require Archive::Tar;

  # Create a tar iterator. The magic 1 tells it to decompress
  my $iter = Archive::Tar->iter( "$src", 1 );

  return "could not read archive: $src"
    if !defined $iter;

  while ( my $entry = $iter->() )
  {
    my $name = $entry->full_path;

    return "unsafe entry name: '$name'"
      if _path_escapes_dir($name);

    if ( $entry->is_symlink || $entry->is_hardlink )
    {
      my $linkname = $entry->linkname;

      return "unsafe link target: '$name' -> '$linkname'"
        if _path_escapes_dir($linkname);
    }
  }

  return;
}

sub inflate_archive
{
  my $src = shift;
  my $dir = shift;

  my $sha256;

  if ( ref $src eq 'HASH' )
  {
    $sha256 = delete $src->{sha256};

    # Technically the error is wrong, it can have an optional sha256 key,
    # but it gets people here to see that the error is that there is a
    # narrow requirement for the hashref version of inflate_archive
    die "Hashref for inflate_archive must be only the 'src' key"
      if scalar( keys %$src ) != 1 || !exists $src->{src};

    $src = $src->{src};
  }

  # $src can be a file path or a URL.
  if ( !-e "$src" )
  {
    $src = fetch_file($src);
  }

  if ($sha256)
  {
    file_digest_chk( $src, $sha256 );
    logmsg "Digest passed: $src";
  }

  if ( !defined $dir )
  {
    my $descr = ( File::Spec->splitpath($src) )[2];
    $dir = humane_tmpdir($descr);
  }

  die "Could not find destination directory: $dir"
    if !-d $dir;

  if ( my $reason = _validate_archive_is_safe($src) )
  {
    croak "Refusing to extract unsafe archive $src: $reason\n";
  }

  my $orig = cwd;

  my $is_complete;
  foreach my $inflate_sub (@inflate)
  {
    local $@;
    my $success;
    my $error_free = eval {
      chdir $dir;
      $success = $inflate_sub->($src);
      1;
    };

    my $err = $@;
    my @glob = glob('*');

    chdir $orig;

    logmsg $err
      unless $error_free;

    if ($success && @glob > 0)
    {
      $is_complete = 1;
      last;
    }
  }

  if ( !$is_complete )
  {
    croak "Could not unpack archive: $src\n";
  }

  # If there's only 1 file and it's a directory, go ahead and chdir into it
  my @files = glob("$dir/*");
  if ( @files == 1 && -d $files[0] )
  {
    $dir = $files[0];
  }

  return $dir;
}

sub _genio
{
  state $iswin32 = $^O eq 'MSWin32';
  my $write_hdl;
  my $read_hdl;

  if ($iswin32)
  {
    use Socket;
    socketpair( $read_hdl, $write_hdl, AF_UNIX, SOCK_STREAM, PF_UNSPEC );
    shutdown( $read_hdl,  1 );
    shutdown( $write_hdl, 0 );
  }