#!/usr/bin/perl -W
#
# dpkg-sig signs deb-files in a standard way
#
# (c) Andreas Barth <aba@not.so.argh.org> 2003
# (c) Marc Brockschmidt <marc@dch-faq.de> 2004
#
#    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.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#    Upstream web site is http://dpkg-sig.turmzimmer.net/

use strict;
use Getopt::Long;
use Data::Dumper;
use ConfigFile qw(read_config_file);
use IPC::Open2;
use Digest::MD5 qw(md5_hex);
use File::Temp qw(tempdir);
use File::Copy qw(move);
use File::Basename qw(dirname basename);
use Fcntl qw(:flock);
$| = 1;

my ($sign, $list, $verify, $verify_role, $verify_exact, $client, $cache_pass, $pass_file, $key, $maintainer, $maintainer_pr, $verbose, %config, $tempdir, %part_cache, $check_v2_sig, $batch, $gpgoptions, $passphrase, $remote_dpkg_sig, %ssh_connections, %md5sum_cache, $sign_changes, $get_hashes, $sign_hashes, $write_signature, $DEBUG);

my @configfiles = qw(/etc/devscripts.conf ~/.devscripts);

exit 1 unless GetOptions("sign|s=s" => \$sign,
                         "list|l|t" => \$list,
                         "verify|check|c" => \$verify,
                         "verify-role=s" => \$verify_role,
                         "verify-exact=s" => \$verify_exact,
                         "get-hashes|h=s" => \$get_hashes,
                         "sign-hashes|d" => \$sign_hashes,
                         "write-signature|w" => \$write_signature,
                         "client" => \$client,
                         #Options:
                         "default-key|k=s" => \$key,
                         "cache-passphrase|p" => \$cache_pass,
                         "passphrase-file|f=s" => \$pass_file,
                         "m=s" => \$maintainer,
                         "e=s" => \$maintainer_pr,
                         "debug+" => \$DEBUG,
                         "verbose|v+" => \$verbose,
                         "also-v2-sig" => \$check_v2_sig,
                         "sign-changes:s" => \$sign_changes,
                         "batch" => \$batch,
                         "gpg-options|g=s" => \$gpgoptions,
                         "remote-dpkg-sig|r=s" => \$remote_dpkg_sig,
                        );
$check_v2_sig = ($check_v2_sig && $check_v2_sig eq "false"?0:"yes");

$DEBUG = ($DEBUG?"--debug":"");

die _die('Please use only one of --sign, --list, --verify[-role|-exact], --get-hashes, --write-signature and --client!')
  if (! !$sign + ! !$list + ! !$verify + ! !$verify_role + ! !$verify_exact + ! !$client + ! !$get_hashes + ! !$sign_hashes + ! !$write_signature > 1);

$maintainer_pr && ($maintainer = $maintainer_pr);
if (!$sign && !$list && !$verify && !$verify_role && !$verify_exact && !$client && !$get_hashes && !$sign_hashes && !$write_signature) {
	$verify = 1;
	print "No action requested, verifying files.\n";
}

foreach my $configfile (@configfiles) {
	($configfile) = glob($configfile); #Expand ~ and stuff like that

	if ($configfile && -r $configfile) {
		%config = %{read_config_file($configfile) || {}};
	}
}

($maintainer = ($config{'DEBSIGN_MAINT'} || "")) =~ s/^"(.+)"$/$1/ if ! $maintainer;
($key        = ($config{'DPKGSIG_KEYID'} || $config{'DEBSIGN_KEYID'} || "")) =~ s/^"(.+)"$/$1/ if ! $key;
($cache_pass = ($config{'DPKGSIG_CACHE_PASS'} || "")) =~ s/^"(.+)"$/$1/ if ! $cache_pass;
($sign_changes=($config{'DPKGSIG_SIGN_CHANGES'} ||""))=~ s/^"(.+)"$/$1/ if ! $sign_changes;

$remote_dpkg_sig ||= "dpkg-sig";

my @files = @ARGV;

if (! $sign_changes) {
	$sign_changes = "auto";
} elsif (! grep {$sign_changes eq $_} qw(no auto yes full force_full)) {
	if ($sign_changes =~ /(?:deb|changes)$/) {
		push @files, $sign_changes;
		$sign_changes = "yes";		
	} else {
		print "W: Unrecognized argument to --sign-changes, using \"auto\": $sign_changes\n";
		$sign_changes = "auto";		
	}
}

if ($sign_hashes || $write_signature) {
	for (@files) {
		unless (/\.dpkg-sig-hashes$/) {
			die _die("$_: Make sure all files were generated by dpkg-sig --get-hashes file\n");
		}
	}
	
	for my $file (@files) {
		if ($sign_hashes) {
			print "Processing $file...\n";
			sign_hashes($file);
			print "Signed hashes in $file...\n";
		} else {
			print "Processing $file...\n";		
			my @done = write_signature($file);
			print "Added signature to $_\n" for (@done);
		}
	}
	exit;
}

if ($client) {
	print "Welcome. This is dpkg-sig in client mode. Protocol version 5\n";
	&read_cmds();
	exit;
}

if (grep { ! /(?:deb|changes)$/ } @files) {
	die _die("We can only work on debs and changes files.");
}

if ($sign) {
	#Check given sig name:
	if (length($sign) > 9 || $sign !~ /^[a-z]+$/) {
		die _die("The signing name '$sign' is too long.");
	}

	if ($cache_pass && ! $pass_file) {
		eval { require Term::ReadKey; };
		if ($@) {
			print STDERR "Couldn't load Term::ReadKey. Please install. Passphrase caching disabled.\n";
		} else {
			print "The passphrase for ".($key || "your default key").": ";
			Term::ReadKey::ReadMode("noecho");
			chomp($passphrase = Term::ReadKey::ReadLine(0));
			Term::ReadKey::ReadMode("restore");
			print "\n";
		}
	}
}

my $ver_re;
if ($verify_role) {
	$ver_re = "^_gpg".$verify_role."[0-9A-Z]?\$";
} elsif ($verify_exact) {
	$ver_re = "^_gpg$verify_exact";
} else {
	$ver_re = "^_gpg.+";
}

for my $exp (@files) {
	for my $file (glob_exp($exp)) {
		if ($file =~ /\.deb$/) { #Yay! That's easy!
			print "Processing $file...\n";
			if ($sign) {
				sign_deb($sign, $file);
				print "Signed deb $file\n" if ! $batch;
			} elsif ($verify || $verify_role || $verify_exact) {
				print verify_deb($file, $ver_re);
			} elsif ($list) {
				for (@{get_md5sums($file)}) {
					print "$1\n" if ($_->[1] =~ /_gpg(.+)/);
				}
			} elsif ($get_hashes) {
				write_hashes($get_hashes, $file);
				unlink "$file.dpkg-sig-hashes";
				add_part_to_ar_archive ("$file.dpkg-sig-hashes", "deb\n$get_hashes\n$file ".get_file_md5sum($file)."\n" , "control");
				add_part_to_ar_archive ("$file.dpkg-sig-hashes", _read_file("$tempdir/md5sum"), "deb0");
			}
			
		} else {
			print "--- Processing changes file $file:\n";
			my $changes_signed = 0;
			my (%new_debs, $sums_control_data, @deb_md5sums);

			if ($get_hashes) {
				unlink "$file.dpkg-sig-hashes";
				$sums_control_data = "changes $file\n$get_hashes\n";
			}

			for my $deb (get_debs_from_changes($file, \$changes_signed)) {
				print "Processing $deb...\n";
				
				if ($sign) {
					my $r = sign_deb($sign, $deb);
					$new_debs{$r->[2]} = $r;
					print "Signed deb $deb\n" if ! $batch;
				} elsif ($verify || $verify_role || $verify_exact) {
					print verify_deb($deb, $ver_re);
				} elsif ($list) {
					for (@{get_md5sums($deb)}) {
						print "$1\n" if ($_->[1] =~ /_gpg(.+)/);
					}
				} elsif ($get_hashes) {
					$sums_control_data .= $deb." ".get_file_md5sum($deb)."\n";
					write_hashes($get_hashes, $deb);
					push @deb_md5sums, _read_file("$tempdir/md5sum");
				}
			}

			if ($sign) {
				correct_changes_file($file, \%new_debs);
				sign_control_files($file) if ($sign_changes ne "no" && ! ($sign_changes eq "auto" && ! $changes_signed));
			} elsif ($get_hashes) {
				add_part_to_ar_archive ("$file.dpkg-sig-hashes", $sums_control_data , "control");
				for (my $i=0; $i<@deb_md5sums; $i++) {
					add_part_to_ar_archive ("$file.dpkg-sig-hashes", $deb_md5sums[$i], "deb$i");
				}				
			}
		}
	}
}

for (values %ssh_connections) {
	my ($pid, $readerfh, $writerfh) = @$_;
	print $writerfh "quit\n";

	sleep 1;
	kill $pid;
}

exit;

sub sign_deb {
	my ($sig_name, $deb) = @_;

	#Check the existing signatures:
	my @verify = verify_deb($deb, "^_gpg.+");
	if (grep { /^BADSIG/ } @verify) {
		_die("Can't sign $deb, some signatures are invalid:\n".(join "", grep { /^BADSIG/ } @verify));
	}

	#This also chooses the right sig name:
	$sig_name = write_hashes($sig_name, $deb);

	sign_file ("$tempdir/md5sum", "$tempdir/md5sum.asc");

	#Read sig:
	my $sig = _read_file ($tempdir."/md5sum.asc");

	return add_sig_to_deb($deb, $sig, $sig_name);
}

sub write_hashes {
	my ($sig_name, $deb) = @_;

	#Get MD5 sums:
	my $md5sums = get_md5sums($deb);

	#Get name for our new signature part of the archive
	$sig_name = get_sig_name($sig_name, $md5sums, $deb);

	#Create md5sums file
	write_tmp_md5sums($sig_name, $md5sums);

	return $sig_name
}

sub sign_hashes {
	my ($file) = @_;

	if ($tempdir) {
		unlink ($tempdir."/md5sum");			
		unlink ($tempdir."/md5sum.asc");
		unlink ($tempdir."/hashes.signed");
	} else {
		$tempdir = tempdir("debsigs-ng.XXXXXX",
		    CLEANUP => 1, TMPDIR => 1);
	}

	#We don't need the control data, we just want to check if this is real
	#dpkg-sig generated hashes archiv:
	my $control = get_archive_part($file, "control");
	if ($control !~ /^(deb|changes)/) {
		die _die("$file seems not to be a dpkg-sig hash archive");
	}

	add_part_to_ar_archive($tempdir."/hashes.signed", $control, "control");

	#Now sign all hashes:
	my $num = 0;
	for (@{get_md5sums($file)}) {
		my $part_name = $_->[1];
		if ($part_name !~ /^(deb\d+|control)$/) {
			print STDERR "W: $file contains $part_name, which shouldn't happen in dpkg-sig hash archive\n";
		} elsif ($part_name =~ /^deb\d+/) {
			my $data = get_archive_part($file, $part_name);
			
			if ($data =~ /^-----BEGIN PGP SIGNATURE-----/) {
				die _die("$file seems to be already signed!\n");
			}

			_write_file($tempdir."/md5sum", $data);
			sign_file("$tempdir/md5sum", "$tempdir/md5sum.asc");
			my $s_data = _read_file($tempdir."/md5sum.asc");

			add_part_to_ar_archive($tempdir."/hashes.signed", $s_data, "deb".$num++);
		}
	}

	move($tempdir."/hashes.signed", $file);
}

sub write_signature {
	my ($file) = @_;
	my @done;

	if ($tempdir) {
		unlink ($tempdir."/md5sum");			
		unlink ($tempdir."/md5sum.asc");
		unlink ($tempdir."/hashes.signed");
	} else {
		$tempdir = tempdir("debsigs-ng.XXXXXX",
		    CLEANUP => 1, TMPDIR => 1);
	}

	#Get control data:
	my @control = split (/\n/, get_archive_part($file, "control"));
	if ($control[0] !~ /^(deb|changes)/) {
		die _die("$file seems not to be a dpkg-sig hash archive");
	}
	chomp(my $sig_name = $control[1]);

	my ($num, %new_debs) = (0);
	for (@{get_md5sums($file)}) {	
		my $part_name = $_->[1];
		if ($part_name !~ /^(deb\d+|control)$/) {
			print STDERR "W: $file contains $part_name, which shouldn't happen in dpkg-sig hash archive\n";
		} elsif ($part_name =~ /^deb\d+/) {
			my $sig = get_archive_part($file, $part_name);

			if ($sig !~ /^-----BEGIN PGP SIGNATURE-----/) {
				die _die("$file seems to be unsigned!\n");
			}

			#deb$num is the detached sig for the deb named in control line $num + 1
			#Get the name and the md5sum:
			my ($name, $md5sum) = split / /, $control[$num + 2];

			my $path;
			
			#Try to find the deb in this dir:
			if (file_readable(basename($name)) && get_file_md5sum(basename($name)) eq $md5sum) {
				$path = basename($name);
			#Now try the path in the hashes file:
			} elsif (file_readable($name) && get_file_md5sum($name) eq $md5sum) {
				$path = $name;
			#Wrong md5sum
			} elsif (! (get_file_md5sum(basename($name)) eq $md5sum || get_file_md5sum($name) eq $md5sum)) {
				die _die("The md5sum for $name is wrong. Please use an archive of signed hashes of the version of the file existing now.");
			#We don't find the damn file!
			} else {
				die _die("Can't find $name. Please start dpkg-sig either in the dir with the debs to sign or in the dir where you got the hashes.");
			}

			push @done, $path;

			$sig_name = get_sig_name($sig_name, get_md5sums($path), $path);
			my $r = add_sig_to_deb($path, $sig, $sig_name);
			$new_debs{$r->[2]} = $r;

			$num++;
		}
	}

	if ($control[0] =~ /^changes (.+)$/) {
		if (file_readable(basename($1))) {
			correct_changes_file(basename($1), \%new_debs);
			print "Corrected chanfes file ".basename($1)."\n";
		} elsif (file_readable($1)) {
			correct_changes_file($1, \%new_debs);
			print "Corrected chanfes file $1\n";			
		} else {
			print STDERR "Can't find changes file $1, so won't correct it.\n";
		}
	}

	return @done;
}

sub verify_deb {
	my ($deb, $ver_re) = @_;
	my @return;

	#Get MD5 sums:
	my $md5sums = get_md5sums($deb);

	for (my $n=0;$n<@$md5sums;$n++) {
		my ($md5sum, $part_name) = @{@$md5sums[$n]};
		next if $part_name !~ /$ver_re/;
		
		if ($tempdir) {
			unlink ($tempdir."/md5sum.asc");
			unlink ($tempdir."/md5sums");
		} else {
			$tempdir = tempdir("debsigs-ng.XXXXXX",
			    CLEANUP => 1, TMPDIR => 1);
		}

		open (FH, ">", $tempdir."/md5sums") || die _die("Couldn't open $tempdir/md5sums: $!");
		$part_name =~ /^_gpg(\S+?)[A-Z0-9]?$/ && print FH $1, "\n";
		print FH join "\n", map { $_->[0] . "  " . $_->[1] } @$md5sums[0..$n-1];
		print FH "\n";
		close FH;

		my $sig = get_archive_part($deb, $part_name);

		open (FH, ">", $tempdir."/md5sum.asc") || die _die("Couldn't open $tempdir/md5sum.asc: $!");
		print FH $sig;
		close FH;

		my @cmdline = ("gpg", "--openpgp", "--verify");
		push (@cmdline, "--no-auto-check-trustdb");
		push (@cmdline, "--batch", "--no-tty");
		push (@cmdline, "--status-fd", "1");
		push (@cmdline, "2>&1");
		push (@cmdline, "$tempdir/md5sum.asc", "$tempdir/md5sums");
		my $res=qx/@cmdline/;
		#	print "Verifying $n (".($? ? "failure" : "good signature").")\n";

		$part_name =~ s/^_gpg(\S+?)[A-Z0-9]?$/$1/;

		my @info = split(/ /, $1 ) if $res =~ /^\[GNUPG:\] VALIDSIG (.*)$/m;
		$res =~ /^\[GNUPG:\] (GOOD|BAD)/m;
		my $status = $1;

		if ($check_v2_sig && $status eq "BAD") {
			push @return, "$part_name: Invalid v3 sig ... Trying v2\n" if $verbose;
			open (FH, ">", $tempdir."/md5sums") || die _die("Couldn't open $tempdir/md5sums: $!");
			print FH join "\n", map { $_->[0] . "  " . $_->[1] } @$md5sums[0..$n-1];
			print FH "\n";
			close FH;

			$res= qx/@cmdline/;
			@info = split(/ /, $1 ) if $res =~ /^\[GNUPG:\] VALIDSIG (.*)$/m;
			$res =~ /^\[GNUPG:\] (GOOD|BAD)/m;
			$status = $1;
		}

		if ($status eq "GOOD") {
			push @return, "GOODSIG $part_name $info[0] $info[2]\n";
		} else {
			push @return, "BADSIG $part_name\n";
		}
	}

	return @return;
}

sub write_tmp_md5sums {
	my ($sig_name, $md5sums) = @_;
	
	if ($tempdir) {
		unlink ($tempdir."/md5sum.asc");
	} else {
		$tempdir = tempdir("debsigs-ng.XXXXXX",
		    CLEANUP => 1, TMPDIR => 1);
	}

	my $data  = "$1\n" if $sig_name =~ /^_gpg(\S+?)[A-Z0-9]?$/;
	   $data .= $_->[0]. "  ". $_->[1] . "\n" for (@$md5sums);

	_write_file("$tempdir/md5sum", $data);
}

sub get_sig_name {
	my ($sig_name, $md5sums, $deb) = @_;

	$sig_name = "_gpg".$sig_name;
	if (grep { $_->[1] eq $sig_name } @$md5sums) {
		my $changed = 0;
		for my $ext (0..9, "A" .. "Z") {
			if (! grep { $_->[1] eq $sig_name.$ext} @$md5sums) {
				$sig_name .= $ext;
				++$changed;
				last;
			}
		}
		die _die("$deb: Couldn't get a name for the signature part") if ! $changed;
	}

	return $sig_name;
}

sub correct_changes_file {
	my ($changes, $new_debs) = @_;

	if ($changes =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($changes);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		print $writerfh "correct_changes_file $file\n";
		
		my ($response, $t);
		$response = '';
		do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
		chomp($response);

		if ($response =~ /^300 /) {
			for (keys %$new_debs) {
				print $writerfh join (" ", @{$new_debs->{$_}}), "\n";
			}
			print $writerfh ".\n";
			
			$response = '';
			do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
			chomp($response);

			if ($response !~ /^200 /) {
				die _die("remote dpkg-sig on $host returned \"$response\"");
			}
		} else {
			die _die("remote dpkg-sig on $host seems to be weird. Can't parse \"$response\"");
		}
	} else {
		my ($new_changes, $in_files) = ('', 0);
		open (CHANGES, "+<", $changes) || die _die("$changes: Can't open file: $!");
		while (<CHANGES>) {
			if (/^-----BEGIN PGP SIGNED MESSAGE-----$/) { while (<CHANGES>) { last if /^\s*$/ }; next }

			if ($in_files) {
				chomp;				
				last if ! s/^ //;
				my ($md5sum, $size, $section, $priority, $file_name) = split / /, $_;
				if ($new_debs->{$file_name}) {
					$md5sum = $new_debs->{$file_name}->[0];
					$size   = $new_debs->{$file_name}->[1];
					chomp($md5sum);
				}
				$new_changes .= " " . join (" ", ($md5sum, $size, $section, $priority, $file_name)). "\n";
			} else {
				$new_changes .= $_;
			}

			$in_files = "yes" if /^Files:/;
		}
		
		seek(CHANGES, 0, 0)   || die _die("$changes: Can't rewind file: $!");
		truncate(CHANGES, 0)  || die _die("$changes: Can't truncate file: $!");

		print CHANGES $new_changes;
		close CHANGES;
	}
}

#add_part_to_ar_archive and add_sig_to_deb are the same:
sub add_part_to_ar_archive {
	return add_sig_to_deb(@_);
}

sub add_sig_to_deb {
	my ($deb, $sig, $sig_name) = @_;
	my ($new_md5sum, $new_file_size);

	if ($deb =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($deb);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		print $writerfh "add_sig_to_deb $sig_name $file\n";

		my ($response, $t);
		$response = '';
		do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
		chomp($response);

		if ($response =~ /^300 /) {
			for (split /\n/, $sig) {
				s/^\./../g;
				print $writerfh $_, "\n";
			}
			print $writerfh ".\n";
			
			$response = '';
			do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
			chomp($response);

			if ($response !~ /^200 /) {
				die _die("remote dpkg-sig on $host returned \"$response\"");
			} else {
				
				$response = '';
				do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
				chomp($response);
				($new_md5sum, $new_file_size) = split (/ /, $response);
			}
		} else {
			die _die("remote dpkg-sig on $host seems to be weird. Can't parse \"$response\"");
		}

	} else {
		die _die("$deb: Arch member name $sig_name too long!") if (length($sig_name) > 14);

		my $new_part = sprintf("%-16s%-12s%-6s%-6s%-8s%-10s`\n%s",
		   $sig_name, time, 0, 0, 100644, length($sig), $sig . (length($sig)%2 ? "\n":""));

		if (!stat($deb)) {
			open (DEB, ">", (glob $deb)[0]) || die _die("Couldn't open ".(glob $deb)[0].": $!");
			print DEB "!<arch>\n";
		} else {
			open (DEB, ">>", (glob $deb)[0]) || die _die("Couldn't open ".(glob $deb)[0].": $!");
		}

		print DEB $new_part || die _die("Couldn write to $deb: $!");
		close DEB;

		$new_md5sum = get_file_md5sum($deb);

		$new_file_size = (stat($deb))[7];
	}

	return [$new_md5sum, $new_file_size, basename($deb)];
}

sub get_debs_from_changes {
	my ($changes, $changes_signed) = @_;
	my $changes_path = dirname($changes);
	my @debs;

	if ($changes =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($changes);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		print $writerfh "get_debs_from_changes $file\n";
		my $response = <$readerfh>;	
		if ($response !~ /^200 /) {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		} else {
			$$changes_signed = "yes" if $response =~ /^200 ok debs in signed/;	
			while (<$readerfh>) {
				last if (/^\.$/);
				s/^\.\././;
				chomp;
				push @debs, "ssh://$user\@$host:$_";
			}
		}
	} else {
		open (CHANGES, "<", $changes) || die _die("$changes: Can't open file: $!");
		while (<CHANGES>) { 
			$$changes_signed = "yes" if /-----BEGIN PGP SIGNED MESSAGE-----/;
			last if /^Files:/
		}

		while (<CHANGES>) {
			chomp;
			if (/^ [^ ]+ \d+ [^ ]+ [^ ]+ (.+)$/) {
				push @debs, $changes_path."/".$1 if $1 =~ /^(.+\.deb)$/;
			} elsif (/^\s*$/) {
				last;
			} else {
				print STDERR "$changes corrupted\n";
			}
		}
		close CHANGES;
	}

	return @debs;
}

sub get_md5sums {
	my $deb = shift;
	my @md5sums;

	if ($md5sum_cache{$deb}) {
		return $md5sum_cache{$deb};
	}
	
	if ($deb =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($deb);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		print $writerfh "get_md5sums $file\n";

		my $response = <$readerfh>;
		if ($response !~ /^200 /) {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		} else {
			while (<$readerfh>) {
				last if (/^\.$/);
				s/^\.\././;
				chomp;
				my ($md5sum, $part) = split / /, $_;
				push @md5sums, [$md5sum, $part];
			}
		}
	} else {
        open(DEB, "<", (glob $deb)[0]) || die _die("Couldn't open $deb: $!");
		
		if (read(DEB, $_, 8) != 8) {
			die _die("Couldn't open $deb: ar format b0rken [Couldn't read first 8 bytes]");
		} elsif ($_ ne "!<arch>\n") {
			die _die("Couldn't open $deb: ar format b0rken");
		}

		do {
			my $line = <DEB>;
			if ($line =~ /\S/) { #This should help with additional newlines
				#debian-binary   1075243548  0     0     100644  4         `
				my $name   = substr($line, 0, 16);
				$name =~ s/\s*//g;
				my $length = substr($line, 48, 10);
				$length =~ s/\s*//g;
				next if (!$name && $length && $length =~ /^\d+\s*$/);
			
				my $part;
				if (read (DEB, $part, $length) != $length) {
					die _die("Couldn't read $name in $deb: File too short!");
				}
				if ($length % 2 && read (DEB, $_, 1) != 1) {
					die _die("Couldn't read $name in $deb: File too short!");			
				}

				push @md5sums, [md5_hex($part), $name];
			}
		} while (!eof(DEB));

		close DEB;
	}

	$md5sum_cache{$deb} = \@md5sums;

	return \@md5sums;
}

sub get_file_md5sum {
	my $file = shift;
	my $md5sum;

	if ($file =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($file);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		if ($prot_version < 5) {
			die _die("remote dpkg-sig on $host is too old and can't return the needed md5sum of a file.");
		}

		print $writerfh "get_file_md5sum $file\n";

		my ($response, $t);
		$response = '';
		do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
		chomp($response);

		if ($response =~ /^200 ok md5sum is (\S+)/) {
			$md5sum = $1;
		} else {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		}
	} else {
		chomp ($md5sum = `md5sum $file | cut -d " " -f 1`);
	}

	return $md5sum;
}


sub get_archive_part {
	my ($deb, $part_name) = @_;
	my $part = '';

	if ($deb =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($deb);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		print $writerfh "get_archive_part $part_name $file\n";
		my $response = <$readerfh>;
		if ($response !~ /^200 /) {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		} else {
			while (<$readerfh>) {
				last if (/^\.$/);
				s/^\.\././;
				chomp;
				$part .= "$_\n";
			}
		}
	} else {
		open(DEB, "<", $deb) || die _die("Couldn't open $deb: $!");
		
		if (read(DEB, $_, 8) != 8) {
			die _die("Couldn't open $deb: ar format b0rken [Couldn't read first 8 bytes]");
		} elsif ($_ ne "!<arch>\n") {
			die _die("Couldn't open $deb: ar format b0rken");
		}

		while (!eof(DEB)) {
			my $line = <DEB>;
			#debian-binary   1075243548  0     0     100644  4         `
			my $name   = substr($line, 0, 16);
			my $length = substr($line, 48, 10);
			next if (!$name && $length && $length =~ /^\d+\s*$/);
			
			my $tmp_part;
			if (read (DEB, $tmp_part, $length) != $length) {
				die _die("Couldn't read $name in $deb: File too short!");
			}
			if ($length % 2 && read (DEB, $_, 1) != 1) {
				die _die("Couldn't read $name in $deb: File too short!");			
			}

			if ($name =~ /^$part_name\s*$/) {
				$part = $tmp_part;
				last;
			}
		}

		close DEB;
	}

	return $part;
}

sub read_control_file {
	my $file = shift;
	my @r;

	die _die("This only returns debian control files (ending with .changes or dsc)") if $file !~ /\.(?:dsc|changes)$/;

	if ($file =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($file);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		if ($prot_version < 3) {
			die _die("remote dpkg-sig on $host is too old and can't return the needed control file data.");
		}

		print $writerfh "read_control_file $file\n";

		my $response = <$readerfh>;
		if ($response !~ /^200 /) {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		} else {
			while (<$readerfh>) {
				last if (/^\.$/);
				s/^\.\././;
				push @r, $_;
			}
		}
	
	} else {
		open (FH, $file) or die _die("Can't open $file: $!");
		@r = <FH>;
		close FH;
	}

	return @r;
}

sub write_control_file {
	my ($file, @data) = @_;
	my ($response, $t, $new_md5sum, $new_file_size);

	die _die("This only writes debian control files (ending with .changes or dsc)") if $file !~ /\.(?:dsc|changes)$/;

	if ($file =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($file);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		if ($prot_version < 3) {
			die _die("remote dpkg-sig on $host is too old and can't return the needed control file data.");
		}

		print $writerfh "write_control_file $file\n";

		$response = '';
		do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
		chomp($response);
		
		if ($response =~ /^300 /) {
			print $writerfh @data;
			print $writerfh ".\n";

			$response = '';
			do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
			chomp($response);

			if ($response =~ /^200 .+New md5sum, size: ([^ ]+) (\d+)/) {
				$new_md5sum = $1;
				$new_file_size = $2;
			} else {
				die _die("remote dpkg-sig on $host returned \"$response\"");
			}
		} else {
			die _die("remote dpkg-sig on $host seems to be weird. Can't parse \"$response\"");
		}	
	} else {
		open (FH, ">", $file) or die _die("Can't open $file: $!");
		print FH @data;
		close FH;

		chomp ($new_md5sum = `md5sum $file | cut -d " " -f 1`);
		$new_file_size = (stat($file))[7];
	}

	return ($new_md5sum, $new_file_size);
}


sub glob_exp {
	my $exp = shift;
	my @files;
	
	if ($exp =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($exp);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);

		print $writerfh "glob_exp $file\n";
		my $response = <$readerfh>;
		if ($response !~ /^200 /) {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		} else {
			while (<$readerfh>) {
				last if (/^\.$/);
				s/^\.\././;
				chomp;
				push @files, "ssh://$user\@$host:$_";
			}
		}
	} else {
		push @files, glob($exp);
	}

	return @files;
}

sub file_readable {
	my $file = shift;

	if ($file =~ m!^ssh://!) {
		my ($user, $host, $file) = split_ssh_uri($file);
		my ($readerfh, $writerfh, $prot_version) = get_ssh_connection($user, $host);


		if ($prot_version < 4) {
			print "W: remote dpkg-sig on $host is too old and can't return the needed data. .dsc not signed";
			return 0;
		}

		print $writerfh "file_readable $file\n";

		my ($response, $t);
		$response = '';
		do { read($readerfh, $t, 1); $response .= $t } while ($t ne "\n");
		chomp($response);

		if ($response =~ /^200 /) {
			return 1;
		} elsif ($response =~ /^400 /) {
			return 0;
		} else {
			die _die("remote dpkg-sig on $host returned \"$response\"");
		}
	} else {
		return -r $file;
	}
}

sub split_ssh_uri {
	my ($uri) = @_;

	my ($user, $host, $path);
	
	#ssh://$USER@$HOST:$PATH

	if ($uri =~ m!^ssh://(?:([^@\s]+)@)?(\S+):(.+)!) {
		($user, $host, $path) = ($1, $2, $3);
		
		$user ||= $ENV{'USER'};
		die _die("$uri: Please specify at least a host to connect to.") if !$host;
		die _die("$uri: Please specify a path on the remote host.") if !$path;	
	} else {
		die _die("$uri is no ssh uri!");
	}

	return ($user, $host, $path);
}

sub get_ssh_connection {
	my ($user, $host) = @_;
	if (!$ssh_connections{"$user\@$host"}) {
		my ($readerfh, $writerfh);
		die _die("No ssh installed, we need it to connect to the remote host.") if (not `which ssh`);
		my $pid = open2($readerfh, $writerfh, qq{ssh $user\@$host '$remote_dpkg_sig --client $DEBUG || echo "No dpkg-sig available"' 2>/dev/null});
		my $response = <$readerfh>;
		if ($response =~ /No dpkg-sig available/) {
			die _die("No $remote_dpkg_sig on remote host installed.");
		} elsif ($response !~ /protocol version (\d+)$/i || $1 < 2) {
			die _die("dpkg-sig on $host is too old (we need protocol version 2)");
		}
		$ssh_connections{"$user\@$host"} = [$pid, $readerfh, $writerfh, $1];
	}

	return ($ssh_connections{"$user\@$host"}->[1], $ssh_connections{"$user\@$host"}->[2], $ssh_connections{"$user\@$host"}->[3]);
}

sub sign_control_files {
	my $file = shift;
	my $sign_dsc = $sign_changes =~ /full$/ ? 1 : 0;
	my ($dsc, $new_dsc_md5sum, $new_dsc_size);
	    $dsc = "$1.dsc" if ($file =~ /^(.+)_[^ _]+.changes/ && file_readable("$1.dsc"));

	#Clean the tempdir:
	if ($tempdir) {
		unlink ($tempdir."/dsc.unsigned");
		unlink ($tempdir."/dsc.signed");
		unlink ($tempdir."/changes.unsigned");
		unlink ($tempdir."/changes.signed");
	} else {
		$tempdir = tempdir("debsigs-ng.XXXXXX",
		    CLEANUP => 1, TMPDIR => 1);
	}

	if ($sign_dsc && $dsc) {
		open (DSC, ">", $tempdir."/dsc.unsigned") || die _die("Can't open $tempdir/dsc.unsigned: $!");
		my @data = read_control_file($dsc);
		for (my $i=0;$i<@data;$i++) {
			if ($data[$i] =~ /^-----BEGIN PGP SIGNED MESSAGE-----$/) {
				if ($sign_changes eq "force_full") { 
					$sign_dsc = 1;
				} elsif (! $batch) {
					print "The .dsc file is already signed.\nWould you like to use the current signature? [Yn] ";
					chomp(my $answer = lc(<STDIN>));
					$sign_dsc = 0 unless ($answer eq "n" || $answer eq "no");
				} else {
					$sign_dsc = 0;
				}
				while(defined $data[$i]) { last if $data[$i++] =~ /^\s*$/ }
			} elsif ($data[$i] =~ /^\s*$/) {
				last;
			}
			print DSC $data[$i];
		}
		print DSC "\n";
		close DSC;

		if ($sign_dsc) {
			#Sign it:
			sign_file($tempdir."/dsc.unsigned",$tempdir."/dsc.signed", "no_detach") if $sign_dsc;

			#Read and write them to the fitting location:
			open (DSC, $tempdir."/dsc.signed") || die _die("Can't open $tempdir/dsc.signed: $!");
			@data = <DSC>;
			close DSC;
			($new_dsc_md5sum, $new_dsc_size) = write_control_file($dsc, @data);
			print "Signed .dsc $dsc\n" unless $batch;
		}
	}
	
	#Now the changes file:
	open (CHANGES, ">", $tempdir."/changes.unsigned") || die _die("Can't open $tempdir/changes.unsigned: $!");
	my $basename_dsc = basename($dsc) if $dsc;
	for (read_control_file($file), "\n") {
		#If we've changed the .dsc file, we have to use the new values in the .changes:
		if ($basename_dsc && $new_dsc_md5sum && $new_dsc_size && $_ =~ /\Q$basename_dsc\E$/) {
			 s/^ [^ ]+ \d+ (.+)$/ $new_dsc_md5sum $new_dsc_size $1/;
		}
		print CHANGES $_;
	}
	close CHANGES;

	sign_file($tempdir."/changes.unsigned",$tempdir."/changes.signed", "no_detach");
	
	my @data;
	open (CHANGES, $tempdir."/changes.signed") || die _die("Can't open $tempdir/changes.signed: $!");
	@data = <CHANGES>;
	close CHANGES;
	write_control_file($file, @data);
	print "Signed .changes $file\n" unless $batch;	
}


sub sign_file {
	my ($in_file, $out_file, $no_detach) = @_;

	my @cmdline = ("gpg", "--openpgp", "--armor", "--output", $out_file);
	if ($no_detach) {
		push @cmdline, "--clearsign";
	} else {
		push @cmdline, "--detach-sign";
	}

	if ($key) {
		push (@cmdline, "--default-key", $key);
		print "Default key: $key\n" if $verbose;
	} elsif ($maintainer) {
		push (@cmdline, "--default-key", $maintainer);
	}

	if ($pass_file) {
		push (@cmdline, "--no-tty", "--batch", "--passphrase-fd", "42", "42<$pass_file");
		print "Using passphrase from $pass_file\n" if $verbose;
	} elsif ($passphrase) {
		push (@cmdline, "--no-tty", "--batch", "--passphrase-fd", "0");
		print "Using cached passphrase\n" if $verbose;
	}

	push (@cmdline, $gpgoptions) if $gpgoptions;

	print "Signing $in_file with key ".($key || "of $maintainer")."\n" if $verbose;		
	push (@cmdline, $in_file);
	open (GPG, "| ".join " ", @cmdline) || die _die("Signing failed: $!");
	print GPG $passphrase, "\n" if $passphrase;
	close GPG;
	die _die("Signing failed. Error code: $?") if $?;
}

sub read_cmds {
	$DEBUG && (open (LOG, ">", "/tmp/dpkg-sig.log") || die _die("Couldn't open log: $!"));
	$DEBUG && select LOG; $|=1; 
	$DEBUG && select STDOUT;
	
	sub send { print STDOUT @_; $DEBUG && print LOG "Sent: ", @_; }
	sub read { $_ = <STDIN>; $DEBUG && print LOG "Received: ", $_; return $_ } ;

	while ($_ = &read()) {
		chomp;

		if (/^get_md5sums (.+)$/) {
			my $r = eval { get_md5sums ($1) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send ("500 error: $@\n");
			} else {
				&send("200 ok md5sums for $1 follow\n");
				&send($_->[0], " ", $_->[1], "\n") for @$r;
				&send(".\n");
			}

		} elsif (/^get_archive_part ([^ ]+) (.+)$/) {
			my $r = eval { get_archive_part ($2, $1) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: $@\n");
			} else {
				&send("200 ok part $1 of $2 follows\n");
				for (split (/\n/, $r)) {
					s/^\./../;
					&send("$_\n");
				}
				&send(".\n");
			}

		} elsif (/^read_control_file (.+)$/) {
			my @r = eval { read_control_file ($1) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: $@\n");
			} else {
				&send("200 ok file $1 follows\n");
				for (@r) {
					s/^\./../;
					&send("$_");
				}
				&send(".\n");
			}

		} elsif (/^get_debs_from_changes (.+)$/) {
			my $changes_signed = 0;
			my @r = eval { get_debs_from_changes ($1, \$changes_signed) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: $@\n");		
			} else {
				if ($changes_signed) {
					&send("200 ok debs in signed $1 follow\n");	
				} else {
					&send("200 ok debs in $1 follow\n");
				}
				for (@r) {
					s/^\./../;			
					&send("$_\n");
				}
				&send(".\n");
			}

		} elsif (/^glob_exp (.+)$/) {
			my @r = eval { glob_exp ($1) };		
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: $@\n");		
			} else {
				&send("200 ok files matching \"$1\" follow\n");	
				for (@r) {
					s/^\./../;			
					&send("$_\n");
				}
				&send(".\n");
			}

		} elsif (/^file_readable (.+)$/) {
			my $r = eval { file_readable ($1) };		
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: $@\n");		
			} else {
				if ($r) {
					&send("200 ok file readable\n");
				} else {
					&send("400 not ok file not readable\n");
				}
			}

		} elsif (/^get_file_md5sum (.+)$/) {
			my $r = eval { get_file_md5sum ($1) };		
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: $@\n");		
			} else {
				&send("200 ok md5sum is $r\n");
			}


		} elsif (/^add_sig_to_deb ([^ ]+) (.+)$/) {
			my ($sig_name, $deb, $sig) = ($1, $2, '');
			&send("300 ok waiting for data\n");
			while ($_ = &read()) {		
				last if (/^\.$/);
				s/^\.\././;
				$sig .= $_;
			}
			my $r = eval { add_sig_to_deb ($deb, $sig, $sig_name) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: ");
				&send($@, "\n");
			} else {
				&send("200 ok added sig to $deb. New data follows\n");
				&send(join (" ", @$r), "\n");
			}

		} elsif (/^correct_changes_file (.+)$/) {
			my ($changes, $new_changes_data) = ($1, {});
			&send("300 ok waiting for data\n");
			while ($_ = &read()) {	
				last if (/^\.$/);
				s/^\.\././;
				chomp;
				my ($md5sum, $size, $name) = split (/ /, $_, 3);
				$new_changes_data->{$name} = [$md5sum, $size, $name];
			}
			my $r = eval { correct_changes_file ($changes, $new_changes_data) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: ");
				&send($@, "\n");
			} else {
				&send("200 ok $changes corrected\n");
			}

		} elsif (/^write_control_file (.+)$/) {
			my ($file, @data) = ($1, ());
			
			&send("300 ok waiting for data\n");
			while ($_ = &read()) {	
				last if (/^\.$/);
				s/^\.\././;
				push @data, $_;
			}
			my @r = eval { write_control_file ($file, @data) };
			if ($@) {
				chomp($@); $@ =~ s/\n/\t/g;
				&send("500 error: ");
				&send($@, "\n");
			} else {
				&send("200 ok $file written. New md5sum, size: $r[0] $r[1]\n");
			}

		} elsif (/^quit\s*$/) {
			&send("200 ok Bye!\n");
			exit;

		} else {
			&send("501 unknown command ".(split / /, $_)[0]."\n");
		}
	}
	$DEBUG && close LOG;
}

sub _die {
	chomp(my $msg = shift || "No error msg given! This is a bug, hurt the author!");
	my $i = 0;
	
	while ($_ = (caller($i++))[3]) {
		if ($_ && $_ eq "(eval)") {
			return $msg;
		}
	}
	
	my $code = shift || 1;
	my $line = (caller)[2];
	print STDERR "E: $msg\n";
	exit $code;
}

sub _read_file {
	my $file = shift;
	my $content;
	
	open (FH, $file) or die _die "Can't open $file: $!";
	$content = join "", <FH>;
	close FH;

	return $content;
}

sub _write_file {
	my $file = shift;
	my $content = shift;
	
	open (FH, ">", $file) or die _die "Can't open $file for writing: $!";
	print FH $content;
	close FH;
}


# vim:set shiftwidth=4:
# vim:set tabstop=4:
# vim:set noet:
# vim:set shiftround:
