infra/dgit-repos-policy-debian

   1 #!/usr/bin/perl -w
   2 # dgit repos policy hook script for Debian
   3
   4 use strict;
   5 use POSIX;
   6 use JSON;
   7 use File::Temp;
   8
   9 use Debian::Dgit qw(:DEFAULT :policyflags);
  10 use Debian::Dgit::Policy::Debian;
  11
  12 our $distro = shift @ARGV // die "need DISTRO";
  13 our $repos = shift @ARGV // die "need DGIT-REPOS-DIR";
  14 our $action = shift @ARGV // die "need ACTION";
  15
  16 our $publicmode = 02775;
  17 our $new_upload_propagation_slop = 3600*4 + 100;
  18
  19 our $poldbh;
  20 our $pkg;
  21 our $pkgdir;
  22 our ($pkg_exists,$pkg_secret);
  23
  24 our $stderr;
  25
  26 our ($version,$suite,$tagname);
  27 our %deliberately;
  28
  29 # We assume that it is not possible for NEW to have a version older
  30 # than sid.
  31
  32 # Whenever pushing, we check for
  33 #   source-package-local tainted history
  34 #   global tainted history
  35 #   can be overridden by --deliberately except for an admin prohib taint
  36 #
  37 # ALL of the following apply only if history is secret:
  38 #
  39 # if NEW has no version, or a version which is not in our history[1]
  40 #   (always)
  41 #   check all suites
  42 #   if any suite's version is in our history[1], publish our history
  43 #   otherwise discard our history,
  44 #     tainting --deliberately-include-questionable-history
  45 #
  46 # if NEW has a version which is in our history[1]
  47 #   (on push only)
  48 #   require explicit specification of one of
  49 #     --deliberately-include-questionable-history
  50 #     --deliberately-not-fast-forward
  51 #       (latter will taint old NEW version --d-i-q-h)
  52 #   (otherwise)
  53 #   leave it be
  54 #
  55 # [1] looking for the relevant git tag for the version number and not
  56 #    caring what that tag refers to.
  57 #
  58 # A wrinkle: if we approved a push recently, we treat NEW as having
  59 # a version which is in our history.  This is because the package may
  60 # still be being uploaded.  (We record this using the timestamp of the
  61 # package's git repo directory.)
  62
  63 # We aim for the following invariants and properties:
  64 #
  65 # - .dsc of published dgit package will have corresponding publicly
  66 #   visible dgit-repo (soon)
  67 #
  68 # - when a new package is rejected we help maintainer avoid
  69 #   accidentally including bad objects in published dgit history
  70 #
  71 # - .dsc of NEW dgit package has corresponding dgit-repo but not
  72 #   publicly readable
  73
  74 sub apiquery ($) {
  75     my ($subpath) = @_;
  76     local $/=undef;
  77     $!=0; $?=0; my $json = `dgit -d $distro archive-api-query $subpath`;
  78     defined $json or die "$subpath $! $?";
  79     return decode_json $json;
  80 }
  81
  82 sub specific_suite_has_vsn_in_our_history ($) {
  83     my ($suite) = @_;
  84     my $in_suite = apiquery "/dsc_in_suite/$suite/$pkg";
  85     foreach my $entry (@$in_suite) {
  86         my $vsn = $entry->{version};
  87         die "$pkg ?" unless defined $vsn;
  88         my $tag = debiantag $vsn;
  89         $?=0; my $r = system qw(git show-ref --verify --quiet), $tag;
  90         return 1 if !$r;
  91         next if $r==256;
  92         die "$pkg tag $tag $? $!";
  93     }
  94     return 0;
  95 }
  96
  97 sub new_has_vsn_in_our_history () {
  98     stat $pkgdir or die "$pkgdir $!";
  99     my $mtime = ((stat _)[9]);
 100     my $age = time -  $mtime;
 101     return 1 if $age < $new_upload_propagation_slop;
 102     return specific_suite_has_vsn_in_our_history('new');
 103 }
 104
 105 sub good_suite_has_vsn_in_our_history () {
 106     my $suites = apiquery "/suites";
 107     foreach my $suitei (@$suites) {
 108         my $suite = $suitei->{name};
 109         die unless defined $suite;
 110         next if $suite =~ m/\bnew$/;
 111         return 1 if specific_suite_has_vsn_in_our_history($suite);
 112     }
 113     return 0;
 114 }
 115
 116 sub getpackage () {
 117     die unless @ARGV > 1;
 118     $pkg = shift @ARGV;
 119     die if $pkg =~ m#[^-+.0-9a-z]#;
 120     die unless $pkg =~ m#^[^-]#;
 121
 122     $pkgdir = "$repos/$pkg";
 123     if (!stat $pkgdir) {
 124         die "$pkgdir $!" unless $!==ENOENT;
 125         $pkg_exists = 0;
 126     }
 127     $pkg_exists = 1;
 128     $pkg_secret = !!(~(stat _)[2] & 05);
 129 }
 130
 131 sub add_taint ($$) {
 132     my ($refobj, $reason);
 133
 134     my $tf = new File::Temp or die $!;
 135     print $tf "$refobj^0\n" or die $!;
 136
 137     my $gcfpid = open GCF, "-|";
 138     defined $gcfpid or die $!;
 139     if (!$gcfpid) {
 140         open STDIN, "<&", $tf or die $!;
 141         exec 'git', 'cat-file';
 142         die $!;
 143     }
 144
 145     close $tf or die $!;
 146     $_ = <GCF>;
 147     m/^(\w+) (\w+) (\d+)\n/ or die "$objline ?";
 148     my $gitobjid = $1;
 149     my $gitobjtype = $2;
 150     my $bytes = $3;
 151
 152     my $gitobjdata;
 153     if ($gitobjtype eq 'commit' or $gitobjtype eq 'tag') {
 154         $!=0; read GCF, $gitobjdata, $bytes == $bytes
 155             or die "$gitobjid $bytes $!";
 156     }
 157     close GCF;
 158
 159     $poldbh->do("INSERT INTO taints".
 160                 " (package, gitobjid, gitobjtype, gitobjdata, time, comment)",
 161                 " VALUES (?,?,?,?,?,?)", {},
 162                 $pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);
 163
 164     my $taint_id = $poldbh->last_insert_id(undef,undef,"taints","taint_id");
 165     die unless defined $taint_id;
 166
 167     $poldbh->do("INSERT INTO taintoverrides".
 168                 " (taint_id, deliberately)",
 169                 " VALUES (?, 'include-questionable-history')", {},
 170                 $taint_id);
 171 }
 172
 173 sub add_taint_by_tag ($$) {
 174     my ($tagname,$refobjid) = @_;
 175     add_taint($refobjid,
 176               "tag $tagname referred to this object in git tree but all".
 177               " previously pushed versions were found to have been".
 178               " removed from NEW (ie, rejected) (or never arrived)");
 179 }
 180
 181 sub action__check_package () {
 182     getpackage();
 183     return 0 unless $pkg_exists;
 184     return 0 unless $pkg_secret;
 185
 186     chdir $pkgdir or die "$pkgdir $!";
 187     return if new_has_vsn_in_our_history();
 188
 189     if (good_suite_has_vsn_in_our_history) {
 190         chmod $publicmode, "." or die $!;
 191         return 0;
 192     }
 193
 194     git_for_each_ref('refs/tags', sub {
 195         my ($objid,$objtype,$fullrefname,$tagname) = @_;
 196         add_taint_by_tag($tagname,$refobjid);
 197     });
 198     $?=0; $!=0; close TAGL or die "git for-each-ref $? $!";
 199
 200     return FRESHREPO;
 201 }
 202
 203 sub getpushinfo () {
 204     die unless @ARGV >= 4;
 205     $version = shift @ARGV;
 206     $suite = shift @ARGV;
 207     $tagname = shift @ARGV;
 208     my $delibs = shift @ARGV;
 209     foreach my $delib (split /\,/, $delibs) {
 210         $deliberately{$delib} = 1;
 211     }
 212 }
 213
 214 sub deliberately ($) { return $deliberately{$_[0]}; }
 215
 216 sub action_push () {
 217     getpackage();
 218     return 0 unless $pkg_exists;
 219     return 0 unless $pkg_secret;
 220
 221     # we suppose that NEW has a version which is already in our
 222     # history, as otherwise the repo would have been blown away
 223
 224     if (deliberately('not-fast-forward')) {
 225         add_taint(server_ref($suite),
 226                   "suite $suite when --deliberately-not-fast-forward".
 227                   " specified in signed tag $tagname for upload of".
 228                   " version $version into suite $suite");
 229         return NOFFCHECK|FRESHREPO;
 230     }
 231     if (deliberately('include-questionable-history')) {
 232         return 0;
 233     }
 234     die "Package is in NEW and has not been accepted or rejected yet;".
 235         " use a --deliberately option to specify whether you are".
 236         " keeping or discarding the previously pushed history. ".
 237         " Please RTFM dgit(1).\n";
 238 }
 239
 240 sub action_push_confirm () {
 241     my $initq = $dbh->prepare(<<END);
 242         SELECT taint_id, gitobjid FROM taints t
 243             WHERE (package = ? OR package = '')
 244 END
 245     $initq->execute($pkg);
 246
 247     my @taintids;
 248     my $chkinput = tempfile();
 249     while (my $taint = $initq->fetchrow_hashref()) {
 250         push @taintids, $taint->{taint_id};
 251         print $chkinput, $taint->{gitobjid}, "\n" or die $!;
 252     }
 253     flush $chkinput or die $!;
 254     seek $chkinput,0,0 or die $!;
 255
 256     my $checkpid = open2("<&$chkinput", \*CHKOUT, qw(git cat-file --batch));
 257     $checkpid or die $!;
 258
 259     my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);
 260
 261     my $overridesstmt = <<END;
 262         SELECT deliberately FROM taintoverrides WHERE (
 263     my @overridesv = sort keys %deliberately;
 264     $overridesstmt .= join <<END, (<<END x @overridesv);
 265 END
 266             OR
 267 END
 268             deliberately = ?
 269 END
 270     $overridesstmt .= <<END;
 271         ) AND taint_id = ?
 272         ORDER BY deliberately ASC
 273 END
 274
 275     my $mustreject=0;
 276
 277     while (<CHKOUT>) {
 278         my $taintid = shift @taintids;
 279         die unless defined $taintid;
 280
 281         next if m/^\w+ missing$/;
 282         die unless m/^(\w+) (\s+) (\d+)\s/;
 283         my ($objid,$objtype,$nbytes) = @_;
 284
 285         read CHKOUT, $_, $nbytes == $bytes or last;
 286
 287         $taintinfoq ||= $dbh->prepare(<<END);
 288             SELECT package, time, comment FROM taints WHERE taint_id =  ?
 289 END
 290         $taintinfoq->execute($taintid);
 291
 292         my $ti = $taintinfoq->fetchrow_hashref();
 293         die unless $ti;
 294
 295         my $timeshow = defined $ti->{time}
 296             ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->time)
 297             : "";
 298         my $pkgshow = length $ti->{package}
 299             ? "package $ti->{package}"
 300             : "any package";
 301
 302         $stderr .= <<END;
 303
 304 History contains tainted $objtype $objid
 305 Taint recorded$timeshow for $pkginfo
 306 Reason: $ti->{comment}
 307 END
 308
 309         $overridesq ||= $dbh->prepare($overridesstmt);
 310         $overridesq->execute(@overridesv, $taintid);
 311         my ($ovwhy) = $overridesq->fetchrow_array();
 312         if (!defined $ovwhy) {
 313             $overridesanyq ||= $dbh->prepare(<<END);
 314                 SELECT 1 FROM taintoverrides WHERE taint_id = ? LIMIT 1
 315 END
 316             $overridesanyq->execute($taintid);
 317             my ($ovany) = $overridesanyq->fetchrow_array();
 318             $stderr .= $ovany ? <<END : <<END;
 319 Could be forced using --deliberately.  Consult documentation.
 320 END
 321 Uncorrectable error.  If confused, consult administrator.
 322 END
 323             $mustreject = 1;
 324         } else {
 325             $stderr .= <<END;
 326 Forcing due to --deliberately-$ovwhy
 327 END
 328             $untaintq ||= $dbh->prepare(<<END);
 329                 DELETE FROM taints WHERE taint_id = ?
 330 END
 331             $untaintq->execute($taint_id);
 332         }
 333     }
 334     if (@taintids) {
 335         $?=0; my $gotpid = waitpid $checkpid, WNOHANG;
 336         die "@taintids $gotpid $? $!";
 337     }
 338
 339     if ($mustreject) {
 340         $stderr .= <<END;
 341
 342 Rejecting push due to questionable history.
 343 END
 344         return 1;
 345     }
 346
 347     return 0;
 348 }
 349
 350 $cmd =~ y/-/_/;
 351 my $fn = ${*::}{"action__$cmd"};
 352 if (!$fn) {
 353     exit 0;
 354 }
 355
 356 my $sleepy=0;
 357
 358 for (;;) {
 359     poldb_setup(poldb_path($repos));
 360     $stderr = '';
 361
 362     my $rcode = $fn->();
 363     die unless defined $rcode;
 364
 365     eval { $poldbh->commit; };
 366     last unless length $@;
 367
 368     die if $sleepy >= 20;
 369     print STDERR "[policy database busy, retrying]\n";
 370     sleep ++$sleepy;
 371
 372     $poldbh->rollback;
 373 }
 374
 375 print STDERR $stderr;
 376 exit $rcode;