1 files changed, 0 insertions, 627 deletions
diff --git a/dgit-repos-server b/dgit-repos-server
deleted file mode 100755
index 3e74217..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/<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();