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