Print a supplementary message when push fails, giving advice to the user about how...

[dgit.git] / dgit

diff --git a/dgit b/dgit
index d5aa38718c551c7c46b32ecf6c046bb502a50b96..c652e5db10113279fc22aa6d20ece200a641342f 100755 (executable)
--- a/dgit
+++ b/dgit
@@ -39,7 +39,7 @@ use Debian::Dgit;
 
 our $our_version = 'UNRELEASED'; ###substituted###
 
-our @rpushprotovsn_support = qw(2);
+our @rpushprotovsn_support = qw(3 2);
 our $protovsn;
 
 our $isuite = 'unstable';
@@ -103,6 +103,13 @@ our $keyid;
 
 autoflush STDOUT 1;
 
+our $supplementary_message = '';
+
+END {
+    local ($@, $?);
+    print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
+}
+
 our $remotename = 'dgit';
 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
 our $csuite;
@@ -592,6 +599,22 @@ sub pushing () {
     badcfg "pushing but distro is configured readonly"
        if access_forpush_config() eq '0';
     $access_forpush = 1;
+    $supplementary_message = <<'END' unless $we_are_responder;
+Push failed, before we got started.
+You can retry the push, after fixing the problem, if you like.
+END
+}
+
+sub supplementary_message ($) {
+    my ($msg) = @_;
+    if (!$we_are_responder) {
+       $supplementary_message = $msg;
+       return;
+    } elsif ($protovsn >= 3) {
+       responder_send_command "supplementary-message ".length($msg)
+           or die $!;
+       print PO $msg or die $!;
+    }
 }
 
 sub access_distros () {
@@ -1822,6 +1845,10 @@ sub sign_changes ($) {
 sub dopush ($) {
     my ($forceflag) = @_;
     printdebug "actually entering push\n";
+    supplementary_message(<<'END');
+Push failed, while preparing your push.
+You can retry the push, after fixing the problem, if you like.
+END
     prep_ud();
 
     access_giturl(); # check that success is vaguely likely
@@ -1906,6 +1933,11 @@ sub dopush ($) {
     my $tfn = sub { ".git/dgit/tag$_[0]"; };
     my $tagobjfn;
 
+    supplementary_message(<<'END');
+Push failed, while signing the tag.
+You can retry the push, after fixing the problem, if you like.
+END
+    # If we manage to sign but fail to record it anywhere, it's fine.
     if ($we_are_responder) {
        $tagobjfn = $tfn->('.signed.tmp');
        responder_receive_files('signed-tag', $tagobjfn);
@@ -1916,11 +1948,19 @@ sub dopush ($) {
                       $changesfile,$changesfile,
                       $tfn);
     }
+    supplementary_message(<<'END');
+Push failed, *after* signing the tag.
+If you want to try again, you should use a new version number.
+END
 
     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
 
+    supplementary_message(<<'END');
+Push failed, while updating the remote git repository - see messages above.
+If you want to try again, you should use a new version number.
+END
     if (!check_for_git()) {
        create_remote_git_repo();
     }
@@ -1928,6 +1968,10 @@ sub dopush ($) {
         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
 
+    supplementary_message(<<'END');
+Push failed, after updating the remote git repository.
+If you want to try again, you must use a new version number.
+END
     if ($we_are_responder) {
        my $dryrunsuffix = act_local() ? "" : ".tmp";
        responder_receive_files('signed-dsc-changes',
@@ -1942,11 +1986,19 @@ sub dopush ($) {
        sign_changes $changesfile;
     }
 
+    supplementary_message(<<'END');
+Push failed, while uploading package(s) to the archive server.
+You can retry the upload of exactly these same files with dput of:
+  $changesfile
+If that .changes file is broken, you will need to use a new version
+number for your next attempt at the upload.
+END
     my $host = access_cfg('upload-host','RETURN-UNDEF');
     my @hostarg = defined($host) ? ($host,) : ();
     runcmd_ordryrun @dput, @hostarg, $changesfile;
     printdone "pushed and uploaded $cversion";
 
+    supplementary_message('');
     responder_send_command("complete");
 }
 
@@ -2058,6 +2110,10 @@ sub cmd_push {
            fail "dgit push: changelog specifies $isuite ($csuite)".
                " but command line specifies $specsuite";
     }
+    supplementary_message(<<'END');
+Push failed, while checking state of the archive.
+You can retry the push, after fixing the problem, if you like.
+END
     if (check_for_git()) {
        git_fetch_us();
     }
@@ -2086,7 +2142,6 @@ sub cmd_push {
 #---------- remote commands' implementation ----------
 
 sub cmd_remote_push_build_host {
-    pushing();
     my ($nrargs) = shift @ARGV;
     my (@rargs) = @ARGV[0..$nrargs-1];
     @ARGV = @ARGV[$nrargs..$#ARGV];
@@ -2099,6 +2154,8 @@ sub cmd_remote_push_build_host {
     $we_are_responder = 1;
     $us .= " (build host)";
 
+    pushing();
+
     open PI, "<&STDIN" or die $!;
     open STDIN, "/dev/null" or die $!;
     open PO, ">&STDOUT" or die $!;
@@ -2183,6 +2240,7 @@ sub cmd_rpush {
     changedir $i_tmp;
     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
+    $supplementary_message = '' unless $protovsn >= 3;
     for (;;) {
        my ($icmd,$iargs) = initiator_expect {
            m/^(\S+)(?: (.*))?$/;
@@ -2198,6 +2256,11 @@ sub i_resp_progress ($) {
     progress $msg;
 }
 
+sub i_resp_supplementary_message ($) {
+    my ($rhs) = @_;
+    $supplementary_message = protocol_read_bytes \*RO, $rhs;
+}
+
 sub i_resp_complete {
     my $pid = $i_child_pid;
     $i_child_pid = undef; # prevents killing some other process with same pid