2 # dgit repos policy hook script for Debian
9 use Debian::Dgit qw(:DEFAULT :policyflags);
10 use Debian::Dgit::Policy::Debian;
12 our $distro = shift @ARGV // die "need DISTRO";
13 our $repos = shift @ARGV // die "need DGIT-REPOS-DIR";
14 our $action = shift @ARGV // die "need ACTION";
16 our $publicmode = 02775;
17 our $new_upload_propagation_slop = 3600*4 + 100;
22 our ($pkg_exists,$pkg_secret);
26 our ($version,$suite,$tagname);
29 # We assume that it is not possible for NEW to have a version older
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
37 # ALL of the following apply only if history is secret:
39 # if NEW has no version, or a version which is not in our history[1]
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
46 # if NEW has a version which is in our history[1]
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)
55 # [1] looking for the relevant git tag for the version number and not
56 # caring what that tag refers to.
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.)
63 # We aim for the following invariants and properties:
65 # - .dsc of published dgit package will have corresponding publicly
66 # visible dgit-repo (soon)
68 # - when a new package is rejected we help maintainer avoid
69 # accidentally including bad objects in published dgit history
71 # - .dsc of NEW dgit package has corresponding dgit-repo but not
77 $!=0; $?=0; my $json = `dgit -d $distro archive-api-query $subpath`;
78 defined $json or die "$subpath $! $?";
79 return decode_json $json;
82 sub specific_suite_has_vsn_in_our_history ($) {
84 my $in_suite = apiquery "/dsc_in_suite/$suite/$pkg";
85 foreach my $entry (@$in_suite) {
86 my $vsn = $entry->{version};
87 die "$pkg ?" unless defined $vsn;
88 my $tag = debiantag $vsn;
89 $?=0; my $r = system qw(git show-ref --verify --quiet), $tag;
92 die "$pkg tag $tag $? $!";
97 sub new_has_vsn_in_our_history () {
98 stat $pkgdir or die "$pkgdir $!";
99 my $mtime = ((stat _)[9]);
100 my $age = time - $mtime;
101 return 1 if $age < $new_upload_propagation_slop;
102 return specific_suite_has_vsn_in_our_history('new');
105 sub good_suite_has_vsn_in_our_history () {
106 my $suites = apiquery "/suites";
107 foreach my $suitei (@$suites) {
108 my $suite = $suitei->{name};
109 die unless defined $suite;
110 next if $suite =~ m/\bnew$/;
111 return 1 if specific_suite_has_vsn_in_our_history($suite);
117 die unless @ARGV > 1;
119 die if $pkg =~ m#[^-+.0-9a-z]#;
120 die unless $pkg =~ m#^[^-]#;
122 $pkgdir = "$repos/$pkg";
124 die "$pkgdir $!" unless $!==ENOENT;
128 $pkg_secret = !!(~(stat _)[2] & 05);
132 my ($refobj, $reason);
134 my $tf = new File::Temp or die $!;
135 print $tf "$refobj^0\n" or die $!;
137 my $gcfpid = open GCF, "-|";
138 defined $gcfpid or die $!;
140 open STDIN, "<&", $tf or die $!;
141 exec 'git', 'cat-file';
147 m/^(\w+) (\w+) (\d+)\n/ or die "$objline ?";
153 if ($gitobjtype eq 'commit' or $gitobjtype eq 'tag') {
154 $!=0; read GCF, $gitobjdata, $bytes == $bytes
155 or die "$gitobjid $bytes $!";
159 $poldbh->do("INSERT INTO taints".
160 " (package, gitobjid, gitobjtype, gitobjdata, time, comment)",
161 " VALUES (?,?,?,?,?,?)", {},
162 $pkg, $gitobjid, $gitobjtype, $gitobjdata, time, $reason);
164 my $taint_id = $poldbh->last_insert_id(undef,undef,"taints","taint_id");
165 die unless defined $taint_id;
167 $poldbh->do("INSERT INTO taintoverrides".
168 " (taint_id, deliberately)",
169 " VALUES (?, 'include-questionable-history')", {},
173 sub add_taint_by_tag ($$) {
174 my ($tagname,$refobjid) = @_;
176 "tag $tagname referred to this object in git tree but all".
177 " previously pushed versions were found to have been".
178 " removed from NEW (ie, rejected) (or never arrived)");
181 sub action__check_package () {
183 return 0 unless $pkg_exists;
184 return 0 unless $pkg_secret;
186 chdir $pkgdir or die "$pkgdir $!";
187 return if new_has_vsn_in_our_history();
189 if (good_suite_has_vsn_in_our_history) {
190 chmod $publicmode, "." or die $!;
194 git_for_each_ref('refs/tags', sub {
195 my ($objid,$objtype,$fullrefname,$tagname) = @_;
196 add_taint_by_tag($tagname,$refobjid);
198 $?=0; $!=0; close TAGL or die "git for-each-ref $? $!";
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;
214 sub deliberately ($) { return $deliberately{$_[0]}; }
218 return 0 unless $pkg_exists;
219 return 0 unless $pkg_secret;
221 # we suppose that NEW has a version which is already in our
222 # history, as otherwise the repo would have been blown away
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;
231 if (deliberately('include-questionable-history')) {
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";
240 sub action_push_confirm () {
241 my $initq = $dbh->prepare(<<END);
242 SELECT taint_id, gitobjid FROM taints t
243 WHERE (package = ? OR package = '')
245 $initq->execute($pkg);
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 $!;
253 flush $chkinput or die $!;
254 seek $chkinput,0,0 or die $!;
256 my $checkpid = open2("<&$chkinput", \*CHKOUT, qw(git cat-file --batch));
259 my ($taintinfoq,$overridesanyq,$untaintq,$overridesq);
261 my $overridesstmt = <<END;
262 SELECT deliberately FROM taintoverrides WHERE (
263 my @overridesv = sort keys %deliberately;
264 $overridesstmt .= join <<END, (<<END x @overridesv);
270 $overridesstmt .= <<END;
272 ORDER BY deliberately ASC
278 my $taintid = shift @taintids;
279 die unless defined $taintid;
281 next if m/^\w+ missing$/;
282 die unless m/^(\w+) (\s+) (\d+)\s/;
283 my ($objid,$objtype,$nbytes) = @_;
285 read CHKOUT, $_, $nbytes == $bytes or last;
287 $taintinfoq ||= $dbh->prepare(<<END);
288 SELECT package, time, comment FROM taints WHERE taint_id = ?
290 $taintinfoq->execute($taintid);
292 my $ti = $taintinfoq->fetchrow_hashref();
295 my $timeshow = defined $ti->{time}
296 ? " at time ".strftime("%Y-%m-%d %H:%M:%S Z", gmtime $ti->time)
298 my $pkgshow = length $ti->{package}
299 ? "package $ti->{package}"
304 History contains tainted $objtype $objid
305 Taint recorded$timeshow for $pkginfo
306 Reason: $ti->{comment}
309 $overridesq ||= $dbh->prepare($overridesstmt);
310 $overridesq->execute(@overridesv, $taintid);
311 my ($ovwhy) = $overridesq->fetchrow_array();
312 if (!defined $ovwhy) {
313 $overridesanyq ||= $dbh->prepare(<<END);
314 SELECT 1 FROM taintoverrides WHERE taint_id = ? LIMIT 1
316 $overridesanyq->execute($taintid);
317 my ($ovany) = $overridesanyq->fetchrow_array();
318 $stderr .= $ovany ? <<END : <<END;
319 Could be forced using --deliberately. Consult documentation.
321 Uncorrectable error. If confused, consult administrator.
326 Forcing due to --deliberately-$ovwhy
328 $untaintq ||= $dbh->prepare(<<END);
329 DELETE FROM taints WHERE taint_id = ?
331 $untaintq->execute($taint_id);
335 $?=0; my $gotpid = waitpid $checkpid, WNOHANG;
336 die "@taintids $gotpid $? $!";
342 Rejecting push due to questionable history.
351 my $fn = ${*::}{"action__$cmd"};
359 poldb_setup(poldb_path($repos));
363 die unless defined $rcode;
365 eval { $poldbh->commit; };
366 last unless length $@;
368 die if $sleepy >= 20;
369 print STDERR "[policy database busy, retrying]\n";
375 print STDERR $stderr;