chiark / gitweb /
Improve error message for .dsc having already been signed (iff using libdpkg-perl...
[dgit.git] / dgit
diff --git a/dgit b/dgit
index 8744874..ebeb880 100755 (executable)
--- a/dgit
+++ b/dgit
@@ -29,6 +29,7 @@ use File::Basename;
 use Dpkg::Version;
 use POSIX;
 use IPC::Open2;
+use Digest::SHA;
 
 our $our_version = 'UNRELEASED'; ###substituted###
 
@@ -57,6 +58,7 @@ our $suite_re = '[-+.0-9a-z]+';
 
 our (@git) = qw(git);
 our (@dget) = qw(dget);
+our (@curl) = qw(curl -f);
 our (@dput) = qw(dput);
 our (@debsign) = qw(debsign);
 our (@gpg) = qw(gpg);
@@ -69,7 +71,8 @@ our (@dpkggenchanges) = qw(dpkg-genchanges);
 our (@mergechanges) = qw(mergechanges -f);
 our (@changesopts) = ('');
 
-our %opts_opt_map = ('dget' => \@dget,
+our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
+                    'curl' => \@curl,
                     'dput' => \@dput,
                     'debsign' => \@debsign,
                      'gpg' => \@gpg,
@@ -315,10 +318,10 @@ sub url_get {
     my $r = $ua->get(@_) or die $!;
     return undef if $r->code == 404;
     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
-    return $r->decoded_content();
+    return $r->decoded_content(charset => 'none');
 }
 
-our ($dscdata,$dscurl,$dsc,$skew_warning_vsn);
+our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 
 sub shellquote {
     my @out;
@@ -465,7 +468,7 @@ our %defcfg = ('dgit.default.distro' => 'debian',
               'dgit-distro.debian.git-path' => '/git/dgit-repos/repos',
               'dgit-distro.debian.git-check' => 'ssh-cmd',
               'dgit-distro.debian.git-create' => 'ssh-cmd',
-              'dgit-distro.debian.sshpsql-host' => 'coccia.debian.org',
+              'dgit-distro.debian.sshpsql-host' => 'mirror.ftp-master.debian.org',
               'dgit-distro.debian.sshpsql-dbname' => 'service=projectb',
               'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
               'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
@@ -591,11 +594,30 @@ sub access_giturl () {
     return "$url/$package.git";
 }             
 
-sub parsecontrolfh ($$@) {
-    my ($fh, $desc, @opts) = @_;
-    my %opts = ('name' => $desc, @opts);
-    my $c = Dpkg::Control::Hash->new(%opts);
-    $c->parse($fh) or die "parsing of $desc failed";
+sub parsecontrolfh ($$;$) {
+    my ($fh, $desc, $allowsigned) = @_;
+    our $dpkgcontrolhash_noissigned;
+    my $c;
+    for (;;) {
+       my %opts = ('name' => $desc);
+       $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
+print STDERR Dumper(\%opts);
+       $c = Dpkg::Control::Hash->new(%opts);
+       $c->parse($fh) or die "parsing of $desc failed";
+       last if $allowsigned;
+       last if $dpkgcontrolhash_noissigned;
+       my $issigned= $c->get_option('is_pgp_signed');
+       if (!defined $issigned) {
+           $dpkgcontrolhash_noissigned= 1;
+           seek $fh, 0,0 or die "seek $desc: $!";
+       } elsif ($issigned) {
+           fail "control file $desc is (already) PGP-signed. ".
+               " Note that dgit push needs to modify the .dsc and then".
+               " do the signature itself";
+       } else {
+           last;
+       }
+    }
     return $c;
 }
 
@@ -751,7 +773,7 @@ sub archive_query_sshpsql ($$) {
     my ($proto,$data) = @_;
     sql_injection_check $isuite, $package;
     my @rows = sshpsql($data, <<END);
-        SELECT source.version, component.name, files.filename
+        SELECT source.version, component.name, files.filename, files.sha256sum
           FROM source
           JOIN src_associations ON source.id = src_associations.source
           JOIN suite ON suite.id = src_associations.suite
@@ -764,9 +786,10 @@ sub archive_query_sshpsql ($$) {
            AND files.filename LIKE '%.dsc';
 END
     @rows = sort { -version_compare_string($a->[0],$b->[0]) } @rows;
+    my $digester = Digest::SHA->new(256);
     @rows = map {
-       my ($vsn,$component,$filename) = @$_;
-       [ $vsn, "/pool/$component/$filename" ];
+       my ($vsn,$component,$filename,$sha256sum) = @$_;
+       [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
     } @rows;
     return @rows;
 }
@@ -836,19 +859,28 @@ sub get_archive_dsc () {
     canonicalise_suite();
     my @vsns = archive_query('archive_query');
     foreach my $vinfo (@vsns) {
-       my ($vsn,$subpath) = @$vinfo;
+       my ($vsn,$subpath,$digester,$digest) = @$vinfo;
        $dscurl = access_cfg('mirror').$subpath;
        $dscdata = url_get($dscurl);
        if (!$dscdata) {
            $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
            next;
        }
+       if ($digester) {
+           $digester->reset();
+           $digester->add($dscdata);
+           my $got = $digester->hexdigest();
+           $got eq $digest or
+               fail "$dscurl has hash $got but".
+                   " archive told us to expect $digest";
+       }
        my $dscfh = new IO::File \$dscdata, '<' or die $!;
        printdebug Dumper($dscdata) if $debug>1;
-       $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
+       $dsc = parsecontrolfh($dscfh,$dscurl,1);
        printdebug Dumper($dsc) if $debug>1;
        my $fmt = getfield $dsc, 'Format';
        fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+       $dsc_checked = !!$digester;
        return;
     }
     $dsc = undef;
@@ -972,20 +1004,34 @@ sub clogp_authline ($) {
 sub generate_commit_from_dsc () {
     prep_ud();
     changedir $ud;
-    my @files;
-    foreach my $f (dsc_files()) {
+
+    foreach my $fi (dsc_files_info()) {
+       my $f = $fi->{Filename};
        die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
-       push @files, $f;
+
        link "../../../$f", $f
            or $!==&ENOENT
            or die "$f $!";
+
+       complete_file_from_dsc('.', $fi);
+
+       if (is_orig_file($f)) {
+           link $f, "../../../../$f"
+               or $!==&EEXIST
+               or die "$f $!";
+       }
     }
-    runcmd @dget, qw(--), $dscurl;
-    foreach my $f (grep { is_orig_file($_) } @files) {
-       link $f, "../../../../$f"
-           or $!==&EEXIST
-           or die "$f $!";
-    }
+
+    my $dscfn = "$package.dsc";
+
+    open D, ">", $dscfn or die "$dscfn: $!";
+    print D $dscdata or die "$dscfn: $!";
+    close D or die "$dscfn: $!";
+    my @cmd = qw(dpkg-source);
+    push @cmd, '--no-check' if $dsc_checked;
+    push @cmd, qw(-x --), $dscfn;
+    runcmd @cmd;
+
     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
@@ -1046,30 +1092,47 @@ END
     return $outputhash;
 }
 
+sub complete_file_from_dsc ($$) {
+    our ($dstdir, $fi) = @_;
+    # Ensures that we have, in $dir, the file $fi, with the correct
+    # contents.  (Downloading it from alongside $dscurl if necessary.)
+
+    my $f = $fi->{Filename};
+    my $tf = "$dstdir/$f";
+    my $downloaded = 0;
+
+    if (stat $tf) {
+       progress "using existing $f";
+    } else {
+       die "$tf $!" unless $!==&ENOENT;
+
+       my $furl = $dscurl;
+       $furl =~ s{/[^/]+$}{};
+       $furl .= "/$f";
+       die "$f ?" unless $f =~ m/^${package}_/;
+       die "$f ?" if $f =~ m#/#;
+       runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
+       next if !act_local();
+       $downloaded = 1;
+    }
+
+    open F, "<", "$tf" or die "$tf: $!";
+    $fi->{Digester}->reset();
+    $fi->{Digester}->addfile(*F);
+    F->error and die $!;
+    my $got = $fi->{Digester}->hexdigest();
+    $got eq $fi->{Hash} or
+       fail "file $f has hash $got but .dsc".
+           " demands hash $fi->{Hash} ".
+           ($downloaded ? "(got wrong file from archive!)"
+            : "(perhaps you should delete this file?)");
+}
+
 sub ensure_we_have_orig () {
     foreach my $fi (dsc_files_info()) {
        my $f = $fi->{Filename};
        next unless is_orig_file($f);
-       if (open F, "<", "../$f") {
-           $fi->{Digester}->reset();
-           $fi->{Digester}->addfile(*F);
-           F->error and die $!;
-           my $got = $fi->{Digester}->hexdigest();
-           $got eq $fi->{Hash} or
-               fail "existing file $f has hash $got but .dsc".
-                   " demands hash $fi->{Hash}".
-                   " (perhaps you should delete this file?)";
-           progress "using existing $f";
-           next;
-       } else {
-           die "$f $!" unless $!==&ENOENT;
-       }
-       my $origurl = $dscurl;
-       $origurl =~ s{/[^/]+$}{};
-       $origurl .= "/$f";
-       die "$f ?" unless $f =~ m/^${package}_/;
-       die "$f ?" if $f =~ m#/#;
-       runcmd_ordryrun_local shell_cmd 'cd ..', @dget,'--',$origurl;
+       complete_file_from_dsc('..', $fi);
     }
 }
 
@@ -1217,6 +1280,10 @@ sub clone ($) {
        progress "starting new git history";
     }
     fetch_from_archive() or no_such_package;
+    my $vcsgiturl = $dsc->{'Vcs-Git'};
+    if (length $vcsgiturl) {
+       runcmd @git, qw(remote add vcs-git), $vcsgiturl;
+    }
     runcmd @git, qw(reset --hard), lrref();
     printdone "ready for work in $dstdir";
 }
@@ -1515,6 +1582,12 @@ sub cmd_clone {
     }
     $dstdir ||= "$package";
 
+    if (stat $dstdir) {
+       fail "$dstdir already exists";
+    } elsif ($! != &ENOENT) {
+       die "$dstdir: $!";
+    }
+
     my $cwd_remove;
     if ($rmonerror && !$dryrun_level) {
        $cwd_remove= getcwd();
@@ -1898,6 +1971,11 @@ sub clean_tree () {
     }
 }
 
+sub cmd_clean () {
+    badusage "clean takes no additional arguments" if @ARGV;
+    clean_tree();
+}
+
 sub build_prep () {
     badusage "-p is not allowed when building" if defined $package;
     check_not_dirty();
@@ -2158,8 +2236,6 @@ if ($ENV{$fakeeditorenv}) {
     quilt_fixup_editor();
 }
 
-delete $ENV{'DGET_UNPACK'};
-
 parseopts();
 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
@@ -2170,4 +2246,7 @@ if (!@ARGV) {
 }
 my $cmd = shift @ARGV;
 $cmd =~ y/-/_/;
-{ no strict qw(refs); &{"cmd_$cmd"}(); }
+
+my $fn = ${*::}{"cmd_$cmd"};
+$fn or badusage "unknown operation $cmd";
+$fn->();