chiark / gitweb /
Infra: Document dgit-repos-policy-trusting a bit
[dgit.git] / infra / dgit-repos-server
1 #!/usr/bin/perl -w
2 # dgit-repos-server
3 #
4 # usages:
5 #   dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [<settings>] --ssh
6 #   dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [<settings>] --cron
7 # settings
8 #   --repos=GIT-REPOS-DIR      default DISTRO-DIR/repos/
9 #   --suites=SUITES-FILE       default DISTRO-DIR/suites
10 #   --policy-hook=POLICY-HOOK  default DISTRO-DIR/policy-hook
11 #   --dgit-live=DGIT-LIVE-DIR  default DISTRO-DIR/dgit-live
12 # (DISTRO-DIR is not used other than as default and to pass to policy hook)
13 # internal usage:
14 #  .../dgit-repos-server --pre-receive-hook PACKAGE
15 #
16 # Invoked as the ssh restricted command
17 #
18 # Works like git-receive-pack
19 #
20 # SUITES is the name of a file which lists the permissible suites
21 # one per line (#-comments and blank lines ignored)
22 #
23 # AUTH-SPEC is a :-separated list of
24 #   KEYRING.GPG,AUTH-SPEC
25 # where AUTH-SPEC is one of
26 #   a
27 #   mDM.TXT
28 # (With --cron AUTH-SPEC is not used and may be the empty string.)
29
30 use strict;
31 $SIG{__WARN__} = sub { die $_[0]; };
32
33 # DGIT-REPOS-DIR contains:
34 # git tree (or other object)      lock (in acquisition order, outer first)
35 #
36 #  _tmp/PACKAGE_prospective       ! } SAME.lock, held during receive-pack
37 #
38 #  _tmp/PACKAGE_incoming$$        ! } SAME.lock, held during receive-pack
39 #  _tmp/PACKAGE_incoming$$_fresh  ! }
40 #
41 #  PACKAGE.git                      } PACKAGE.git.lock
42 #  PACKAGE_garbage                  }   (also covers executions of
43 #  PACKAGE_garbage-old              }    policy hook script for PACKAGE)
44 #  PACKAGE_garbage-tmp              }
45 #  policy*                          } (for policy hook script, covered by
46 #                                   }  lock only when invoked for a package)
47 #
48 # leaf locks, held during brief operaton only:
49 #
50 #  _empty                           } SAME.lock
51 #  _empty.new                       }
52 #
53 #  _template                        } SAME.lock
54 #
55 # locks marked ! may be held during client data transfer
56
57 # What we do on push is this:
58 #  - extract the destination repo name
59 #  - make a hardlink clone of the destination repo
60 #  - provide the destination with a stunt pre-receive hook
61 #  - run actual git-receive-pack with that new destination
62 #   as a result of this the stunt pre-receive hook runs; it does this:
63 #    + understand what refs we are allegedly updating and
64 #      check some correspondences:
65 #        * we are updating only refs/tags/debian/* and refs/dgit/*
66 #        * and only one of each
67 #        * and the tag does not already exist
68 #      and
69 #        * recover the suite name from the destination refs/dgit/ ref
70 #    + disassemble the signed tag into its various fields and signature
71 #      including:
72 #        * parsing the first line of the tag message to recover
73 #          the package name, version and suite
74 #        * checking that the package name corresponds to the dest repo name
75 #        * checking that the suite name is as recovered above
76 #    + verify the signature on the signed tag
77 #      and if necessary check that the keyid and package are listed in dm.txt
78 #    + check various correspondences:
79 #        * the signed tag must refer to a commit
80 #        * the signed tag commit must be the refs/dgit value
81 #        * the name in the signed tag must correspond to its ref name
82 #        * the tag name must be debian/<version> (massaged as needed)
83 #        * the suite is one of those permitted
84 #        * the signed tag has a suitable name
85 #        * run the "push" policy hook
86 #        * replay prevention for --deliberately-not-fast-forward
87 #        * check the commit is a fast forward
88 #        * handle a request from the policy hook for a fresh repo
89 #    + push the signed tag and new dgit branch to the actual repo
90 #
91 # If the destination repo does not already exist, we need to make
92 # sure that we create it reasonably atomically, and also that
93 # we don't every have a destination repo containing no refs at all
94 # (because such a thing causes git-fetch-pack to barf).  So then we
95 # do as above, except:
96 #  - before starting, we take out our own lock for the destination repo
97 #  - we create a prospective new destination repo by making a copy
98 #    of _template
99 #  - we use the prospective new destination repo instead of the
100 #    actual new destination repo (since the latter doesn't exist)
101 #  - after git-receive-pack exits, we
102 #    + check that the prospective repo contains a tag and head
103 #    + rename the prospective destination repo into place
104 #
105 # Cleanup strategy:
106 #  - We are crash-only
107 #  - Temporary working trees and their locks are cleaned up
108 #    opportunistically by a program which tries to take each lock and
109 #    if successful deletes both the tree and the lockfile
110 #  - Prospective working trees and their locks are cleaned up by
111 #    a program which tries to take each lock and if successful
112 #    deletes any prospective working tree and the lock (but not
113 #    of course any actual tree)
114 #  - It is forbidden to _remove_ the lockfile without removing
115 #    the corresponding temporary tree, as the lockfile is also
116 #    a stampfile whose presence indicates that there may be
117 #    cleanup to do
118 #
119 # Policy hook script is invoked like this:
120 #   POLICY-HOOK-SCRIPT DISTRO DGIT-REPOS-DIR DGIT-LIVE-DIR DISTRO-DIR ACTION...
121 # ie.
122 #   POLICY-HOOK-SCRIPT ... check-list [...]
123 #   POLICY-HOOK-SCRIPT ... check-package PACKAGE [...]
124 #   POLICY-HOOK-SCRIPT ... push PACKAGE \
125 #         VERSION SUITE TAGNAME DELIBERATELIES [...]
126 #   POLICY-HOOK-SCRIPT ... push-confirm PACKAGE \
127 #         VERSION SUITE TAGNAME DELIBERATELIES FRESH-REPO|'' [...]
128 #
129 # DELIBERATELIES is like this: --deliberately-foo,--deliberately-bar,...
130 #
131 # Exit status is a bitmask.  Bit weight constants are defined in Dgit.pm.
132 #    NOFFCHECK   (2)
133 #         suppress dgit-repos-server's fast-forward check ("push" only)
134 #    FRESHREPO   (4)
135 #         blow away repo right away (ie, as if before push or fetch)
136 #         ("check-package" and "push" only)
137 # any unexpected bits mean failure, and then known set bits are ignored
138 # if no unexpected bits set, operation continues (subject to meaning
139 # of any expected bits set).  So, eg, exit 0 means "continue normally"
140 # and would be appropriate for an unknown action.
141 #
142 # cwd for push and push-confirm is a temporary repo where the incoming
143 # objects have been received; TAGNAME is the version-based tag.
144 #
145 # FRESH-REPO is '' iff the repo for this package already existed, or
146 # the pathname of the newly-created repo which will be renamed into
147 # place if everything goes well.  (NB that this is generally not the
148 # same repo as the cwd, because the objects are first received into a
149 # temporary repo so they can be examined.)  In this case FRESH-REPO
150 # contains exactly the objects and refs that will appear in the
151 # destination if push-confirm approves.
152
153 # if push requested FRESHREPO, push-confirm happens in the old working
154 # repo and FRESH-REPO is guaranteed not to be ''.
155 #
156 # policy hook for a particular package will be invoked only once at
157 # a time - (see comments about DGIT-REPOS-DIR, above)
158 #
159 # check-list and check-package are invoked via the --cron option.
160 # First, without any locking, check-list is called.  It should produce
161 # a list of package names (one per line).  Then check-package will be
162 # invoked for each named package, in each case after taking an
163 # appropriate lock.
164 #
165 # If policy hook wants to run dgit (or something else in the dgit
166 # package), it should use DGIT-LIVE-DIR/dgit (etc.)
167
168
169 use POSIX;
170 use Fcntl qw(:flock);
171 use File::Path qw(rmtree);
172 use File::Temp qw(tempfile);
173
174 use Debian::Dgit qw(:DEFAULT :policyflags);
175
176 initdebug('');
177
178 our $func;
179 our $dgitrepos;
180 our $package;
181 our $distro;
182 our $suitesfile;
183 our $policyhook;
184 our $dgitlive;
185 our $distrodir;
186 our $destrepo;
187 our $workrepo;
188 our $keyrings;
189 our @lockfhs;
190
191 our @deliberatelies;
192 our %supersedes;
193 our $policy;
194 our @policy_args;
195
196 #----- utilities -----
197
198 sub realdestrepo () { "$dgitrepos/$package.git"; }
199
200 sub acquirelock ($$) {
201     my ($lock, $must) = @_;
202     my $fh;
203     printdebug sprintf "locking %s %d\n", $lock, $must;
204     for (;;) {
205         close $fh if $fh;
206         $fh = new IO::File $lock, ">" or die "open $lock: $!";
207         my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
208         if (!$ok) {
209             die "flock $lock: $!" if $must;
210             printdebug " locking $lock failed\n";
211             return undef;
212         }
213         next unless stat_exists $lock;
214         my $want = (stat _)[1];
215         stat $fh or die $!;
216         my $got = (stat _)[1];
217         last if $got == $want;
218     }
219     return $fh;
220 }
221
222 sub acquirermtree ($$) {
223     my ($tree, $must) = @_;
224     my $fh = acquirelock("$tree.lock", $must);
225     if ($fh) {
226         push @lockfhs, $fh;
227         rmtree $tree;
228     }
229     return $fh;
230 }
231
232 sub locksometree ($) {
233     my ($tree) = @_;
234     acquirelock("$tree.lock", 1);
235 }
236
237 sub lockrealtree () {
238     locksometree(realdestrepo);
239 }
240
241 sub mkrepotmp () { ensuredir "$dgitrepos/_tmp" };
242
243 sub removedtagsfile () { "$dgitrepos/_removed-tags/$package"; }
244
245 sub recorderror ($) {
246     my ($why) = @_;
247     my $w = $ENV{'DGIT_DRS_WORK'}; # we are in stunthook
248     if (defined $w) {
249         chomp $why;
250         open ERR, ">", "$w/drs-error" or die $!;
251         print ERR $why, "\n" or die $!;
252         close ERR or die $!;
253         return 1;
254     }
255     return 0;
256 }
257
258 sub reject ($) {
259     my ($why) = @_;
260     recorderror "reject: $why";
261     die "dgit-repos-server: reject: $why\n";
262 }
263
264 sub runcmd {
265     debugcmd '+',@_;
266     $!=0; $?=0;
267     my $r = system @_;
268     die (shellquote @_)." $? $!" if $r;
269 }
270
271 sub policyhook {
272     my ($policyallowbits, @polargs) = @_;
273     # => ($exitstatuspolicybitmap);
274     die if $policyallowbits & ~0x3e;
275     my @cmd = ($policyhook,$distro,$dgitrepos,$dgitlive,$distrodir,@polargs);
276     debugcmd '+',@cmd;
277     my $r = system @cmd;
278     die "system: $!" if $r < 0;
279     die "dgit-repos-server: policy hook failed (or rejected) ($?)\n"
280         if $r & ~($policyallowbits << 8);
281     printdebug sprintf "hook => %#x\n", $r;
282     return $r >> 8;
283 }
284
285 sub mkemptyrepo ($$) {
286     my ($dir,$sharedperm) = @_;
287     runcmd qw(git init --bare --quiet), "--shared=$sharedperm", $dir;
288 }
289
290 sub mkrepo_fromtemplate ($) {
291     my ($dir) = @_;
292     my $template = "$dgitrepos/_template";
293     locksometree($template);
294     printdebug "copy template $template -> $dir\n";
295     my $r = system qw(cp -a --), $template, $dir;
296     !$r or die "create new repo $dir failed: $r $!";
297 }
298
299 sub movetogarbage () {
300     # realdestrepo must have been locked
301
302     my $real = realdestrepo;
303     return unless stat_exists $real;
304
305     my $garbagerepo = "$dgitrepos/${package}_garbage";
306     # We arrange to always keep at least one old tree, for recovery
307     # from mistakes.  This is either $garbage or $garbage-old.
308     if (stat_exists "$garbagerepo") {
309         printdebug "movetogarbage: rmtree $garbagerepo-tmp\n";
310         rmtree "$garbagerepo-tmp";
311         if (rename "$garbagerepo-old", "$garbagerepo-tmp") {
312             printdebug "movetogarbage: $garbagerepo-old -> -tmp, rmtree\n";
313             rmtree "$garbagerepo-tmp";
314         } else {
315             die "$garbagerepo $!" unless $!==ENOENT;
316             printdebug "movetogarbage: $garbagerepo-old -> -tmp\n";
317         }
318         printdebug "movetogarbage: $garbagerepo -> -old\n";
319         rename "$garbagerepo", "$garbagerepo-old" or die "$garbagerepo $!";
320     }
321
322     ensuredir "$dgitrepos/_removed-tags";
323     open PREVIOUS, ">>", removedtagsfile or die removedtagsfile." $!";
324     git_for_each_ref('refs/tags/'.debiantag('*'), sub {
325         my ($objid,$objtype,$fullrefname,$reftail) = @_;
326         print PREVIOUS "\n$objid $reftail .\n" or die $!;
327     }, $real);
328     close PREVIOUS or die $!;
329
330     printdebug "movetogarbage: $real -> $garbagerepo\n";
331     rename $real, $garbagerepo
332         or $! == ENOENT
333         or die "$garbagerepo $!";
334 }
335
336 sub policy_checkpackage () {
337     my $lfh = lockrealtree();
338
339     $policy = policyhook(FRESHREPO,'check-package',$package);
340     if ($policy & FRESHREPO) {
341         movetogarbage();
342     }
343
344     close $lfh;
345 }
346
347 #----- git-receive-pack -----
348
349 sub fixmissing__git_receive_pack () {
350     mkrepotmp();
351     $destrepo = "$dgitrepos/_tmp/${package}_prospective";
352     acquirermtree($destrepo, 1);
353     mkrepo_fromtemplate($destrepo);
354 }
355
356 sub makeworkingclone () {
357     mkrepotmp();
358     $workrepo = "$dgitrepos/_tmp/${package}_incoming$$";
359     acquirermtree($workrepo, 1);
360     my $lfh = lockrealtree();
361     runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
362     close $lfh;
363     rmtree "${workrepo}_fresh";
364 }
365
366 sub setupstunthook () {
367     my $prerecv = "$workrepo/hooks/pre-receive";
368     my $fh = new IO::File $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
369         or die "$prerecv: $!";
370     print $fh <<END or die "$prerecv: $!";
371 #!/bin/sh
372 set -e
373 exec $0 --pre-receive-hook $package
374 END
375     close $fh or die "$prerecv: $!";
376     $ENV{'DGIT_DRS_WORK'}= $workrepo;
377     $ENV{'DGIT_DRS_DEST'}= $destrepo;
378     printdebug " stunt hook set up $prerecv\n";
379 }
380
381 sub dealwithfreshrepo () {
382     my $freshrepo = "${workrepo}_fresh";
383     return unless stat_exists $freshrepo;
384     $destrepo = $freshrepo;
385 }
386
387 sub maybeinstallprospective () {
388     return if $destrepo eq realdestrepo;
389
390     if (open REJ, "<", "$workrepo/drs-error") {
391         local $/ = undef;
392         my $msg = <REJ>;
393         REJ->error and die $!;
394         print STDERR $msg;
395         exit 1;
396     } else {
397         $!==&ENOENT or die $!;
398     }
399
400     printdebug " show-ref ($destrepo) ...\n";
401
402     my $child = open SR, "-|";
403     defined $child or die $!;
404     if (!$child) {
405         chdir $destrepo or die $!;
406         exec qw(git show-ref);
407         die $!;
408     }
409     my %got = qw(tag 0 head 0);
410     while (<SR>) {
411         chomp or die;
412         printdebug " show-refs| $_\n";
413         s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
414         my $wh =
415             m{^refs/tags/} ? 'tag' :
416             m{^refs/dgit/} ? 'head' :
417             die;
418         die if $got{$wh}++;
419     }
420     $!=0; $?=0; close SR or $?==256 or die "$? $!";
421
422     printdebug "installprospective ?\n";
423     die Dumper(\%got)." -- missing refs in new repo"
424         if grep { !$_ } values %got;
425
426     lockrealtree();
427
428     if ($destrepo eq "${workrepo}_fresh") {
429         movetogarbage;
430     }
431
432     printdebug "install $destrepo => ".realdestrepo."\n";
433     rename $destrepo, realdestrepo or die $!;
434     remove realdestrepo.".lock" or die $!;
435 }
436
437 sub main__git_receive_pack () {
438     makeworkingclone();
439     setupstunthook();
440     runcmd qw(git receive-pack), $workrepo;
441     dealwithfreshrepo();
442     maybeinstallprospective();
443 }
444
445 #----- stunt post-receive hook -----
446
447 our ($tagname, $tagval, $suite, $oldcommit, $commit);
448 our ($version, %tagh);
449
450 our ($tagexists_error);
451
452 sub readupdates () {
453     printdebug " updates ...\n";
454     while (<STDIN>) {
455         chomp or die;
456         printdebug " upd.| $_\n";
457         m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
458         my ($old, $sha1, $refname) = ($1, $2, $3);
459         if ($refname =~ m{^refs/tags/(?=debian/)}) {
460             reject "pushing multiple tags!" if defined $tagname;
461             $tagname = $'; #';
462             $tagval = $sha1;
463             $tagexists_error= "tag $tagname already exists -".
464                 " not replacing previously-pushed version"
465                 if $old =~ m/[^0]/;
466         } elsif ($refname =~ m{^refs/dgit/}) {
467             reject "pushing multiple heads!" if defined $suite;
468             $suite = $'; #';
469             $oldcommit = $old;
470             $commit = $sha1;
471         } else {
472             reject "pushing unexpected ref!";
473         }
474     }
475     STDIN->error and die $!;
476
477     reject "push is missing tag ref update" unless defined $tagname;
478     reject "push is missing head ref update" unless defined $suite;
479     printdebug " updates ok.\n";
480 }
481
482 sub parsetag () {
483     printdebug " parsetag...\n";
484     open PT, ">dgit-tmp/plaintext" or die $!;
485     open DS, ">dgit-tmp/plaintext.asc" or die $!;
486     open T, "-|", qw(git cat-file tag), $tagval or die $!;
487     for (;;) {
488         $!=0; $_=<T>; defined or die $!;
489         print PT or die $!;
490         if (m/^(\S+) (.*)/) {
491             push @{ $tagh{$1} }, $2;
492         } elsif (!m/\S/) {
493             last;
494         } else {
495             die;
496         }
497     }
498     $!=0; $_=<T>; defined or die $!;
499     m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or
500         reject "tag message not in expected format";
501
502     die unless $1 eq $package;
503     $version = $2;
504     die "$3 != $suite " unless $3 eq $suite;
505
506     my $copyl = $_;
507     for (;;) {
508         print PT $copyl or die $!;
509         $!=0; $_=<T>; defined or die "missing signature? $!";
510         $copyl = $_;
511         if (m/^\[dgit ([^"].*)\]$/) { # [dgit "something"] is for future
512             $_ = $1." ";
513             while (length) {
514                 if (s/^distro\=(\S+) //) {
515                     die "$1 != $distro" unless $1 eq $distro;
516                 } elsif (s/^(--deliberately-$deliberately_re) //) {
517                     push @deliberatelies, $1;
518                 } elsif (s/^supersede:(\S+)=(\w+) //) {
519                     die "supersede $1 twice" if defined $supersedes{$1};
520                     $supersedes{$1} = $2;
521                 } elsif (s/^[-+.=0-9a-z]\S* //) {
522                 } else {
523                     die "unknown dgit info in tag ($_)";
524                 }
525             }
526             next;
527         }
528         last if m/^-----BEGIN PGP/;
529     }
530     $_ = $copyl;
531     for (;;) {
532         print DS or die $!;
533         $!=0; $_=<T>;
534         last if !defined;
535     }
536     T->error and die $!;
537     close PT or die $!;
538     close DS or die $!;
539     printdebug " parsetag ok.\n";
540 }
541
542 sub checksig_keyring ($) {
543     my ($keyringfile) = @_;
544     # returns primary-keyid if signed by a key in this keyring
545     # or undef if not
546     # or dies on other errors
547
548     my $ok = undef;
549
550     printdebug " checksig keyring $keyringfile...\n";
551
552     our @cmd = (qw(gpgv --status-fd=1 --keyring),
553                    $keyringfile,
554                    qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext));
555     debugcmd '|',@cmd;
556
557     open P, "-|", @cmd
558         or die $!;
559
560     while (<P>) {
561         next unless s/^\[GNUPG:\] //;
562         chomp or die;
563         printdebug " checksig| $_\n";
564         my @l = split / /, $_;
565         if ($l[0] eq 'NO_PUBKEY') {
566             last;
567         } elsif ($l[0] eq 'VALIDSIG') {
568             my $sigtype = $l[9];
569             $sigtype eq '00' or reject "signature is not of type 00!";
570             $ok = $l[10];
571             die unless defined $ok;
572             last;
573         }
574     }
575     close P;
576
577     printdebug sprintf " checksig ok=%d\n", !!$ok;
578
579     return $ok;
580 }
581
582 sub dm_txt_check ($$) {
583     my ($keyid, $dmtxtfn) = @_;
584     printdebug " dm_txt_check $keyid $dmtxtfn\n";
585     open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
586     while (<DT>) {
587         m/^fingerprint:\s+$keyid$/oi
588             ..0 or next;
589         if (s/^allow:/ /i..0) {
590         } else {
591             m/^./
592                 or reject "key $keyid missing Allow section in permissions!";
593             next;
594         }
595         # in right stanza...
596         s/^[ \t]+//
597             or reject "package $package not allowed for key $keyid";
598         # in allow field...
599         s/\([^()]+\)//;
600         s/\,//;
601         chomp or die;
602         printdebug " dm_txt_check allow| $_\n";
603         foreach my $p (split /\s+/) {
604             if ($p eq $package) {
605                 # yay!
606                 printdebug " dm_txt_check ok\n";
607                 return;
608             }
609         }
610     }
611     DT->error and die $!;
612     close DT or die $!;
613     reject "key $keyid not in permissions list although in keyring!";
614 }
615
616 sub verifytag () {
617     foreach my $kas (split /:/, $keyrings) {
618         printdebug "verifytag $kas...\n";
619         $kas =~ s/^([^,]+),// or die;
620         my $keyid = checksig_keyring $1;
621         if (defined $keyid) {
622             if ($kas =~ m/^a$/) {
623                 printdebug "verifytag a ok\n";
624                 return; # yay
625             } elsif ($kas =~ m/^m([^,]+)$/) {
626                 dm_txt_check($keyid, $1);
627                 printdebug "verifytag m ok\n";
628                 return;
629             } else {
630                 die;
631             }
632         }   
633     }
634     reject "key not found in keyrings";
635 }
636
637 sub checksuite () {
638     printdebug "checksuite ($suitesfile)\n";
639     open SUITES, "<", $suitesfile or die $!;
640     while (<SUITES>) {
641         chomp;
642         next unless m/\S/;
643         next if m/^\#/;
644         s/\s+$//;
645         return if $_ eq $suite;
646     }
647     die $! if SUITES->error;
648     reject "unknown suite";
649 }
650
651 sub checktagnoreplay () {
652     # We need to prevent a replay attack using an earlier signed tag.
653     # We also want to archive in the history the object ids of
654     # anything we remove, even if we get rid of the actual objects.
655     #
656     # So, we check that the signed tag mentions the name and tag
657     # object id of:
658     #
659     # (a) In the case of FRESHREPO: all tags and refs/heads/* in
660     #     the repo.  That is, effectively, all the things we are
661     #     deleting.
662     #
663     #     This prevents any tag implying a FRESHREPO push
664     #     being replayed into a different state of the repo.
665     #
666     #     There is still the folowing risk: If a non-ff push is of a
667     #     head which is an ancestor of a previous ff-only push, the
668     #     previous push can be replayed.
669     #
670     #     So we keep a separate list, as a file in the repo, of all
671     #     the tag object ids we have ever seen and removed.  Any such
672     #     tag object id will be rejected even for ff-only pushes.
673     #
674     # (b) In the case of just NOFFCHECK: all tags referring to the
675     #     current head for the suite (there must be at least one).
676     #
677     #     This prevents any tag implying a NOFFCHECK push being
678     #     replayed to rewind from a different head.
679     #
680     #     The possibility of an earlier ff-only push being replayed is
681     #     eliminated as follows: the tag from such a push would still
682     #     be in our repo, and therefore the replayed push would be
683     #     rejected because the set of refs being updated would be
684     #     wrong.
685
686     if (!open PREVIOUS, "<", removedtagsfile) {
687         die removedtagsfile." $!" unless $!==ENOENT;
688     } else {
689         # Protocol for updating this file is to append to it, not
690         # write-new-and-rename.  So all updates are prefixed with \n
691         # and suffixed with " .\n" so that partial writes can be
692         # ignored.
693         while (<PREVIOUS>) {
694             next unless m/^(\w+) (.*) \.\n/;
695             next unless $1 eq $tagval;
696             reject "Replay of previously-rewound upload ($tagval $2)";
697         }
698         die removedtagsfile." $!" if PREVIOUS->error;
699         close PREVIOUS;
700     }
701
702     return unless $policy & (FRESHREPO|NOFFCHECK);
703
704     my $garbagerepo = "$dgitrepos/${package}_garbage";
705     lockrealtree();
706
707     my $nchecked = 0;
708     my @problems;
709
710     my $check_ref_superseded= sub {
711         my ($objid,$objtype,$fullrefname,$reftail) = @_;
712         my $supkey = $fullrefname;
713         $supkey =~ s{^refs/}{} or die "$supkey $objid ?";
714         my $supobjid = $supersedes{$supkey};
715         if (!defined $supobjid) {
716             printdebug "checktagnoreply - missing\n";
717             push @problems, "does not supersede $supkey";
718         } elsif ($supobjid ne $objid) {
719             push @problems, "supersedes $supkey=$supobjid".
720                 " but previously $supkey=$objid";
721         } else {
722             $nchecked++;
723         }
724     };
725
726     if ($policy & FRESHREPO) {
727         foreach my $kind (qw(tags heads)) {
728             git_for_each_ref("refs/$kind", $check_ref_superseded);
729         }
730     } else {
731         my $branch= server_branch($suite);
732         my $branchhead= git_get_ref($branch);
733         if (!length $branchhead) {
734             # No such branch - NOFFCHECK was unnecessary.  Oh well.
735             printdebug "checktagnoreplay - not FRESHREPO, new branch, ok\n";
736         } else {
737             printdebug "checktagnoreplay - not FRESHREPO,".
738                 " checking for overwriting refs/$branch=$branchhead\n";
739             git_for_each_tag_referring($branchhead, sub {
740                 my ($tagobjid,$refobjid,$fullrefname,$tagname) = @_;
741                 $check_ref_superseded->($tagobjid,undef,$fullrefname,undef);
742             });
743             printdebug "checktagnoreplay - not FRESHREPO, nchecked=$nchecked";
744             push @problems, "does not supersede any tag".
745                 " referring to branch head $branch=$branchhead"
746                 unless $nchecked;
747         }
748     }
749
750     if (@problems) {
751         reject "replay attack prevention check failed:".
752             " signed tag for $version: ".
753             join("; ", @problems).
754             "\n";
755     }
756     printdebug "checktagnoreplay - all ok ($tagval)\n"
757 }
758
759 sub tagh1 ($) {
760     my ($tag) = @_;
761     my $vals = $tagh{$tag};
762     reject "missing header $tag in signed tag object" unless $vals;
763     reject "multiple headers $tag in signed tag object" unless @$vals == 1;
764     return $vals->[0];
765 }
766
767 sub checks () {
768     printdebug "checks\n";
769
770     tagh1('type') eq 'commit' or reject "tag refers to wrong kind of object";
771     tagh1('object') eq $commit or reject "tag refers to wrong commit";
772     tagh1('tag') eq $tagname or reject "tag name in tag is wrong";
773
774     my $v = $version;
775     $v =~ y/~:/_%/;
776
777     printdebug "translated version $v\n";
778     $tagname eq "debian/$v" or die;
779
780     lockrealtree();
781
782     @policy_args = ($package,$version,$suite,$tagname,
783                     join(",",@deliberatelies));
784     $policy = policyhook(NOFFCHECK|FRESHREPO, 'push', @policy_args);
785
786     if (defined $tagexists_error) {
787         if ($policy & FRESHREPO) {
788             printdebug "ignoring tagexists_error: $tagexists_error\n";
789         } else {
790             reject $tagexists_error;
791         }
792     }
793
794     checktagnoreplay();
795     checksuite();
796
797     # check that our ref is being fast-forwarded
798     printdebug "oldcommit $oldcommit\n";
799     if (!($policy & NOFFCHECK) && $oldcommit =~ m/[^0]/) {
800         $?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
801         chomp $mb;
802         $mb eq $oldcommit or reject "not fast forward on dgit branch";
803     }
804     if ($policy & FRESHREPO) {
805         # It's a bit late to be discovering this here, isn't it ?
806         #
807         # What we do is: Generate a fresh destination repo right now,
808         # and arrange to treat it from now on as if it were a
809         # prospective repo.
810         #
811         # The presence of this fresh destination repo is detected by
812         # the parent, which responds by making a fresh master repo
813         # from the template.  (If the repo didn't already exist then
814         # $destrepo was _prospective, and we change it here.  This is
815         # OK because the parent's check for _fresh persuades it not to
816         # use _prospective.)
817         #
818         $destrepo = "${workrepo}_fresh"; # workrepo lock covers
819         mkrepo_fromtemplate $destrepo;
820     }
821 }
822
823 sub onwardpush () {
824     my @cmd = (qw(git send-pack), $destrepo);
825     push @cmd, qw(--force) if $policy & NOFFCHECK;
826     push @cmd, "$commit:refs/dgit/$suite",
827                "$tagval:refs/tags/$tagname";
828     debugcmd '+',@cmd;
829     $!=0;
830     my $r = system @cmd;
831     !$r or die "onward push to $destrepo failed: $r $!";
832 }
833
834 sub finalisepush () {
835     if ($destrepo eq realdestrepo) {
836         policyhook(0, 'push-confirm', @policy_args, '');
837         onwardpush();
838     } else {
839         # We are to receive the push into a new repo (perhaps
840         # because the policy push hook asked us to with FRESHREPO, or
841         # perhaps because the repo didn't exist before).
842         #
843         # We want to provide the policy push-confirm hook with a repo
844         # which looks like the one which is going to be installed.
845         # The working repo is no good because it might contain
846         # previous history.
847         #
848         # So we push the objects into the prospective new repo right
849         # away.  If the hook declines, we decline, and the prospective
850         # repo is never installed.
851         onwardpush();
852         policyhook(0, 'push-confirm', @policy_args, $destrepo);
853     }
854 }
855
856 sub stunthook () {
857     printdebug "stunthook in $workrepo\n";
858     chdir $workrepo or die "chdir $workrepo: $!";
859     mkdir "dgit-tmp" or $!==EEXIST or die $!;
860     readupdates();
861     parsetag();
862     verifytag();
863     checks();
864     finalisepush();
865     printdebug "stunthook done.\n";
866 }
867
868 #----- git-upload-pack -----
869
870 sub fixmissing__git_upload_pack () {
871     $destrepo = "$dgitrepos/_empty";
872     my $lfh = locksometree($destrepo);
873     return if stat_exists $destrepo;
874     rmtree "$destrepo.new";
875     mkemptyrepo "$destrepo.new", "0644";
876     rename "$destrepo.new", $destrepo or die $!;
877     unlink "$destrepo.lock" or die $!;
878     close $lfh;
879 }
880
881 sub main__git_upload_pack () {
882     my $lfh = locksometree($destrepo);
883     printdebug "git-upload-pack in $destrepo\n";
884     chdir $destrepo or die "$destrepo: $!";
885     close $lfh;
886     runcmd qw(git upload-pack), ".";
887 }
888
889 #----- arg parsing and main program -----
890
891 sub argval () {
892     die unless @ARGV;
893     my $v = shift @ARGV;
894     die if $v =~ m/^-/;
895     return $v;
896 }
897
898 our %indistrodir = (
899     # keys are used for DGIT_DRS_XXX too
900     'repos' => \$dgitrepos,
901     'suites' => \$suitesfile,
902     'policy-hook' => \$policyhook,
903     'dgit-live' => \$dgitlive,
904     );
905
906 our @hookenvs = qw(distro suitesfile policyhook
907                    dgitlive keyrings dgitrepos distrodir);
908
909 # workrepo and destrepo handled ad-hoc
910
911 sub mode_ssh () {
912     die if @ARGV;
913
914     my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
915     $cmd =~ m{
916         ^
917         (?: \S* / )?
918         ( [-0-9a-z]+ )
919         \s+
920         '? (?: \S* / )?
921         ($package_re) \.git
922         '?$
923     }ox 
924     or reject "command string not understood";
925     my $method = $1;
926     $package = $2;
927
928     my $funcn = $method;
929     $funcn =~ y/-/_/;
930     my $mainfunc = $main::{"main__$funcn"};
931
932     reject "unknown method" unless $mainfunc;
933
934     policy_checkpackage();
935
936     if (stat_exists realdestrepo) {
937         $destrepo = realdestrepo;
938     } else {
939         printdebug " fixmissing $funcn\n";
940         my $fixfunc = $main::{"fixmissing__$funcn"};
941         &$fixfunc;
942     }
943
944     printdebug " running main $funcn\n";
945     &$mainfunc;
946 }
947
948 sub mode_cron () {
949     die if @ARGV;
950
951     my $listfh = tempfile();
952     open STDOUT, ">&", $listfh or die $!;
953     policyhook(0,'check-list');
954     open STDOUT, ">&STDERR" or die $!;
955
956     seek $listfh, 0, 0 or die $!;
957     while (<$listfh>) {
958         chomp or die;
959         next if m/^\s*\#/;
960         next unless m/\S/;
961         die unless m/^($package_re)$/;
962         
963         $package = $1;
964         policy_checkpackage();
965     }
966     die $! if $listfh->error;
967 }    
968
969 sub parseargsdispatch () {
970     die unless @ARGV;
971
972     delete $ENV{'GIT_DIR'}; # if not run via ssh, our parent git process
973     delete $ENV{'GIT_PREFIX'}; # sets these and they mess things up
974
975     if ($ENV{'DGIT_DRS_DEBUG'}) {
976         enabledebug();
977     }
978
979     if ($ARGV[0] eq '--pre-receive-hook') {
980         if ($debuglevel) {
981             $debugprefix.="=";
982             printdebug "in stunthook ".(shellquote @ARGV)."\n";
983             foreach my $k (sort keys %ENV) {
984                 printdebug "$k=$ENV{$k}\n" if $k =~  m/^DGIT/;
985             }
986         }
987         shift @ARGV;
988         @ARGV == 1 or die;
989         $package = shift @ARGV;
990         ${ $main::{$_} } = $ENV{"DGIT_DRS_\U$_"} foreach @hookenvs;
991         defined($workrepo = $ENV{'DGIT_DRS_WORK'}) or die;
992         defined($destrepo = $ENV{'DGIT_DRS_DEST'}) or die;
993         open STDOUT, ">&STDERR" or die $!;
994         eval {
995             stunthook();
996         };
997         if ($@) {
998             recorderror "$@" or die;
999             die $@;
1000         }
1001         exit 0;
1002     }
1003
1004     $distro    = argval();
1005     $distrodir = argval();
1006     $keyrings  = argval();
1007
1008     foreach my $dk (keys %indistrodir) {
1009         ${ $indistrodir{$dk} } = "$distrodir/$dk";
1010     }
1011
1012     while (@ARGV && $ARGV[0] =~ m/^--([-0-9a-z]+)=/ && $indistrodir{$1}) {
1013         ${ $indistrodir{$1} } = $'; #';
1014         shift @ARGV;
1015     }
1016
1017     $ENV{"DGIT_DRS_\U$_"} = ${ $main::{$_} } foreach @hookenvs;
1018
1019     die unless @ARGV==1;
1020
1021     my $mode = shift @ARGV;
1022     die unless $mode =~ m/^--(\w+)$/;
1023     my $fn = ${*::}{"mode_$1"};
1024     die unless $fn;
1025     $fn->();
1026 }
1027
1028 sub unlockall () {
1029     while (my $fh = pop @lockfhs) { close $fh; }
1030 }
1031
1032 sub cleanup () {
1033     unlockall();
1034     if (!chdir "$dgitrepos/_tmp") {
1035         $!==ENOENT or die $!;
1036         return;
1037     }
1038     foreach my $lf (<*.lock>) {
1039         my $tree = $lf;
1040         $tree =~ s/\.lock$//;
1041         next unless acquirermtree($tree, 0);
1042         remove $lf or warn $!;
1043         unlockall();
1044     }
1045 }
1046
1047 parseargsdispatch();
1048 cleanup();