X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit-repos-server;h=3e74217a822159be9a602b2dd6549dd8af10eee4;hp=cbbfe1ea7ccd297b7bc3835b48e9acc27aee611b;hb=4383b44c16571b49dd741987a1dc49d145242039;hpb=44a2c13511958d2dec9de240fbbcc1102869b9a8

diff --git a/dgit-repos-server b/dgit-repos-server
old mode 100644
new mode 100755
index cbbfe1ea..3e74217a
--- a/dgit-repos-server
+++ b/dgit-repos-server
@@ -86,30 +86,39 @@ 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 $pkg;
+our $package;
 our $suitesfile;
 our $realdestrepo;
 our $destrepo;
 our $workrepo;
-our @keyrings;
+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: $!";
+	$fh = new IO::File $lock, ">" or die "open $lock: $!";
 	my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
 	if (!$ok) {
-	    return undef unless $must;
-	    die "flock $lock: $!";
+	    die "flock $lock: $!" if $must;
+	    debug " locking $lock failed";
+	    return undef;
 	}
 	if (!stat $lock) {
 	    next if $! == ENOENT;
@@ -133,42 +142,97 @@ sub acquiretree ($$) {
     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 ($) {
-    die "dgit-repos-server: reject: $_[0]\n";
+    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 () {
-    $destrepo = "$dgitrepos/_tmp/${pkg}_prospective";
+    mkrepotmp();
+    $destrepo = "$dgitrepos/_tmp/${package}_prospective";
     acquiretree($destrepo, 1);
-    my $r = system qw(cp -a --), "$dgitrepos/_template", "$destrepo";
+    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 () {
-    $workrepo = "$dgitrepos/_tmp/${pkg}_incoming$$";
+    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
+    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 $pkg
+exec $0 --pre-receive-hook $package
 END
     close $fh or die "$prerecv: $!";
-    $ENV{'DGIT_RPR_WORK'}= $workrepo;
-    $ENV{'DGIT_RPR_DEST'}= $destrepo;
+    $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) {
@@ -179,6 +243,7 @@ sub maybeinstallprospective () {
     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' :
@@ -186,9 +251,13 @@ sub maybeinstallprospective () {
 	    die;
 	die if $got{$wh}++;
     }
-    die if grep { !$_ } values %got;
-    $!=0; $?=0; close SR or die "$? $!";
+    $!=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 $!;
 }
@@ -196,7 +265,7 @@ sub maybeinstallprospective () {
 sub main__git_receive_pack () {
     makeworkingclone();
     setupstunthook();
-    runcmd qw(git receive-pack), $destdir;
+    runcmd qw(git receive-pack), $workrepo;
     maybeinstallprospective();
 }
 
@@ -206,32 +275,37 @@ 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/)}) {
-	    die if defined $tagname;
+	    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/}) {
-	    die if defined $suite;
+	    reject "pushing multiple heads!" if defined $suite;
 	    $suite = $'; #';
 	    $oldcommit = $old;
 	    $commit = $sha1;
 	} else {
-	    die;
+	    reject "pushing unexpected ref!";
 	}
     }
     STDIN->error and die $!;
 
-    die unless defined $refname;
-    die unless defined $branchname;
+    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 $!;
@@ -247,15 +321,16 @@ sub parsetag () {
 	}
     }
     $!=0; $_=<T>; defined or die $!;
-    m/^($package_re) release (\S+) for (\S+) \[dgit\]$/ or die;
+    m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or
+	reject "tag message not in expected format";
 
-    die unless $1 eq $pkg;
+    die unless $1 eq $package;
     $version = $2;
-    die unless $3 eq $suite;
+    die "$3 != $suite " unless $3 eq $suite;
 
     for (;;) {
 	print PT or die $!;
-	$!=0; $_=<T>; defined or die $!;
+	$!=0; $_=<T>; defined or die "missing signature? $!";
 	last if m/^-----BEGIN PGP/;
     }
     for (;;) {
@@ -266,6 +341,7 @@ sub parsetag () {
     T->error and die $!;
     close PT or die $!;
     close DS or die $!;
+    debug " parsetag ok.";
 }
 
 sub checksig_keyring ($) {
@@ -276,14 +352,20 @@ sub checksig_keyring ($) {
 
     my $ok = undef;
 
-    open P, "-|", (qw(gpgv --status-fd=1),
-		   map { '--keyring', $_ }, @keyrings,
-		   qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext))
+    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:\]: //;
+	next unless s/^\[GNUPG:\] //;
 	chomp or die;
+	debug " checksig| $_";
 	my @l = split / /, $_;
 	if ($l[0] eq 'NO_PUBKEY') {
 	    last;
@@ -297,27 +379,38 @@ sub checksig_keyring ($) {
     }
     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;
-	m/^\S/
-	    or reject "key $keyid missing Allow section in permissions!";
+	if (s/^allow:/ /i..0) {
+	} else {
+	    m/^./
+		or reject "key $keyid missing Allow section in permissions!";
+	    next;
+	}
 	# in right stanza...
-	s/^allow:/ /i
-	    ..0 or next;
-	s/^\s+//
+	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+/) {
-	    return if $p eq $package; # yay!
+	    if ($p eq $package) {
+		# yay!
+		debug " dm_txt_check ok";
+		return;
+	    }
 	}
     }
     DT->error and die $!;
@@ -327,13 +420,16 @@ sub dm_txt_check ($$) {
 
 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;
@@ -344,6 +440,7 @@ sub verifytag () {
 }
 
 sub checksuite () {
+    debug "checksuite ($suitesfile)";
     open SUITES, "<", $suitesfile or die $!;
     while (<SUITES>) {
 	chomp;
@@ -356,17 +453,29 @@ sub checksuite () {
     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 die;
-    tagh1('object') eq $commit or die;
-    tagh1('tag') eq $tagname or die;
+    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;
@@ -375,15 +484,17 @@ sub checks () {
 }
 
 sub onwardpush () {
+    my @cmd = (qw(git send-pack), $destrepo,
+	       "$commit:refs/dgit/$suite",
+	       "$tagval:refs/tags/$tagname");
+    debugcmd @cmd;
     $!=0;
-    my $r = system (qw(git send-pack),
-		    $destrepo,
-		    "$commit:refs/dgit/$suite",
-		    "$tagval:refs/tags/$tagname");
+    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();
@@ -391,16 +502,26 @@ sub stunthook () {
     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), $destdir;
+    runcmd qw(git upload-pack), $destrepo;
 }
 
 #----- arg parsing and main program -----
@@ -415,21 +536,36 @@ sub argval () {
 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;
-	$pkg = shift @ARGV;
-	defined($suitesfile = $ENV{'DGIT_RPR_SUITES'}) or die;
-	defined($workrepo = $ENV{'DGIT_RPR_WORK'}) or die;
-	defined($destrepo = $ENV{'DGIT_RPR_DEST'}) or die;
-	defined($keyrings = $ENV{'DGIT_RPR_KEYRINGS'}) 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 $!;
-	stunthook();
+	eval {
+	    stunthook();
+	};
+	if ($@) {
+	    recorderror "$@" or die;
+	    die $@;
+	}
 	exit 0;
     }
 
-    $ENV{'DGIT_RPR_SUITES'} = argval();
-    $ENV{'DGIT_RPR_KEYRINGS'} = argval();
+    $ENV{'DGIT_DRS_SUITES'} = argval();
+    $ENV{'DGIT_DRS_KEYRINGS'} = argval();
     $dgitrepos = argval();
 
     die unless @ARGV==1 && $ARGV[0] eq '--ssh';
@@ -445,9 +581,9 @@ sub parseargsdispatch () {
 	$
     }ox 
     or reject "command string not understood";
-    $method = $1;
-    $pkg = $2;
-    $realdestrepo = "$dgitrepos/$pkg.git";
+    my $method = $1;
+    $package = $2;
+    $realdestrepo = "$dgitrepos/$package.git";
 
     my $funcn = $method;
     $funcn =~ y/-/_/;
@@ -459,25 +595,30 @@ sub parseargsdispatch () {
 	$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; }
+    while (my $fh = pop @lockfhs) { close $fh; }
 }
 
 sub cleanup () {
     unlockall();
-    chdir "$dgitrepos/_tmp" or die $!;
-    foreach my $lock (<*.lock>) {
+    if (!chdir "$dgitrepos/_tmp") {
+	$!==ENOENT or die $!;
+	return;
+    }
+    foreach my $lf (<*.lock>) {
 	my $tree = $lf;
 	$tree =~ s/\.lock$//;
 	next unless acquiretree($tree, 0);
-	remove $lock or warn $!;
+	remove $lf or warn $!;
 	unlockall();
     }
 }