+++ /dev/null
-#!/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();
~ianmdlvl / dgit.git / blobdiff