#!/usr/bin/perl -w
# dgit-repos-server
#
# git protocol proxy to check dgit pushes etc.
#
# Copyright (C) 2014-2016  Ian Jackson
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

# usages:
#   dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [<settings>] --ssh
#   dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [<settings>] --cron
# settings
#   --repos=GIT-REPOS-DIR      default DISTRO-DIR/repos/
#   --suites=SUITES-FILE       default DISTRO-DIR/suites
#   --suites-master=SUITES-FILE default DISTRO-DIR/suites-master
#   --policy-hook=POLICY-HOOK  default DISTRO-DIR/policy-hook
#   --mirror-hook=MIRROR-HOOK  default DISTRO-DIR/mirror-hook
#   --dgit-live=DGIT-LIVE-DIR  default DISTRO-DIR/dgit-live
# (DISTRO-DIR is not used other than as default and to pass to policy
# and mirror hooks)
# internal usage:
#  .../dgit-repos-server --pre-receive-hook PACKAGE
#
# Invoked as the ssh restricted command
#
# Works like git-receive-pack
#
# SUITES-FILE is the name of a file which lists the permissible suites
# one per line (#-comments and blank lines ignored).  For --suites-master
# it is a list of the suite(s) which should, when pushed to, update
# `master' on the server (if fast forward).
#
# AUTH-SPEC is a :-separated list of
#   KEYRING.GPG,AUTH-SPEC
# where AUTH-SPEC is one of
#   a
#   mDM.TXT
# (With --cron AUTH-SPEC is not used and may be the empty string.)

use strict;

use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
use Debian::Dgit qw(:DEFAULT :policyflags);
setup_sigwarn();

# DGIT-REPOS-DIR contains:
# git tree (or other object)      lock (in acquisition order, outer first)
#
#  _tmp/PACKAGE_prospective       ! } SAME.lock, held during receive-pack
#
#  _tmp/PACKAGE_incoming$$        ! } SAME.lock, held during receive-pack
#  _tmp/PACKAGE_incoming$$_fresh  ! }
#
#  PACKAGE.git                      } PACKAGE.git.lock
#  PACKAGE_garbage                  }   (also covers executions of
#  PACKAGE_garbage-old              }    policy hook script for PACKAGE)
#  PACKAGE_garbage-tmp              }
#  policy*                          } (for policy hook script, covered by
#                                   }  lock only when invoked for a package)
#
# leaf locks, held during brief operaton only:
#
#  _empty                           } SAME.lock
#  _empty.new                       }
#
#  _template                        } SAME.lock
#
# locks marked ! may be held during client data transfer

# What we do on push 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/[archive/]DISTRO/* 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 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 [archive/]debian/<version> (massaged as needed)
#        * the suite is one of those permitted
#        * the signed tag has a suitable name
#        * run the "push" policy hook
#        * replay prevention for --deliberately-not-fast-forward
#        * check the commit is a fast forward
#        * handle a request from the policy hook for a fresh repo
#    + 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)
#  - 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
#
# Policy hook scripts are invoked like this:
#   POLICY-HOOK-SCRIPT DISTRO DGIT-REPOS-DIR DGIT-LIVE-DIR DISTRO-DIR ACTION...
# ie.
#   POLICY-HOOK-SCRIPT ... check-list [...]
#   POLICY-HOOK-SCRIPT ... check-package PACKAGE [...]
#   POLICY-HOOK-SCRIPT ... push PACKAGE \
#         VERSION SUITE TAGNAME DELIBERATELIES [...]
#   POLICY-HOOK-SCRIPT ... push-confirm PACKAGE \
#         VERSION SUITE TAGNAME DELIBERATELIES FRESH-REPO|'' [...]
#
# DELIBERATELIES is like this: --deliberately-foo,--deliberately-bar,...
#
# Exit status of policy hook is a bitmask.
# Bit weight constants are defined in Dgit.pm.
#    NOFFCHECK   (2)
#         suppress dgit-repos-server's fast-forward check ("push" only)
#    FRESHREPO   (4)
#         blow away repo right away (ie, as if before push or fetch)
#         ("check-package" and "push" only)
#    NOCOMMITCHECK   (8)
#         suppress dgit-repos-server's check that commits do
#         not lack "committer" info (eg as produced by #849041)
#         ("push" only)
# any unexpected bits mean failure, and then known set bits are ignored
# if no unexpected bits set, operation continues (subject to meaning
# of any expected bits set).  So, eg, exit 0 means "continue normally"
# and would be appropriate for an unknown action.
#
# cwd for push and push-confirm is a temporary repo where the incoming
# objects have been received; TAGNAME is the version-based tag.
#
# FRESH-REPO is '' iff the repo for this package already existed, or
# the pathname of the newly-created repo which will be renamed into
# place if everything goes well.  (NB that this is generally not the
# same repo as the cwd, because the objects are first received into a
# temporary repo so they can be examined.)  In this case FRESH-REPO
# contains exactly the objects and refs that will appear in the
# destination if push-confirm approves.
# 
# if push requested FRESHREPO, push-confirm happens in the old working
# repo and FRESH-REPO is guaranteed not to be ''.
#
# policy hook for a particular package will be invoked only once at
# a time - (see comments about DGIT-REPOS-DIR, above)
#
# check-list and check-package are invoked via the --cron option.
# First, without any locking, check-list is called.  It should produce
# a list of package names (one per line).  Then check-package will be
# invoked for each named package, in each case after taking an
# appropriate lock.
#
# If policy hook wants to run dgit (or something else in the dgit
# package), it should use DGIT-LIVE-DIR/dgit (etc.), or if that is
# ENOENT, use the installed version.
#
# Mirror hook scripts are invoked like this:
#   MIRROR-HOOK-SCRIPT DISTRO-DIR ACTION...
# and currently there is only one action invoked by dgit-repos-server:
#   MIRROR-HOOK-SCRIPT DISTRO-DIR updated-hook PACKAGE [...]
#
# Exit status of the mirror hook is advisory only.  The mirror hook
# runs too late to do anything useful about a problem, so the only
# effect of a mirror hook exiting nonzero is a warning message to
# stderr (which the pushing user should end up seeing).
#
# If the mirror hook does not exist, it is silently skipped.

use POSIX;
use Fcntl qw(:flock);
use File::Path qw(rmtree);
use File::Temp qw(tempfile);

initdebug('');

our $func;
our $dgitrepos;
our $package;
our $distro;
our $suitesfile;
our $suitesformasterfile;
our $policyhook;
our $mirrorhook;
our $dgitlive;
our $distrodir;
our $destrepo;
our $workrepo;
our $keyrings;
our @lockfhs;

our @deliberatelies;
our %previously;
our $policy;
our @policy_args;

#----- utilities -----

sub realdestrepo () { "$dgitrepos/$package.git"; }

sub acquirelock ($$) {
    my ($lock, $must) = @_;
    my $fh;
    printdebug sprintf "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;
	    printdebug " locking $lock failed\n";
	    return undef;
	}
	next unless stat_exists $lock;
	my $want = (stat _)[1];
	stat $fh or die $!;
	my $got = (stat _)[1];
	last if $got == $want;
    }
    return $fh;
}

sub acquirermtree ($$) {
    my ($tree, $must) = @_;
    my $fh = acquirelock("$tree.lock", $must);
    if ($fh) {
	push @lockfhs, $fh;
	rmtree $tree;
    }
    return $fh;
}

sub locksometree ($) {
    my ($tree) = @_;
    acquirelock("$tree.lock", 1);
}

sub lockrealtree () {
    locksometree(realdestrepo);
}

sub mkrepotmp () { ensuredir "$dgitrepos/_tmp" };

sub removedtagsfile () { "$dgitrepos/_removed-tags/$package"; }

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 "\ndgit-repos-server: reject: $why\n\n";
}

sub policyhook {
    my ($policyallowbits, @polargs) = @_;
    # => ($exitstatuspolicybitmap);
    die if $policyallowbits & ~0x3e;
    my @cmd = ($policyhook,$distro,$dgitrepos,$dgitlive,$distrodir,@polargs);
    debugcmd '+M',@cmd;
    my $r = system @cmd;
    die "system: $!" if $r < 0;
    die "dgit-repos-server: policy hook failed (or rejected) ($?)\n"
	if $r & ~($policyallowbits << 8);
    printdebug sprintf "hook => %#x\n", $r;
    return $r >> 8;
}

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

sub mkrepo_fromtemplate ($) {
    my ($dir) = @_;
    my $template = "$dgitrepos/_template";
    my $templatelock = locksometree($template);
    printdebug "copy template $template -> $dir\n";
    my $r = system qw(cp -a --), $template, $dir;
    !$r or die "create new repo $dir failed: $r $!";
    close $templatelock;
}

sub movetogarbage () {
    # realdestrepo must have been locked

    my $real = realdestrepo;
    return unless stat_exists $real;

    my $garbagerepo = "$dgitrepos/${package}_garbage";
    # We arrange to always keep at least one old tree, for recovery
    # from mistakes.  This is either $garbage or $garbage-old.
    if (stat_exists "$garbagerepo") {
	printdebug "movetogarbage: rmtree $garbagerepo-tmp\n";
	rmtree "$garbagerepo-tmp";
	if (rename "$garbagerepo-old", "$garbagerepo-tmp") {
	    printdebug "movetogarbage: $garbagerepo-old -> -tmp, rmtree\n";
	    rmtree "$garbagerepo-tmp";
	} else {
	    die "$garbagerepo $!" unless $!==ENOENT;
	    printdebug "movetogarbage: $garbagerepo-old -> -tmp\n";
	}
	printdebug "movetogarbage: $garbagerepo -> -old\n";
	rename "$garbagerepo", "$garbagerepo-old" or die "$garbagerepo $!";
    }

    ensuredir "$dgitrepos/_removed-tags";
    open PREVIOUS, ">>", removedtagsfile or die removedtagsfile." $!";
    git_for_each_ref([ map { 'refs/tags/'.$_ } debiantags('*',$distro) ],
		     sub {
	my ($objid,$objtype,$fullrefname,$reftail) = @_;
	print PREVIOUS "\n$objid $reftail .\n" or die $!;
    }, $real);
    close PREVIOUS or die $!;

    printdebug "movetogarbage: $real -> $garbagerepo\n";
    rename $real, $garbagerepo
	or $! == ENOENT
	or die "$garbagerepo $!";
}

sub policy_checkpackage () {
    my $lfh = lockrealtree();

    $policy = policyhook(FRESHREPO,'check-package',$package);
    if ($policy & FRESHREPO) {
	movetogarbage();
    }

    close $lfh;
}

#----- git-receive-pack -----

sub fixmissing__git_receive_pack () {
    mkrepotmp();
    $destrepo = "$dgitrepos/_tmp/${package}_prospective";
    acquirermtree($destrepo, 1);
    mkrepo_fromtemplate($destrepo);
}

sub makeworkingclone () {
    mkrepotmp();
    $workrepo = "$dgitrepos/_tmp/${package}_incoming$$";
    acquirermtree($workrepo, 1);
    my $lfh = lockrealtree();
    runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
    close $lfh;
    rmtree "${workrepo}_fresh";
}

sub mkscript ($$) {
    my ($path,$contents) = @_;
    my $fh = new IO::File $path, O_WRONLY|O_CREAT|O_TRUNC, 0777
	or die "$path: $!";
    print $fh $contents or die "$path: $!";
    close $fh or die "$path: $!";
}

sub setupstunthook () {
    my $prerecv = "$workrepo/hooks/pre-receive";
    mkscript $prerecv, <<END;
#!/bin/sh
set -e
exec $0 --pre-receive-hook $package
END
    $ENV{'DGIT_DRS_WORK'}= $workrepo;
    $ENV{'DGIT_DRS_DEST'}= $destrepo;
    printdebug " stunt hook set up $prerecv\n";
}

sub dealwithfreshrepo () {
    my $freshrepo = "${workrepo}_fresh";
    return unless stat_exists $freshrepo;
    $destrepo = $freshrepo;
}

sub mirrorhook {
    my @cmd = ($mirrorhook,$distrodir,@_);
    debugcmd '+',@cmd;
    return unless stat_exists $mirrorhook;
    my $r = system @cmd;
    if ($r) {
	printf STDERR <<END,
dgit-repos-server: warning: mirror hook failed: %s
dgit-repos-server: push complete but may not fully visible.
END
            ($r < 0 ? "exec: $!" :
	     $r == (124 << 8) ? "exited status 124 (timeout?)" :
	     !($r & ~0xff00) ? "exited ".($? >> 8) :
	     "wait status $?");
    }
}

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 $!;
    }

    printdebug " show-ref ($destrepo) ...\n";

    my $child = open SR, "-|";
    defined $child or die $!;
    if (!$child) {
	chdir $destrepo or die $!;
	exec qw(git show-ref);
	die $!;
    }
    my %got = qw(newtag 0 omtag 0 head 0);
    while (<SR>) {
	chomp or die;
	printdebug " show-refs| $_\n";
	s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
	next if m{^refs/heads/master$};
	my $wh =
	    m{^refs/tags/archive/} ? 'newtag' :
	    m{^refs/tags/} ? 'omtag' :
	    m{^refs/dgit/} ? 'head' :
	    die;
	use Data::Dumper;
	die if $got{$wh}++;
    }
    $!=0; $?=0; close SR or $?==256 or die "$? $!";

    printdebug "installprospective ?\n";
    die Dumper(\%got)." -- missing refs in new repo"
	unless $got{head} && grep { m/tag$/ && $got{$_} } keys %got;

    lockrealtree();

    if ($destrepo eq "${workrepo}_fresh") {
	movetogarbage;
    }

    printdebug "install $destrepo => ".realdestrepo."\n";
    rename $destrepo, realdestrepo or die $!;
    remove realdestrepo.".lock" or die $!;
}

sub main__git_receive_pack () {
    makeworkingclone();
    setupstunthook();
    runcmd qw(git receive-pack), $workrepo;
    dealwithfreshrepo();
    maybeinstallprospective();
    mirrorhook('updated-hook', $package);
}

#----- stunt post-receive hook -----

our ($tagname, $tagval, $suite, $oldcommit, $commit);
our ($version, %tagh);
our ($maint_tagname, $maint_tagval);

our ($tagexists_error);

sub readupdates () {
    printdebug " updates ...\n";
    my %tags;
    while (<STDIN>) {
	chomp or die;
	printdebug " upd.| $_\n";
	m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
	my ($old, $sha1, $refname) = ($1, $2, $3);
	if ($refname =~ m{^refs/tags/(?=(?:archive/)?$distro/)}) {
	    my $tn = $'; #';
	    $tags{$tn} = $sha1;
	    $tagexists_error= "tag $tn 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 %tags;
    my @dtags = grep { m#^archive/# } keys %tags;
    reject "need exactly one archive/* tag" if @dtags!=1;
    my @mtags = grep { !m#^archive/# } keys %tags;
    reject "pushing too many non-dgit tags" if @mtags>1;
    ($tagname) = @dtags;
    ($maint_tagname) = @mtags;
    $tagval = $tags{$tagname};
    $maint_tagval = $tags{$maint_tagname // ''};

    reject "push is missing head ref update" unless defined $suite;
    printdebug " updates ok.\n";
}

sub parsetag () {
    printdebug " parsetag...\n";
    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;

    my $copyl = $_;
    for (;;) {
	print PT $copyl or die $!;
	$!=0; $_=<T>; defined or die "missing signature? $!";
	$copyl = $_;
	if (m/^\[dgit ([^"].*)\]$/) { # [dgit "something"] is for future
	    $_ = $1." ";
	    while (length) {
		if (s/^distro\=(\S+) //) {
		    die "$1 != $distro" unless $1 eq $distro;
		} elsif (s/^(--deliberately-$deliberately_re) //) {
		    push @deliberatelies, $1;
		} elsif (s/^previously:(\S+)=(\w+) //) {
		    die "previously $1 twice" if defined $previously{$1};
		    $previously{$1} = $2;
		} elsif (s/^[-+.=0-9a-z]\S* //) {
		} else {
		    die "unknown dgit info in tag ($_)";
		}
	    }
	    next;
	}
	last if m/^-----BEGIN PGP/;
    }
    $_ = $copyl;
    for (;;) {
	print DS or die $!;
	$!=0; $_=<T>;
	last if !defined;
    }
    T->error and die $!;
    close PT or die $!;
    close DS or die $!;
    printdebug " parsetag ok.\n";
}

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;

    printdebug " checksig keyring $keyringfile...\n";

    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;
	printdebug " checksig| $_\n";
	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;

    printdebug sprintf " checksig ok=%d\n", !!$ok;

    return $ok;
}

sub dm_txt_check ($$) {
    my ($keyid, $dmtxtfn) = @_;
    printdebug " dm_txt_check $keyid $dmtxtfn\n";
    open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
    while (<DT>) {
	m/^fingerprint:\s+\Q$keyid\E$/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;
	printdebug " dm_txt_check allow| $_\n";
	foreach my $p (split /\s+/) {
	    if ($p eq $package) {
		# yay!
		printdebug " dm_txt_check ok\n";
		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) {
	printdebug "verifytag $kas...\n";
	$kas =~ s/^([^,]+),// or die;
	my $keyid = checksig_keyring $1;
	if (defined $keyid) {
	    if ($kas =~ m/^a$/) {
		printdebug "verifytag a ok\n";
		return; # yay
	    } elsif ($kas =~ m/^m([^,]+)$/) {
		dm_txt_check($keyid, $1);
		printdebug "verifytag m ok\n";
		return;
	    } else {
		die;
	    }
	}   
    }
    reject "key not found in keyrings";
}

sub suite_is_in ($) {
    my ($sf) = @_;
    printdebug "suite_is_in ($sf)\n";
    if (!open SUITES, "<", $sf) {
	$!==ENOENT or die $!;
	return 0;
    }
    while (<SUITES>) {
	chomp;
	next unless m/\S/;
	next if m/^\#/;
	s/\s+$//;
	return 1 if $_ eq $suite;
    }
    die $! if SUITES->error;
    return 0;
}

sub checksuite () {
    printdebug "checksuite ($suitesfile)\n";
    return if suite_is_in $suitesfile;
    reject "unknown suite";
}

sub checktagnoreplay () {
    # We need to prevent a replay attack using an earlier signed tag.
    # We also want to archive in the history the object ids of
    # anything we remove, even if we get rid of the actual objects.
    #
    # So, we check that the signed tag mentions the name and tag
    # object id of:
    #
    # (a) In the case of FRESHREPO: all tags and refs/heads/* in
    #     the repo.  That is, effectively, all the things we are
    #     deleting.
    #
    #     This prevents any tag implying a FRESHREPO push
    #     being replayed into a different state of the repo.
    #
    #     There is still the folowing risk: If a non-ff push is of a
    #     head which is an ancestor of a previous ff-only push, the
    #     previous push can be replayed.
    #
    #     So we keep a separate list, as a file in the repo, of all
    #     the tag object ids we have ever seen and removed.  Any such
    #     tag object id will be rejected even for ff-only pushes.
    #
    # (b) In the case of just NOFFCHECK: all tags referring to the
    #     current head for the suite (there must be at least one).
    #
    #     This prevents any tag implying a NOFFCHECK push being
    #     replayed to rewind from a different head.
    #
    #     The possibility of an earlier ff-only push being replayed is
    #     eliminated as follows: the tag from such a push would still
    #     be in our repo, and therefore the replayed push would be
    #     rejected because the set of refs being updated would be
    #     wrong.

    if (!open PREVIOUS, "<", removedtagsfile) {
	die removedtagsfile." $!" unless $!==ENOENT;
    } else {
	# Protocol for updating this file is to append to it, not
	# write-new-and-rename.  So all updates are prefixed with \n
	# and suffixed with " .\n" so that partial writes can be
	# ignored.
	while (<PREVIOUS>) {
	    next unless m/^(\w+) (.*) \.\n/;
	    next unless $1 eq $tagval;
	    reject "Replay of previously-rewound upload ($tagval $2)";
	}
	die removedtagsfile." $!" if PREVIOUS->error;
	close PREVIOUS;
    }

    return unless $policy & (FRESHREPO|NOFFCHECK);

    my $garbagerepo = "$dgitrepos/${package}_garbage";
    lockrealtree();

    my $nchecked = 0;
    my @problems;

    my $check_ref_previously= sub {
	my ($objid,$objtype,$fullrefname,$reftail) = @_;
	my $supkey = $fullrefname;
	$supkey =~ s{^refs/}{} or die "$supkey $objid ?";
	my $supobjid = $previously{$supkey};
	if (!defined $supobjid) {
	    printdebug "checktagnoreply - missing\n";
	    push @problems, "does not declare previously $supkey";
	} elsif ($supobjid ne $objid) {
	    push @problems, "declared previously $supkey=$supobjid".
		" but actually previously $supkey=$objid";
	} else {
	    $nchecked++;
	}
    };

    if ($policy & FRESHREPO) {
	foreach my $kind (qw(tags heads)) {
	    git_for_each_ref("refs/$kind", $check_ref_previously);
	}
    } else {
	my $branch= server_branch($suite);
	my $branchhead= git_get_ref(server_ref($suite));
	if (!length $branchhead) {
	    # No such branch - NOFFCHECK was unnecessary.  Oh well.
	    printdebug "checktagnoreplay - not FRESHREPO, new branch, ok\n";
	} else {
	    printdebug "checktagnoreplay - not FRESHREPO,".
		" checking for overwriting refs/$branch=$branchhead\n";
	    git_for_each_tag_referring($branchhead, sub {
		my ($tagobjid,$refobjid,$fullrefname,$tagname) = @_;
		$check_ref_previously->($tagobjid,undef,$fullrefname,undef);
            });
	    printdebug "checktagnoreplay - not FRESHREPO, nchecked=$nchecked";
	    push @problems, "does not declare previously any tag".
		" referring to branch head $branch=$branchhead"
		unless $nchecked;
	}
    }

    if (@problems) {
	reject "replay attack prevention check failed:".
	    " signed tag for $version: ".
	    join("; ", @problems).
	    "\n";
    }
    printdebug "checktagnoreplay - all ok ($tagval)\n"
}

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 () {
    printdebug "checks\n";

    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 @expecttagnames = debiantags($version, $distro);
    printdebug "expected tag @expecttagnames\n";
    grep { $tagname eq $_ } @expecttagnames or die;

    foreach my $othertag (grep { $_ ne $tagname } @expecttagnames) {
	reject "tag $othertag already exists -".
	    " not replacing previously-pushed version"
	    if git_get_ref "refs/tags/".$othertag;
    }

    lockrealtree();

    @policy_args = ($package,$version,$suite,$tagname,
		    join(",",@deliberatelies));
    $policy = policyhook(NOFFCHECK|FRESHREPO|NOCOMMITCHECK, 'push', @policy_args);

    if (defined $tagexists_error) {
	if ($policy & FRESHREPO) {
	    printdebug "ignoring tagexists_error: $tagexists_error\n";
	} else {
	    reject $tagexists_error;
	}
    }

    checktagnoreplay();
    checksuite();

    # check that our ref is being fast-forwarded
    printdebug "oldcommit $oldcommit\n";
    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";
    }

    # defend against commits generated by #849041
    if (!($policy & NOCOMMITCHECK)) {
	my @checks = qw(%at
			%ct);
	my @chk = qw(git log -z);
	push @chk, '--pretty=tformat:%H%n'.
	    (join "", map { $_, '%n' } @checks);
	push @chk, "^$oldcommit" if $oldcommit =~ m/[^0]/;
	push @chk, $commit;;
	printdebug " ~NOCOMMITCHECK @chk\n";
	open CHK, "-|", @chk or die $!;
	local $/ = "\0";
	while (<CHK>) {
	    next unless m/^$/m;
	    m/^\w+(?=\n)/ or die;
	    reject "corrupted object $& (missing metadata)";
	}
	$!=0; $?=0; close CHK or $?==256 or die "$? $!";
    }

    if ($policy & FRESHREPO) {
	# It's a bit late to be discovering this here, isn't it ?
	#
	# What we do is: Generate a fresh destination repo right now,
	# and arrange to treat it from now on as if it were a
	# prospective repo.
	#
	# The presence of this fresh destination repo is detected by
	# the parent, which responds by making a fresh master repo
	# from the template.  (If the repo didn't already exist then
	# $destrepo was _prospective, and we change it here.  This is
	# OK because the parent's check for _fresh persuades it not to
	# use _prospective.)
	#
	$destrepo = "${workrepo}_fresh"; # workrepo lock covers
	mkrepo_fromtemplate $destrepo;
    }
}

sub onwardpush () {
    my @cmdbase = (qw(git send-pack), $destrepo);
    push @cmdbase, qw(--force) if $policy & NOFFCHECK;

    if ($ENV{GIT_QUARANTINE_PATH}) {
	my $recv_wrapper = "$ENV{GIT_QUARANTINE_PATH}/dgit-recv-wrapper";
	mkscript $recv_wrapper, <<'END';
#!/bin/sh
set -e
unset GIT_QUARANTINE_PATH
exec git receive-pack "$@"
END
	push @cmdbase, "--receive-pack=$recv_wrapper";
    }

    my @cmd = @cmdbase;
    push @cmd, "$commit:refs/dgit/$suite",
	       "$tagval:refs/tags/$tagname";
    push @cmd, "$maint_tagval:refs/tags/$maint_tagname"
	if defined $maint_tagname;
    debugcmd '+',@cmd;
    $!=0;
    my $r = system @cmd;
    !$r or die "onward push to $destrepo failed: $r $!";

    if (suite_is_in $suitesformasterfile) {
	@cmd = @cmdbase;
	push @cmd, "$commit:refs/heads/master";
	debugcmd '+', @cmd;
	$!=0; my $r = system @cmd;
	# tolerate errors (might be not ff)
	!($r & ~0xff00) or die
	    "onward push to $destrepo#master failed: $r $!";
    }
}

sub finalisepush () {
    if ($destrepo eq realdestrepo) {
	policyhook(0, 'push-confirm', @policy_args, '');
	onwardpush();
    } else {
	# We are to receive the push into a new repo (perhaps
	# because the policy push hook asked us to with FRESHREPO, or
	# perhaps because the repo didn't exist before).
	#
	# We want to provide the policy push-confirm hook with a repo
	# which looks like the one which is going to be installed.
	# The working repo is no good because it might contain
	# previous history.
	#
	# So we push the objects into the prospective new repo right
	# away.  If the hook declines, we decline, and the prospective
	# repo is never installed.
	onwardpush();
	policyhook(0, 'push-confirm', @policy_args, $destrepo);
    }
}

sub stunthook () {
    printdebug "stunthook in $workrepo\n";
    chdir $workrepo or die "chdir $workrepo: $!";
    mkdir "dgit-tmp" or $!==EEXIST or die $!;
    readupdates();
    parsetag();
    verifytag();
    checks();
    finalisepush();
    printdebug "stunthook done.\n";
}

#----- git-upload-pack -----

sub fixmissing__git_upload_pack () {
    $destrepo = "$dgitrepos/_empty";
    my $lfh = locksometree($destrepo);
    return if stat_exists $destrepo;
    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 () {
    my $lfh = locksometree($destrepo);
    printdebug "git-upload-pack in $destrepo\n";
    chdir $destrepo or die "$destrepo: $!";
    close $lfh;
    runcmd qw(git upload-pack), ".";
}

#----- arg parsing and main program -----

sub argval () {
    die unless @ARGV;
    my $v = shift @ARGV;
    die if $v =~ m/^-/;
    return $v;
}

our %indistrodir = (
    # keys are used for DGIT_DRS_XXX too
    'repos' => \$dgitrepos,
    'suites' => \$suitesfile,
    'suites-master' => \$suitesformasterfile,
    'policy-hook' => \$policyhook,
    'mirror-hook' => \$mirrorhook,
    'dgit-live' => \$dgitlive,
    );

our @hookenvs = qw(distro suitesfile suitesformasterfile policyhook
                   mirrorhook dgitlive keyrings dgitrepos distrodir);

# workrepo and destrepo handled ad-hoc

sub mode_ssh () {
    die if @ARGV;

    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;

    my $funcn = $method;
    $funcn =~ y/-/_/;
    my $mainfunc = $main::{"main__$funcn"};

    reject "unknown method" unless $mainfunc;

    policy_checkpackage();

    if (stat_exists realdestrepo) {
	$destrepo = realdestrepo;
    } else {
	printdebug " fixmissing $funcn\n";
	my $fixfunc = $main::{"fixmissing__$funcn"};
	&$fixfunc;
    }

    printdebug " running main $funcn\n";
    &$mainfunc;
}

sub mode_cron () {
    die if @ARGV;

    my $listfh = tempfile();
    open STDOUT, ">&", $listfh or die $!;
    policyhook(0,'check-list');
    open STDOUT, ">&STDERR" or die $!;

    seek $listfh, 0, 0 or die $!;
    while (<$listfh>) {
	chomp or die;
	next if m/^\s*\#/;
	next unless m/\S/;
	die unless m/^($package_re)$/;
	
	$package = $1;
	policy_checkpackage();
    }
    die $! if $listfh->error;
}    

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'}) {
	enabledebug();
    }

    if ($ARGV[0] eq '--pre-receive-hook') {
	if ($debuglevel) {
	    $debugprefix.="=";
	    printdebug "in stunthook ".(shellquote @ARGV)."\n";
	    foreach my $k (sort keys %ENV) {
		printdebug "$k=$ENV{$k}\n" if $k =~  m/^DGIT/;
	    }
	}
	shift @ARGV;
	@ARGV == 1 or die;
	$package = shift @ARGV;
	${ $main::{$_} } = $ENV{"DGIT_DRS_\U$_"} foreach @hookenvs;
	defined($workrepo = $ENV{'DGIT_DRS_WORK'}) or die;
	defined($destrepo = $ENV{'DGIT_DRS_DEST'}) or die;
	open STDOUT, ">&STDERR" or die $!;
	eval {
	    stunthook();
	};
	if ($@) {
	    recorderror "$@" or die;
	    die $@;
	}
	exit 0;
    }

    $distro    = argval();
    $distrodir = argval();
    $keyrings  = argval();

    foreach my $dk (keys %indistrodir) {
	${ $indistrodir{$dk} } = "$distrodir/$dk";
    }

    while (@ARGV && $ARGV[0] =~ m/^--([-0-9a-z]+)=/ && $indistrodir{$1}) {
	${ $indistrodir{$1} } = $'; #';
	shift @ARGV;
    }

    $ENV{"DGIT_DRS_\U$_"} = ${ $main::{$_} } foreach @hookenvs;

    die unless @ARGV==1;

    my $mode = shift @ARGV;
    die unless $mode =~ m/^--(\w+)$/;
    my $fn = ${*::}{"mode_$1"};
    die unless $fn;
    $fn->();
}

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 acquirermtree($tree, 0);
	remove $lf or warn $!;
	unlockall();
    }
}

parseargsdispatch();
cleanup();