path: root/Master/tlpkg/TeXLive/TLCrypto.pm

# $Id$
# TeXLive::TLcrypto.pm - handle checksums and signatures.
# Copyright 2016 Norbert Preining
# This file is licensed under the GNU General Public License version 2
# or any later version.

package TeXLive::TLCrypto;

use Digest::MD5;
use Digest::SHA;

use TeXLive::TLConfig;
use TeXLive::TLUtils qw(debug ddebug win32 which platform conv_to_w32_path);

my $svnrev = '$Revision: 40650 $';
my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
sub module_revision { return $_modulerevision; }

=pod

=head1 NAME

C<TeXLive::TLCrypto> -- checksums and cryptographic signatures

=head1 SYNOPSIS

  use TeXLive::TLCrypto;  # requires Digest::MD5 and Digest::SHA

=head2 Checksums

  TeXLive::TLCrypto::tlchecksum($path);
  TeXLive::TLCrypto::tlmd5($path);
  TeXLive::TLCrypto::verify_checksum($file, $url);

=head2 Signatures

  TeXLive::TLCrypto::setup_gpg();
  TeXLive::TLCrypto::verify_signature($file, $url);

=head1 DESCRIPTION

=cut

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT_OK @EXPORT);
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(
    &tlchecksum
    &tlmd5
    &tldigest
    &tl_short_digest
    &tlmd5
    &verify_checksum
    &setup_gpg
    &verify_signature
  );
}

=pod

=item C<< tlchecksum($file) >>

Return checksum of C<$file>.

=cut

sub tlchecksum {
  my ($file) = @_;
  if (-r $file) {
    open(FILE, $file) || die "open($file) failed: $!";
    binmode(FILE);
    my $cshash = Digest::SHA->new(512)->addfile(*FILE)->hexdigest;
    close(FILE);
    return $cshash;
  } else {
    tlwarn("tlchecksum: given file not readable: $file\n");
    return "";
  }
}

sub tlchecksum_data {
  my ($data) = @_;
  my $cshash = Digest::SHA->new(512)->add($data)->hexdigest;
  return $cshash;
}

=pod

=item C<< tlmd5($file) >>

Return md5, specifically, of C<$file>.

=cut

sub tlmd5 {
  my ($file) = @_;
  if (-r $file) {
    open(FILE, $file) || die "open($file) failed: $!";
    binmode(FILE);
    my $md5hash = Digest::MD5->new->addfile(*FILE)->hexdigest;
    close(FILE);
    return $md5hash;
  } else {
    tlwarn("tlmd5, given file not readable: $file\n");
    return "";
  }
}

=pod

=item C<< tldigest($str) >>

=item C<< tl_short_digest($str) >>

Return full and short digests of C<$str>, respectively.

=cut

sub tldigest { return (Digest::SHA::sha512_hex(shift)); }
sub tl_short_digest { return (Digest::MD5::md5_hex(shift)); }

# emacs-page
=pod

=item C<< verify_checksum($file, $checksum_url) >>

Verifies that C<$file> has checksum C<$checksum_url>, and if gpg is
available also verifies that the checksum is signed.

Returns 0 on success, -1 on connection error, -2 on missing signature
file, -3 if no gpg program is available, 1 on checksum,
and 2 on signature errors.
In case of errors returns an informal message as second argument.

=cut

sub verify_checksum {
  my ($file, $checksum_url) = @_;
  my $checksum_file
    = TeXLive::TLUtils::download_to_temp_or_file($checksum_url);

  # next step is verification of tlpdb checksum with checksum file
  # existenc of checksum_file was checked above
  if (!$checksum_file) {
    return(-1, "download did not succeed: $checksum_url");
  }
  # check the signature
  my ($ret, $msg) = verify_signature($checksum_file, $checksum_url);
  return ($ret, $msg) if ($ret != 0);

  # verify local data
  open $cs_fh, "<$checksum_file" or die("cannot read file: $!");
  if (read ($cs_fh, $remote_digest, $ChecksumLength) != $ChecksumLength) {
    close($cs_fh);
    return(1, "incomplete read from $checksum_file");
  } else {
    close($cs_fh);
    ddebug("found remote digest: $remote_digest\n");
  }
  $local_digest = tlchecksum($file);
  ddebug("local_digest = $local_digest\n");
  if ($local_digest ne $remote_digest) {
    return(1, "digest disagree");
  }

  # we are still here, so checksum also succeeded
  debug("checksum of local copy identical with remote hash\n");

  return(0);
}

# emacs-page
=pod

=item C<< setup_gpg() >>

Tries to set up gpg command line C<$::gpg> used for verification of
downloads. Checks for the environment variable C<TL_GNUPG>; if that
envvar is not set, first C<gpg>, then C<gpg2>, then, on Windows only,
C<tlpkg/installer/gpg/gpg.exe> is looked for.  Further adaptation of the
invocation of C<gpg> can be done using the two enviroment variables
C<TL_GNUPGHOME>, which is passed to C<gpg> with C<--homedir>, and
C<TL_GNUPGARGS>, which replaces the default arguments
C<--no-secmem-warning --no-permission-warning>.

Returns 1/0 on success/failure.

=cut

sub setup_gpg {
  my $master = shift;
  my $found = 0;
  my $prg;
  if ($ENV{'TL_GNUPG'}) {
    # if envvar is set, don't look for anything else.
    $prg = test_one_gpg($ENV{'TL_GNUPG'});
    $found = 1 if ($prg);
  } else {
    # no envvar, look for gpg
    $prg = test_one_gpg('gpg');
    $found = 1 if ($prg);
  
    # no gpg, look for gpg2
    if (!$found) {
      $prg = test_one_gpg('gpg2');
      $found = 1 if ($prg);
    }
    if (!$found) {
      # test also a shipped version from tlgpg
      my $p = "$master/tlpkg/installer/gpg/gpg." .
        ($^O =~ /^MSWin/i ? "exe" : platform()) ;
      debug("Testing for gpg in $p\n");
      if (-r $p) {
        if ($^O =~ /^MSWin/i) {
          $prg = conv_to_w32_path($p);
        } else {
          $prg = "\"$p\"";
        }
        $found = 1;
      }
    }
  }
  return 0 if (!$found);

  # $prg is already properly quoted!

  # ok, we found one
  # Set up the gpg invocation:
  my $gpghome = ($ENV{'TL_GNUPGHOME'} ? $ENV{'TL_GNUPGHOME'} : 
                                        "$master/tlpkg/gpg" );
  $gpghome =~ s!/!\\!g if win32();
  my $gpghome_quote = "\"$gpghome\"";
  # mind the final space for following args
  $::gpg = "$prg --homedir $gpghome_quote ";
  if ($ENV{'TL_GNUPGARGS'}) {
    $::gpg .= $ENV{'TL_GNUPGARGS'};
  } else {
    $::gpg .= "--no-secmem-warning --no-permission-warning ";
  }
  debug("gpg command line: $::gpg\n");
  return 1;
}

sub test_one_gpg {
  my $prg = shift;
  my $cmdline;
  debug("Testing for gpg in $prg\n");
  if ($^O =~ /^MSWin/i) {
    # Perl on Windows somehow does not allow calling a program
    # without a full path - at least a call to "gpg" tells me
    # that "c:/Users/norbert/gpg" is not recognized ...
    # consequence - use which!
    $prg = which($prg);
    return "" if (!$prg);
    $prg = conv_to_w32_path($prg);
    $cmdline = "$prg --version >nul 2>&1";
  } else {
    $cmdline = "$prg --version >/dev/null 2>&1";
  }
  my $ret = system($cmdline);
  if ($ret == 0) {
    debug("  ... found!\n");
    return $prg;
  } else {
    debug("  ... not found!\n");
    return "";
  }
}

# emacs-page
=pod

=item C<< verify_signature($file, $url) >>

Verifies a download of C<$url> into C<$file> by cheking the 
gpg signature in C<$url.asc>.

Returns 0 on success, -2 on missing signature file, 2 on signature error,
and -3 if no gpg is available.
In case of errors returns an informal message as second argument.

=cut

sub verify_signature {
  my ($file, $url) = @_;
  my $signature_url = "$url.asc";

  # if we have $::gpg set, we try to verify cryptographic signatures
  if ($::gpg) {
    my $signature_file
      = TeXLive::TLUtils::download_to_temp_or_file($signature_url);
    if ($signature_file) {
      my ($ret, $out) = gpg_verify_signature($file, $signature_file);
      if ($ret) {
        # no need to show the output
        debug("cryptographic signature of $url verified\n");
        return(0);
      } else {
        return(2, <<GPGERROR);
cryptographic signature verification of
  $file
against
  $signature_url
failed. Output was
$out
Please report to texlive\@tug.org
GPGERROR
      }
    } else {
      debug("no access to cryptographic signature $signature_url\n");
      return(-2, "no access to cryptographic signature");
    }
  } else {
    debug("gpg prog not defined, no checking of signatures\n");
    # we return 0 (= success) if not gpg is available
    return(-3, "no gpg available");
  }
  # not reached
  return (0);
}

=pod

=item C<< gpg_verify_signature($file, $sig) >>

Internal routine running gpg to verify signature C<$sig> of C<$file>.

=cut

sub gpg_verify_signature {
  my ($file, $sig) = @_;
  my ($file_quote, $sig_quote);
  if (win32()) {
    $file =~ s!/!\\!g;
    $sig =~ s!/!\\!g;
  }
  $file_quote = TeXLive::TLUtils::quotify_path_with_spaces ($file);
  $sig_quote = TeXLive::TLUtils::quotify_path_with_spaces ($sig);
  my ($out, $ret)
    = TeXLive::TLUtils::run_cmd("$::gpg --verify $sig_quote $file_quote 2>&1");
  if ($ret == 0) {
    debug("verification succeeded, output:\n$out\n");
    return (1, $out);
  } else {
    return (0, $out);
  }
}

=back
=cut
1;
__END__

=head1 SEE ALSO

The modules L<TeXLive::Config>, L<TeXLive::TLUtils>, etc.,
and the documentation in the repository: C<Master/tlpkg/doc/>.
Also the standard modules L<Digest::MD5> and L<Digest::SHA>.

=head1 AUTHORS AND COPYRIGHT

This script and its documentation were written for the TeX Live
distribution (L<http://tug.org/texlive>) and both are licensed under the
GNU General Public License Version 2 or later.

=cut

### Local Variables:
### perl-indent-level: 2
### tab-width: 2
### indent-tabs-mode: nil
### End:
# vim:set tabstop=2 expandtab: #