X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit-repos-server;h=ce48eeb217f95ea7f8359db2416516af3d6cb243;hp=0cbcf3579aa1ce598dd9a9d7b8792d3931c89e81;hb=b58de5245d0a98e91a5f708d93c2eb6b4a198b47;hpb=3d27642f17e325c02209fff73d343f22ab4a0c0c diff --git a/dgit-repos-server b/dgit-repos-server old mode 100644 new mode 100755 index 0cbcf357..ce48eeb2 --- a/dgit-repos-server +++ b/dgit-repos-server @@ -1,16 +1,18 @@ #!/usr/bin/perl -w -# dgit-repos-push-receiver +# dgit-repos-server # # usages: -# .../dgit-repos-push-receiver KEYRING-AUTH-SPEC DGIT-REPOS-DIR --ssh -# .../dgit-repos-push-receiver KEYRING-AUTH-SPEC DGIT-REPOS-DIR PACKAGE +# .../dgit-repos-server SUITES KEYRING-AUTH-SPEC DGIT-REPOS-DIR --ssh # internal usage: -# .../dgit-repos-push-receiver --pre-receive-hook PACKAGE +# .../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 @@ -24,14 +26,14 @@ use strict; # - 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 +# 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 -# * recovering the suite name from the destination refs/dgit/ ref +# * 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 @@ -56,32 +58,67 @@ use strict; # (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 don't make a hardline clone of the destination repo; instead -# we make a copy (not a hardlink clone) of _template -# - we set up a post-receive hook as well, which does the following: -# + check that exactly two refs were updated -# + delete the two stunt hooks -# + rename the working repo into place as 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 $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 (;;) { - my $fh = new IO::File, ">", $lock or die "open $lock: $!"; + 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) { - return unless $must; - die "flock $lock: $!"; + die "flock $lock: $!" if $must; + debug " locking $lock failed"; + return undef; } if (!stat $lock) { next if $! == ENOENT; @@ -90,35 +127,134 @@ sub acquirelock ($$) { my $want = (stat _)[1]; stat $fh or die $!; my $got = (stat _)[1]; - return $fh if $got == $want; + last if $got == $want; } + return $fh; } -sub makeworkingclone () { - $workrepo = "$dgitrepos/_tmp/${pkg}_incoming$$"; - my $lock = "$workrepo.lock"; - my $lockfh = acquirelock($lock, 1); - if (!stat $destrepo) { - $! == ENOENT or die "stat dest repo $destrepo: $!"; - mkdir $workrepo or die "create work repo $workrepo: $!"; - runcmd qw(git init --bare), $workrepo; - } else { - runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo; +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 reject ($) { + my ($why) = @_; + my $w = $ENV{'DGIT_DRS_WORK'}; # we are in stunthook + if (defined $w) { + open REJ, ">", "$w/drs-reject" or die $!; + print REJ $why, "\n" or die $!; + close REJ or die $!; + } + 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 + my $fh = new IO::File $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777 or die "$prerecv: $!"; print $fh <; + chomp $why or die $!; + reject $why; + } 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 () { + 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}++; + } + debug "installprospective ?"; + die if grep { !$_ } values %got; + $!=0; $?=0; close SR or die "$? $!"; + + 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 ----- @@ -127,7 +263,10 @@ our ($tagname, $tagval, $suite, $oldcommit, $commit); our ($version, %tagh); sub readupdates () { + debug " updates ..."; while () { + chomp or die; + debug " upd.| $_"; m/^(\S+) (\S+) (\S+)$/ or die "$_ ?"; my ($old, $sha1, $refname) = ($1, $2, $3); if ($refname =~ m{^refs/tags/(?=debian/)}) { @@ -148,11 +287,13 @@ sub readupdates () { } STDIN->error and die $!; - die unless defined $refname; - die unless defined $branchname; + die unless defined $tagname; + die 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 $!; @@ -168,11 +309,12 @@ sub parsetag () { } } $!=0; $_=; defined or die $!; - m/^($package_re) release (\S+) for (\S+) \[dgit\]$/ or die; + m/^($package_re) release (\S+) for (\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 $!; @@ -187,6 +329,7 @@ sub parsetag () { T->error and die $!; close PT or die $!; close DS or die $!; + debug " parsetag ok."; } sub checksig_keyring ($) { @@ -197,14 +340,17 @@ sub checksig_keyring ($) { my $ok = undef; - open P, "-|", (qw(gpgv --status-fd=1), - map { '--keyring', $_ }, @keyrings, + debug " checksig keyring $keyringfile..."; + + open P, "-|", (qw(gpgv --status-fd=1 --keyring), + $keyringfile, qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext)) or die $!; while (

) { next unless s/^\[GNUPG:\]: //; chomp or die; + debug " checksig| $_"; my @l = split / /, $_; if ($l[0] eq 'NO_PUBKEY') { last; @@ -218,11 +364,14 @@ 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 (

) { m/^fingerprint:\s+$keyid$/oi @@ -237,8 +386,14 @@ sub dm_txt_check ($$) { # 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 $!; @@ -248,13 +403,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; @@ -264,17 +422,35 @@ sub verifytag () { reject "key not found in keyrings"; } +sub checksuite () { + debug "checksuite"; + open SUITES, "<", $suitesfile or die $!; + while () { + chomp; + next unless m/\S/; + next if m/^\#/; + s/\s+$//; + return if $_ eq $suite; + } + die $! if SUITES->error; + reject "unknown suite"; +} + sub checks () { -fixme check the suite against the approved list + debug "checks"; + checksuite(); tagh1('type') eq 'commit' or die; tagh1('object') eq $commit or die; tagh1('tag') eq $tagname or die; 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; @@ -283,15 +459,18 @@ fixme check the suite against the approved list } 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"; + print Dumper(\$ENV{GIT_DIR}); chdir $workrepo or die "chdir $workrepo: $!"; mkdir "dgit-tmp" or $!==EEXIST or die $!; readupdates(); @@ -299,67 +478,117 @@ 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), $destrepo; } #----- arg parsing and main program ----- -sub parseargs () { +sub argval () { die unless @ARGV; + my $v = shift @ARGV; + die if $v =~ m/^-/; + return $v; +} + +sub parseargsdispatch () { + die unless @ARGV; + + 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($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(); exit 0; } - die unless @ARGV>=2; - - die if $ARGV[0] =~ m/^-/; - $ENV{'DGIT_RPR_KEYRINGS'} = shift @ARGV; - die if $ARGV[0] =~ m/^-/; - $dgitrepos = shift @ARGV; - - die unless @ARGV; - if ($ARGV[0] != m/^-/) { - @ARGV == 1 or die; - $pkg = shift @ARGV; - } elsif ($ARGV[0] eq '--ssh') { - shift @ARGV; - !@ARGV or die; - my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'}; - $cmd =~ m{ - ^ - (?:\S*/)? - (git-receive-pack|git-upload-pack) - \s+ - (?:\S*/)? - ($package_re)\.git - $ - }ox - or die "requested command $cmd not understood"; - $method = $1; - $pkg = $2; - my $func = $method; - $func =~ y/-/_/; - $func = $main::{"main__$func"}; - &$func; + $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 { - die; + $! == ENOENT or die "stat dest repo $destrepo: $!"; + debug " fixmissing $funcn"; + my $fixfunc = $main::{"fixmissing__$funcn"}; + &$fixfunc; } - $destrepo = "$dgitrepos/$pkg.git"; + debug " running main $funcn"; + &$mainfunc; } -sub main__git_receive_pack () { - parseargs(); -fixme check method; - makeworkingclone(); - setupstunthook(); - runcmd qw(git receive-pack), $destdir; +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();