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
  11 our $distro = shift @ARGV // die "need DISTRO";
  12 our $repos = shift @ARGV // die "need DGIT-REPOS-DIR";
  13 our $action = shift @ARGV // die "need ACTION";
  14
  15 our $publicmode = 02775;
  16 our $policydb = "dbi:SQLite:$repos/policy.sqlite3";
  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
  64 sub poldb_setup () {
  65     $poldbh ||= DBI->connect($policydb,'','', {
  66         RaiseError=>1, PrintError=>1, AutoCommit=>0
  67                            });
  68     $poldbh->do("PRAGMA foreign_keys = ON");
  69
  70     $poldbh->do(<<END);
  71         CREATE TABLE IF NOT EXISTS taints (
  72             taint_id   INTEGER NOT NULL PRIMARY KEY ASC AUTOINCREMENT,
  73             package    TEXT    NOT NULL,
  74             gitobjid   TEXT    NOT NULL,
  75             comment    TEXT    NOT NULL,
  76             time       INTEGER,
  77             gitobjtype TEXT,
  78             gitobjdata TEXT
  79             )
  80 END
  81     $poldbh->do(<<END);
  82         CREATE INDEX IF NOT EXISTS taints_by_package
  83             ON taints (package, gitobject)
  84 END
  85     # any one of of the listed deliberatelies will override its taint
  86     $poldbh->do(<<END);
  87         CREATE TABLE IF NOT EXISTS taintoverrides (
  88             taint_id  INTEGER NOT NULL
  89                       REFERENCES taints (taint_id)
  90                           ON UPDATE RESTRICT
  91                           ON DELETE CASCADE
  92                       DEFERRABLE INITIALLY DEFERRED,
  93             deliberately TEXT NOT NULL,
  94             PRIMARY KEY (taint_id, deliberately)
  95         )
  96 END
  97 }
  98
  99 sub apiquery ($) {
 100     my ($subpath) = @_;
 101     local $/=undef;
 102     $!=0; $?=0; my $json = `dgit -d $distro archive-api-query $subpath`;
 103     defined $json or die "$subpath $! $?";
 104     return decode_json $json;
 105 }
 106
 107 sub specific_suite_has_vsn_in_our_history ($) {
 108     my ($suite) = @_;
 109     my $in_new = apiquery "/dsc_in_suite/$suite/$pkg";
 110     foreach my $entry (@$in_new) {
 111         my $vsn = $entry->{version};
 112         die "$pkg ?" unless defined $vsn;
 113         my $tag = debiantag $vsn;
 114         $?=0; my $r = system qw(git show-ref --verify --quiet), $tag;
 115         return 1 if !$r;
 116         next if $r==256;
 117         die "$pkg tag $tag $? $!";
 118     }
 119     return 0;
 120 }
 121
 122 sub new_has_vsn_in_our_history () {
 123     stat $pkgdir or die "$pkgdir $!";
 124     my $mtime = ((stat _)[9]);
 125     my $age = time -  $mtime;
 126     return 1 if $age < $new_upload_propagation_slop;
 127     return specific_suite_has_vsn_in_our_history('new');
 128 }
 129
 130 sub good_suite_has_vsn_in_our_history () {
 131     my $suites = apiquery "/suites";
 132     foreach my $suitei (@$suites) {
 133         my $suite = $suitei->{name};
 134         die unless defined $suite;
 135         next if $suite =~ m/\bnew$/;
 136         return 1 if specific_suite_has_vsn_in_our_history($suite);
 137     }
 138     return 0;
 139 }
 140
 141 sub getpackage () {
 142     die unless @ARGV > 1;
 143     $pkg = shift @ARGV;
 144     die if $pkg =~ m#[^-+.0-9a-z]#;
 145     die unless $pkg =~ m#^[^-]#;
 146
 147     $pkgdir = "$repos/$pkg";
 148     if (!stat $pkgdir) {
 149         die "$pkgdir $!" unless $!==ENOENT;
 150         $pkg_exists = 0;
 151     }
 152     $pkg_exists = 1;
 153     $pkg_secret = !!(~(stat _)[2] & 05);
 154 }
 155
 156 sub add_taint ($$) {
 157     my ($refobj, $reason);
 158
 159     my $tf = new File::Temp or die $!;
 160     print $tf "$refobj^0\n" or die $!;
 161
 162     my $gcfpid = open GCF, "-|";
 163     defined $gcfpid or die $!;
 164     if (!$gcfpid) {
 165         open STDIN, "<&", $tf or die $!;
 166         exec 'git', 'cat-file';
 167         die $!;
 168     }
 169
 170     close $tf or die $!;
 171     $_ = <GCF>;
 172     m/^(\w+) (\w+) (\d+)\n/ or die "$objline ?";
 173     my $gitobjid = $1;
 174     my $gitobjtype = $2;
 175     my $bytes = $3;
 176
 177     my $gitobjdata;
 178     if ($gitobjtype eq 'commit' or $gitobjtype eq 'tag') {
 179         $!=0; read GCF, $gitobjdata, $bytes == $bytes
 180             or die "$gitobjid $bytes $!";
 181     }
 182     close GCF;
 183
 184     $poldbh->do("INSERT INTO taints".
 185                 " (package, gitobjid, gitobjtype, gitobjdata, time, comment)",
 186                 " VALUES (?,?,?,?,?,?)", {},
 187                 $pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);
 188
 189     my $taint_id = $poldbh->last_insert_id(undef,undef,"taints","taint_id");
 190     die unless defined $taint_id;
 191
 192     $poldbh->do("INSERT INTO taintoverrides".
 193                 " (taint_id, deliberately)",
 194                 " VALUES (?, 'include-questionable-history')", {},
 195                 $taint_id);
 196 }
 197
 198 sub add_taint_by_tag ($$) {
 199     my ($tagname,$refobjid) = @_;
 200     add_taint($refobjid,
 201               "tag $tagname referred to this object in git tree but all".
 202               " previously pushed versions were found to have been".
 203               " removed from NEW (ie, rejected) (or never arrived)");
 204 }
 205
 206 sub action__check_package () {
 207     getpackage();
 208     return 0 unless $pkg_exists;
 209     return 0 unless $pkg_secret;
 210
 211     chdir $pkgdir or die "$pkgdir $!";
 212     return if new_has_vsn_in_our_history();
 213
 214     if (good_suite_has_vsn_in_our_history) {
 215         chmod $publicmode, "." or die $!;
 216         return 0;
 217     }
 218
 219     git_for_each_ref('refs/tags', sub {
 220         my ($objid,$objtype,$fullrefname,$tagname) = @_;
 221         add_taint_by_tag($tagname,$refobjid);
 222     });
 223     $?=0; $!=0; close TAGL or die "git for-each-ref $? $!";
 224
 225     return FRESHREPO;
 226 }
 227
 228 sub getpushinfo () {
 229     die unless @ARGV >= 4;
 230     $version = shift @ARGV;
 231     $suite = shift @ARGV;
 232     $tagname = shift @ARGV;
 233     my $delibs = shift @ARGV;
 234     foreach my $delib (split /\,/, $delibs) {
 235         $deliberately{$delib} = 1;
 236     }
 237 }
 238
 239 sub deliberately ($) { return $deliberately{$_[0]}; }
 240
 241 sub action_push () {
 242     getpackage();
 243     return 0 unless $pkg_exists;
 244     return 0 unless $pkg_secret;
 245
 246     # we suppose that NEW has a version which is already in our
 247     # history, as otherwise the repo would have been blown away
 248
 249     if (deliberately('not-fast-forward')) {
 250         add_taint(server_ref($suite),
 251                   "suite $suite when --deliberately-not-fast-forward".
 252                   " specified in signed tag $tagname for upload of".
 253                   " version $version into suite $suite");
 254         return NOFFCHECK|FRESHREPO;
 255     }
 256     if (deliberately('include-questionable-history')) {
 257         return 0;
 258     }
 259     die "Package is in NEW and has not been accepted or rejected yet;".
 260         " use a --deliberately option to specify whether you are".
 261         " keeping or discarding the previously pushed history. ".
 262         " Please RTFM dgit(1).\n";
 263 }
 264
 265 sub action_push_confirm () {
 266     my $initq = $dbh->prepare(<<END);
 267         SELECT taint_id, gitobjid FROM taints t
 268             WHERE (package = ? OR package = '')
 269 END
 270     $initq->execute($pkg);
 271
 272     my @taintids;
 273     my $chkinput = tempfile();
 274     while (my $taint = $initq->fetchrow_hashref()) {
 275         push @taintids, $taint->{taint_id};
 276         print $chkinput, $taint->{gitobjid}, "\n" or die $!;
 277     }
 278     flush $chkinput or die $!;
 279     seek $chkinput,0,0 or die $!;
 280
 281     my $checkpid = open2("<&$chkinput", \*CHKOUT, qw(git cat-file --batch));
 282     $checkpid or die $!;
 283
 284     my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);
 285
 286     my $overridesstmt = <<END;
 287         SELECT deliberately FROM taintoverrides WHERE (
 288     my @overridesv = sort keys %deliberately;
 289     $overridesstmt .= join <<END, (<<END x @overridesv);
 290 END
 291             OR
 292 END
 293             deliberately = ?
 294 END
 295     $overridesstmt .= <<END;
 296         ) AND taint_id = ?
 297         ORDER BY deliberately ASC
 298 END
 299
 300     my $mustreject=0;
 301
 302     while (<CHKOUT>) {
 303         my $taintid = shift @taintids;
 304         die unless defined $taintid;
 305
 306         next if m/^\w+ missing$/;
 307         die unless m/^(\w+) (\s+) (\d+)\s/;
 308         my ($objid,$objtype,$nbytes) = @_;
 309
 310         read CHKOUT, $_, $nbytes == $bytes or last;
 311
 312         $taintinfoq ||= $dbh->prepare(<<END);
 313             SELECT package, time, comment FROM taints WHERE taint_id =  ?
 314 END
 315         $taintinfoq->execute($taintid);
 316
 317         my $ti = $taintinfoq->fetchrow_hashref();
 318         die unless $ti;
 319
 320         my $timeshow = defined $ti->{time}
 321             ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->time)
 322             : "";
 323         my $pkgshow = length $ti->{package}
 324             ? "package $ti->{package}"
 325             : "any package";
 326
 327         $stderr .= <<END;
 328
 329 History contains tainted $objtype $objid
 330 Taint recorded$timeshow for $pkginfo
 331 Reason: $ti->{comment}
 332 END
 333
 334         $overridesq ||= $dbh->prepare($overridesstmt);
 335         $overridesq->execute(@overridesv, $taintid);
 336         my ($ovwhy) = $overridesq->fetchrow_array();
 337         if (!defined $ovwhy) {
 338             $overridesanyq ||= $dbh->prepare(<<END);
 339                 SELECT 1 FROM taintoverrides WHERE taint_id = ? LIMIT 1
 340 END
 341             $overridesanyq->execute($taintid);
 342             my ($ovany) = $overridesanyq->fetchrow_array();
 343             $stderr .= $ovany ? <<END : <<END;
 344 Could be forced using --deliberately.  Consult documentation.
 345 END
 346 Uncorrectable error.  If confused, consult administrator.
 347 END
 348             $mustreject = 1;
 349         } else {
 350             $stderr .= <<END;
 351 Forcing due to --deliberately-$ovwhy
 352 END
 353             $untaintq ||= $dbh->prepare(<<END);
 354                 DELETE FROM taints WHERE taint_id = ?
 355 END
 356             $untaintq->execute($taint_id);
 357         }
 358     }
 359     if (@taintids) {
 360         $?=0; my $gotpid = waitpid $checkpid, WNOHANG;
 361         die "@taintids $gotpid $? $!";
 362     }
 363
 364     if ($mustreject) {
 365         $stderr .= <<END;
 366
 367 Rejecting push due to questionable history.
 368 END
 369         return 1;
 370     }
 371
 372     return 0;
 373 }
 374
 375 $cmd =~ y/-/_/;
 376 my $fn = ${*::}{"action__$cmd"};
 377 if (!$fn) {
 378     exit 0;
 379 }
 380
 381 my $sleepy=0;
 382
 383 for (;;) {
 384     poldb_setup();
 385     $stderr = '';
 386
 387     my $rcode = $fn->();
 388     die unless defined $rcode;
 389
 390     eval { $poldbh->commit; };
 391     last unless length $@;
 392
 393     die if $sleepy >= 20;
 394     print STDERR "[policy database busy, retrying]\n";
 395     sleep ++$sleepy;
 396
 397     $poldbh->rollback;
 398 }
 399
 400 print STDERR $stderr;
 401 exit $rcode;