From 1b2c10f57b0257aac61a696378e9c8c05df8bf4f Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Sat, 8 Nov 2014 22:21:27 +0000 Subject: New dgit-infrastructure binary package containing dgit-repos-server et al. Client users probably don't want this stuff. Also, it provides a convenient way to publish the dependencies. --- .gitignore | 1 + Makefile | 15 +- debian/changelog | 4 + debian/control | 10 + debian/rules | 4 + debian/tests/control | 2 +- dgit-repos-server | 627 ------------------------------------------------ infra/dgit-repos-server | 627 ++++++++++++++++++++++++++++++++++++++++++++++++ infra/dgit-ssh-dispatch | 2 +- tests/lib | 2 +- 10 files changed, 663 insertions(+), 631 deletions(-) delete mode 100755 dgit-repos-server create mode 100755 infra/dgit-repos-server diff --git a/.gitignore b/.gitignore index 737875f..c25efea 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ *~ tests/tmp debian/dgit +debian/dgit-infrastructure debian/files debian/*.substvars debian/*.log diff --git a/Makefile b/Makefile index f456d93..caac3d9 100644 --- a/Makefile +++ b/Makefile @@ -26,10 +26,14 @@ prefix?=/usr/local bindir=$(prefix)/bin mandir=$(prefix)/share/man man1dir=$(mandir)/man1 +infraexamplesdir=$(prefix)/share/doc/dgit-infrastructure/examples -PROGRAMS=dgit dgit-repos-server +PROGRAMS=dgit MAN1PAGES=dgit.1 +INFRA_PROGRAMS=dgit-repos-server dgit-ssh-dispatch +INFRA_EXAMPLES=get-dm-txt ssh-wrap + all: install: installdirs @@ -39,6 +43,15 @@ install: installdirs installdirs: $(INSTALL_DIR) $(DESTDIR)$(bindir) $(DESTDIR)$(man1dir) +install-infra: installdirs-infra + $(INSTALL_PROGRAM) $(addprefix infra/, $(INFRA_PROGRAMS)) \ + $(DESTDIR)$(bindir) + $(INSTALL_PROGRAM) $(addprefix infra/, $(INFRA_EXAMPLES)) \ + $(DESTDIR)$(infraexamplesdir) + +installdirs-infra: + $(INSTALL_DIR) $(DESTDIR)$(bindir) $(DESTDIR)$(infraexamplesdir) + check installcheck: clean distclean mostlyclean maintainer-clean: diff --git a/debian/changelog b/debian/changelog index 775be6c..6629b0b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -31,6 +31,10 @@ dgit (0.23~) unstable; urgency=low * Add missing `gpgv' to test dependencies in debian/tests/control. + * New dgit-infrastructure binary package containing dgit-repos-server et + al. Client users probably don't want this stuff. Also, it provides a + convenient way to publish the dependencies. + -- dgit (0.22.1) unstable; urgency=high diff --git a/debian/control b/debian/control index 798465b..cc26c04 100644 --- a/debian/control +++ b/debian/control @@ -21,3 +21,13 @@ Description: git interoperability with the Debian archive dgit push constructs uploads from git commits . dgit clone and dgit fetch construct git commits from uploads. + +Package: dgit-infrastructure +Depends: ${misc:Depends} +Recommends: perl, git-core, gpgv, chiark-utils-bin, wget, + libdigest-sha-perl +Architecture: all +Priority: extra +Description: dgit server backend infrastructure + This package contains tools which are useful for setting up a dgit + git repository server. You probably want dgit, the client package. diff --git a/debian/rules b/debian/rules index fece672..e02ea90 100755 --- a/debian/rules +++ b/debian/rules @@ -29,3 +29,7 @@ override_dh_gencontrol: cd debian/dgit; \ v=$$(perl -ne 'print if s/^version:\s+//i' DEBIAN/control); \ perl -i -pe "s/UNRELEASED/$$v/g if m/###substituted###/" usr/bin/dgit + +override_dh_auto_install: + make install prefix=/usr DESTDIR=debian/dgit + make install-infra prefix=/usr DESTDIR=debian/dgit-infrastructure diff --git a/debian/tests/control b/debian/tests/control index aca24c4..37124e6 100644 --- a/debian/tests/control +++ b/debian/tests/control @@ -1,3 +1,3 @@ Tests: clone-nogit fetch-localgitonly fetch-somegit-notlast push-newpackage push-nextdgit quilt push-buildproductsdir Tests-Directory: tests/tests -Depends: @, devscripts, gpgv +Depends: dgit, dgit-infrastructure, devscripts, gpgv diff --git a/dgit-repos-server b/dgit-repos-server deleted file mode 100755 index c70bc27..0000000 --- a/dgit-repos-server +++ /dev/null @@ -1,627 +0,0 @@ -#!/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/ (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 <; - 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 () { - 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 () { - 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; $_=; defined or die $!; - print PT or die $!; - if (m/^(\S+) (.*)/) { - push @{ $tagh{$1} }, $2; - } elsif (!m/\S/) { - last; - } else { - die; - } - } - $!=0; $_=; 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; $_=; defined or die "missing signature? $!"; - last if m/^-----BEGIN PGP/; - } - for (;;) { - print DS or die $!; - $!=0; $_=; - 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 (

) { - 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 (

) { - 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 () { - 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(); diff --git a/infra/dgit-repos-server b/infra/dgit-repos-server new file mode 100755 index 0000000..c70bc27 --- /dev/null +++ b/infra/dgit-repos-server @@ -0,0 +1,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/ (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 <; + 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 () { + 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 () { + 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; $_=; defined or die $!; + print PT or die $!; + if (m/^(\S+) (.*)/) { + push @{ $tagh{$1} }, $2; + } elsif (!m/\S/) { + last; + } else { + die; + } + } + $!=0; $_=; 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; $_=; defined or die "missing signature? $!"; + last if m/^-----BEGIN PGP/; + } + for (;;) { + print DS or die $!; + $!=0; $_=; + 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 (

) { + 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 (

) { + 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 () { + 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(); diff --git a/infra/dgit-ssh-dispatch b/infra/dgit-ssh-dispatch index bd8582a..b515eda 100755 --- a/infra/dgit-ssh-dispatch +++ b/infra/dgit-ssh-dispatch @@ -120,7 +120,7 @@ sub dispatch () { my $cmd=$1; selectpackage $2,$3; if ($cmd eq 'receive-pack') { - my $s = "$dgitlive/dgit-repos-server"; + my $s = "$dgitlive/infra/dgit-repos-server"; exec $s, $suites, $authrune, $repos, qw(--ssh); die "exec $s: $!"; } elsif ($cmd eq 'upload-pack') { diff --git a/tests/lib b/tests/lib index 019a998..adbd79f 100644 --- a/tests/lib +++ b/tests/lib @@ -5,7 +5,7 @@ set -x if [ "x$DGIT_TEST_INTREE" != x ]; then : ${DGIT_TEST:=$DGIT_TEST_INTREE/dgit} - : ${DGIT_REPOS_SERVER_TEST:=$DGIT_TEST_INTREE/dgit-repos-server} + : ${DGIT_REPOS_SERVER_TEST:=$DGIT_TEST_INTREE/infra/dgit-repos-server} : ${DGIT_SSH_DISPATCH_TEST:=$DGIT_TEST_INTREE/infra/dgit-ssh-dispatch} export DGIT_TEST DGIT_REPOS_SERVER_TEST DGIT_SSH_DISPATCH_TEST fi -- cgit v1.2.3