#! /usr/bin/perl -w

# This program takes .changes or .dsc files as arguments and verifies
# that they're properly signed by a Debian developer, and that the local
# copies of the files mentioned in them match the MD5 sums given.

# Copyright 1998 Roderick Schertler <roderick@argon.org>
# Modifications copyright 1999 Julian Gilbey <jdg@debian.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# For a copy of the GNU General Public License write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

use 5.004;	# correct pipe close behavior
use strict;

use POSIX;
use IPC::Open3 qw(open3);
BEGIN {
    eval { require MD5; };
    if ($@) {
	die "Problem loading the MD5.pm module: $@\nHave you installed the libdigest-md5-perl package?\n";
    }
}
use Cwd;
use lib '@pkgdatadir@';
use checkgettext;

setlocale(LC_MESSAGES(), "");
textdomain("devscripts");

(my $progname = $0) =~ s%.*/%%;
my $Exit = 0;
my $start_dir = cwd();

my $usage = sprintf
	gettext("Usage: %s [--help|--version] dsc-or-changes-file ...\n"),
	$progname;

my $version = sprintf gettext(<<'EOF'), $progname, '@VERSION@';
This is %s, from the Debian devscripts package, version %s
This code is copyright 1998 Roderick Schertler <roderick@argon.org>
Modifications are copyright 1999 Julian Gilbey <jdg@debian.org>
This program comes with ABSOLUTELY NO WARRANTY.
You are free to redistribute this code under the terms of the
GNU General Public License, version 2 or later.
EOF

##
## handle command-line options
##
if ($ARGV[0] eq '--help') { print $usage; exit 0; }
if ($ARGV[0] eq '--version') { print $version; exit 0; }

sub xwarndie_mess {
    my @mess = ("$progname: ", @_);
    $mess[$#mess] =~ s/:$/: $!\n/;	# XXX loses if it's really /:\n/
    return @mess;
}

sub xwarn {
    warn xwarndie_mess @_;
    $Exit ||= 1;
}

sub xdie {
    die xwarndie_mess @_;
}

# We retain the reference to Guy's directory on master even though
# it won't be of use other than on master.  In this way, this program
# may be installed on master without any changes being necessary,
# and it is hardly likely to cause any ill effects elsewhere.
sub get_rings {
    my @rings;
    for (qw(/org/keyring.debian.org/keyrings/debian-keyring.gpg
	    /debian/home/maor/dinstall/debian-keyring.gpg
	    /usr/share/keyrings/debian-keyring.gpg
	    /org/keyring.debian.org/keyrings/debian-keyring.gpg
	    /debian/home/maor/dinstall/debian-keyring.pgp
	    /usr/share/keyrings/debian-keyring.pgp)) {
	push @rings, $_ if -r;
    }
    return @rings if @rings;
    xdie gettext("can't find any debian-keyring.{pgp,gpg}\n");
}

sub process_file {
    my ($file, @rings) = @_;
    my ($pid, $rin, $rout, $out, $err, $any, @spec, $filedir, $filebase);
    local (*INPUT, *OUT, *ERR);

    print "$file:\n";

    # Move to the directory in which the file appears to live
    chdir $start_dir or xdie gettext("can't chdir to original directory!\n");
    if ($file =~ m-(.*)/([^/]+)-) {
	$filedir = $1;
	$filebase = $2;
	unless (chdir $filedir) {
	    xwarn sprintf(gettext("can't chdir %s:"), $filedir);
	    return;
	}
    } else {
	$filebase = $file;
    }

    unless (open INPUT, $filebase) {
	xwarn sprintf(gettext("can't read %s:"),$file);
	return;
    }

    # I read and save the output from pgp before checking anything so
    # that I don't misleadingly "validate" any files from a source which
    # fails its signature check.  I use open3() to run it so I can read
    # the stdout and stderr independently.
    #
    # Originally I just parsed PGP's stderr to tell whether the signature
    # was good, because it didn't vary its exit status based on whether the
    # file passed the signature test or not.  It turns out that it doesn't
    # do this unless you use +batchmode.  I still parse the stderr so that I
    # can output the name of the person who signed it, but not finding that
    # isn't an error so that it works in the face of internationalization or
    # whatever.

    my @cmd = qw(gpg --batch --output - --no-default-keyring);
    foreach (@rings) { push @cmd, '--keyring', $_ }
    $pid = open3 '<&INPUT', *OUT, *ERR, @cmd;

    @spec = (['stdout', *OUT, \$out], ['stderr', *ERR, \$err]);
    $rin = '';
    for (@spec) {
	${ $_->[2] } = '';
	vec($rin, fileno $_->[1], 1) = 1;
    }

    while (@spec) {
	unless (defined select $rout=$rin, undef, undef, undef) {
	    next if $! == EINTR();
	    xdie gettext("select() error reading gpg's output:");
	}
	for (my $i = 0; $i <= $#spec; $i++) {
	    my ($name, $fh, $rdata) = @{ $spec[$i] };
	    if (vec $rout, fileno $fh, 1) {
		my $n = sysread $fh, $$rdata, 16*1024, length $$rdata;
		defined $n
		    or xdie sprintf(gettext("error reading gpg's %s:"),$name);
		if (!$n) {
		    vec($rin, fileno $fh, 1) = 0;
		    close $fh
			or xdie sprintf(gettext("error closing pgp's %s:"),$name);
		    undef $spec[$i];
		}
	    }
	}
	@spec = grep { defined } @spec;
    }

    waitpid($pid, 0) == $pid or xdie gettext("error waiting for gpg:");
    unless ($? == 0) {
	xwarn sprintf(gettext("%s failed signature check\n"),$file);
	return;
    }

# This doesn't work if LANG/LC_ALL has been set
#     if ($err =~ /(gpg: Good signature from .*)/im) {
# 	  print "    $1\n";
#     }
#     else {
# 	  print
# 	      gettext("    Good signature, but name not present in pgp's stderr\n");
#     }
    print $err;

    @spec = map { split /\n/ } $out =~ /^Files:\s*\n((?:[\040\t]+.*\n)+)/mg;
    unless (@spec) {
	xwarn sprintf(gettext("no file spec lines in %s\n"),$file);
	return;
    }

    my $md5o = MD5->new or xdie gettext("can't initialize MD5\n");
    for (@spec) {
	unless (/^\s+(\S+)\s+(\d+)\s+(?:\S+\s+\S+\s+)?(\S+)\s*$/) {
	    xwarn sprintf(gettext("invalid file spec in %s `%s'\n"),$file,$_);
	    next;
	}
	my ($md5, $size, $file) = ($1, $2, $3);

	unless (open FILE, $file) {
	    if ($! == ENOENT()) {
		print sprintf(gettext("   skipping   %s\n"),$file);
	    }
	    else {
		xwarn sprintf(gettext("can't read %s:"),$file);
	    }
	    next;
	}

	$any = 1;
	print sprintf(gettext("   validating %s\n"),$file);

	# size
	my $this_size = -s FILE;
	unless (defined $this_size) {
	    xwarn sprintf(gettext("can't fstat %s:"),$file);
	    next;
	}
	unless ($this_size == $size) {
	    xwarn sprintf(gettext(
			"invalid file length for %s (wanted %d got %d)\n"),
			  $file,$size,$this_size);
	    next;
	}

	# MD5
	$md5o->reset;
	$md5o->addfile(*FILE);
	my $this_md5 = $md5o->hexdigest;
	unless ($this_md5 eq $md5) {
	    xwarn sprintf(gettext("MD5 mismatch for %s (wanted %s got %s)\n"),
			 $file,$md5,$this_md5);
	    next;
	}
    }

    $any or
	xwarn sprintf(gettext("%s didn't specify any files present locally\n"),
		      $file);
}

sub main {
    my @rings = get_rings;

    @ARGV or xdie gettext("no .changes or .dsc files specified\n");
    for my $file (@ARGV) {
	process_file $file, @rings;
    }

    return 0;
}

$Exit = main || $Exit;
$Exit = 1 if $Exit and not $Exit % 256;
exit $Exit;