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