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