X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=infra%2Fdgit-repos-server;h=d8dc8574bd2157a4a5d4b4e7e53984448ad1ebcf;hp=ee4d5c52db3d2c4fa0f35ae5a5294d602d6e6585;hb=c023de1aef27e1ff1170ed1b4310f205c7118856;hpb=134136229bc4e6638d4a064b92a43b2e4f6bc341 diff --git a/infra/dgit-repos-server b/infra/dgit-repos-server index ee4d5c52..d8dc8574 100755 --- a/infra/dgit-repos-server +++ b/infra/dgit-repos-server @@ -21,6 +21,8 @@ # usages: # dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [] --ssh # dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [] --cron +# dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [] \ +# --tag2upload URL TAGNAME # settings # --repos=GIT-REPOS-DIR default DISTRO-DIR/repos/ # --suites=SUITES-FILE default DISTRO-DIR/suites @@ -50,6 +52,8 @@ # (With --cron AUTH-SPEC is not used and may be the empty string.) use strict; +use Carp; +use IO::Handle; use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC! use Debian::Dgit qw(:DEFAULT :policyflags); @@ -552,9 +556,9 @@ sub readupdates () { printdebug " updates ok.\n"; } -sub parsetag_general ($$;$) { - my ($mainfn, $dgititemfn, $need_distro) = @_; - printdebug " parsetag...\n"; +sub readtag () { + printdebug " readtag...\n"; + open PT, ">dgit-tmp/plaintext" or die $!; open DS, ">dgit-tmp/plaintext.asc" or die $!; open T, "-|", qw(git cat-file tag), $tagval or die $!; @@ -570,8 +574,11 @@ sub parsetag_general ($$;$) { } } $!=0; $_=; defined or die $!; +} - $mainfn->(); +sub parsetag_general ($$) { + my ($dgititemfn, $distrofn) = @_; + printdebug " parsetag...\n"; my $copyl = $_; for (;;) { @@ -583,8 +590,7 @@ sub parsetag_general ($$;$) { while (length) { if ($dgititemfn->()) { } elsif (s/^distro\=(\S+) //) { - die "$1 != $distro" unless $1 eq $distro; - $need_distro = 0; + $distrofn->($1); } elsif (s/^[-+.=0-9a-z]\S* //) { } else { die "unknown dgit info in tag ($_)"; @@ -594,7 +600,6 @@ sub parsetag_general ($$;$) { } last if m/^-----BEGIN PGP/; } - reject "need distro info in tag" if $need_distro; $_ = $copyl; for (;;) { @@ -609,13 +614,14 @@ sub parsetag_general ($$;$) { } sub parsetag () { + readtag(); + m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or + reject "tag message not in expected format"; + die unless $1 eq $package; + $version = $2; + die "$3 != $suite " unless $3 eq $suite; + parsetag_general sub { - m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or - reject "tag message not in expected format"; - die unless $1 eq $package; - $version = $2; - die "$3 != $suite " unless $3 eq $suite; - }, sub { if (s/^(--deliberately-$deliberately_re) //) { push @deliberatelies, $1; } elsif (s/^previously:(\S+)=(\w+) //) { @@ -625,6 +631,9 @@ sub parsetag () { return 0; } return 1; + }, sub { + my ($gotdistro) = @_; + die "$gotdistro != $distro" unless $gotdistro eq $distro; }; } @@ -1063,6 +1072,228 @@ our @hookenvs = qw(distro suitesfile suitesformasterfile policyhook # workrepo and destrepo handled ad-hoc +sub mode_tag2upload () { + # PROTOTYPE + # CALLER MUST PREVENT MULTIPLE CONCURRENT RUNS IN SAME CWD + # If we fail (exit nonzero), caller should capture our stderr, + # and retry some bounded number of times in some appropriate way + @ARGV==2 or die; + + my $url; + ($url,$tagval) = @ARGV; + + $ENV{DGIT_DRS_EMAIL_NOREPLY} // die; + + my $start = time // die; + my @t = gmtime $start; + + die if $url =~ m/[^[:graph:]]/; + die if $tagval =~ m/[^[:graph:]]/; + + open OL, ">>overall.log" or die $!; + autoflush OL 1; + my $quit = sub { + printf OL "%04d-%02d-%02d %02d:%02d:%02d (%04ds): %s %s: %s\n", + $t[5] + 1900, @t[4,3,2,1,0], (time-$start), $url, $tagval, $_[0]; + exit 0; + }; + + $ENV{DGIT_DRS_ANY_URL} or $url =~ m{^https://}s + or $quit->("url scheme not as expected"); + + $tagval =~ m{^$distro/($versiontag_re)$}s + or $quit->("tag name not for us"); + + $version = $1; + $version =~ y/_\%\#/:~/d; + + my $work = 'work'; + + my $tagref = "refs/tags/$tagval"; + + rmtree $work; + rmtree 'bpd'; + mkdir $work or die $!; + mkdir 'bpd' or die $!; + unlink <*.orig*>; + dif $! if <*.orig*>; + changedir $work; + runcmd qw(git init -q); + runcmd qw(git remote add origin), $url; + runcmd qw(git fetch --depth=1 origin), "$tagref:$tagref"; + changedir ".git"; + mkdir 'dgit-tmp' or die $!; + + my $tagger; + open T, "-|", qw(git cat-file tag), $tagval or die $!; + { + local $/ = undef; + $!=0; $_=; defined or die $!; + + # quick and dirty check, will check properly later + m/^\[dgit[^"]* please-upload(?:\]| )/m or + $quit->("tag missing please-upload request"); + + m/^tagger (.*) \d+ [-+]\d+$/m or + $quit->("failed to fish tagger out of tag"); + $tagger = $1; + }; + + readtag(); + m/^($package_re) release (\S+) for ($suite_re)$/ or + $quit->("tag headline not for us"); + $package = $1; + my $tagmversion = $2; + $suite = $3; + + + # This is for us. From now on, we will capture errors to + # be emailed to the tagger. + + open H, ">>dgit-tmp/tagupl.email" or die $!; + print H <>dgit-tmp/tagupl.log" or die $!; + + my $child = fork() // die $!; + if ($child) { + # we are the parent + # if child exits 0, it has called $quit->() + $!=0; waitpid $child, 0 == $child or die $!; + printdebug "child $child ?=$?\n"; + exit 0 unless $?; + print L "execution child: ", waitstatusmsg(), "\n" or die $!; + close L or die $!; + print H <>tagupl.email + $ENV{DGIT_DRS_SENDMAIL} -oee -odb -oi -t \\ + -f$ENV{DGIT_DRS_EMAIL_NOREPLY} \\ + ("failed, emailed"); + } + + open STDERR, ">&L" or die $!; + open STDOUT, ">&STDERR" or die $!; + open DEBUG, ">&STDERR" if $debuglevel; + + reject "version mismatch $tagmversion != $version " + unless $tagmversion eq $version; + + my %need = map { $_ => 1 } qw(please-upload split); + my ($upstreamc, $upstreamt); + my $quilt; + my $distro_ok; + + confess if defined $upstreamt; + + parsetag_general sub { + if (m/^(\S+) / && exists $need{$1}) { + $_ = $'; + delete $need{$1}; + } elsif (s/^upstream=(\w+) //) { + $upstreamc = $1; + } elsif (s/^upstream-tag=(\S+) //) { + $upstreamt = $1; + } elsif (s/^quilt=([-+0-9a-z]+) //) { + $quilt = $1; + } else { + return 0; + } + return 1; + }, sub { + my ($gotdistro) = @_; + $distro_ok ||= $gotdistro eq $distro; + }; + + $quit->("not for this distro") unless $distro_ok; + + reject "missing \"$_\"" foreach keys %need; + + verifytag(); + + reject "upstream tag and not commitish, or v-v" + unless defined $upstreamt == defined $upstreamc; + + my @dgit; + push @dgit, $ENV{DGIT_DRS_DGIT} // 'dgit'; + push @dgit, '-wn'; + push @dgit, "-p$package"; + push @dgit, '--build-products-dir=../bpd'; + + changedir ".."; + runcmd (@dgit, qw(setup-gitattributes)); + + my @fetch = qw(git fetch origin --unshallow); + if (defined $upstreamt) { + runcmd qw(git check-ref-format), "refs/tags/$upstreamt"; + my $utagref = "refs/tags/$upstreamt"; + push @fetch, "$utagref:$utagref"; + } + runcmd @fetch; + + runcmd qw(git checkout -q), "refs/tags/$tagval"; + + my $clogp = parsechangelog(); + my $clogf = sub { + my ($f, $exp) = @_; + my $got = getfield $clogp, $f; + return if $got eq $exp; + reject "mismatch: changelog $f $got != $exp"; + }; + $clogf->('Version', $version); + $clogf->('Source', $package); + + @fetch = (@dgit, qw(fetch), $suite); + debugcmd "+",@_; + $!=0; $?=-1; + if (system @fetch) { + failedcmd @fetch unless $? == 4*256; + } + # this is just to get the orig, so we don't really care about the ref + if (defined $upstreamc) { + my $need_upstreamc = git_rev_parse "refs/tags/$upstreamt"; + $upstreamc eq $need_upstreamc or reject + "upstream-commitish=$upstreamc but tag refers to $need_upstreamc"; + runcmd qw(git deborig), "$upstreamc"; + } + + my @dgitcmd; + push @dgitcmd, @dgit; + push @dgitcmd, qw(--force-uploading-source-only); + if (defined $quilt) { + push @dgitcmd, "--quilt=$quilt"; + if ($quilt =~ m/baredebian/) { + die "needed upstream commmitish with --quilt=baredebian"; + push @dgitcmd, "--upstream-commitish=$upstreamc"; + } + } + push @dgitcmd, qw(push-source --new --overwrite), $suite; + # xxx what about the key to use? + + runcmd @dgitcmd; + + $quit->('done'); +} + sub mode_ssh () { die if @ARGV;