2 # dgit repos policy hook script for Debian
4 # Copyright (C) 2015-2016 Ian Jackson
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 3 of the License, or
9 # (at your option) any later version.
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
22 use Debian::Dgit qw(:DEFAULT :policyflags);
27 use File::Temp qw(tempfile);
32 use Debian::Dgit::Policy::Debian;
35 enabledebuglevel $ENV{'DGIT_DRS_DEBUG'};
37 END { $? = 127; } # deliberate exit uses _exit
39 our $distro = shift @ARGV // die "need DISTRO";
40 our $repos = shift @ARGV // die "need DGIT-REPOS-DIR";
41 our $dgitlive = shift @ARGV // die "need DGIT-LIVE-DIR";
42 our $distrodir = shift @ARGV // die "need DISTRO-DIR";
43 our $action = shift @ARGV // die "need ACTION";
45 our $publicmode = 02775;
46 our $new_upload_propagation_slop = 3600*4 + 100;# fixme config;
51 our ($pkg_exists,$pkg_secret);
55 our ($version,$suite,$tagname);
58 # We assume that it is not possible for NEW to have a version older
61 # Whenever pushing, we check for
62 # source-package-local tainted history
63 # global tainted history
64 # can be overridden by --deliberately except for an admin prohib taint
66 # ALL of the following apply only if history is secret:
68 # if NEW has no version, or a version which is not in our history[1]
71 # if any suite's version is in our history[1], publish our history
72 # otherwise discard our history,
73 # tainting --deliberately-include-questionable-history
75 # if NEW has a version which is in our history[1]
77 # require explicit specification of one of
78 # --deliberately-include-questionable-history
79 # --deliberately-not-fast-forward
80 # (latter will taint old NEW version --d-i-q-h)
84 # [1] looking for the relevant git tag for the version number and not
85 # caring what that tag refers to.
87 # When we are doing a push to a fresh repo, any version will do: in
88 # this case, this is the first dgit upload of an existing package,
89 # and we trust that the uploader hasn't included in their git
90 # history any previous non-dgit uploads.
92 # A wrinkle: if we approved a push recently, we treat NEW as having
93 # a version which is in our history. This is because the package may
94 # still be being uploaded. (We record this using the timestamp of the
95 # package's git repo directory.)
97 # We aim for the following invariants and properties:
99 # - .dsc of published dgit package will have corresponding publicly
100 # visible dgit-repo (soon)
102 # - when a new package is rejected we help maintainer avoid
103 # accidentally including bad objects in published dgit history
105 # - .dsc of NEW dgit package has corresponding dgit-repo but not
111 my $dgit = "$dgitlive/dgit";
112 $dgit = "dgit" if !stat_exists $dgit;
113 my $cmd = "$dgit -d$distro \$DGIT_TEST_OPTS";
114 $cmd .= " -".("D" x $debuglevel) if $debuglevel;
115 $cmd .= " archive-api-query $subpath";
116 printdebug "apiquery $cmd\n";
117 $!=0; $?=0; my $json = `$cmd`;
118 defined $json && !$? or die "$subpath $! $?";
119 my $r = decode_json $json;
120 my $d = new Data::Dumper([$r], [qw(r)]);
121 printdebug "apiquery $subpath | ", $d->Dump() if $debuglevel>=2;
125 sub vsn_in_our_history ($) {
128 # Eventually, when we withdraw support for old-format (DEP-14
129 # namespace) tags, we will need to change this to only look
130 # for debiantag_new. See the commit
131 # "Tag change: Update dgit-repos-policy-debian"
132 # (reverting which is a good start for that change).
134 my @tagrefs = map { "refs/tags/".$_ } debiantags $vsn, $distro;
135 printdebug " checking history vsn=$vsn tagrefs=@tagrefs\n";
136 open F, "-|", qw(git for-each-ref), @tagrefs;
139 return 1 if defined && m/\S/;
140 die "$pkg tagrefs @tagrefs $? $!" if $?;
144 sub specific_suite_has_suitable_vsn ($$) {
145 my ($suite, $vsn_check) = @_; # tests $vsn_check->($version)
146 my $in_suite = apiquery "dsc_in_suite/$suite/$pkg";
147 foreach my $entry (@$in_suite) {
148 my $vsn = $entry->{version};
149 die "$pkg ?" unless defined $vsn;
150 printdebug " checking history found suite=$suite vsn=$vsn\n";
151 return 1 if $vsn_check->($vsn);
156 sub new_has_vsn_in_our_history () {
157 return specific_suite_has_suitable_vsn('new', \&vsn_in_our_history);
160 sub good_suite_has_suitable_vsn ($) {
161 my ($vsn_check) = @_; # as for specific_suite_has_specific_vsn
162 my $suites = apiquery "suites";
163 foreach my $suitei (@$suites) {
164 my $suite = $suitei->{name};
165 die unless defined $suite;
166 next if $suite =~ m/\bnew$/;
167 return 1 if specific_suite_has_suitable_vsn($suite, $vsn_check);
173 $pkgdir = "$repos/$pkg.git";
174 if (!stat_exists $pkgdir) {
175 printdebug "statpackage $pkg => ENOENT\n";
179 $pkg_secret = !!(~(stat _)[2] & 05);
180 printdebug "statpackage $pkg => exists, secret=$pkg_secret.\n";
185 die unless @ARGV >= 1;
187 die unless $pkg =~ m/^$package_re$/;
193 my ($refobj, $reason) = @_;
195 printdebug "TAINTING $refobj\n",
196 (map { "\%| $_" } split "\n", $reason),
199 my $tf = new File::Temp or die $!;
200 print $tf "$refobj^0\n" or die $!;
202 seek $tf,0,0 or die $!;
204 my $gcfpid = open GCF, "-|";
205 defined $gcfpid or die $!;
207 open STDIN, "<&", $tf or die $!;
208 exec 'git', 'cat-file', '--batch';
215 m/^(\w+) (\w+) (\d+)\n/ or die "$_ ?";
221 if ($gitobjtype eq 'commit' or $gitobjtype eq 'tag') {
222 $!=0; read GCF, $gitobjdata, $bytes == $bytes
223 or die "$gitobjid $bytes $!";
227 $poldbh->do("INSERT INTO taints".
228 " (package, gitobjid, gitobjtype, gitobjdata, time, comment)".
229 " VALUES (?,?,?,?,?,?)", {},
230 $pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);
232 my $taint_id = $poldbh->last_insert_id(undef,undef,"taints","taint_id");
233 die unless defined $taint_id;
235 $poldbh->do("INSERT INTO taintoverrides".
236 " (taint_id, deliberately)".
237 " VALUES (?, '--deliberately-include-questionable-history')",
241 sub add_taint_by_tag ($$) {
242 my ($tagname,$refobjid) = @_;
244 "tag $tagname referred to this object in git tree but all".
245 " previously pushed versions were found to have been".
246 " removed from NEW (ie, rejected) (or never arrived)");
249 sub check_package () {
250 return 0 unless $pkg_exists;
251 return 0 unless $pkg_secret;
253 printdebug "check_package\n";
255 chdir $pkgdir or die "$pkgdir $!";
257 stat '.' or die "$pkgdir $!";
258 my $mtime = ((stat _)[9]);
259 my $age = time - $mtime;
260 printdebug "check_package age=$age\n";
262 if (good_suite_has_suitable_vsn(\&vsn_in_our_history)) {
263 chmod $publicmode, "." or die $!;
266 my $mirror_hook = "$distrodir/mirror-hook";
267 if (stat_exists $mirror_hook) {
269 ($mirror_hook, $distrodir, "updated-hook", $pkg);
270 debugcmd " (mirror)",@mirror_cmd;
271 system @mirror_cmd and failedcmd @mirror_cmd;
276 print STDERR "policy hook: warning:".
277 " failed to mirror publication of \`$pkg':".
283 return 0 if $age < $new_upload_propagation_slop;
285 return 0 if new_has_vsn_in_our_history();
287 printdebug "check_package secret, deleted, tainting\n";
289 git_for_each_ref('refs/tags', sub {
290 my ($objid,$objtype,$fullrefname,$tagname) = @_;
291 add_taint_by_tag($tagname,$objid);
297 sub action_check_package () {
299 return check_package();
303 die unless @ARGV >= 4;
304 $version = shift @ARGV;
305 $suite = shift @ARGV;
306 $tagname = shift @ARGV;
307 my $delibs = shift @ARGV;
308 foreach my $delib (split /\,/, $delibs) {
309 $deliberately{$delib} = 1;
313 sub deliberately ($) { return $deliberately{"--deliberately-$_[0]"}; }
319 check_package(); # might make package public, or might add taints
321 return 0 unless $pkg_exists;
322 return 0 unless $pkg_secret;
324 # we suppose that NEW has a version which is already in our
325 # history, as otherwise the repo would have been blown away
327 if (deliberately('not-fast-forward')) {
328 add_taint(server_ref($suite),
329 "rewound suite $suite; --deliberately-not-fast-forward".
330 " specified in signed tag $tagname for upload of".
331 " version $version");
332 return NOFFCHECK|FRESHREPO;
334 if (deliberately('include-questionable-history')) {
339 Package is in NEW and has not been accepted or rejected yet.
340 Unfortunately, we cannot determine automatically what should happen.
341 You will have to pass either --deliberately-not-fast-forward or
342 --deliberately-include-questionable-history to specify whether you are
343 keeping or discarding the previously pushed history.
345 The choice is important, to ensure that your git history is both
346 suitable for public distribution and as useful as possible. Please
347 see the descriptions of these options in dgit(1).
352 sub action_push_confirm () {
355 die unless @ARGV >= 1;
356 my $freshrepo = shift @ARGV;
358 my $initq = $poldbh->prepare(<<END);
359 SELECT taint_id, gitobjid FROM taints t
360 WHERE (package = ? OR package = '')
362 $initq->execute($pkg);
364 my @objscatcmd = qw(git);
365 push @objscatcmd, qw(--git-dir), $freshrepo if length $freshrepo;
366 push @objscatcmd, qw(cat-file --batch);
367 debugcmd '|',@objscatcmd if $debuglevel>=2;
370 my $chkinput = tempfile();
371 while (my $taint = $initq->fetchrow_hashref()) {
372 push @taintids, $taint->{taint_id};
373 print $chkinput $taint->{gitobjid}, "\n" or die $!;
374 printdebug '|> ', $taint->{gitobjid}, "\n" if $debuglevel>=2;
376 flush $chkinput or die $!;
377 seek $chkinput,0,0 or die $!;
379 my $checkpid = open CHKOUT, "-|" // die $!;
381 open STDIN, "<&", $chkinput or die $!;
382 delete $ENV{GIT_ALTERNATE_OBJECT_DIRECTORIES};
383 # ^ recent versions of git set this in the environment of
384 # receive hooks. This can cause us to see things which
385 # the user is trying to abolish.
386 exec @objscatcmd or die $!;
389 my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);
391 my $overridesstmt = <<END;
392 SELECT deliberately FROM taintoverrides WHERE (
395 my @overridesv = sort keys %deliberately;
396 $overridesstmt .= <<END foreach @overridesv;
399 $overridesstmt .= <<END;
401 ORDER BY deliberately ASC
406 while (my $taintid = shift @taintids) {
408 die "($taintid @objscatcmd) $!" unless defined $_;
409 printdebug "|< ", $_ if $debuglevel>=2;
411 next if m/^\w+ missing$/;
412 die "($taintid @objscatcmd) $_ ?" unless m/^(\w+) (\w+) (\d+)\s/;
413 my ($objid,$objtype,$nbytes) = ($1,$2,$3);
416 (read CHKOUT, $drop, $nbytes) == $nbytes
417 or die "($taintid @objscatcmd) $!";
420 die "($taintid @objscatcmd) $!" unless defined $_;
421 die "($taintid @objscatcmd) $_ ?" if m/\S/;
423 $taintinfoq ||= $poldbh->prepare(<<END);
424 SELECT package, time, comment FROM taints WHERE taint_id = ?
426 $taintinfoq->execute($taintid);
428 my $ti = $taintinfoq->fetchrow_hashref();
429 die "($taintid)" unless $ti;
431 my $timeshow = defined $ti->{time}
432 ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->{time})
434 my $pkgshow = length $ti->{package}
435 ? "package $ti->{package}"
440 History contains tainted $objtype $objid
441 Taint recorded$timeshow for $pkgshow
442 Reason: $ti->{comment}
445 printdebug "SQL overrides: @overridesv $taintid /\n$overridesstmt\n";
447 $overridesq ||= $poldbh->prepare($overridesstmt);
448 $overridesq->execute(@overridesv, $taintid);
449 my ($ovwhy) = $overridesq->fetchrow_array();
450 if (!defined $ovwhy) {
451 $overridesanyq ||= $poldbh->prepare(<<END);
452 SELECT 1 FROM taintoverrides WHERE taint_id = ? LIMIT 1
454 $overridesanyq->execute($taintid);
455 my ($ovany) = $overridesanyq->fetchrow_array();
456 $stderr .= $ovany ? <<END : <<END;
457 Could be forced using --deliberately. Consult documentation.
459 Uncorrectable error. If confused, consult administrator.
464 Forcing due to --deliberately-$ovwhy
466 $untaintq ||= $poldbh->prepare(<<END);
467 DELETE FROM taints WHERE taint_id = ?
469 $untaintq->execute($taintid);
477 Rejecting push due to questionable history.
482 if (length $freshrepo) {
483 if (!good_suite_has_suitable_vsn(sub { 1; })) {
484 stat $freshrepo or die "$freshrepo $!";
485 my $oldmode = ((stat _)[2]);
486 my $oldwrites = $oldmode & 0222;
487 # remove r and x bits which have corresponding w bits clear
488 my $newmode = $oldmode &
489 (~0555 | ($oldwrites << 1) | ($oldwrites >> 1));
490 printdebug sprintf "chmod %#o (was %#o) %s\n",
491 $newmode, $oldmode, $freshrepo;
492 chmod $newmode, $freshrepo or die $!;
493 utime undef, undef, $freshrepo or die $!;
500 sub action_check_list () {
501 opendir L, "$repos" or die "$repos $!";
502 while (defined (my $dent = readdir L)) {
503 next unless $dent =~ m/^($package_re)\.git$/;
506 next unless $pkg_exists;
507 next unless $pkg_secret;
508 print "$pkg\n" or die $!;
510 closedir L or die $!;
511 close STDOUT or die $!;
516 my $fn = ${*::}{"action_$action"};
518 printdebug "dgit-repos-policy-debian: unknown action $action\n";
525 my $db_busy_exception= 'Debian::Dgit::Policy::Debian::DB_BUSY';
532 poldb_setup(poldb_path($repos), sub {
533 $poldbh->{HandleError} = sub {
534 return 0 unless $poldbh->err == 5; # SQLITE_BUSY, not in .pm :-(
535 die bless { }, $db_busy_exception;
538 eval ($ENV{'DGIT_RPD_TEST_DBLOOP_HOOK'}//'');
540 # used by tests/tests/debpolicy-dbretry
546 die unless defined $rcode;
550 last unless length $@;
551 die $@ unless ref $@ eq $db_busy_exception;
553 die if $sleepy >= 20;
555 print STDERR "[policy database busy, retrying (${sleepy}s)]\n";
557 eval { $poldbh->rollback; };
560 print STDERR $stderr or die $!;
561 flush STDERR or die $!;