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