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