infra/dgit-repos-policy-debian

   1 #!/usr/bin/perl -w
   2 # dgit repos policy hook script for Debian
   3 #
   4 # Copyright (C) 2015-2016  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 --deliberately-$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     };
 550     last unless length $@;
 551     die $@ unless ref $@ eq $db_busy_exception;
 552
 553     die if $sleepy >= 20;
 554     $sleepy++;
 555     print STDERR "[policy database busy, retrying (${sleepy}s)]\n";
 556
 557     eval { $poldbh->rollback; };
 558 }
 559
 560 print STDERR $stderr or die $!;
 561 flush STDERR or die $!;
 562 _exit $rcode;