#!/usr/bin/perl -w
# dgit-repos-server
#
# usages:
#  .../dgit-repos-server DISTRO SUITES KEYRING-AUTH-SPEC \
#      DGIT-REPOS-DIR POLICY-HOOK-SCRIPT --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);

use Debian::Dgit qw(:DEFAULT :policyflags);

open DEBUG, ">/dev/null" or die $!;

our $func;
our $dgitrepos;
our $package;
our $suitesfile;
our $policyhook;
our $realdestrepo;
our $destrepo;
our $workrepo;
our $keyrings;
our @lockfhs;
our $debug='';
our @deliberatelies;
our $policy;

#----- 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;
}

sub policyhook {
    my ($policyallowbits, @polargs) = @_;
    # => ($exitstatuspolicybitmap, $policylockfh);
    die if $policyallowbits & ~0x3e;
    my @cmd = ($policyhook,$distro,$repos,@polargs);
    debugcmd @_;
    my $r = system @_;
    die "system: $!" if $r < 0;
    die "hook (@cmd) failed ($?)" if $r & ~($policyallowbits << 8);
    return $r >> 8;
}

sub mkemptyrepo ($$) {
    my ($dir,$sharedperm) = @_;
    runcmd qw(git init --bare --quiet), "--shared=$sharedperm", $dir;
}

#----- 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? $!";
	if (m/^\[dgit ([^"].*)\]$/) { # [dgit "something"] is for future
	    $_ = $1." ";
	    for (;;) {
		if (s/^distro\=(\S+) //) {
		    die "$1 != $distro" unless $1 eq $distro;
		} elsif (s/^(--deliberately-$package_re) //) {
		    push @deliberatelies, $1;
		} elsif (s/^[-+.=0-9a-z]\S* //) {
		} else {
		    die "unknown dgit info in tag";
		}
	    }
	    next;
	}
	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";

    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;

    my ($policy) = policyhook(NOFFCHECK, 'push',$package,
			      $version,$suite,$tagname,
			      join(",",@delberatelies));

    checksuite();

    # check that our ref is being fast-forwarded
    debug "oldcommit $oldcommit";
    if (!($policy & NOFFCHECK) && $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";
    mkemptyrepo "$destrepo.new", "0644";
    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($distro = $ENV{'DGIT_DRS_DISTRO'}) or die;
	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 $!;
	defined($policyhook = $ENV{'DGIT_DRS_POLICYHOOK'}) or die $!;
	open STDOUT, ">&STDERR" or die $!;
	eval {
	    stunthook();
	};
	if ($@) {
	    recorderror "$@" or die;
	    die $@;
	}
	exit 0;
    }

    $ENV{'DGIT_DRS_DISTRO'} = argval();
    $ENV{'DGIT_DRS_SUITES'} = argval();
    $ENV{'DGIT_DRS_KEYRINGS'} = argval();
    $dgitrepos = argval();
    $ENV{'DGIT_DRS_POLICYHOOK'} = $policyhook = 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;

    my ($policy, $pollock) = policyhook(FRESHREPO,'check-package',$package);
    if ($policy & FRESHREPO) {
	my $garbagerepo = "$dgitrepos/_tmp/${package}_garbage";
	acquiretree($garbagerepo,1);
	rmtree $garbagerepo;
	rename $realdestrepo, $garbagerepo
	    or $! == ENOENT
	    or die "rename repo $destrepo to $garbagerepo: $!";
    }
    close $pollock or die $!;

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