infra/dgit-repos-server

   1 #!/usr/bin/perl -w
   2 # dgit-repos-server
   3 #
   4 # git protocol proxy to check dgit pushes etc.
   5 #
   6 # Copyright (C) 2014-2016  Ian Jackson
   7 #
   8 #    This program is free software; you can redistribute it and/or modify
   9 #    it under the terms of the GNU General Public License as published by
  10 #    the Free Software Foundation; either version 3 of the License, or
  11 #    (at your option) any later version.
  12 #
  13 #    This program is distributed in the hope that it will be useful,
  14 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 #    GNU General Public License for more details.
  17 #
  18 #    You should have received a copy of the GNU General Public License
  19 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 # usages:
  22 #   dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [<settings>] --ssh
  23 #   dgit-repos-server DISTRO DISTRO-DIR AUTH-SPEC [<settings>] --cron
  24 # settings
  25 #   --repos=GIT-REPOS-DIR      default DISTRO-DIR/repos/
  26 #   --suites=SUITES-FILE       default DISTRO-DIR/suites
  27 #   --suites-master=SUITES-FILE default DISTRO-DIR/suites-master
  28 #   --policy-hook=POLICY-HOOK  default DISTRO-DIR/policy-hook
  29 #   --mirror-hook=MIRROR-HOOK  default DISTRO-DIR/mirror-hook
  30 #   --dgit-live=DGIT-LIVE-DIR  default DISTRO-DIR/dgit-live
  31 # (DISTRO-DIR is not used other than as default and to pass to policy
  32 # and mirror hooks)
  33 # internal usage:
  34 #  .../dgit-repos-server --pre-receive-hook PACKAGE
  35 #
  36 # Invoked as the ssh restricted command
  37 #
  38 # Works like git-receive-pack
  39 #
  40 # SUITES-FILE is the name of a file which lists the permissible suites
  41 # one per line (#-comments and blank lines ignored).  For --suites-master
  42 # it is a list of the suite(s) which should, when pushed to, update
  43 # `master' on the server (if fast forward).
  44 #
  45 # AUTH-SPEC is a :-separated list of
  46 #   KEYRING.GPG,AUTH-SPEC
  47 # where AUTH-SPEC is one of
  48 #   a
  49 #   mDM.TXT
  50 # (With --cron AUTH-SPEC is not used and may be the empty string.)
  51
  52 use strict;
  53
  54 use Debian::Dgit qw(:DEFAULT :policyflags);
  55 setup_sigwarn();
  56
  57 # DGIT-REPOS-DIR contains:
  58 # git tree (or other object)      lock (in acquisition order, outer first)
  59 #
  60 #  _tmp/PACKAGE_prospective       ! } SAME.lock, held during receive-pack
  61 #
  62 #  _tmp/PACKAGE_incoming$$        ! } SAME.lock, held during receive-pack
  63 #  _tmp/PACKAGE_incoming$$_fresh  ! }
  64 #
  65 #  PACKAGE.git                      } PACKAGE.git.lock
  66 #  PACKAGE_garbage                  }   (also covers executions of
  67 #  PACKAGE_garbage-old              }    policy hook script for PACKAGE)
  68 #  PACKAGE_garbage-tmp              }
  69 #  policy*                          } (for policy hook script, covered by
  70 #                                   }  lock only when invoked for a package)
  71 #
  72 # leaf locks, held during brief operaton only:
  73 #
  74 #  _empty                           } SAME.lock
  75 #  _empty.new                       }
  76 #
  77 #  _template                        } SAME.lock
  78 #
  79 # locks marked ! may be held during client data transfer
  80
  81 # What we do on push is this:
  82 #  - extract the destination repo name
  83 #  - make a hardlink clone of the destination repo
  84 #  - provide the destination with a stunt pre-receive hook
  85 #  - run actual git-receive-pack with that new destination
  86 #   as a result of this the stunt pre-receive hook runs; it does this:
  87 #    + understand what refs we are allegedly updating and
  88 #      check some correspondences:
  89 #        * we are updating only refs/tags/[archive/]DISTRO/* and refs/dgit/*
  90 #        * and only one of each
  91 #        * and the tag does not already exist
  92 #      and
  93 #        * recover the suite name from the destination refs/dgit/ ref
  94 #    + disassemble the signed tag into its various fields and signature
  95 #      including:
  96 #        * parsing the first line of the tag message to recover
  97 #          the package name, version and suite
  98 #        * checking that the package name corresponds to the dest repo name
  99 #        * checking that the suite name is as recovered above
 100 #    + verify the signature on the signed tag
 101 #      and if necessary check that the keyid and package are listed in dm.txt
 102 #    + check various correspondences:
 103 #        * the signed tag must refer to a commit
 104 #        * the signed tag commit must be the refs/dgit value
 105 #        * the name in the signed tag must correspond to its ref name
 106 #        * the tag name must be [archive/]debian/<version> (massaged as needed)
 107 #        * the suite is one of those permitted
 108 #        * the signed tag has a suitable name
 109 #        * run the "push" policy hook
 110 #        * replay prevention for --deliberately-not-fast-forward
 111 #        * check the commit is a fast forward
 112 #        * handle a request from the policy hook for a fresh repo
 113 #    + push the signed tag and new dgit branch to the actual repo
 114 #
 115 # If the destination repo does not already exist, we need to make
 116 # sure that we create it reasonably atomically, and also that
 117 # we don't every have a destination repo containing no refs at all
 118 # (because such a thing causes git-fetch-pack to barf).  So then we
 119 # do as above, except:
 120 #  - before starting, we take out our own lock for the destination repo
 121 #  - we create a prospective new destination repo by making a copy
 122 #    of _template
 123 #  - we use the prospective new destination repo instead of the
 124 #    actual new destination repo (since the latter doesn't exist)
 125 #  - after git-receive-pack exits, we
 126 #    + check that the prospective repo contains a tag and head
 127 #    + rename the prospective destination repo into place
 128 #
 129 # Cleanup strategy:
 130 #  - We are crash-only
 131 #  - Temporary working trees and their locks are cleaned up
 132 #    opportunistically by a program which tries to take each lock and
 133 #    if successful deletes both the tree and the lockfile
 134 #  - Prospective working trees and their locks are cleaned up by
 135 #    a program which tries to take each lock and if successful
 136 #    deletes any prospective working tree and the lock (but not
 137 #    of course any actual tree)
 138 #  - It is forbidden to _remove_ the lockfile without removing
 139 #    the corresponding temporary tree, as the lockfile is also
 140 #    a stampfile whose presence indicates that there may be
 141 #    cleanup to do
 142 #
 143 # Policy hook scripts are invoked like this:
 144 #   POLICY-HOOK-SCRIPT DISTRO DGIT-REPOS-DIR DGIT-LIVE-DIR DISTRO-DIR ACTION...
 145 # ie.
 146 #   POLICY-HOOK-SCRIPT ... check-list [...]
 147 #   POLICY-HOOK-SCRIPT ... check-package PACKAGE [...]
 148 #   POLICY-HOOK-SCRIPT ... push PACKAGE \
 149 #         VERSION SUITE TAGNAME DELIBERATELIES [...]
 150 #   POLICY-HOOK-SCRIPT ... push-confirm PACKAGE \
 151 #         VERSION SUITE TAGNAME DELIBERATELIES FRESH-REPO|'' [...]
 152 #
 153 # DELIBERATELIES is like this: --deliberately-foo,--deliberately-bar,...
 154 #
 155 # Exit status of policy hook is a bitmask.
 156 # Bit weight constants are defined in Dgit.pm.
 157 #    NOFFCHECK   (2)
 158 #         suppress dgit-repos-server's fast-forward check ("push" only)
 159 #    FRESHREPO   (4)
 160 #         blow away repo right away (ie, as if before push or fetch)
 161 #         ("check-package" and "push" only)
 162 # any unexpected bits mean failure, and then known set bits are ignored
 163 # if no unexpected bits set, operation continues (subject to meaning
 164 # of any expected bits set).  So, eg, exit 0 means "continue normally"
 165 # and would be appropriate for an unknown action.
 166 #
 167 # cwd for push and push-confirm is a temporary repo where the incoming
 168 # objects have been received; TAGNAME is the version-based tag.
 169 #
 170 # FRESH-REPO is '' iff the repo for this package already existed, or
 171 # the pathname of the newly-created repo which will be renamed into
 172 # place if everything goes well.  (NB that this is generally not the
 173 # same repo as the cwd, because the objects are first received into a
 174 # temporary repo so they can be examined.)  In this case FRESH-REPO
 175 # contains exactly the objects and refs that will appear in the
 176 # destination if push-confirm approves.
 177 #
 178 # if push requested FRESHREPO, push-confirm happens in the old working
 179 # repo and FRESH-REPO is guaranteed not to be ''.
 180 #
 181 # policy hook for a particular package will be invoked only once at
 182 # a time - (see comments about DGIT-REPOS-DIR, above)
 183 #
 184 # check-list and check-package are invoked via the --cron option.
 185 # First, without any locking, check-list is called.  It should produce
 186 # a list of package names (one per line).  Then check-package will be
 187 # invoked for each named package, in each case after taking an
 188 # appropriate lock.
 189 #
 190 # If policy hook wants to run dgit (or something else in the dgit
 191 # package), it should use DGIT-LIVE-DIR/dgit (etc.), or if that is
 192 # ENOENT, use the installed version.
 193 #
 194 # Mirror hook scripts are invoked like this:
 195 #   MIRROR-HOOK-SCRIPT DISTRO-DIR ACTION...
 196 # and currently there is only one action invoked by dgit-repos-server:
 197 #   MIRROR-HOOK-SCRIPT DISTRO-DIR updated-hook PACKAGE [...]
 198 #
 199 # Exit status of the mirror hook is advisory only.  The mirror hook
 200 # runs too late to do anything useful about a problem, so the only
 201 # effect of a mirror hook exiting nonzero is a warning message to
 202 # stderr (which the pushing user should end up seeing).
 203 #
 204 # If the mirror hook does not exist, it is silently skipped.
 205
 206 use POSIX;
 207 use Fcntl qw(:flock);
 208 use File::Path qw(rmtree);
 209 use File::Temp qw(tempfile);
 210
 211 initdebug('');
 212
 213 our $func;
 214 our $dgitrepos;
 215 our $package;
 216 our $distro;
 217 our $suitesfile;
 218 our $suitesformasterfile;
 219 our $policyhook;
 220 our $mirrorhook;
 221 our $dgitlive;
 222 our $distrodir;
 223 our $destrepo;
 224 our $workrepo;
 225 our $keyrings;
 226 our @lockfhs;
 227
 228 our @deliberatelies;
 229 our %previously;
 230 our $policy;
 231 our @policy_args;
 232
 233 #----- utilities -----
 234
 235 sub realdestrepo () { "$dgitrepos/$package.git"; }
 236
 237 sub acquirelock ($$) {
 238     my ($lock, $must) = @_;
 239     my $fh;
 240     printdebug sprintf "locking %s %d\n", $lock, $must;
 241     for (;;) {
 242         close $fh if $fh;
 243         $fh = new IO::File $lock, ">" or die "open $lock: $!";
 244         my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
 245         if (!$ok) {
 246             die "flock $lock: $!" if $must;
 247             printdebug " locking $lock failed\n";
 248             return undef;
 249         }
 250         next unless stat_exists $lock;
 251         my $want = (stat _)[1];
 252         stat $fh or die $!;
 253         my $got = (stat _)[1];
 254         last if $got == $want;
 255     }
 256     return $fh;
 257 }
 258
 259 sub acquirermtree ($$) {
 260     my ($tree, $must) = @_;
 261     my $fh = acquirelock("$tree.lock", $must);
 262     if ($fh) {
 263         push @lockfhs, $fh;
 264         rmtree $tree;
 265     }
 266     return $fh;
 267 }
 268
 269 sub locksometree ($) {
 270     my ($tree) = @_;
 271     acquirelock("$tree.lock", 1);
 272 }
 273
 274 sub lockrealtree () {
 275     locksometree(realdestrepo);
 276 }
 277
 278 sub mkrepotmp () { ensuredir "$dgitrepos/_tmp" };
 279
 280 sub removedtagsfile () { "$dgitrepos/_removed-tags/$package"; }
 281
 282 sub recorderror ($) {
 283     my ($why) = @_;
 284     my $w = $ENV{'DGIT_DRS_WORK'}; # we are in stunthook
 285     if (defined $w) {
 286         chomp $why;
 287         open ERR, ">", "$w/drs-error" or die $!;
 288         print ERR $why, "\n" or die $!;
 289         close ERR or die $!;
 290         return 1;
 291     }
 292     return 0;
 293 }
 294
 295 sub reject ($) {
 296     my ($why) = @_;
 297     recorderror "reject: $why";
 298     die "\ndgit-repos-server: reject: $why\n\n";
 299 }
 300
 301 sub runcmd {
 302     debugcmd '+',@_;
 303     $!=0; $?=0;
 304     my $r = system @_;
 305     die (shellquote @_)." $? $!" if $r;
 306 }
 307
 308 sub policyhook {
 309     my ($policyallowbits, @polargs) = @_;
 310     # => ($exitstatuspolicybitmap);
 311     die if $policyallowbits & ~0x3e;
 312     my @cmd = ($policyhook,$distro,$dgitrepos,$dgitlive,$distrodir,@polargs);
 313     debugcmd '+M',@cmd;
 314     my $r = system @cmd;
 315     die "system: $!" if $r < 0;
 316     die "dgit-repos-server: policy hook failed (or rejected) ($?)\n"
 317         if $r & ~($policyallowbits << 8);
 318     printdebug sprintf "hook => %#x\n", $r;
 319     return $r >> 8;
 320 }
 321
 322 sub mkemptyrepo ($$) {
 323     my ($dir,$sharedperm) = @_;
 324     runcmd qw(git init --bare --quiet), "--shared=$sharedperm", $dir;
 325 }
 326
 327 sub mkrepo_fromtemplate ($) {
 328     my ($dir) = @_;
 329     my $template = "$dgitrepos/_template";
 330     my $templatelock = locksometree($template);
 331     printdebug "copy template $template -> $dir\n";
 332     my $r = system qw(cp -a --), $template, $dir;
 333     !$r or die "create new repo $dir failed: $r $!";
 334     close $templatelock;
 335 }
 336
 337 sub movetogarbage () {
 338     # realdestrepo must have been locked
 339
 340     my $real = realdestrepo;
 341     return unless stat_exists $real;
 342
 343     my $garbagerepo = "$dgitrepos/${package}_garbage";
 344     # We arrange to always keep at least one old tree, for recovery
 345     # from mistakes.  This is either $garbage or $garbage-old.
 346     if (stat_exists "$garbagerepo") {
 347         printdebug "movetogarbage: rmtree $garbagerepo-tmp\n";
 348         rmtree "$garbagerepo-tmp";
 349         if (rename "$garbagerepo-old", "$garbagerepo-tmp") {
 350             printdebug "movetogarbage: $garbagerepo-old -> -tmp, rmtree\n";
 351             rmtree "$garbagerepo-tmp";
 352         } else {
 353             die "$garbagerepo $!" unless $!==ENOENT;
 354             printdebug "movetogarbage: $garbagerepo-old -> -tmp\n";
 355         }
 356         printdebug "movetogarbage: $garbagerepo -> -old\n";
 357         rename "$garbagerepo", "$garbagerepo-old" or die "$garbagerepo $!";
 358     }
 359
 360     ensuredir "$dgitrepos/_removed-tags";
 361     open PREVIOUS, ">>", removedtagsfile or die removedtagsfile." $!";
 362     git_for_each_ref([ map { 'refs/tags/'.$_ } debiantags('*',$distro) ],
 363                      sub {
 364         my ($objid,$objtype,$fullrefname,$reftail) = @_;
 365         print PREVIOUS "\n$objid $reftail .\n" or die $!;
 366     }, $real);
 367     close PREVIOUS or die $!;
 368
 369     printdebug "movetogarbage: $real -> $garbagerepo\n";
 370     rename $real, $garbagerepo
 371         or $! == ENOENT
 372         or die "$garbagerepo $!";
 373 }
 374
 375 sub policy_checkpackage () {
 376     my $lfh = lockrealtree();
 377
 378     $policy = policyhook(FRESHREPO,'check-package',$package);
 379     if ($policy & FRESHREPO) {
 380         movetogarbage();
 381     }
 382
 383     close $lfh;
 384 }
 385
 386 #----- git-receive-pack -----
 387
 388 sub fixmissing__git_receive_pack () {
 389     mkrepotmp();
 390     $destrepo = "$dgitrepos/_tmp/${package}_prospective";
 391     acquirermtree($destrepo, 1);
 392     mkrepo_fromtemplate($destrepo);
 393 }
 394
 395 sub makeworkingclone () {
 396     mkrepotmp();
 397     $workrepo = "$dgitrepos/_tmp/${package}_incoming$$";
 398     acquirermtree($workrepo, 1);
 399     my $lfh = lockrealtree();
 400     runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
 401     close $lfh;
 402     rmtree "${workrepo}_fresh";
 403 }
 404
 405 sub setupstunthook () {
 406     my $prerecv = "$workrepo/hooks/pre-receive";
 407     my $fh = new IO::File $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
 408         or die "$prerecv: $!";
 409     print $fh <<END or die "$prerecv: $!";
 410 #!/bin/sh
 411 set -e
 412 exec $0 --pre-receive-hook $package
 413 END
 414     close $fh or die "$prerecv: $!";
 415     $ENV{'DGIT_DRS_WORK'}= $workrepo;
 416     $ENV{'DGIT_DRS_DEST'}= $destrepo;
 417     printdebug " stunt hook set up $prerecv\n";
 418 }
 419
 420 sub dealwithfreshrepo () {
 421     my $freshrepo = "${workrepo}_fresh";
 422     return unless stat_exists $freshrepo;
 423     $destrepo = $freshrepo;
 424 }
 425
 426 sub mirrorhook {
 427     my @cmd = ($mirrorhook,$distrodir,@_);
 428     debugcmd '+',@cmd;
 429     return unless stat_exists $mirrorhook;
 430     my $r = system @cmd;
 431     if ($r) {
 432         printf STDERR <<END,
 433 dgit-repos-server: warning: mirror hook failed: %s
 434 dgit-repos-server: push complete but may not fully visible.
 435 END
 436             ($r < 0 ? "exec: $!" :
 437              $r == (124 << 8) ? "exited status 124 (timeout?)" :
 438              !($r & ~0xff00) ? "exited ".($? >> 8) :
 439              "wait status $?");
 440     }
 441 }
 442
 443 sub maybeinstallprospective () {
 444     return if $destrepo eq realdestrepo;
 445
 446     if (open REJ, "<", "$workrepo/drs-error") {
 447         local $/ = undef;
 448         my $msg = <REJ>;
 449         REJ->error and die $!;
 450         print STDERR $msg;
 451         exit 1;
 452     } else {
 453         $!==&ENOENT or die $!;
 454     }
 455
 456     printdebug " show-ref ($destrepo) ...\n";
 457
 458     my $child = open SR, "-|";
 459     defined $child or die $!;
 460     if (!$child) {
 461         chdir $destrepo or die $!;
 462         exec qw(git show-ref);
 463         die $!;
 464     }
 465     my %got = qw(newtag 0 omtag 0 head 0);
 466     while (<SR>) {
 467         chomp or die;
 468         printdebug " show-refs| $_\n";
 469         s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
 470         next if m{^refs/heads/master$};
 471         my $wh =
 472             m{^refs/tags/archive/} ? 'newtag' :
 473             m{^refs/tags/} ? 'omtag' :
 474             m{^refs/dgit/} ? 'head' :
 475             die;
 476         use Data::Dumper;
 477         die if $got{$wh}++;
 478     }
 479     $!=0; $?=0; close SR or $?==256 or die "$? $!";
 480
 481     printdebug "installprospective ?\n";
 482     die Dumper(\%got)." -- missing refs in new repo"
 483         unless $got{head} && grep { m/tag$/ && $got{$_} } keys %got;
 484
 485     lockrealtree();
 486
 487     if ($destrepo eq "${workrepo}_fresh") {
 488         movetogarbage;
 489     }
 490
 491     printdebug "install $destrepo => ".realdestrepo."\n";
 492     rename $destrepo, realdestrepo or die $!;
 493     remove realdestrepo.".lock" or die $!;
 494 }
 495
 496 sub main__git_receive_pack () {
 497     makeworkingclone();
 498     setupstunthook();
 499     runcmd qw(git receive-pack), $workrepo;
 500     dealwithfreshrepo();
 501     maybeinstallprospective();
 502     mirrorhook('updated-hook', $package);
 503 }
 504
 505 #----- stunt post-receive hook -----
 506
 507 our ($tagname, $tagval, $suite, $oldcommit, $commit);
 508 our ($version, %tagh);
 509 our ($maint_tagname, $maint_tagval);
 510
 511 our ($tagexists_error);
 512
 513 sub readupdates () {
 514     printdebug " updates ...\n";
 515     my %tags;
 516     while (<STDIN>) {
 517         chomp or die;
 518         printdebug " upd.| $_\n";
 519         m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
 520         my ($old, $sha1, $refname) = ($1, $2, $3);
 521         if ($refname =~ m{^refs/tags/(?=(?:archive/)?$distro/)}) {
 522             my $tn = $'; #';
 523             $tags{$tn} = $sha1;
 524             $tagexists_error= "tag $tn already exists -".
 525                 " not replacing previously-pushed version"
 526                 if $old =~ m/[^0]/;
 527         } elsif ($refname =~ m{^refs/dgit/}) {
 528             reject "pushing multiple heads!" if defined $suite;
 529             $suite = $'; #';
 530             $oldcommit = $old;
 531             $commit = $sha1;
 532         } else {
 533             reject "pushing unexpected ref!";
 534         }
 535     }
 536     STDIN->error and die $!;
 537
 538     reject "push is missing tag ref update" unless %tags;
 539     my @newtags = grep { m#^archive/# } keys %tags;
 540     my @omtags = grep { !m#^archive/# } keys %tags;
 541     reject "pushing too many similar tags" if @newtags>1 || @omtags>1;
 542     if (@newtags) {
 543         ($tagname) = @newtags;
 544         ($maint_tagname) = @omtags;
 545     } else {
 546         ($tagname) = @omtags or die;
 547     }
 548     $tagval = $tags{$tagname};
 549     $maint_tagval = $tags{$maint_tagname // ''};
 550
 551     reject "push is missing head ref update" unless defined $suite;
 552     printdebug " updates ok.\n";
 553 }
 554
 555 sub parsetag () {
 556     printdebug " parsetag...\n";
 557     open PT, ">dgit-tmp/plaintext" or die $!;
 558     open DS, ">dgit-tmp/plaintext.asc" or die $!;
 559     open T, "-|", qw(git cat-file tag), $tagval or die $!;
 560     for (;;) {
 561         $!=0; $_=<T>; defined or die $!;
 562         print PT or die $!;
 563         if (m/^(\S+) (.*)/) {
 564             push @{ $tagh{$1} }, $2;
 565         } elsif (!m/\S/) {
 566             last;
 567         } else {
 568             die;
 569         }
 570     }
 571     $!=0; $_=<T>; defined or die $!;
 572     m/^($package_re) release (\S+) for \S+ \((\S+)\) \[dgit\]$/ or
 573         reject "tag message not in expected format";
 574
 575     die unless $1 eq $package;
 576     $version = $2;
 577     die "$3 != $suite " unless $3 eq $suite;
 578
 579     my $copyl = $_;
 580     for (;;) {
 581         print PT $copyl or die $!;
 582         $!=0; $_=<T>; defined or die "missing signature? $!";
 583         $copyl = $_;
 584         if (m/^\[dgit ([^"].*)\]$/) { # [dgit "something"] is for future
 585             $_ = $1." ";
 586             while (length) {
 587                 if (s/^distro\=(\S+) //) {
 588                     die "$1 != $distro" unless $1 eq $distro;
 589                 } elsif (s/^(--deliberately-$deliberately_re) //) {
 590                     push @deliberatelies, $1;
 591                 } elsif (s/^previously:(\S+)=(\w+) //) {
 592                     die "previously $1 twice" if defined $previously{$1};
 593                     $previously{$1} = $2;
 594                 } elsif (s/^[-+.=0-9a-z]\S* //) {
 595                 } else {
 596                     die "unknown dgit info in tag ($_)";
 597                 }
 598             }
 599             next;
 600         }
 601         last if m/^-----BEGIN PGP/;
 602     }
 603     $_ = $copyl;
 604     for (;;) {
 605         print DS or die $!;
 606         $!=0; $_=<T>;
 607         last if !defined;
 608     }
 609     T->error and die $!;
 610     close PT or die $!;
 611     close DS or die $!;
 612     printdebug " parsetag ok.\n";
 613 }
 614
 615 sub checksig_keyring ($) {
 616     my ($keyringfile) = @_;
 617     # returns primary-keyid if signed by a key in this keyring
 618     # or undef if not
 619     # or dies on other errors
 620
 621     my $ok = undef;
 622
 623     printdebug " checksig keyring $keyringfile...\n";
 624
 625     our @cmd = (qw(gpgv --status-fd=1 --keyring),
 626                    $keyringfile,
 627                    qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext));
 628     debugcmd '|',@cmd;
 629
 630     open P, "-|", @cmd
 631         or die $!;
 632
 633     while (<P>) {
 634         next unless s/^\[GNUPG:\] //;
 635         chomp or die;
 636         printdebug " checksig| $_\n";
 637         my @l = split / /, $_;
 638         if ($l[0] eq 'NO_PUBKEY') {
 639             last;
 640         } elsif ($l[0] eq 'VALIDSIG') {
 641             my $sigtype = $l[9];
 642             $sigtype eq '00' or reject "signature is not of type 00!";
 643             $ok = $l[10];
 644             die unless defined $ok;
 645             last;
 646         }
 647     }
 648     close P;
 649
 650     printdebug sprintf " checksig ok=%d\n", !!$ok;
 651
 652     return $ok;
 653 }
 654
 655 sub dm_txt_check ($$) {
 656     my ($keyid, $dmtxtfn) = @_;
 657     printdebug " dm_txt_check $keyid $dmtxtfn\n";
 658     open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
 659     while (<DT>) {
 660         m/^fingerprint:\s+\Q$keyid\E$/oi
 661             ..0 or next;
 662         if (s/^allow:/ /i..0) {
 663         } else {
 664             m/^./
 665                 or reject "key $keyid missing Allow section in permissions!";
 666             next;
 667         }
 668         # in right stanza...
 669         s/^[ \t]+//
 670             or reject "package $package not allowed for key $keyid";
 671         # in allow field...
 672         s/\([^()]+\)//;
 673         s/\,//;
 674         chomp or die;
 675         printdebug " dm_txt_check allow| $_\n";
 676         foreach my $p (split /\s+/) {
 677             if ($p eq $package) {
 678                 # yay!
 679                 printdebug " dm_txt_check ok\n";
 680                 return;
 681             }
 682         }
 683     }
 684     DT->error and die $!;
 685     close DT or die $!;
 686     reject "key $keyid not in permissions list although in keyring!";
 687 }
 688
 689 sub verifytag () {
 690     foreach my $kas (split /:/, $keyrings) {
 691         printdebug "verifytag $kas...\n";
 692         $kas =~ s/^([^,]+),// or die;
 693         my $keyid = checksig_keyring $1;
 694         if (defined $keyid) {
 695             if ($kas =~ m/^a$/) {
 696                 printdebug "verifytag a ok\n";
 697                 return; # yay
 698             } elsif ($kas =~ m/^m([^,]+)$/) {
 699                 dm_txt_check($keyid, $1);
 700                 printdebug "verifytag m ok\n";
 701                 return;
 702             } else {
 703                 die;
 704             }
 705         }
 706     }
 707     reject "key not found in keyrings";
 708 }
 709
 710 sub suite_is_in ($) {
 711     my ($sf) = @_;
 712     printdebug "suite_is_in ($sf)\n";
 713     if (!open SUITES, "<", $sf) {
 714         $!==ENOENT or die $!;
 715         return 0;
 716     }
 717     while (<SUITES>) {
 718         chomp;
 719         next unless m/\S/;
 720         next if m/^\#/;
 721         s/\s+$//;
 722         return 1 if $_ eq $suite;
 723     }
 724     die $! if SUITES->error;
 725     return 0;
 726 }
 727
 728 sub checksuite () {
 729     printdebug "checksuite ($suitesfile)\n";
 730     return if suite_is_in $suitesfile;
 731     reject "unknown suite";
 732 }
 733
 734 sub checktagnoreplay () {
 735     # We need to prevent a replay attack using an earlier signed tag.
 736     # We also want to archive in the history the object ids of
 737     # anything we remove, even if we get rid of the actual objects.
 738     #
 739     # So, we check that the signed tag mentions the name and tag
 740     # object id of:
 741     #
 742     # (a) In the case of FRESHREPO: all tags and refs/heads/* in
 743     #     the repo.  That is, effectively, all the things we are
 744     #     deleting.
 745     #
 746     #     This prevents any tag implying a FRESHREPO push
 747     #     being replayed into a different state of the repo.
 748     #
 749     #     There is still the folowing risk: If a non-ff push is of a
 750     #     head which is an ancestor of a previous ff-only push, the
 751     #     previous push can be replayed.
 752     #
 753     #     So we keep a separate list, as a file in the repo, of all
 754     #     the tag object ids we have ever seen and removed.  Any such
 755     #     tag object id will be rejected even for ff-only pushes.
 756     #
 757     # (b) In the case of just NOFFCHECK: all tags referring to the
 758     #     current head for the suite (there must be at least one).
 759     #
 760     #     This prevents any tag implying a NOFFCHECK push being
 761     #     replayed to rewind from a different head.
 762     #
 763     #     The possibility of an earlier ff-only push being replayed is
 764     #     eliminated as follows: the tag from such a push would still
 765     #     be in our repo, and therefore the replayed push would be
 766     #     rejected because the set of refs being updated would be
 767     #     wrong.
 768
 769     if (!open PREVIOUS, "<", removedtagsfile) {
 770         die removedtagsfile." $!" unless $!==ENOENT;
 771     } else {
 772         # Protocol for updating this file is to append to it, not
 773         # write-new-and-rename.  So all updates are prefixed with \n
 774         # and suffixed with " .\n" so that partial writes can be
 775         # ignored.
 776         while (<PREVIOUS>) {
 777             next unless m/^(\w+) (.*) \.\n/;
 778             next unless $1 eq $tagval;
 779             reject "Replay of previously-rewound upload ($tagval $2)";
 780         }
 781         die removedtagsfile." $!" if PREVIOUS->error;
 782         close PREVIOUS;
 783     }
 784
 785     return unless $policy & (FRESHREPO|NOFFCHECK);
 786
 787     my $garbagerepo = "$dgitrepos/${package}_garbage";
 788     lockrealtree();
 789
 790     my $nchecked = 0;
 791     my @problems;
 792
 793     my $check_ref_previously= sub {
 794         my ($objid,$objtype,$fullrefname,$reftail) = @_;
 795         my $supkey = $fullrefname;
 796         $supkey =~ s{^refs/}{} or die "$supkey $objid ?";
 797         my $supobjid = $previously{$supkey};
 798         if (!defined $supobjid) {
 799             printdebug "checktagnoreply - missing\n";
 800             push @problems, "does not declare previously $supkey";
 801         } elsif ($supobjid ne $objid) {
 802             push @problems, "declared previously $supkey=$supobjid".
 803                 " but actually previously $supkey=$objid";
 804         } else {
 805             $nchecked++;
 806         }
 807     };
 808
 809     if ($policy & FRESHREPO) {
 810         foreach my $kind (qw(tags heads)) {
 811             git_for_each_ref("refs/$kind", $check_ref_previously);
 812         }
 813     } else {
 814         my $branch= server_branch($suite);
 815         my $branchhead= git_get_ref(server_ref($suite));
 816         if (!length $branchhead) {
 817             # No such branch - NOFFCHECK was unnecessary.  Oh well.
 818             printdebug "checktagnoreplay - not FRESHREPO, new branch, ok\n";
 819         } else {
 820             printdebug "checktagnoreplay - not FRESHREPO,".
 821                 " checking for overwriting refs/$branch=$branchhead\n";
 822             git_for_each_tag_referring($branchhead, sub {
 823                 my ($tagobjid,$refobjid,$fullrefname,$tagname) = @_;
 824                 $check_ref_previously->($tagobjid,undef,$fullrefname,undef);
 825             });
 826             printdebug "checktagnoreplay - not FRESHREPO, nchecked=$nchecked";
 827             push @problems, "does not declare previously any tag".
 828                 " referring to branch head $branch=$branchhead"
 829                 unless $nchecked;
 830         }
 831     }
 832
 833     if (@problems) {
 834         reject "replay attack prevention check failed:".
 835             " signed tag for $version: ".
 836             join("; ", @problems).
 837             "\n";
 838     }
 839     printdebug "checktagnoreplay - all ok ($tagval)\n"
 840 }
 841
 842 sub tagh1 ($) {
 843     my ($tag) = @_;
 844     my $vals = $tagh{$tag};
 845     reject "missing header $tag in signed tag object" unless $vals;
 846     reject "multiple headers $tag in signed tag object" unless @$vals == 1;
 847     return $vals->[0];
 848 }
 849
 850 sub checks () {
 851     printdebug "checks\n";
 852
 853     tagh1('type') eq 'commit' or reject "tag refers to wrong kind of object";
 854     tagh1('object') eq $commit or reject "tag refers to wrong commit";
 855     tagh1('tag') eq $tagname or reject "tag name in tag is wrong";
 856
 857     my @expecttagnames = debiantags($version, $distro);
 858     printdebug "expected tag @expecttagnames\n";
 859     grep { $tagname eq $_ } @expecttagnames or die;
 860
 861     foreach my $othertag (grep { $_ ne $tagname } @expecttagnames) {
 862         reject "tag $othertag (pushed with differing dgit version)".
 863             " already exists -".
 864             " not replacing previously-pushed version"
 865             if git_get_ref "refs/tags/".$othertag;
 866     }
 867
 868     lockrealtree();
 869
 870     @policy_args = ($package,$version,$suite,$tagname,
 871                     join(",",@deliberatelies));
 872     $policy = policyhook(NOFFCHECK|FRESHREPO, 'push', @policy_args);
 873
 874     if (defined $tagexists_error) {
 875         if ($policy & FRESHREPO) {
 876             printdebug "ignoring tagexists_error: $tagexists_error\n";
 877         } else {
 878             reject $tagexists_error;
 879         }
 880     }
 881
 882     checktagnoreplay();
 883     checksuite();
 884
 885     # check that our ref is being fast-forwarded
 886     printdebug "oldcommit $oldcommit\n";
 887     if (!($policy & NOFFCHECK) && $oldcommit =~ m/[^0]/) {
 888         $?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
 889         chomp $mb;
 890         $mb eq $oldcommit or reject "not fast forward on dgit branch";
 891     }
 892     if ($policy & FRESHREPO) {
 893         # It's a bit late to be discovering this here, isn't it ?
 894         #
 895         # What we do is: Generate a fresh destination repo right now,
 896         # and arrange to treat it from now on as if it were a
 897         # prospective repo.
 898         #
 899         # The presence of this fresh destination repo is detected by
 900         # the parent, which responds by making a fresh master repo
 901         # from the template.  (If the repo didn't already exist then
 902         # $destrepo was _prospective, and we change it here.  This is
 903         # OK because the parent's check for _fresh persuades it not to
 904         # use _prospective.)
 905         #
 906         $destrepo = "${workrepo}_fresh"; # workrepo lock covers
 907         mkrepo_fromtemplate $destrepo;
 908     }
 909 }
 910
 911 sub onwardpush () {
 912     my @cmdbase = (qw(git send-pack), $destrepo);
 913     push @cmdbase, qw(--force) if $policy & NOFFCHECK;
 914
 915     my @cmd = @cmdbase;
 916     push @cmd, "$commit:refs/dgit/$suite",
 917                "$tagval:refs/tags/$tagname";
 918     push @cmd, "$maint_tagval:refs/tags/$maint_tagname"
 919         if defined $maint_tagname;
 920     debugcmd '+',@cmd;
 921     $!=0;
 922     my $r = system @cmd;
 923     !$r or die "onward push to $destrepo failed: $r $!";
 924
 925     if (suite_is_in $suitesformasterfile) {
 926         @cmd = @cmdbase;
 927         push @cmd, "$commit:refs/heads/master";
 928         debugcmd '+', @cmd;
 929         $!=0; my $r = system @cmd;
 930         # tolerate errors (might be not ff)
 931         !($r & ~0xff00) or die
 932             "onward push to $destrepo#master failed: $r $!";
 933     }
 934 }
 935
 936 sub finalisepush () {
 937     if ($destrepo eq realdestrepo) {
 938         policyhook(0, 'push-confirm', @policy_args, '');
 939         onwardpush();
 940     } else {
 941         # We are to receive the push into a new repo (perhaps
 942         # because the policy push hook asked us to with FRESHREPO, or
 943         # perhaps because the repo didn't exist before).
 944         #
 945         # We want to provide the policy push-confirm hook with a repo
 946         # which looks like the one which is going to be installed.
 947         # The working repo is no good because it might contain
 948         # previous history.
 949         #
 950         # So we push the objects into the prospective new repo right
 951         # away.  If the hook declines, we decline, and the prospective
 952         # repo is never installed.
 953         onwardpush();
 954         policyhook(0, 'push-confirm', @policy_args, $destrepo);
 955     }
 956 }
 957
 958 sub stunthook () {
 959     printdebug "stunthook in $workrepo\n";
 960     chdir $workrepo or die "chdir $workrepo: $!";
 961     mkdir "dgit-tmp" or $!==EEXIST or die $!;
 962     readupdates();
 963     parsetag();
 964     verifytag();
 965     checks();
 966     finalisepush();
 967     printdebug "stunthook done.\n";
 968 }
 969
 970 #----- git-upload-pack -----
 971
 972 sub fixmissing__git_upload_pack () {
 973     $destrepo = "$dgitrepos/_empty";
 974     my $lfh = locksometree($destrepo);
 975     return if stat_exists $destrepo;
 976     rmtree "$destrepo.new";
 977     mkemptyrepo "$destrepo.new", "0644";
 978     rename "$destrepo.new", $destrepo or die $!;
 979     unlink "$destrepo.lock" or die $!;
 980     close $lfh;
 981 }
 982
 983 sub main__git_upload_pack () {
 984     my $lfh = locksometree($destrepo);
 985     printdebug "git-upload-pack in $destrepo\n";
 986     chdir $destrepo or die "$destrepo: $!";
 987     close $lfh;
 988     runcmd qw(git upload-pack), ".";
 989 }
 990
 991 #----- arg parsing and main program -----
 992
 993 sub argval () {
 994     die unless @ARGV;
 995     my $v = shift @ARGV;
 996     die if $v =~ m/^-/;
 997     return $v;
 998 }
 999
1000 our %indistrodir = (
1001     # keys are used for DGIT_DRS_XXX too
1002     'repos' => \$dgitrepos,
1003     'suites' => \$suitesfile,
1004     'suites-master' => \$suitesformasterfile,
1005     'policy-hook' => \$policyhook,
1006     'mirror-hook' => \$mirrorhook,
1007     'dgit-live' => \$dgitlive,
1008     );
1009
1010 our @hookenvs = qw(distro suitesfile suitesformasterfile policyhook
1011                    mirrorhook dgitlive keyrings dgitrepos distrodir);
1012
1013 # workrepo and destrepo handled ad-hoc
1014
1015 sub mode_ssh () {
1016     die if @ARGV;
1017
1018     my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
1019     $cmd =~ m{
1020         ^
1021         (?: \S* / )?
1022         ( [-0-9a-z]+ )
1023         \s+
1024         '? (?: \S* / )?
1025         ($package_re) \.git
1026         '?$
1027     }ox
1028     or reject "command string not understood";
1029     my $method = $1;
1030     $package = $2;
1031
1032     my $funcn = $method;
1033     $funcn =~ y/-/_/;
1034     my $mainfunc = $main::{"main__$funcn"};
1035
1036     reject "unknown method" unless $mainfunc;
1037
1038     policy_checkpackage();
1039
1040     if (stat_exists realdestrepo) {
1041         $destrepo = realdestrepo;
1042     } else {
1043         printdebug " fixmissing $funcn\n";
1044         my $fixfunc = $main::{"fixmissing__$funcn"};
1045         &$fixfunc;
1046     }
1047
1048     printdebug " running main $funcn\n";
1049     &$mainfunc;
1050 }
1051
1052 sub mode_cron () {
1053     die if @ARGV;
1054
1055     my $listfh = tempfile();
1056     open STDOUT, ">&", $listfh or die $!;
1057     policyhook(0,'check-list');
1058     open STDOUT, ">&STDERR" or die $!;
1059
1060     seek $listfh, 0, 0 or die $!;
1061     while (<$listfh>) {
1062         chomp or die;
1063         next if m/^\s*\#/;
1064         next unless m/\S/;
1065         die unless m/^($package_re)$/;
1066
1067         $package = $1;
1068         policy_checkpackage();
1069     }
1070     die $! if $listfh->error;
1071 }
1072
1073 sub parseargsdispatch () {
1074     die unless @ARGV;
1075
1076     delete $ENV{'GIT_DIR'}; # if not run via ssh, our parent git process
1077     delete $ENV{'GIT_PREFIX'}; # sets these and they mess things up
1078
1079     if ($ENV{'DGIT_DRS_DEBUG'}) {
1080         enabledebug();
1081     }
1082
1083     if ($ARGV[0] eq '--pre-receive-hook') {
1084         if ($debuglevel) {
1085             $debugprefix.="=";
1086             printdebug "in stunthook ".(shellquote @ARGV)."\n";
1087             foreach my $k (sort keys %ENV) {
1088                 printdebug "$k=$ENV{$k}\n" if $k =~  m/^DGIT/;
1089             }
1090         }
1091         shift @ARGV;
1092         @ARGV == 1 or die;
1093         $package = shift @ARGV;
1094         ${ $main::{$_} } = $ENV{"DGIT_DRS_\U$_"} foreach @hookenvs;
1095         defined($workrepo = $ENV{'DGIT_DRS_WORK'}) or die;
1096         defined($destrepo = $ENV{'DGIT_DRS_DEST'}) or die;
1097         open STDOUT, ">&STDERR" or die $!;
1098         eval {
1099             stunthook();
1100         };
1101         if ($@) {
1102             recorderror "$@" or die;
1103             die $@;
1104         }
1105         exit 0;
1106     }
1107
1108     $distro    = argval();
1109     $distrodir = argval();
1110     $keyrings  = argval();
1111
1112     foreach my $dk (keys %indistrodir) {
1113         ${ $indistrodir{$dk} } = "$distrodir/$dk";
1114     }
1115
1116     while (@ARGV && $ARGV[0] =~ m/^--([-0-9a-z]+)=/ && $indistrodir{$1}) {
1117         ${ $indistrodir{$1} } = $'; #';
1118         shift @ARGV;
1119     }
1120
1121     $ENV{"DGIT_DRS_\U$_"} = ${ $main::{$_} } foreach @hookenvs;
1122
1123     die unless @ARGV==1;
1124
1125     my $mode = shift @ARGV;
1126     die unless $mode =~ m/^--(\w+)$/;
1127     my $fn = ${*::}{"mode_$1"};
1128     die unless $fn;
1129     $fn->();
1130 }
1131
1132 sub unlockall () {
1133     while (my $fh = pop @lockfhs) { close $fh; }
1134 }
1135
1136 sub cleanup () {
1137     unlockall();
1138     if (!chdir "$dgitrepos/_tmp") {
1139         $!==ENOENT or die $!;
1140         return;
1141     }
1142     foreach my $lf (<*.lock>) {
1143         my $tree = $lf;
1144         $tree =~ s/\.lock$//;
1145         next unless acquirermtree($tree, 0);
1146         remove $lf or warn $!;
1147         unlockall();
1148     }
1149 }
1150
1151 parseargsdispatch();
1152 cleanup();