chiark / gitweb /
Bring forward push of the version tag ref so it happens alongside the push of the...
[dgit.git] / dgit-repos-server
1 #!/usr/bin/perl -w
2 # dgit-repos-push-receiver
3 #
4 # usages:
5 #  .../dgit-repos-push-receiver SUITES KEYRING-AUTH-SPEC DGIT-REPOS-DIR --ssh
6 # internal usage:
7 #  .../dgit-repos-push-receiver --pre-receive-hook PACKAGE
8 #
9 # Invoked as the ssh restricted command
10 #
11 # Works like git-receive-pack
12 #
13 # SUITES is the name of a file which lists the permissible suites
14 # one per line (#-comments and blank lines ignored)
15 #
16 # KEYRING-AUTH-SPEC is a :-separated list of
17 #   KEYRING.GPG,AUTH-SPEC
18 # where AUTH-SPEC is one of
19 #   a
20 #   mDM.TXT
21
22 use strict;
23
24 # What we do is this:
25 #  - extract the destination repo name
26 #  - make a hardlink clone of the destination repo
27 #  - provide the destination with a stunt pre-receive hook
28 #  - run actual git-receive-pack with that new destination
29 #   as a result of this the stunt pre-receive hook runs; it does this:
30 #    + understand what refs we are allegedly updating and
31 #      check some correspondences:
32 #        * we are updating only refs/tags/debian/* and refs/dgit/*
33 #        * and only one of each
34 #        * and the tag does not already exist
35 #      and
36 #        * recover the suite name from the destination refs/dgit/ ref
37 #    + disassemble the signed tag into its various fields and signature
38 #      including:
39 #        * parsing the first line of the tag message to recover
40 #          the package name, version and suite
41 #        * checking that the package name corresponds to the dest repo name
42 #        * checking that the suite name is as recovered above
43 #    + verify the signature on the signed tag
44 #      and if necessary check that the keyid and package are listed in dm.txt
45 #    + check various correspondences:
46 #        * the suite is one of those permitted
47 #        * the signed tag must refer to a commit
48 #        * the signed tag commit must be the refs/dgit value
49 #        * the name in the signed tag must correspond to its ref name
50 #        * the tag name must be debian/<version> (massaged as needed)
51 #        * the signed tag has a suitable name
52 #        * the commit is a fast forward
53 #    + push the signed tag and new dgit branch to the actual repo
54 #
55 # If the destination repo does not already exist, we need to make
56 # sure that we create it reasonably atomically, and also that
57 # we don't every have a destination repo containing no refs at all
58 # (because such a thing causes git-fetch-pack to barf).  So then we
59 # do as above, except:
60 #  - before starting, we take out our own lock for the destination repo
61 #  - we create a prospective new destination repo by making a copy
62 #    of _template
63 #  - we use the prospective new destination repo instead of the
64 #    actual new destination repo (since the latter doesn't exist)
65 #  - we set up a post-receive hook as well, which
66 #    + touches a stamp file
67 #  - after git-receive-pack exits, we
68 #    + check that the prospective repo contains a tag and head
69 #    + rename the prospective destination repo into place
70 #
71 # Cleanup strategy:
72 #  - We are crash-only
73 #  - Temporary working trees and their locks are cleaned up
74 #    opportunistically by a program which tries to take each lock and
75 #    if successful deletes both the tree and the lockfile
76 #  - Prospective working trees and their locks are cleaned up by
77 #    a program which tries to take each lock and if successful
78 #    deletes any prospective working tree and the lock (but not
79 #    of course any actual tree)
80 #  - It is forbidden to _remove_ the lockfile without removing
81 #    the corresponding temporary tree, as the lockfile is also
82 #    a stampfile whose presence indicates that there may be
83 #    cleanup to do
84
85 use POSIX;
86 use Fcntl qw(:flock);
87 use File::Path qw(rmtree);
88
89 our $package_re = '[0-9a-z][-+.0-9a-z]+';
90
91 our $func;
92 our $dgitrepos;
93 our $pkg;
94 our $suitesfile;
95 our $realdestrepo;
96 our $destrepo;
97 our $workrepo;
98 our @keyrings;
99 our @lockfhs;
100
101 #----- utilities -----
102
103 sub acquirelock ($$) {
104     my ($lock, $must) = @_;
105     my $fh;
106     for (;;) {
107         close $fh if $fh;
108         $fh = new IO::File, ">", $lock or die "open $lock: $!";
109         my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
110         if (!$ok) {
111             return undef unless $must;
112             die "flock $lock: $!";
113         }
114         if (!stat $lock) {
115             next if $! == ENOENT;
116             die "stat $lock: $!";
117         }
118         my $want = (stat _)[1];
119         stat $fh or die $!;
120         my $got = (stat _)[1];
121         last if $got == $want;
122     }
123     return $fh;
124 }
125
126 sub acquiretree ($$) {
127     my ($tree, $must) = @_;
128     my $fh = acquirelock("$tree.lock", $must);
129     if ($fh) {
130         push @lockfhs, $fh;
131         rmtree $tree;
132     }
133     return $fh;
134 }
135
136 sub reject ($) {
137     die "dgit-repos-server: reject: $_[0]\n";
138 }
139
140 #----- git-receive-pack -----
141
142 sub fixmissing__git_receive_pack () {
143     $destrepo = "$dgitrepos/_tmp/${pkg}_prospective";
144     acquiretree($destrepo, 1);
145     my $r = system qw(cp -a --), "$dgitrepos/_template", "$destrepo";
146     !$r or die "create new repo failed failed: $r $!";
147 }
148
149 sub makeworkingclone () {
150     $workrepo = "$dgitrepos/_tmp/${pkg}_incoming$$";
151     acquiretree($workrepo, 1);
152     runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
153 }
154
155 sub setupstunthook () {
156     my $prerecv = "$workrepo/hooks/pre-receive";
157     my $fh = new IO::File, $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
158         or die "$prerecv: $!";
159     print $fh <<END or die "$prerecv: $!";
160 #!/bin/sh
161 set -e
162 exec $0 --pre-receive-hook $pkg
163 END
164     close $fh or die "$prerecv: $!";
165     $ENV{'DGIT_RPR_WORK'}= $workrepo;
166     $ENV{'DGIT_RPR_DEST'}= $destrepo;
167 }
168
169 sub maybeinstallprospective () {
170     return if $destrepo eq $realdestrepo;
171
172     my $child = open SR, "-|";
173     defined $child or die $!;
174     if (!$child) {
175         chdir $destrepo or die $!;
176         exec qw(git show-ref);
177         die $!;
178     }
179     my %got = qw(tag 0 head 0);
180     while (<SR>) {
181         chomp or die;
182         s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
183         my $wh =
184             m{^refs/tags/} ? 'tag' :
185             m{^refs/dgit/} ? 'head' :
186             die;
187         die if $got{$wh}++;
188     }
189     die if grep { !$_ } values %got;
190     $!=0; $?=0; close SR or die "$? $!";
191
192     rename $destrepo, $realdestrepo or die $!;
193     remove "$destrepo.lock" or die $!;
194 }
195
196 sub main__git_receive_pack () {
197     makeworkingclone();
198     setupstunthook();
199     runcmd qw(git receive-pack), $destdir;
200     maybeinstallprospective();
201 }
202
203 #----- stunt post-receive hook -----
204
205 our ($tagname, $tagval, $suite, $oldcommit, $commit);
206 our ($version, %tagh);
207
208 sub readupdates () {
209     while (<STDIN>) {
210         m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
211         my ($old, $sha1, $refname) = ($1, $2, $3);
212         if ($refname =~ m{^refs/tags/(?=debian/)}) {
213             die if defined $tagname;
214             $tagname = $'; #';
215             $tagval = $sha1;
216             reject "tag $tagname already exists -".
217                 " not replacing previously-pushed version"
218                 if $old =~ m/[^0]/;
219         } elsif ($refname =~ m{^refs/dgit/}) {
220             die if defined $suite;
221             $suite = $'; #';
222             $oldcommit = $old;
223             $commit = $sha1;
224         } else {
225             die;
226         }
227     }
228     STDIN->error and die $!;
229
230     die unless defined $refname;
231     die unless defined $branchname;
232 }
233
234 sub parsetag () {
235     open PT, ">dgit-tmp/plaintext" or die $!;
236     open DS, ">dgit-tmp/plaintext.asc" or die $!;
237     open T, "-|", qw(git cat-file tag), $tagval or die $!;
238     for (;;) {
239         $!=0; $_=<T>; defined or die $!;
240         print PT or die $!;
241         if (m/^(\S+) (.*)/) {
242             push @{ $tagh{$1} }, $2;
243         } elsif (!m/\S/) {
244             last;
245         } else {
246             die;
247         }
248     }
249     $!=0; $_=<T>; defined or die $!;
250     m/^($package_re) release (\S+) for (\S+) \[dgit\]$/ or die;
251
252     die unless $1 eq $pkg;
253     $version = $2;
254     die unless $3 eq $suite;
255
256     for (;;) {
257         print PT or die $!;
258         $!=0; $_=<T>; defined or die $!;
259         last if m/^-----BEGIN PGP/;
260     }
261     for (;;) {
262         print DS or die $!;
263         $!=0; $_=<T>;
264         last if !defined;
265     }
266     T->error and die $!;
267     close PT or die $!;
268     close DS or die $!;
269 }
270
271 sub checksig_keyring ($) {
272     my ($keyringfile) = @_;
273     # returns primary-keyid if signed by a key in this keyring
274     # or undef if not
275     # or dies on other errors
276
277     my $ok = undef;
278
279     open P, "-|", (qw(gpgv --status-fd=1),
280                    map { '--keyring', $_ }, @keyrings,
281                    qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext))
282         or die $!;
283
284     while (<P>) {
285         next unless s/^\[GNUPG:\]: //;
286         chomp or die;
287         my @l = split / /, $_;
288         if ($l[0] eq 'NO_PUBKEY') {
289             last;
290         } elsif ($l[0] eq 'VALIDSIG') {
291             my $sigtype = $l[9];
292             $sigtype eq '00' or reject "signature is not of type 00!";
293             $ok = $l[10];
294             die unless defined $ok;
295             last;
296         }
297     }
298     close P;
299
300     return $ok;
301 }
302
303 sub dm_txt_check ($$) {
304     my ($keyid, $dmtxtfn) = @_;
305     open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
306     while (<DT>) {
307         m/^fingerprint:\s+$keyid$/oi
308             ..0 or next;
309         m/^\S/
310             or reject "key $keyid missing Allow section in permissions!";
311         # in right stanza...
312         s/^allow:/ /i
313             ..0 or next;
314         s/^\s+//
315             or reject "package $package not allowed for key $keyid";
316         # in allow field...
317         s/\([^()]+\)//;
318         s/\,//;
319         foreach my $p (split /\s+/) {
320             return if $p eq $package; # yay!
321         }
322     }
323     DT->error and die $!;
324     close DT or die $!;
325     reject "key $keyid not in permissions list although in keyring!";
326 }
327
328 sub verifytag () {
329     foreach my $kas (split /:/, $keyrings) {
330         $kas =~ s/^([^,]+),// or die;
331         my $keyid = checksig_keyring $1;
332         if (defined $keyid) {
333             if ($kas =~ m/^a$/) {
334                 return; # yay
335             } elsif ($kas =~ m/^m([^,]+)$/) {
336                 dm_txt_check($keyid, $1);
337                 return;
338             } else {
339                 die;
340             }
341         }   
342     }
343     reject "key not found in keyrings";
344 }
345
346 sub checksuite () {
347     open SUITES, "<", $suitesfile or die $!;
348     while (<SUITES>) {
349         chomp;
350         next unless m/\S/;
351         next if m/^\#/;
352         s/\s+$//;
353         return if $_ eq $suite;
354     }
355     die $! if SUITES->error;
356     reject "unknown suite";
357 }
358
359 sub checks () {
360     checksuite();
361     tagh1('type') eq 'commit' or die;
362     tagh1('object') eq $commit or die;
363     tagh1('tag') eq $tagname or die;
364
365     my $v = $version;
366     $v =~ y/~:/_%/;
367     $tagname eq "debian/$v" or die;
368
369     # check that our ref is being fast-forwarded
370     if ($oldcommit =~ m/[^0]/) {
371         $?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
372         chomp $mb;
373         $mb eq $oldcommit or reject "not fast forward on dgit branch";
374     }
375 }
376
377 sub onwardpush () {
378     $!=0;
379     my $r = system (qw(git send-pack),
380                     $destrepo,
381                     "$commit:refs/dgit/$suite",
382                     "$tagval:refs/tags/$tagname");
383     !$r or die "onward push failed: $r $!";
384 }       
385
386 sub stunthook () {
387     chdir $workrepo or die "chdir $workrepo: $!";
388     mkdir "dgit-tmp" or $!==EEXIST or die $!;
389     readupdates();
390     parsetag();
391     verifytag();
392     checks();
393     onwardpush();
394 }
395
396 #----- git-upload-pack -----
397
398 sub fixmissing__git_upload_pack () {
399     $destrepo = "$dgitrepos/_empty";
400 }
401
402 sub main__git_upload_pack () {
403     runcmd qw(git upload-pack), $destdir;
404 }
405
406 #----- arg parsing and main program -----
407
408 sub argval () {
409     die unless @ARGV;
410     my $v = shift @ARGV;
411     die if $v =~ m/^-/;
412     return $v;
413 }
414
415 sub parseargsdispatch () {
416     die unless @ARGV;
417
418     if ($ARGV[0] eq '--pre-receive-hook') {
419         shift @ARGV;
420         @ARGV == 1 or die;
421         $pkg = shift @ARGV;
422         defined($suitesfile = $ENV{'DGIT_RPR_SUITES'}) or die;
423         defined($workrepo = $ENV{'DGIT_RPR_WORK'}) or die;
424         defined($destrepo = $ENV{'DGIT_RPR_DEST'}) or die;
425         defined($keyrings = $ENV{'DGIT_RPR_KEYRINGS'}) or die $!;
426         open STDOUT, ">&STDERR" or die $!;
427         stunthook();
428         exit 0;
429     }
430
431     $ENV{'DGIT_RPR_SUITES'} = argval();
432     $ENV{'DGIT_RPR_KEYRINGS'} = argval();
433     $dgitrepos = argval();
434
435     die unless @ARGV==1 && $ARGV[0] eq '--ssh';
436
437     my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
438     $cmd =~ m{
439         ^
440         (?: \S* / )?
441         ( [-0-9a-z]+ )
442         \s+
443         (?: \S* / )?
444         ($package_re) \.git
445         $
446     }ox 
447     or reject "command string not understood";
448     $method = $1;
449     $pkg = $2;
450     $realdestrepo = "$dgitrepos/$pkg.git";
451
452     my $funcn = $method;
453     $funcn =~ y/-/_/;
454     my $mainfunc = $main::{"main__$funcn"};
455
456     reject "unknown method" unless $mainfunc;
457
458     if (stat $realdestrepo) {
459         $destrepo = $realdestrepo;
460     } else {
461         $! == ENOENT or die "stat dest repo $destrepo: $!";
462         my $fixfunc = $main::{"fixmissing__$funcn"};
463         &$fixfunc;
464     }
465
466     &$mainfunc;
467 }
468
469 sub unlockall () {
470     while (my $fh = pop $lockfhs) { close $fh; }
471 }
472
473 sub cleanup () {
474     unlockall();
475     chdir "$dgitrepos/_tmp" or die $!;
476     foreach my $lock (<*.lock>) {
477         my $tree = $lf;
478         $tree =~ s/\.lock$//;
479         next unless acquiretree($tree, 0);
480         remove $lock or warn $!;
481         unlockall();
482     }
483 }
484
485 parseargsdispatch();
486 cleanup();