chiark / gitweb /
changelog: start 9.13
[dgit.git] / infra / dgit-repos-policy-debian
1 #!/usr/bin/perl -w
2 # dgit repos policy hook script for Debian
3 #
4 # Copyright (C) 2015-2019  Ian Jackson
5 #
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.
10 #
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.
15 #
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/>.
18
19 use strict;
20
21 use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
22 use Debian::Dgit qw(:DEFAULT :policyflags);
23 setup_sigwarn();
24
25 use POSIX;
26 use JSON;
27 use File::Temp qw(tempfile);
28 use DBI;
29 use IPC::Open2;
30 use Data::Dumper;
31
32 use Debian::Dgit::Policy::Debian;
33
34 initdebug('%');
35 enabledebuglevel $ENV{'DGIT_DRS_DEBUG'};
36
37 END { $? = 127; } # deliberate exit uses _exit
38
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";
44
45 our $publicmode = 02775;
46 our $new_upload_propagation_slop = 3600*4 + 100;# fixme config;
47
48 our $poldbh;
49 our $pkg;
50 our $pkgdir;
51 our ($pkg_exists,$pkg_secret);
52
53 our $stderr;
54
55 our ($version,$suite,$tagname);
56 our %deliberately;
57
58 # We assume that it is not possible for NEW to have a version older
59 # than sid.
60
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
65
66 # ALL of the following apply only if history is secret:
67
68 # if NEW has no version, or a version which is not in our history[1]
69 #   (always)
70 #   check all suites
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
74
75 # if NEW has a version which is in our history[1]
76 #   (on push only)
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)
81 #   (otherwise)
82 #   leave it be
83
84 # [1] looking for the relevant git tag for the version number and not
85 #    caring what that tag refers to.
86 #
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.
91 #
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.)
96
97 # We aim for the following invariants and properties:
98 #
99 # - .dsc of published dgit package will have corresponding publicly
100 #   visible dgit-repo (soon)
101 #
102 # - when a new package is rejected we help maintainer avoid
103 #   accidentally including bad objects in published dgit history
104 #
105 # - .dsc of NEW dgit package has corresponding dgit-repo but not
106 #   publicly readable
107
108 sub apiquery ($) {
109     my ($subpath) = @_;
110     local $/=undef;
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;
122     return $r;
123 }
124
125 sub vsn_in_our_history ($) {
126     my ($vsn) = @_;
127
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).
133
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;
137     $_ = <F>;
138     close F;
139     return 1 if defined && m/\S/;
140     die "$pkg tagrefs @tagrefs $? $!" if $?;
141     return 0;
142 }
143
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);
152     }
153     return 0;
154 }
155
156 sub new_has_vsn_in_our_history () {
157     return specific_suite_has_suitable_vsn('new', \&vsn_in_our_history);
158 }
159
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);
168     }
169     return 0;
170 }
171
172 sub statpackage () {
173     $pkgdir = "$repos/$pkg.git";
174     if (!stat_exists $pkgdir) {
175         printdebug "statpackage $pkg => ENOENT\n";
176         $pkg_exists = 0;
177     } else {
178         $pkg_exists = 1;
179         $pkg_secret = !!(~(stat _)[2] & 05);
180         printdebug "statpackage $pkg => exists, secret=$pkg_secret.\n";
181     }
182 }
183
184 sub getpackage () {
185     die unless @ARGV >= 1;
186     $pkg = shift @ARGV;
187     die unless $pkg =~ m/^$package_re$/;
188
189     statpackage();
190 }
191
192 sub add_taint ($$) {
193     my ($refobj, $reason) = @_;
194
195     printdebug "TAINTING $refobj\n",
196         (map { "\%| $_" } split "\n", $reason),
197         "\n";
198
199     my $tf = new File::Temp or die $!;
200     print $tf "$refobj^0\n" or die $!;
201     flush $tf or die $!;
202     seek $tf,0,0 or die $!;
203
204     my $gcfpid = open GCF, "-|";
205     defined $gcfpid or die $!;
206     if (!$gcfpid) {
207         open STDIN, "<&", $tf or die $!;
208         exec 'git', 'cat-file', '--batch';
209         die $!;
210     }
211
212     close $tf or die $!;
213     $_ = <GCF>;
214     defined $_ or die;
215     m/^(\w+) (\w+) (\d+)\n/ or die "$_ ?";
216     my $gitobjid = $1;
217     my $gitobjtype = $2;
218     my $bytes = $3;
219
220     my $gitobjdata;
221     if ($gitobjtype eq 'commit' or $gitobjtype eq 'tag') {
222         $!=0; read GCF, $gitobjdata, $bytes == $bytes
223             or die "$gitobjid $bytes $!";
224     }
225     close GCF;
226
227     $poldbh->do("INSERT INTO taints".
228                 " (package, gitobjid, gitobjtype, gitobjdata, time, comment)".
229                 " VALUES (?,?,?,?,?,?)", {},
230                 $pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);
231
232     my $taint_id = $poldbh->last_insert_id(undef,undef,"taints","taint_id");
233     die unless defined $taint_id;
234
235     $poldbh->do("INSERT INTO taintoverrides".
236                 " (taint_id, deliberately)".
237                 " VALUES (?, '--deliberately-include-questionable-history')", 
238                 {}, $taint_id);
239 }
240
241 sub add_taint_by_tag ($$) {
242     my ($tagname,$refobjid) = @_;
243     add_taint($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)");
247 }
248
249 sub check_package () {
250     return 0 unless $pkg_exists;
251     return 0 unless $pkg_secret;
252
253     printdebug "check_package\n";
254
255     chdir $pkgdir or die "$pkgdir $!";
256
257     stat '.' or die "$pkgdir $!";
258     my $mtime = ((stat _)[9]);
259     my $age = time -  $mtime;
260     printdebug "check_package age=$age\n";
261
262     if (good_suite_has_suitable_vsn(\&vsn_in_our_history)) {
263         chmod $publicmode, "." or die $!;
264         $pkg_secret = 0;
265         eval {
266             my $mirror_hook = "$distrodir/mirror-hook";
267             if (stat_exists $mirror_hook) {
268                 my @mirror_cmd =
269                     ($mirror_hook, $distrodir, "updated-hook", $pkg);
270                 debugcmd " (mirror)",@mirror_cmd;
271                 system @mirror_cmd and failedcmd @mirror_cmd;
272             }
273         };
274         if (length $@) {
275             chomp $@;
276             print STDERR "policy hook: warning:".
277                 " failed to mirror publication of \`$pkg':".
278                 " $@\n";
279         }
280         return 0;
281     }
282
283     return 0 if $age < $new_upload_propagation_slop;
284
285     return 0 if new_has_vsn_in_our_history();
286
287     printdebug "check_package secret, deleted, tainting\n";
288
289     git_for_each_ref('refs/tags', sub {
290         my ($objid,$objtype,$fullrefname,$tagname) = @_;
291         add_taint_by_tag($tagname,$objid);
292     });
293
294     return FRESHREPO;
295 }
296
297 sub action_check_package () {
298     getpackage();
299     return check_package();
300 }
301
302 sub getpushinfo () {
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;
310     }
311 }
312
313 sub deliberately ($) { return $deliberately{"--deliberately-$_[0]"}; }
314
315 sub action_push () {
316     getpackage();
317     getpushinfo();
318
319     check_package(); # might make package public, or might add taints
320
321     return 0 unless $pkg_exists;
322     return 0 unless $pkg_secret;
323
324     # we suppose that NEW has a version which is already in our
325     # history, as otherwise the repo would have been blown away
326
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;
333     }
334     if (deliberately('include-questionable-history')) {
335         return 0;
336     }
337     die <<END;
338
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.
344
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).
348
349 END
350 }
351
352 sub action_push_confirm () {
353     getpackage();
354     getpushinfo();
355     die unless @ARGV >= 1;
356     my $freshrepo = shift @ARGV;
357
358     my $initq = $poldbh->prepare(<<END);
359         SELECT taint_id, gitobjid FROM taints t
360             WHERE (package = ? OR package = '')
361 END
362     $initq->execute($pkg);
363
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;
368
369     my @taintids;
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;
375     }
376     flush $chkinput or die $!;
377     seek $chkinput,0,0 or die $!;
378
379     my $checkpid = open CHKOUT, "-|" // die $!;
380     if (!$checkpid) {
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 $!;
387     }
388
389     my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);
390
391     my $overridesstmt = <<END;
392         SELECT deliberately FROM taintoverrides WHERE (
393             1=0
394 END
395     my @overridesv = sort keys %deliberately;
396     $overridesstmt .= <<END foreach @overridesv;
397             OR deliberately = ?
398 END
399     $overridesstmt .= <<END;
400         ) AND taint_id = ?
401         ORDER BY deliberately ASC
402 END
403
404     my $mustreject=0;
405
406     while (my $taintid = shift @taintids) {
407         $!=0; $_ = <CHKOUT>;
408         die "($taintid @objscatcmd) $!" unless defined $_;
409         printdebug "|< ", $_ if $debuglevel>=2;
410
411         next if m/^\w+ missing$/;
412         die "($taintid @objscatcmd) $_ ?" unless m/^(\w+) (\w+) (\d+)\s/;
413         my ($objid,$objtype,$nbytes) = ($1,$2,$3);
414
415         my $drop;
416         (read CHKOUT, $drop, $nbytes) == $nbytes
417             or die "($taintid @objscatcmd) $!";
418
419         $!=0; $_ = <CHKOUT>;
420         die "($taintid @objscatcmd) $!" unless defined $_;
421         die "($taintid @objscatcmd) $_ ?" if m/\S/;
422
423         $taintinfoq ||= $poldbh->prepare(<<END);
424             SELECT package, time, comment FROM taints WHERE taint_id =  ?
425 END
426         $taintinfoq->execute($taintid);
427
428         my $ti = $taintinfoq->fetchrow_hashref();
429         die "($taintid)" unless $ti;
430
431         my $timeshow = defined $ti->{time}
432             ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->{time})
433             : "";
434         my $pkgshow = length $ti->{package}
435             ? "package $ti->{package}"
436             : "any package";
437
438         $stderr .= <<END;
439
440 History contains tainted $objtype $objid
441 Taint recorded$timeshow for $pkgshow
442 Reason: $ti->{comment}
443 END
444
445         printdebug "SQL overrides: @overridesv $taintid /\n$overridesstmt\n";
446
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
453 END
454             $overridesanyq->execute($taintid);
455             my ($ovany) = $overridesanyq->fetchrow_array();
456             $stderr .= $ovany ? <<END : <<END;
457 Could be forced using --deliberately.  Consult documentation.
458 END
459 Uncorrectable error.  If confused, consult administrator.
460 END
461             $mustreject = 1;
462         } else {
463             $stderr .= <<END;
464 Forcing due to $ovwhy
465 END
466             $untaintq ||= $poldbh->prepare(<<END);
467                 DELETE FROM taints WHERE taint_id = ?
468 END
469             $untaintq->execute($taintid);
470         }
471     }
472     close CHKOUT;
473
474     if ($mustreject) {
475         $stderr .= <<END;
476
477 Rejecting push due to questionable history.
478 END
479         return 1;
480     }
481
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 $!;
494         }
495     }
496
497     return 0;
498 }
499
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$/;
504         $pkg = $1;
505         statpackage();
506         next unless $pkg_exists;
507         next unless $pkg_secret;
508         print "$pkg\n" or die $!;
509     }
510     closedir L or die $!;
511     close STDOUT or die $!;
512     return 0;
513 }
514
515 $action =~ y/-/_/;
516 my $fn = ${*::}{"action_$action"};
517 if (!$fn) {
518     printdebug "dgit-repos-policy-debian: unknown action $action\n";
519     exit 0;
520 }
521
522 my $sleepy=0;
523 my $rcode;
524
525 my $db_busy_exception= 'Debian::Dgit::Policy::Debian::DB_BUSY';
526
527 my @orgargv = @ARGV;
528
529 for (;;) {
530     @ARGV = @orgargv;
531     eval {
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;
536             };
537
538             eval ($ENV{'DGIT_RPD_TEST_DBLOOP_HOOK'}//'');
539             die $@ if length $@;
540             # used by tests/tests/debpolicy-dbretry
541         });
542
543         $stderr = '';
544
545         $rcode = $fn->();
546         die unless defined $rcode;
547
548         $poldbh->commit;
549         printdebug "poldbh commit\n";
550     };
551     last unless length $@;
552     die $@ unless ref $@ eq $db_busy_exception;
553
554     die if $sleepy >= 20;
555     $sleepy++;
556     print STDERR "[policy database busy, retrying (${sleepy}s)]\n";
557
558     eval { $poldbh->rollback; };
559 }
560
561 print STDERR $stderr or die $!;
562 flush STDERR or die $!;
563 _exit $rcode;