summaryrefslogtreecommitdiff
path: root/infra/dgit-repos-policy-debian
blob: a0ac51916027d74e481cad34a47c80a04d2776ae (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
#!/usr/bin/perl -w
# dgit repos policy hook script for Debian

use strict;
$SIG{__WARN__} = sub { die $_[0]; };

use POSIX;
use JSON;
use File::Temp qw(tempfile);
use DBI;
use IPC::Open2;
use Data::Dumper;

use Debian::Dgit qw(:DEFAULT :policyflags);
use Debian::Dgit::Policy::Debian;

initdebug('%');
enabledebuglevel $ENV{'DGIT_DRS_DEBUG'};

END { $? = 127; } # deliberate exit uses _exit

our $distro = shift @ARGV // die "need DISTRO";
our $repos = shift @ARGV // die "need DGIT-REPOS-DIR";
our $dgitlive = shift @ARGV // die "need DGIT-LIVE-DIR";
our $distrodir = shift @ARGV // die "need DISTRO-DIR";
our $action = shift @ARGV // die "need ACTION";

our $publicmode = 02775;
our $new_upload_propagation_slop = 3600*4 + 100;# fixme config;

our $poldbh;
our $pkg;
our $pkgdir;
our ($pkg_exists,$pkg_secret);

our $stderr;

our ($version,$suite,$tagname);
our %deliberately;

# We assume that it is not possible for NEW to have a version older
# than sid.

# Whenever pushing, we check for
#   source-package-local tainted history
#   global tainted history
#   can be overridden by --deliberately except for an admin prohib taint
# 
# ALL of the following apply only if history is secret:
# 
# if NEW has no version, or a version which is not in our history[1]
#   (always)
#   check all suites
#   if any suite's version is in our history[1], publish our history
#   otherwise discard our history,
#     tainting --deliberately-include-questionable-history
# 
# if NEW has a version which is in our history[1]
#   (on push only)
#   require explicit specification of one of
#     --deliberately-include-questionable-history
#     --deliberately-not-fast-forward
#       (latter will taint old NEW version --d-i-q-h)
#   (otherwise)
#   leave it be
# 
# [1] looking for the relevant git tag for the version number and not
#    caring what that tag refers to.
#
# A wrinkle: if we approved a push recently, we treat NEW as having
# a version which is in our history.  This is because the package may
# still be being uploaded.  (We record this using the timestamp of the
# package's git repo directory.)

# We aim for the following invariants and properties:
#
# - .dsc of published dgit package will have corresponding publicly
#   visible dgit-repo (soon)
#
# - when a new package is rejected we help maintainer avoid
#   accidentally including bad objects in published dgit history
#
# - .dsc of NEW dgit package has corresponding dgit-repo but not
#   publicly readable

sub apiquery ($) {
    my ($subpath) = @_;
    local $/=undef;
    my $dgit = "$dgitlive/dgit";
    $dgit = "dgit" if !stat_exists $dgit;
    my $cmd = "$dgit -d$distro \$DGIT_TEST_OPTS";
    $cmd .= " -".("D" x $debuglevel) if $debuglevel;
    $cmd .= " archive-api-query $subpath";
    printdebug "apiquery $cmd\n";
    $!=0; $?=0; my $json = `$cmd`;
    defined $json && !$? or die "$subpath $! $?";
    my $r = decode_json $json;
    my $d = new Data::Dumper([$r], [qw(r)]);
    printdebug "apiquery $subpath | ", $d->Dump() if $debuglevel>=2;
    return $r;
}

sub specific_suite_has_vsn_in_our_history ($) {
    my ($suite) = @_;
    my $in_suite = apiquery "dsc_in_suite/$suite/$pkg";
    foreach my $entry (@$in_suite) {
	my $vsn = $entry->{version};
	die "$pkg ?" unless defined $vsn;
	my $tagref = "refs/tags/".debiantag $vsn, $distro;
	printdebug " checking history suite=$suite vsn=$vsn tagref=$tagref\n";
	$?=0; my $r = system qw(git show-ref --verify --quiet), $tagref;
	return 1 if !$r;
	next if $r==256;
	die "$pkg tagref $tagref $? $!";
    }
    return 0;
}

sub new_has_vsn_in_our_history () {
    return specific_suite_has_vsn_in_our_history('new');
}

sub good_suite_has_vsn_in_our_history () {
    my $suites = apiquery "suites";
    foreach my $suitei (@$suites) {
	my $suite = $suitei->{name};
	die unless defined $suite;
	next if $suite =~ m/\bnew$/;
	return 1 if specific_suite_has_vsn_in_our_history($suite);
    }
    return 0;
}

sub statpackage () {
    $pkgdir = "$repos/$pkg.git";
    if (!stat_exists $pkgdir) {
	printdebug "statpackage $pkg => ENOENT\n";
	$pkg_exists = 0;
    } else {
	$pkg_exists = 1;
	$pkg_secret = !!(~(stat _)[2] & 05);
	printdebug "statpackage $pkg => exists, secret=$pkg_secret.\n";
    }
}

sub getpackage () {
    die unless @ARGV >= 1;
    $pkg = shift @ARGV;
    die unless $pkg =~ m/^$package_re$/;

    statpackage();
}

sub add_taint ($$) {
    my ($refobj, $reason) = @_;

    printdebug "TAINTING $refobj\n",
        (map { "\%| $_" } split "\n", $reason),
        "\n";

    my $tf = new File::Temp or die $!;
    print $tf "$refobj^0\n" or die $!;
    flush $tf or die $!;
    seek $tf,0,0 or die $!;

    my $gcfpid = open GCF, "-|";
    defined $gcfpid or die $!;
    if (!$gcfpid) {
	open STDIN, "<&", $tf or die $!;
	exec 'git', 'cat-file', '--batch';
	die $!;
    }

    close $tf or die $!;
    $_ = <GCF>;
    defined $_ or die;
    m/^(\w+) (\w+) (\d+)\n/ or die "$_ ?";
    my $gitobjid = $1;
    my $gitobjtype = $2;
    my $bytes = $3;

    my $gitobjdata;
    if ($gitobjtype eq 'commit' or $gitobjtype eq 'tag') {
	$!=0; read GCF, $gitobjdata, $bytes == $bytes
	    or die "$gitobjid $bytes $!";
    }
    close GCF;

    $poldbh->do("INSERT INTO taints".
		" (package, gitobjid, gitobjtype, gitobjdata, time, comment)".
		" VALUES (?,?,?,?,?,?)", {},
		$pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);

    my $taint_id = $poldbh->last_insert_id(undef,undef,"taints","taint_id");
    die unless defined $taint_id;

    $poldbh->do("INSERT INTO taintoverrides".
		" (taint_id, deliberately)".
		" VALUES (?, '--deliberately-include-questionable-history')", 
		{}, $taint_id);
}

sub add_taint_by_tag ($$) {
    my ($tagname,$refobjid) = @_;
    add_taint($refobjid,
	      "tag $tagname referred to this object in git tree but all".
	      " previously pushed versions were found to have been".
	      " removed from NEW (ie, rejected) (or never arrived)");
}

sub check_package () {
    return 0 unless $pkg_exists;
    return 0 unless $pkg_secret;

    printdebug "check_package\n";

    chdir $pkgdir or die "$pkgdir $!";

    stat '.' or die "$pkgdir $!";
    my $mtime = ((stat _)[9]);
    my $age = time -  $mtime;
    printdebug "check_package age=$age\n";

    if (good_suite_has_vsn_in_our_history) {
	chmod $publicmode, "." or die $!;
	$pkg_secret = 0;
	return 0;
    }

    return 0 if $age < $new_upload_propagation_slop;

    return 0 if new_has_vsn_in_our_history();

    printdebug "check_package secret, deleted, tainting\n";

    git_for_each_ref('refs/tags', sub {
	my ($objid,$objtype,$fullrefname,$tagname) = @_;
	add_taint_by_tag($tagname,$objid);
    });

    return FRESHREPO;
}

sub action_check_package () {
    getpackage();
    return check_package();
}

sub getpushinfo () {
    die unless @ARGV >= 4;
    $version = shift @ARGV;
    $suite = shift @ARGV;
    $tagname = shift @ARGV;
    my $delibs = shift @ARGV;
    foreach my $delib (split /\,/, $delibs) {
	$deliberately{$delib} = 1;
    }
}

sub deliberately ($) { return $deliberately{"--deliberately-$_[0]"}; }

sub action_push () {
    getpackage();
    getpushinfo();

    check_package(); # might make package public, or might add taints

    return 0 unless $pkg_exists;
    return 0 unless $pkg_secret;

    # we suppose that NEW has a version which is already in our
    # history, as otherwise the repo would have been blown away

    if (deliberately('not-fast-forward')) {
	add_taint(server_ref($suite),
		  "rewound suite $suite; --deliberately-not-fast-forward".
		  " specified in signed tag $tagname for upload of".
		  " version $version");
	return NOFFCHECK|FRESHREPO;
    }
    if (deliberately('include-questionable-history')) {
	return 0;
    }
    die "\nPackage is in NEW and has not been accepted or rejected yet;".
	" use a --deliberately option to specify whether you are".
	" keeping or discarding the previously pushed history. ".
	" Please RTFM dgit(1).\n\n";
}

sub action_push_confirm () {
    getpackage();
    getpushinfo();
    die unless @ARGV >= 1;
    my $freshrepo = shift @ARGV;

    my $initq = $poldbh->prepare(<<END);
        SELECT taint_id, gitobjid FROM taints t
            WHERE (package = ? OR package = '')
END
    $initq->execute($pkg);

    my @objscatcmd = qw(git);
    push @objscatcmd, qw(--git-dir), $freshrepo if length $freshrepo;
    push @objscatcmd, qw(cat-file --batch);
    debugcmd '|',@objscatcmd if $debuglevel>=2;

    my @taintids;
    my $chkinput = tempfile();
    while (my $taint = $initq->fetchrow_hashref()) {
	push @taintids, $taint->{taint_id};
	print $chkinput $taint->{gitobjid}, "\n" or die $!;
	printdebug '|> ', $taint->{gitobjid}, "\n" if $debuglevel>=2;
    }
    flush $chkinput or die $!;
    seek $chkinput,0,0 or die $!;

    my $checkpid = open CHKOUT, "-|" // die $!;
    if (!$checkpid) {
	open STDIN, "<&", $chkinput or die $!;
	exec @objscatcmd or die $!;
    }

    my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);

    my $overridesstmt = <<END;
        SELECT deliberately FROM taintoverrides WHERE (
            1=0
END
    my @overridesv = sort keys %deliberately;
    $overridesstmt .= <<END foreach @overridesv;
            OR deliberately = ?
END
    $overridesstmt .= <<END;
	) AND taint_id = ?
        ORDER BY deliberately ASC
END

    my $mustreject=0;

    while (my $taintid = shift @taintids) {
	# git cat-file prints a spurious newline after it gets EOF
	# This is not documented.  I guess it might go away.  So we
	# just read what we expect and then let it get SIGPIPE.
	$!=0; $_ = <CHKOUT>;
	die "$? $!" unless defined $_;
	printdebug "|< ", $_ if $debuglevel>=2;

	next if m/^\w+ missing$/;
	die unless m/^(\w+) (\w+) (\d+)\s/;
	my ($objid,$objtype,$nbytes) = ($1,$2,$3);

	my $drop;
	(read CHKOUT, $drop, $nbytes) == $nbytes or die;

	$taintinfoq ||= $poldbh->prepare(<<END);
            SELECT package, time, comment FROM taints WHERE taint_id =  ?
END
        $taintinfoq->execute($taintid);

	my $ti = $taintinfoq->fetchrow_hashref();
	die unless $ti;

	my $timeshow = defined $ti->{time}
	    ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->{time})
	    : "";
	my $pkgshow = length $ti->{package}
	    ? "package $ti->{package}"
	    : "any package";

	$stderr .= <<END;

History contains tainted $objtype $objid
Taint recorded$timeshow for $pkgshow
Reason: $ti->{comment}
END

        printdebug "SQL overrides: @overridesv $taintid /\n$overridesstmt\n";

        $overridesq ||= $poldbh->prepare($overridesstmt);
	$overridesq->execute(@overridesv, $taintid);
	my ($ovwhy) = $overridesq->fetchrow_array();
	if (!defined $ovwhy) {
	    $overridesanyq ||= $poldbh->prepare(<<END);
	        SELECT 1 FROM taintoverrides WHERE taint_id = ? LIMIT 1
END
	    $overridesanyq->execute($taintid);
	    my ($ovany) = $overridesanyq->fetchrow_array();
	    $stderr .= $ovany ? <<END : <<END;
Could be forced using --deliberately.  Consult documentation.
END
Uncorrectable error.  If confused, consult administrator.
END
            $mustreject = 1;
	} else {
	    $stderr .= <<END;
Forcing due to --deliberately-$ovwhy
END
            $untaintq ||= $poldbh->prepare(<<END);
                DELETE FROM taints WHERE taint_id = ?
END
            $untaintq->execute($taintid);
        }
    }
    close CHKOUT;

    if ($mustreject) {
	$stderr .= <<END;

Rejecting push due to questionable history.
END
        return 1;
    }

    if (length $freshrepo) {
	if (!good_suite_has_vsn_in_our_history()) {
	    stat $freshrepo or die "$freshrepo $!";
	    my $oldmode = ((stat _)[2]);
	    my $oldwrites = $oldmode & 0222;
	    # remove r and x bits which have corresponding w bits clear
	    my $newmode = $oldmode &
		(~0555 | ($oldwrites << 1) | ($oldwrites >> 1));
	    printdebug sprintf "chmod %#o (was %#o) %s\n",
	        $newmode, $oldmode, $freshrepo;
	    chmod $newmode, $freshrepo or die $!;
	    utime undef, undef, $freshrepo or die $!;
	}
    }

    return 0;
}

sub action_check_list () {
    opendir L, "$repos" or die "$repos $!";
    while (defined (my $dent = readdir L)) {
	next unless $dent =~ m/^($package_re)\.git$/;
	$pkg = $1;
	statpackage();
	next unless $pkg_exists;
	next unless $pkg_secret;
	print "$pkg\n" or die $!;
    }
    closedir L or die $!;
    close STDOUT or die $!;
    return 0;
}

$action =~ y/-/_/;
my $fn = ${*::}{"action_$action"};
if (!$fn) {
    printdebug "dgit-repos-policy-debian: unknown action $action\n";
    exit 0;
}

my $sleepy=0;
my $rcode;

my $db_busy_exception= 'Debian::Dgit::Policy::Debian::DB_BUSY';

my @orgargv = @ARGV;

for (;;) {
    @ARGV = @orgargv;
    eval {
	poldb_setup(poldb_path($repos), sub {
	    $poldbh->{HandleError} = sub {
		return 0 unless $poldbh->err == 5; # SQLITE_BUSY, not in .pm :-(
		die bless { }, $db_busy_exception;
	    };

	    eval ($ENV{'DGIT_RPD_TEST_DBLOOP_HOOK'}//'');
	    die $@ if length $@;
	    # used by tests/tests/debpolicy-dbretry
        });

	$stderr = '';

	$rcode = $fn->();
	die unless defined $rcode;

	$poldbh->commit;
    };
    last unless length $@;
    die $@ unless ref $@ eq $db_busy_exception;

    die if $sleepy >= 20;
    $sleepy++;
    print STDERR "[policy database busy, retrying (${sleepy}s)]\n";

    eval { $poldbh->rollback; };
}

print STDERR $stderr or die $!;
flush STDERR or die $!;
_exit $rcode;