summaryrefslogtreecommitdiff
path: root/dgit-repos-server
blob: 3e74217a822159be9a602b2dd6549dd8af10eee4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
#!/usr/bin/perl -w
# dgit-repos-server
#
# usages:
#  .../dgit-repos-server SUITES KEYRING-AUTH-SPEC DGIT-REPOS-DIR --ssh
# internal usage:
#  .../dgit-repos-server --pre-receive-hook PACKAGE
#
# Invoked as the ssh restricted command
#
# Works like git-receive-pack
#
# SUITES is the name of a file which lists the permissible suites
# one per line (#-comments and blank lines ignored)
#
# KEYRING-AUTH-SPEC is a :-separated list of
#   KEYRING.GPG,AUTH-SPEC
# where AUTH-SPEC is one of
#   a
#   mDM.TXT

use strict;

# What we do is this:
#  - extract the destination repo name
#  - make a hardlink clone of the destination repo
#  - provide the destination with a stunt pre-receive hook
#  - run actual git-receive-pack with that new destination
#   as a result of this the stunt pre-receive hook runs; it does this:
#    + understand what refs we are allegedly updating and
#      check some correspondences:
#        * we are updating only refs/tags/debian/* and refs/dgit/*
#        * and only one of each
#        * and the tag does not already exist
#      and
#        * recover the suite name from the destination refs/dgit/ ref
#    + disassemble the signed tag into its various fields and signature
#      including:
#        * parsing the first line of the tag message to recover
#          the package name, version and suite
#        * checking that the package name corresponds to the dest repo name
#        * checking that the suite name is as recovered above
#    + verify the signature on the signed tag
#      and if necessary check that the keyid and package are listed in dm.txt
#    + check various correspondences:
#        * the suite is one of those permitted
#        * the signed tag must refer to a commit
#        * the signed tag commit must be the refs/dgit value
#        * the name in the signed tag must correspond to its ref name
#        * the tag name must be debian/<version> (massaged as needed)
#        * the signed tag has a suitable name
#        * the commit is a fast forward
#    + push the signed tag and new dgit branch to the actual repo
#
# If the destination repo does not already exist, we need to make
# sure that we create it reasonably atomically, and also that
# we don't every have a destination repo containing no refs at all
# (because such a thing causes git-fetch-pack to barf).  So then we
# do as above, except:
#  - before starting, we take out our own lock for the destination repo
#  - we create a prospective new destination repo by making a copy
#    of _template
#  - we use the prospective new destination repo instead of the
#    actual new destination repo (since the latter doesn't exist)
#  - we set up a post-receive hook as well, which
#    + touches a stamp file
#  - after git-receive-pack exits, we
#    + check that the prospective repo contains a tag and head
#    + rename the prospective destination repo into place
#
# Cleanup strategy:
#  - We are crash-only
#  - Temporary working trees and their locks are cleaned up
#    opportunistically by a program which tries to take each lock and
#    if successful deletes both the tree and the lockfile
#  - Prospective working trees and their locks are cleaned up by
#    a program which tries to take each lock and if successful
#    deletes any prospective working tree and the lock (but not
#    of course any actual tree)
#  - It is forbidden to _remove_ the lockfile without removing
#    the corresponding temporary tree, as the lockfile is also
#    a stampfile whose presence indicates that there may be
#    cleanup to do

use POSIX;
use Fcntl qw(:flock);
use File::Path qw(rmtree);

open DEBUG, ">/dev/null" or die $!;

our $package_re = '[0-9a-z][-+.0-9a-z]+';

our $func;
our $dgitrepos;
our $package;
our $suitesfile;
our $realdestrepo;
our $destrepo;
our $workrepo;
our $keyrings;
our @lockfhs;
our $debug='';

#----- utilities -----

sub debug {
    print DEBUG "$debug @_\n";
}

sub acquirelock ($$) {
    my ($lock, $must) = @_;
    my $fh;
    printf DEBUG "$debug locking %s %d\n", $lock, $must;
    for (;;) {
	close $fh if $fh;
	$fh = new IO::File $lock, ">" or die "open $lock: $!";
	my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
	if (!$ok) {
	    die "flock $lock: $!" if $must;
	    debug " locking $lock failed";
	    return undef;
	}
	if (!stat $lock) {
	    next if $! == ENOENT;
	    die "stat $lock: $!";
	}
	my $want = (stat _)[1];
	stat $fh or die $!;
	my $got = (stat _)[1];
	last if $got == $want;
    }
    return $fh;
}

sub acquiretree ($$) {
    my ($tree, $must) = @_;
    my $fh = acquirelock("$tree.lock", $must);
    if ($fh) {
	push @lockfhs, $fh;
	rmtree $tree;
    }
    return $fh;
}

sub mkrepotmp () {
    my $tmpdir = "$dgitrepos/_tmp";
    return if mkdir $tmpdir;
    return if $! == EEXIST;
    die $!;
}

sub recorderror ($) {
    my ($why) = @_;
    my $w = $ENV{'DGIT_DRS_WORK'}; # we are in stunthook
    if (defined $w) {
	chomp $why;
	open ERR, ">", "$w/drs-error" or die $!;
	print ERR $why, "\n" or die $!;
	close ERR or die $!;
	return 1;
    }
    return 0;
}

sub reject ($) {
    my ($why) = @_;
    recorderror "reject: $why";
    die "dgit-repos-server: reject: $why\n";
}

sub debugcmd {
    if ($debug) {
	use Data::Dumper;
	local $Data::Dumper::Indent = 0;
	local $Data::Dumper::Terse = 1;
	debug "|".Dumper(\@_);
    }
}

sub runcmd {
    debugcmd @_;
    $!=0; $?=0;
    my $r = system @_;
    die "@_ $? $!" if $r;
}

#----- git-receive-pack -----

sub fixmissing__git_receive_pack () {
    mkrepotmp();
    $destrepo = "$dgitrepos/_tmp/${package}_prospective";
    acquiretree($destrepo, 1);
    my $template = "$dgitrepos/_template";
    debug "fixmissing copy tempalate $template -> $destrepo";
    my $r = system qw(cp -a --), $template, $destrepo;
    !$r or die "create new repo failed failed: $r $!";
}

sub makeworkingclone () {
    mkrepotmp();
    $workrepo = "$dgitrepos/_tmp/${package}_incoming$$";
    acquiretree($workrepo, 1);
    runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
}

sub setupstunthook () {
    my $prerecv = "$workrepo/hooks/pre-receive";
    my $fh = new IO::File $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
	or die "$prerecv: $!";
    print $fh <<END or die "$prerecv: $!";
#!/bin/sh
set -e
exec $0 --pre-receive-hook $package
END
    close $fh or die "$prerecv: $!";
    $ENV{'DGIT_DRS_WORK'}= $workrepo;
    $ENV{'DGIT_DRS_DEST'}= $destrepo;
    debug " stunt hook set up $prerecv";
}

sub maybeinstallprospective () {
    return if $destrepo eq $realdestrepo;

    if (open REJ, "<", "$workrepo/drs-error") {
	local $/ = undef;
	my $msg = <REJ>;
	REJ->error and die $!;
	print STDERR $msg;
	exit 1;
    } else {
	$!==&ENOENT or die $!;
    }

    debug " show-ref ($destrepo) ...";

    my $child = open SR, "-|";
    defined $child or die $!;
    if (!$child) {
	chdir $destrepo or die $!;
	exec qw(git show-ref);
	die $!;
    }
    my %got = qw(tag 0 head 0);
    while (<SR>) {
	chomp or die;
	debug " show-refs| $_";
	s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
	my $wh =
	    m{^refs/tags/} ? 'tag' :
	    m{^refs/dgit/} ? 'head' :
	    die;
	die if $got{$wh}++;
    }
    $!=0; $?=0; close SR or $?==256 or die "$? $!";

    debug "installprospective ?";
    die Dumper(\%got)." -- missing refs in new repo"
	if grep { !$_ } values %got;

    debug "install $destrepo => $realdestrepo";
    rename $destrepo, $realdestrepo or die $!;
    remove "$destrepo.lock" or die $!;
}

sub main__git_receive_pack () {
    makeworkingclone();
    setupstunthook();
    runcmd qw(git receive-pack), $workrepo;
    maybeinstallprospective();
}

#----- stunt post-receive hook -----

our ($tagname, $tagval, $suite, $oldcommit, $commit);
our ($version, %tagh);

sub readupdates () {
    debug " updates ...";
    while (<STDIN>) {
	chomp or die;
	debug " upd.| $_";
	m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
	my ($old, $sha1, $refname) = ($1, $2, $3);
	if ($refname =~ m{^refs/tags/(?=debian/)}) {
	    reject "pushing multiple tags!" if defined $tagname;
	    $tagname = $'; #';
	    $tagval = $sha1;
	    reject "tag $tagname already exists -".
		" not replacing previously-pushed version"
		if $old =~ m/[^0]/;
	} elsif ($refname =~ m{^refs/dgit/}) {
	    reject "pushing multiple heads!" if defined $suite;
	    $suite = $'; #';
	    $oldcommit = $old;
	    $commit = $sha1;
	} else {
	    reject "pushing unexpected ref!";
	}
    }
    STDIN->error and die $!;

    reject "push is missing tag ref update" unless defined $tagname;
    reject "push is missing head ref update" unless defined $suite;
    debug " updates ok.";
}

sub parsetag () {
    debug " parsetag...";
    open PT, ">dgit-tmp/plaintext" or die $!;
    open DS, ">dgit-tmp/plaintext.asc" or die $!;
    open T, "-|", qw(git cat-file tag), $tagval or die $!;
    for (;;) {
	$!=0; $_=<T>; defined or die $!;
	print PT or die $!;
	if (m/^(\S+) (.*)/) {
	    push @{ $tagh{$1} }, $2;
	} elsif (!m/\S/) {
	    last;
	} else {
	    die;
	}
    }
    $!=0; $_=<T>; defined or die $!;
    m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or
	reject "tag message not in expected format";

    die unless $1 eq $package;
    $version = $2;
    die "$3 != $suite " unless $3 eq $suite;

    for (;;) {
	print PT or die $!;
	$!=0; $_=<T>; defined or die "missing signature? $!";
	last if m/^-----BEGIN PGP/;
    }
    for (;;) {
	print DS or die $!;
	$!=0; $_=<T>;
	last if !defined;
    }
    T->error and die $!;
    close PT or die $!;
    close DS or die $!;
    debug " parsetag ok.";
}

sub checksig_keyring ($) {
    my ($keyringfile) = @_;
    # returns primary-keyid if signed by a key in this keyring
    # or undef if not
    # or dies on other errors

    my $ok = undef;

    debug " checksig keyring $keyringfile...";

    our @cmd = (qw(gpgv --status-fd=1 --keyring),
		   $keyringfile,
		   qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext));
    debugcmd @cmd;

    open P, "-|", @cmd
	or die $!;

    while (<P>) {
	next unless s/^\[GNUPG:\] //;
	chomp or die;
	debug " checksig| $_";
	my @l = split / /, $_;
	if ($l[0] eq 'NO_PUBKEY') {
	    last;
	} elsif ($l[0] eq 'VALIDSIG') {
	    my $sigtype = $l[9];
	    $sigtype eq '00' or reject "signature is not of type 00!";
	    $ok = $l[10];
	    die unless defined $ok;
	    last;
	}
    }
    close P;

    debug sprintf " checksig ok=%d", !!$ok;

    return $ok;
}

sub dm_txt_check ($$) {
    my ($keyid, $dmtxtfn) = @_;
    debug " dm_txt_check $keyid $dmtxtfn";
    open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
    while (<DT>) {
	m/^fingerprint:\s+$keyid$/oi
	    ..0 or next;
	if (s/^allow:/ /i..0) {
	} else {
	    m/^./
		or reject "key $keyid missing Allow section in permissions!";
	    next;
	}
	# in right stanza...
	s/^[ \t]+//
	    or reject "package $package not allowed for key $keyid";
	# in allow field...
	s/\([^()]+\)//;
	s/\,//;
	chomp or die;
	debug " dm_txt_check allow| $_";
	foreach my $p (split /\s+/) {
	    if ($p eq $package) {
		# yay!
		debug " dm_txt_check ok";
		return;
	    }
	}
    }
    DT->error and die $!;
    close DT or die $!;
    reject "key $keyid not in permissions list although in keyring!";
}

sub verifytag () {
    foreach my $kas (split /:/, $keyrings) {
	debug "verifytag $kas...";
	$kas =~ s/^([^,]+),// or die;
	my $keyid = checksig_keyring $1;
	if (defined $keyid) {
	    if ($kas =~ m/^a$/) {
		debug "verifytag a ok";
		return; # yay
	    } elsif ($kas =~ m/^m([^,]+)$/) {
		dm_txt_check($keyid, $1);
		debug "verifytag m ok";
		return;
	    } else {
		die;
	    }
	}   
    }
    reject "key not found in keyrings";
}

sub checksuite () {
    debug "checksuite ($suitesfile)";
    open SUITES, "<", $suitesfile or die $!;
    while (<SUITES>) {
	chomp;
	next unless m/\S/;
	next if m/^\#/;
	s/\s+$//;
	return if $_ eq $suite;
    }
    die $! if SUITES->error;
    reject "unknown suite";
}

sub tagh1 ($) {
    my ($tag) = @_;
    my $vals = $tagh{$tag};
    reject "missing header $tag in signed tag object" unless $vals;
    reject "multiple headers $tag in signed tag object" unless @$vals == 1;
    return $vals->[0];
}

sub checks () {
    debug "checks";
    checksuite();
    tagh1('type') eq 'commit' or reject "tag refers to wrong kind of object";
    tagh1('object') eq $commit or reject "tag refers to wrong commit";
    tagh1('tag') eq $tagname or reject "tag name in tag is wrong";

    my $v = $version;
    $v =~ y/~:/_%/;

    debug "translated version $v";
    $tagname eq "debian/$v" or die;

    # check that our ref is being fast-forwarded
    debug "oldcommit $oldcommit";
    if ($oldcommit =~ m/[^0]/) {
	$?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
	chomp $mb;
	$mb eq $oldcommit or reject "not fast forward on dgit branch";
    }
}

sub onwardpush () {
    my @cmd = (qw(git send-pack), $destrepo,
	       "$commit:refs/dgit/$suite",
	       "$tagval:refs/tags/$tagname");
    debugcmd @cmd;
    $!=0;
    my $r = system @cmd;
    !$r or die "onward push failed: $r $!";
}	

sub stunthook () {
    debug "stunthook";
    chdir $workrepo or die "chdir $workrepo: $!";
    mkdir "dgit-tmp" or $!==EEXIST or die $!;
    readupdates();
    parsetag();
    verifytag();
    checks();
    onwardpush();
    debug "stunthook done.";
}

#----- git-upload-pack -----

sub fixmissing__git_upload_pack () {
    $destrepo = "$dgitrepos/_empty";
    my $lfh = acquiretree($destrepo,1);
    return if stat $destrepo;
    die $! unless $!==ENOENT;
    rmtree "$destrepo.new";
    umask 022;
    runcmd qw(git init --bare --quiet), "$destrepo.new";
    rename "$destrepo.new", $destrepo or die $!;
    unlink "$destrepo.lock" or die $!;
    close $lfh;
}

sub main__git_upload_pack () {
    runcmd qw(git upload-pack), $destrepo;
}

#----- arg parsing and main program -----

sub argval () {
    die unless @ARGV;
    my $v = shift @ARGV;
    die if $v =~ m/^-/;
    return $v;
}

sub parseargsdispatch () {
    die unless @ARGV;

    delete $ENV{'GIT_DIR'}; # if not run via ssh, our parent git process
    delete $ENV{'GIT_PREFIX'}; # sets these and they mess things up

    if ($ENV{'DGIT_DRS_DEBUG'}) {
	$debug='=';
	open DEBUG, ">&STDERR" or die $!;
    }

    if ($ARGV[0] eq '--pre-receive-hook') {
	if ($debug) { $debug.="="; }
	shift @ARGV;
	@ARGV == 1 or die;
	$package = shift @ARGV;
	defined($suitesfile = $ENV{'DGIT_DRS_SUITES'}) or die;
	defined($workrepo = $ENV{'DGIT_DRS_WORK'}) or die;
	defined($destrepo = $ENV{'DGIT_DRS_DEST'}) or die;
	defined($keyrings = $ENV{'DGIT_DRS_KEYRINGS'}) or die $!;
	open STDOUT, ">&STDERR" or die $!;
	eval {
	    stunthook();
	};
	if ($@) {
	    recorderror "$@" or die;
	    die $@;
	}
	exit 0;
    }

    $ENV{'DGIT_DRS_SUITES'} = argval();
    $ENV{'DGIT_DRS_KEYRINGS'} = argval();
    $dgitrepos = argval();

    die unless @ARGV==1 && $ARGV[0] eq '--ssh';

    my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
    $cmd =~ m{
	^
	(?: \S* / )?
	( [-0-9a-z]+ )
	\s+
	(?: \S* / )?
	($package_re) \.git
	$
    }ox 
    or reject "command string not understood";
    my $method = $1;
    $package = $2;
    $realdestrepo = "$dgitrepos/$package.git";

    my $funcn = $method;
    $funcn =~ y/-/_/;
    my $mainfunc = $main::{"main__$funcn"};

    reject "unknown method" unless $mainfunc;

    if (stat $realdestrepo) {
	$destrepo = $realdestrepo;
    } else {
	$! == ENOENT or die "stat dest repo $destrepo: $!";
	debug " fixmissing $funcn";
	my $fixfunc = $main::{"fixmissing__$funcn"};
	&$fixfunc;
    }

    debug " running main $funcn";
    &$mainfunc;
}

sub unlockall () {
    while (my $fh = pop @lockfhs) { close $fh; }
}

sub cleanup () {
    unlockall();
    if (!chdir "$dgitrepos/_tmp") {
	$!==ENOENT or die $!;
	return;
    }
    foreach my $lf (<*.lock>) {
	my $tree = $lf;
	$tree =~ s/\.lock$//;
	next unless acquiretree($tree, 0);
	remove $lf or warn $!;
	unlockall();
    }
}

parseargsdispatch();
cleanup();