chiark / gitweb /
New approach to replay prevention - WIP
[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 # Exit status is a bitmask.  Bit weight constants are defined in Dgit.pm.
130 #    NOFFCHECK   (2)
131 #         suppress dgit-repos-server's fast-forward check ("push" only)
132 #    FRESHREPO   (4)
133 #         blow away repo right away (ie, as if before push or fetch)
134 #         ("check-package" and "push" only)
135 # any unexpected bits mean failure, and then known set bits are ignored
136 # if no unexpected bits set, operation continues (subject to meaning
137 # of any expected bits set).  So, eg, exit 0 means "continue normally"
138 # and would be appropriate for an unknown action.
139 #
140 # cwd for push and push-confirm is a temporary repo where the
141 # to-be-pushed objects have been received; TAGNAME is the
142 # version-based tag
143 #
144 # FRESH-REPO is '' iff the repo for this package already existed, or
145 # the pathname of the newly-created repo which will be renamed into
146 # place if everything goes well.  (NB that this is generally not the
147 # same repo as the cwd, because the objects are first received into a
148 # temporary repo so they can be examined.)
149
150 # if push requested FRESHREPO, push-confirm happens in said fresh repo
151 # and FRESH-REPO is guaranteed not to be ''.
152 #
153 # policy hook for a particular package will be invoked only once at
154 # a time - (see comments about DGIT-REPOS-DIR, above)
155 #
156 # check-list and check-package are invoked via the --cron option.
157 # First, without any locking, check-list is called.  It should produce
158 # a list of package names (one per line).  Then check-package will be
159 # invoked for each named package, in each case after taking an
160 # appropriate lock.
161 #
162 # If policy hook wants to run dgit (or something else in the dgit
163 # package), it should use DGIT-LIVE-DIR/dgit (etc.)
164
165
166 use POSIX;
167 use Fcntl qw(:flock);
168 use File::Path qw(rmtree);
169 use File::Temp qw(tempfile);
170
171 use Debian::Dgit qw(:DEFAULT :policyflags);
172
173 initdebug('');
174
175 our $func;
176 our $dgitrepos;
177 our $package;
178 our $distro;
179 our $suitesfile;
180 our $policyhook;
181 our $dgitlive;
182 our $distrodir;
183 our $destrepo;
184 our $workrepo;
185 our $keyrings;
186 our @lockfhs;
187
188 our @deliberatelies;
189 our %supersedes;
190 our $policy;
191
192 #----- utilities -----
193
194 sub realdestrepo () { "$dgitrepos/$package.git"; }
195
196 sub acquirelock ($$) {
197     my ($lock, $must) = @_;
198     my $fh;
199     printdebug sprintf "locking %s %d\n", $lock, $must;
200     for (;;) {
201         close $fh if $fh;
202         $fh = new IO::File $lock, ">" or die "open $lock: $!";
203         my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
204         if (!$ok) {
205             die "flock $lock: $!" if $must;
206             printdebug " locking $lock failed\n";
207             return undef;
208         }
209         next unless stat_exists $lock;
210         my $want = (stat _)[1];
211         stat $fh or die $!;
212         my $got = (stat _)[1];
213         last if $got == $want;
214     }
215     return $fh;
216 }
217
218 sub acquirermtree ($$) {
219     my ($tree, $must) = @_;
220     my $fh = acquirelock("$tree.lock", $must);
221     if ($fh) {
222         push @lockfhs, $fh;
223         rmtree $tree;
224     }
225     return $fh;
226 }
227
228 sub locksometree ($) {
229     my ($tree) = @_;
230     acquirelock("$tree.lock", 1);
231 }
232
233 sub lockrealtree () {
234     locksometree(realdestrepo);
235 }
236
237 sub mkrepotmp () { ensuredir "$dgitrepos/_tmp" };
238
239 sub removedtagsfile () { "$dgitrepos/_removed-tags/$package"; }
240
241 sub recorderror ($) {
242     my ($why) = @_;
243     my $w = $ENV{'DGIT_DRS_WORK'}; # we are in stunthook
244     if (defined $w) {
245         chomp $why;
246         open ERR, ">", "$w/drs-error" or die $!;
247         print ERR $why, "\n" or die $!;
248         close ERR or die $!;
249         return 1;
250     }
251     return 0;
252 }
253
254 sub reject ($) {
255     my ($why) = @_;
256     recorderror "reject: $why";
257     die "dgit-repos-server: reject: $why\n";
258 }
259
260 sub runcmd {
261     debugcmd '+',@_;
262     $!=0; $?=0;
263     my $r = system @_;
264     die (shellquote @_)." $? $!" if $r;
265 }
266
267 sub policyhook {
268     my ($policyallowbits, @polargs) = @_;
269     # => ($exitstatuspolicybitmap);
270     die if $policyallowbits & ~0x3e;
271     my @cmd = ($policyhook,$distro,$dgitrepos,$dgitlive,$distrodir,@polargs);
272     debugcmd '+',@cmd;
273     my $r = system @cmd;
274     die "system: $!" if $r < 0;
275     die "dgit-repos-server: policy hook failed (or rejected) ($?)\n"
276         if $r & ~($policyallowbits << 8);
277     printdebug sprintf "hook => %#x\n", $r;
278     return $r >> 8;
279 }
280
281 sub mkemptyrepo ($$) {
282     my ($dir,$sharedperm) = @_;
283     runcmd qw(git init --bare --quiet), "--shared=$sharedperm", $dir;
284 }
285
286 sub mkrepo_fromtemplate ($) {
287     my ($dir) = @_;
288     my $template = "$dgitrepos/_template";
289     locksometree($template);
290     printdebug "copy template $template -> $dir\n";
291     my $r = system qw(cp -a --), $template, $dir;
292     !$r or die "create new repo $dir failed: $r $!";
293 }
294
295 sub movetogarbage () {
296     # realdestrepo must have been locked
297     my $garbagerepo = "$dgitrepos/${package}_garbage";
298     # We arrange to always keep at least one old tree, for anti-rewind
299     # purposes (and, I guess, recovery from mistakes).  This is either
300     # $garbage or $garbage-old.
301     if (stat_exists "$garbagerepo") {
302         printdebug "movetogarbage: rmtree $garbagerepo-tmp\n";
303         rmtree "$garbagerepo-tmp";
304         if (rename "$garbagerepo-old", "$garbagerepo-tmp") {
305             printdebug "movetogarbage: $garbagerepo-old -> -tmp, rmtree\n";
306             rmtree "$garbagerepo-tmp";
307         } else {
308             die "$garbagerepo $!" unless $!==ENOENT;
309             printdebug "movetogarbage: $garbagerepo-old -> -tmp\n";
310         }
311         printdebug "movetogarbage: $garbagerepo -> -old\n";
312         rename "$garbagerepo", "$garbagerepo-old" or die "$garbagerepo $!";
313     }
314     my $real = realdestrepo;
315     printdebug "movetogarbage: $real -> $garbagerepo\n";
316     rename $real, $garbagerepo
317         or $! == ENOENT
318         or die "$garbagerepo $!";
319 }
320
321 sub policy_checkpackage () {
322     my $lfh = lockrealtree();
323
324     $policy = policyhook(FRESHREPO,'check-package',$package);
325     if ($policy & FRESHREPO) {
326         movetogarbage();
327     }
328
329     close $lfh;
330 }
331
332 #----- git-receive-pack -----
333
334 sub fixmissing__git_receive_pack () {
335     mkrepotmp();
336     $destrepo = "$dgitrepos/_tmp/${package}_prospective";
337     acquirermtree($destrepo, 1);
338     mkrepo_fromtemplate($destrepo);
339 }
340
341 sub makeworkingclone () {
342     mkrepotmp();
343     $workrepo = "$dgitrepos/_tmp/${package}_incoming$$";
344     acquirermtree($workrepo, 1);
345     my $lfh = lockrealtree();
346     runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
347     close $lfh;
348     rmtree "${workrepo}_fresh";
349 }
350
351 sub setupstunthook () {
352     my $prerecv = "$workrepo/hooks/pre-receive";
353     my $fh = new IO::File $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
354         or die "$prerecv: $!";
355     print $fh <<END or die "$prerecv: $!";
356 #!/bin/sh
357 set -e
358 exec $0 --pre-receive-hook $package
359 END
360     close $fh or die "$prerecv: $!";
361     $ENV{'DGIT_DRS_WORK'}= $workrepo;
362     $ENV{'DGIT_DRS_DEST'}= $destrepo;
363     printdebug " stunt hook set up $prerecv\n";
364 }
365
366 sub dealwithfreshrepo () {
367     my $freshrepo = "${workrepo}_fresh";
368     return unless stat_exists $freshrepo;
369     $destrepo = $freshrepo;
370 }
371
372 sub maybeinstallprospective () {
373     return if $destrepo eq realdestrepo;
374
375     if (open REJ, "<", "$workrepo/drs-error") {
376         local $/ = undef;
377         my $msg = <REJ>;
378         REJ->error and die $!;
379         print STDERR $msg;
380         exit 1;
381     } else {
382         $!==&ENOENT or die $!;
383     }
384
385     printdebug " show-ref ($destrepo) ...\n";
386
387     my $child = open SR, "-|";
388     defined $child or die $!;
389     if (!$child) {
390         chdir $destrepo or die $!;
391         exec qw(git show-ref);
392         die $!;
393     }
394     my %got = qw(tag 0 head 0);
395     while (<SR>) {
396         chomp or die;
397         printdebug " show-refs| $_\n";
398         s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
399         my $wh =
400             m{^refs/tags/} ? 'tag' :
401             m{^refs/dgit/} ? 'head' :
402             die;
403         die if $got{$wh}++;
404     }
405     $!=0; $?=0; close SR or $?==256 or die "$? $!";
406
407     printdebug "installprospective ?\n";
408     die Dumper(\%got)." -- missing refs in new repo"
409         if grep { !$_ } values %got;
410
411     lockrealtree();
412
413     if ($destrepo eq "${workrepo}_fresh") {
414         movetogarbage;
415     }
416
417     printdebug "install $destrepo => ".realdestrepo."\n";
418     rename $destrepo, realdestrepo or die $!;
419     remove "$destrepo.lock" or die $!;
420 }
421
422 sub main__git_receive_pack () {
423     makeworkingclone();
424     setupstunthook();
425     runcmd qw(git receive-pack), $workrepo;
426     dealwithfreshrepo();
427     maybeinstallprospective();
428 }
429
430 #----- stunt post-receive hook -----
431
432 our ($tagname, $tagval, $suite, $oldcommit, $commit);
433 our ($version, %tagh);
434
435 sub readupdates () {
436     printdebug " updates ...\n";
437     while (<STDIN>) {
438         chomp or die;
439         printdebug " upd.| $_\n";
440         m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
441         my ($old, $sha1, $refname) = ($1, $2, $3);
442         if ($refname =~ m{^refs/tags/(?=debian/)}) {
443             reject "pushing multiple tags!" if defined $tagname;
444             $tagname = $'; #';
445             $tagval = $sha1;
446             reject "tag $tagname already exists -".
447                 " not replacing previously-pushed version"
448                 if $old =~ m/[^0]/;
449         } elsif ($refname =~ m{^refs/dgit/}) {
450             reject "pushing multiple heads!" if defined $suite;
451             $suite = $'; #';
452             $oldcommit = $old;
453             $commit = $sha1;
454         } else {
455             reject "pushing unexpected ref!";
456         }
457     }
458     STDIN->error and die $!;
459
460     reject "push is missing tag ref update" unless defined $tagname;
461     reject "push is missing head ref update" unless defined $suite;
462     printdebug " updates ok.\n";
463 }
464
465 sub parsetag () {
466     printdebug " parsetag...\n";
467     open PT, ">dgit-tmp/plaintext" or die $!;
468     open DS, ">dgit-tmp/plaintext.asc" or die $!;
469     open T, "-|", qw(git cat-file tag), $tagval or die $!;
470     for (;;) {
471         $!=0; $_=<T>; defined or die $!;
472         print PT or die $!;
473         if (m/^(\S+) (.*)/) {
474             push @{ $tagh{$1} }, $2;
475         } elsif (!m/\S/) {
476             last;
477         } else {
478             die;
479         }
480     }
481     $!=0; $_=<T>; defined or die $!;
482     m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or
483         reject "tag message not in expected format";
484
485     die unless $1 eq $package;
486     $version = $2;
487     die "$3 != $suite " unless $3 eq $suite;
488
489     my $copyl = $_;
490     for (;;) {
491         print PT $copyl or die $!;
492         $!=0; $_=<T>; defined or die "missing signature? $!";
493         $copyl = $_;
494         if (m/^\[dgit ([^"].*)\]$/) { # [dgit "something"] is for future
495             $_ = $1." ";
496             while (length) {
497                 if (s/^distro\=(\S+) //) {
498                     die "$1 != $distro" unless $1 eq $distro;
499                 } elsif (s/^(--deliberately-$deliberately_re) //) {
500                     push @deliberatelies, $1;
501                 } elsif (s/^supersede:(\S+)=(\w+) //) {
502                     die "supersede $1 twice" if defined $supersedes{$1};
503                     $supersedes{$1} = $2;
504                 } elsif (s/^[-+.=0-9a-z]\S* //) {
505                 } else {
506                     die "unknown dgit info in tag ($_)";
507                 }
508             }
509             next;
510         }
511         last if m/^-----BEGIN PGP/;
512     }
513     $_ = $copyl;
514     for (;;) {
515         print DS or die $!;
516         $!=0; $_=<T>;
517         last if !defined;
518     }
519     T->error and die $!;
520     close PT or die $!;
521     close DS or die $!;
522     printdebug " parsetag ok.\n";
523 }
524
525 sub checksig_keyring ($) {
526     my ($keyringfile) = @_;
527     # returns primary-keyid if signed by a key in this keyring
528     # or undef if not
529     # or dies on other errors
530
531     my $ok = undef;
532
533     printdebug " checksig keyring $keyringfile...\n";
534
535     our @cmd = (qw(gpgv --status-fd=1 --keyring),
536                    $keyringfile,
537                    qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext));
538     debugcmd '|',@cmd;
539
540     open P, "-|", @cmd
541         or die $!;
542
543     while (<P>) {
544         next unless s/^\[GNUPG:\] //;
545         chomp or die;
546         printdebug " checksig| $_\n";
547         my @l = split / /, $_;
548         if ($l[0] eq 'NO_PUBKEY') {
549             last;
550         } elsif ($l[0] eq 'VALIDSIG') {
551             my $sigtype = $l[9];
552             $sigtype eq '00' or reject "signature is not of type 00!";
553             $ok = $l[10];
554             die unless defined $ok;
555             last;
556         }
557     }
558     close P;
559
560     printdebug sprintf " checksig ok=%d\n", !!$ok;
561
562     return $ok;
563 }
564
565 sub dm_txt_check ($$) {
566     my ($keyid, $dmtxtfn) = @_;
567     printdebug " dm_txt_check $keyid $dmtxtfn\n";
568     open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
569     while (<DT>) {
570         m/^fingerprint:\s+$keyid$/oi
571             ..0 or next;
572         if (s/^allow:/ /i..0) {
573         } else {
574             m/^./
575                 or reject "key $keyid missing Allow section in permissions!";
576             next;
577         }
578         # in right stanza...
579         s/^[ \t]+//
580             or reject "package $package not allowed for key $keyid";
581         # in allow field...
582         s/\([^()]+\)//;
583         s/\,//;
584         chomp or die;
585         printdebug " dm_txt_check allow| $_\n";
586         foreach my $p (split /\s+/) {
587             if ($p eq $package) {
588                 # yay!
589                 printdebug " dm_txt_check ok\n";
590                 return;
591             }
592         }
593     }
594     DT->error and die $!;
595     close DT or die $!;
596     reject "key $keyid not in permissions list although in keyring!";
597 }
598
599 sub verifytag () {
600     foreach my $kas (split /:/, $keyrings) {
601         printdebug "verifytag $kas...\n";
602         $kas =~ s/^([^,]+),// or die;
603         my $keyid = checksig_keyring $1;
604         if (defined $keyid) {
605             if ($kas =~ m/^a$/) {
606                 printdebug "verifytag a ok\n";
607                 return; # yay
608             } elsif ($kas =~ m/^m([^,]+)$/) {
609                 dm_txt_check($keyid, $1);
610                 printdebug "verifytag m ok\n";
611                 return;
612             } else {
613                 die;
614             }
615         }   
616     }
617     reject "key not found in keyrings";
618 }
619
620 sub checksuite () {
621     printdebug "checksuite ($suitesfile)\n";
622     open SUITES, "<", $suitesfile or die $!;
623     while (<SUITES>) {
624         chomp;
625         next unless m/\S/;
626         next if m/^\#/;
627         s/\s+$//;
628         return if $_ eq $suite;
629     }
630     die $! if SUITES->error;
631     reject "unknown suite";
632 }
633
634 sub checktagnoreplay () {
635     # We check that the signed tag mentions the name and tag object id of
636     # (a) in the case of FRESHREPO all tags in the repo;
637     # (b) in the case of just NOFFCHECK all tags referring to
638     #     the current head for the suite (there must be at least one).
639     # This prevents a replay attack using an earlier signed tag.
640     return unless $policy & (FRESHREPO|NOFFCHECK);
641
642     my $garbagerepo = "$dgitrepos/${package}_garbage";
643     lockrealtree();
644
645     local $ENV{GIT_DIR};
646     foreach my $garb ("$garbagerepo", "$garbagerepo-old") {
647         if (stat_exists $garb) {
648             $ENV{GIT_DIR} = $garb;
649             last;
650         }
651     }
652     if (!defined $ENV{GIT_DIR}) {
653         # Nothing to overwrite so the FRESHREPO and NOFFCHECK were
654         # pointless.  Oh well.
655         printdebug "checktagnoreplay - no garbage, ok\n";
656         return;
657     }
658
659     my $onlyreferring;
660     if (!($policy & FRESHREPO)) {
661         my $branch = server_branch($suite);
662         $!=0; $?=0; $_ =
663             `git for-each-ref --format='%(objectname)' '[r]efs/$branch'`;
664         defined or die "$branch $? $!";
665         $? and die "$branch $?";
666         if (!length) {
667             # No such branch - NOFFCHECK was unnecessary.  Oh well.
668             printdebug "checktagnoreplay - not FRESHREPO, new branch, ok\n";
669             return;
670         }
671         m/^(\w+)\n$/ or die "$branch $_ ?";
672         $onlyreferring = $1;
673         printdebug "checktagnoreplay - not FRESHREPO,".
674             " checking for overwriting refs/$branch=$onlyreferring\n";
675     }
676
677     my @problems;
678
679     git_for_each_tag_referring($onlyreferring, sub {
680         my ($tagobjid,$refobjid,$fullrefname,$tagname) = @_;
681         printdebug "checktagnoreplay - overwriting".
682             " $fullrefname=$tagobjid->$refobjid\n";
683         my $supers = $supersedes{$fullrefname};
684         if (!defined $supers) {
685             printdebug "checktagnoreply - fallbacks\n";
686             my $super_fallback = 0;
687             foreach my $didsuper (sort keys %supersedes) {
688                 my $didsuper_tagobjid = $supersedes{$didsuper};
689                 my $didsuper_refobjid = git_rev_parse $didsuper_tagobjid;
690                 printdebug "checktagnoreply - fallback".
691                     " $didsuper=$didsuper_refobjid->$didsuper_tagobjid\n";
692                 last if 
693                     $refobjid ne $didsuper_refobjid
694                     and is_fast_fwd($refobjid, $didsuper_refobjid);
695                 printdebug "checktagnoreply - fallback $didsuper OK\n";
696                 $super_fallback = 1;
697             }
698             push @problems, "does not supersede $fullrefname"
699                 unless $super_fallback;
700         } elsif ($supers ne $tagobjid) {
701             push @problems,
702  "supersedes $fullrefname=$supers but previously $fullrefname=$tagobjid";
703         } else {
704             # ok;
705         }
706     });
707
708     if (@problems) {
709         reject "replay attack prevention check failed:".
710             " signed tag for $version: ".
711             join("; ", @problems).
712             "\n";
713     }
714     printdebug "checktagnoreply - all ok\n"
715 }
716
717 sub tagh1 ($) {
718     my ($tag) = @_;
719     my $vals = $tagh{$tag};
720     reject "missing header $tag in signed tag object" unless $vals;
721     reject "multiple headers $tag in signed tag object" unless @$vals == 1;
722     return $vals->[0];
723 }
724
725 sub checks () {
726     printdebug "checks\n";
727
728     tagh1('type') eq 'commit' or reject "tag refers to wrong kind of object";
729     tagh1('object') eq $commit or reject "tag refers to wrong commit";
730     tagh1('tag') eq $tagname or reject "tag name in tag is wrong";
731
732     my $v = $version;
733     $v =~ y/~:/_%/;
734
735     printdebug "translated version $v\n";
736     $tagname eq "debian/$v" or die;
737
738     lockrealtree();
739
740     my @policy_args = ($package,$version,$suite,$tagname,
741                        join(",",@deliberatelies));
742     $policy = policyhook(NOFFCHECK|FRESHREPO, 'push', @policy_args);
743
744     checktagnoreplay();
745     checksuite();
746
747     # check that our ref is being fast-forwarded
748     printdebug "oldcommit $oldcommit\n";
749     if (!($policy & NOFFCHECK) && $oldcommit =~ m/[^0]/) {
750         $?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
751         chomp $mb;
752         $mb eq $oldcommit or reject "not fast forward on dgit branch";
753     }
754
755     if ($policy & FRESHREPO) {
756         # This is troublesome.  We have been asked by the policy hook
757         # to receive the push into a fresh repo.  But of course we
758         # have actually already mostly received the push into the working
759         # repo.  (This is unavoidable because the instruction to use a new
760         # repo comes ultimately from the signed tag for the dgit push,
761         # which has to have been received into some repo.)
762         #
763         # So what we do is generate a fresh working repo right now and
764         # push the head and tag into it.  The presence of this fresh
765         # working repo is detected by the parent, which responds by
766         # making a fresh master repo from the template.
767
768         $destrepo = "${workrepo}_fresh"; # workrepo lock covers
769         mkrepo_fromtemplate $destrepo;
770     }
771
772     my $willinstall = ($destrepo eq realdestrepo ? '' : $destrepo);
773     policyhook(0, 'push-confirm', @policy_args, $willinstall);
774 }
775
776 sub onwardpush () {
777     my @cmd = (qw(git send-pack), $destrepo);
778     push @cmd, qw(--force) if $policy & NOFFCHECK;
779     push @cmd, "$commit:refs/dgit/$suite",
780                "$tagval:refs/tags/$tagname";
781     debugcmd '+',@cmd;
782     $!=0;
783     my $r = system @cmd;
784     !$r or die "onward push to $destrepo failed: $r $!";
785 }
786
787 sub stunthook () {
788     printdebug "stunthook in $workrepo\n";
789     chdir $workrepo or die "chdir $workrepo: $!";
790     mkdir "dgit-tmp" or $!==EEXIST or die $!;
791     readupdates();
792     parsetag();
793     verifytag();
794     checks();
795     onwardpush();
796     printdebug "stunthook done.\n";
797 }
798
799 #----- git-upload-pack -----
800
801 sub fixmissing__git_upload_pack () {
802     $destrepo = "$dgitrepos/_empty";
803     my $lfh = locksometree($destrepo);
804     return if stat_exists $destrepo;
805     rmtree "$destrepo.new";
806     mkemptyrepo "$destrepo.new", "0644";
807     rename "$destrepo.new", $destrepo or die $!;
808     unlink "$destrepo.lock" or die $!;
809     close $lfh;
810 }
811
812 sub main__git_upload_pack () {
813     my $lfh = locksometree($destrepo);
814     printdebug "git-upload-pack in $destrepo\n";
815     chdir $destrepo or die "$destrepo: $!";
816     close $lfh;
817     runcmd qw(git upload-pack), ".";
818 }
819
820 #----- arg parsing and main program -----
821
822 sub argval () {
823     die unless @ARGV;
824     my $v = shift @ARGV;
825     die if $v =~ m/^-/;
826     return $v;
827 }
828
829 our %indistrodir = (
830     # keys are used for DGIT_DRS_XXX too
831     'repos' => \$dgitrepos,
832     'suites' => \$suitesfile,
833     'policy-hook' => \$policyhook,
834     'dgit-live' => \$dgitlive,
835     );
836
837 our @hookenvs = qw(distro suitesfile policyhook
838                    dgitlive keyrings dgitrepos distrodir);
839
840 # workrepo and destrepo handled ad-hoc
841
842 sub mode_ssh () {
843     die if @ARGV;
844
845     my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
846     $cmd =~ m{
847         ^
848         (?: \S* / )?
849         ( [-0-9a-z]+ )
850         \s+
851         '? (?: \S* / )?
852         ($package_re) \.git
853         '?$
854     }ox 
855     or reject "command string not understood";
856     my $method = $1;
857     $package = $2;
858
859     my $funcn = $method;
860     $funcn =~ y/-/_/;
861     my $mainfunc = $main::{"main__$funcn"};
862
863     reject "unknown method" unless $mainfunc;
864
865     policy_checkpackage();
866
867     if (stat_exists realdestrepo) {
868         $destrepo = realdestrepo;
869     } else {
870         printdebug " fixmissing $funcn\n";
871         my $fixfunc = $main::{"fixmissing__$funcn"};
872         &$fixfunc;
873     }
874
875     printdebug " running main $funcn\n";
876     &$mainfunc;
877 }
878
879 sub mode_cron () {
880     die if @ARGV;
881
882     my $listfh = tempfile();
883     open STDOUT, ">&", $listfh or die $!;
884     policyhook(0,'check-list');
885     open STDOUT, ">&STDERR" or die $!;
886
887     seek $listfh, 0, 0 or die $!;
888     while (<$listfh>) {
889         chomp or die;
890         next if m/^\s*\#/;
891         next unless m/\S/;
892         die unless m/^($package_re)$/;
893         
894         $package = $1;
895         policy_checkpackage();
896     }
897     die $! if $listfh->error;
898 }    
899
900 sub parseargsdispatch () {
901     die unless @ARGV;
902
903     delete $ENV{'GIT_DIR'}; # if not run via ssh, our parent git process
904     delete $ENV{'GIT_PREFIX'}; # sets these and they mess things up
905
906     if ($ENV{'DGIT_DRS_DEBUG'}) {
907         enabledebug();
908     }
909
910     if ($ARGV[0] eq '--pre-receive-hook') {
911         if ($debuglevel) {
912             $debugprefix.="=";
913             printdebug "in stunthook ".(shellquote @ARGV)."\n";
914             foreach my $k (sort keys %ENV) {
915                 printdebug "$k=$ENV{$k}\n" if $k =~  m/^DGIT/;
916             }
917         }
918         shift @ARGV;
919         @ARGV == 1 or die;
920         $package = shift @ARGV;
921         ${ $main::{$_} } = $ENV{"DGIT_DRS_\U$_"} foreach @hookenvs;
922         defined($workrepo = $ENV{'DGIT_DRS_WORK'}) or die;
923         defined($destrepo = $ENV{'DGIT_DRS_DEST'}) or die;
924         open STDOUT, ">&STDERR" or die $!;
925         eval {
926             stunthook();
927         };
928         if ($@) {
929             recorderror "$@" or die;
930             die $@;
931         }
932         exit 0;
933     }
934
935     $distro    = argval();
936     $distrodir = argval();
937     $keyrings  = argval();
938
939     foreach my $dk (keys %indistrodir) {
940         ${ $indistrodir{$dk} } = "$distrodir/$dk";
941     }
942
943     while (@ARGV && $ARGV[0] =~ m/^--([-0-9a-z]+)=/ && $indistrodir{$1}) {
944         ${ $indistrodir{$1} } = $'; #';
945         shift @ARGV;
946     }
947
948     $ENV{"DGIT_DRS_\U$_"} = ${ $main::{$_} } foreach @hookenvs;
949
950     die unless @ARGV==1;
951
952     my $mode = shift @ARGV;
953     die unless $mode =~ m/^--(\w+)$/;
954     my $fn = ${*::}{"mode_$1"};
955     die unless $fn;
956     $fn->();
957 }
958
959 sub unlockall () {
960     while (my $fh = pop @lockfhs) { close $fh; }
961 }
962
963 sub cleanup () {
964     unlockall();
965     if (!chdir "$dgitrepos/_tmp") {
966         $!==ENOENT or die $!;
967         return;
968     }
969     foreach my $lf (<*.lock>) {
970         my $tree = $lf;
971         $tree =~ s/\.lock$//;
972         next unless acquirermtree($tree, 0);
973         remove $lf or warn $!;
974         unlockall();
975     }
976 }
977
978 parseargsdispatch();
979 cleanup();