dgit-repos-server

   1 #!/usr/bin/perl -w
   2 # dgit-repos-push-receiver
   3 #
   4 # usages:
   5 #  .../dgit-repos-push-receiver SUITES KEYRING-AUTH-SPEC DGIT-REPOS-DIR --ssh
   6 # internal usage:
   7 #  .../dgit-repos-push-receiver --pre-receive-hook PACKAGE
   8 #
   9 # Invoked as the ssh restricted command
  10 #
  11 # Works like git-receive-pack
  12 #
  13 # SUITES is the name of a file which lists the permissible suites
  14 # one per line (#-comments and blank lines ignored)
  15 #
  16 # KEYRING-AUTH-SPEC is a :-separated list of
  17 #   KEYRING.GPG,AUTH-SPEC
  18 # where AUTH-SPEC is one of
  19 #   a
  20 #   mDM.TXT
  21
  22 use strict;
  23
  24 # What we do is this:
  25 #  - extract the destination repo name
  26 #  - make a hardlink clone of the destination repo
  27 #  - provide the destination with a stunt pre-receive hook
  28 #  - run actual git-receive-pack with that new destination
  29 #   as a result of this the stunt pre-receive hook runs; it does this:
  30 #    + understand what refs we are allegedly updating and
  31 #      check some correspondences:
  32 #        * we are updating only refs/tags/debian/* and refs/dgit/*
  33 #        * and only one of each
  34 #        * and the tag does not already exist
  35 #      and
  36 #        * recover the suite name from the destination refs/dgit/ ref
  37 #    + disassemble the signed tag into its various fields and signature
  38 #      including:
  39 #        * parsing the first line of the tag message to recover
  40 #          the package name, version and suite
  41 #        * checking that the package name corresponds to the dest repo name
  42 #        * checking that the suite name is as recovered above
  43 #    + verify the signature on the signed tag
  44 #      and if necessary check that the keyid and package are listed in dm.txt
  45 #    + check various correspondences:
  46 #        * the suite is one of those permitted
  47 #        * the signed tag must refer to a commit
  48 #        * the signed tag commit must be the refs/dgit value
  49 #        * the name in the signed tag must correspond to its ref name
  50 #        * the tag name must be debian/<version> (massaged as needed)
  51 #        * the signed tag has a suitable name
  52 #        * the commit is a fast forward
  53 #    + push the signed tag and new dgit branch to the actual repo
  54 #
  55 # If the destination repo does not already exist, we need to make
  56 # sure that we create it reasonably atomically, and also that
  57 # we don't every have a destination repo containing no refs at all
  58 # (because such a thing causes git-fetch-pack to barf).  So then we
  59 # do as above, except:
  60 #  - before starting, we take out our own lock for the destination repo
  61 #  - we create a prospective new destination repo by making a copy
  62 #    of _template
  63 #  - we use the prospective new destination repo instead of the
  64 #    actual new destination repo (since the latter doesn't exist)
  65 #  - we set up a post-receive hook as well, which
  66 #    + touches a stamp file
  67 #  - after git-receive-pack exits, we
  68 #    + check that the prospective repo contains a tag and head
  69 #    + rename the prospective destination repo into place
  70 #
  71 # Cleanup strategy:
  72 #  - We are crash-only
  73 #  - Temporary working trees and their locks are cleaned up
  74 #    opportunistically by a program which tries to take each lock and
  75 #    if successful deletes both the tree and the lockfile
  76 #  - Prospective working trees and their locks are cleaned up by
  77 #    a program which tries to take each lock and if successful
  78 #    deletes any prospective working tree and the lock (but not
  79 #    of course any actual tree)
  80 #  - It is forbidden to _remove_ the lockfile without removing
  81 #    the corresponding temporary tree, as the lockfile is also
  82 #    a stampfile whose presence indicates that there may be
  83 #    cleanup to do
  84
  85 use POSIX;
  86 use Fcntl qw(:flock);
  87 use File::Path qw(rmtree);
  88
  89 our $package_re = '[0-9a-z][-+.0-9a-z]+';
  90
  91 our $func;
  92 our $dgitrepos;
  93 our $pkg;
  94 our $suitesfile;
  95 our $realdestrepo;
  96 our $destrepo;
  97 our $workrepo;
  98 our @keyrings;
  99 our @lockfhs;
 100
 101 #----- utilities -----
 102
 103 sub acquirelock ($$) {
 104     my ($lock, $must) = @_;
 105     my $fh;
 106     for (;;) {
 107         close $fh if $fh;
 108         $fh = new IO::File, ">", $lock or die "open $lock: $!";
 109         my $ok = flock $fh, $must ? LOCK_EX : (LOCK_EX|LOCK_NB);
 110         if (!$ok) {
 111             return undef unless $must;
 112             die "flock $lock: $!";
 113         }
 114         if (!stat $lock) {
 115             next if $! == ENOENT;
 116             die "stat $lock: $!";
 117         }
 118         my $want = (stat _)[1];
 119         stat $fh or die $!;
 120         my $got = (stat _)[1];
 121         last if $got == $want;
 122     }
 123     return $fh;
 124 }
 125
 126 sub acquiretree ($$) {
 127     my ($tree, $must) = @_;
 128     my $fh = acquirelock("$tree.lock", $must);
 129     if ($fh) {
 130         push @lockfhs, $fh;
 131         rmtree $tree;
 132     }
 133     return $fh;
 134 }
 135
 136 sub reject ($) {
 137     die "dgit-repos-server: reject: $_[0]\n";
 138 }
 139
 140 #----- git-receive-pack -----
 141
 142 sub fixmissing__git_receive_pack () {
 143     $destrepo = "$dgitrepos/_tmp/${pkg}_prospective";
 144     acquiretree($destrepo, 1);
 145     my $r = system qw(cp -a --), "$dgitrepos/_template", "$destrepo";
 146     !$r or die "create new repo failed failed: $r $!";
 147 }
 148
 149 sub makeworkingclone () {
 150     $workrepo = "$dgitrepos/_tmp/${pkg}_incoming$$";
 151     acquiretree($workrepo, 1);
 152     runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
 153 }
 154
 155 sub setupstunthook () {
 156     my $prerecv = "$workrepo/hooks/pre-receive";
 157     my $fh = new IO::File, $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
 158         or die "$prerecv: $!";
 159     print $fh <<END or die "$prerecv: $!";
 160 #!/bin/sh
 161 set -e
 162 exec $0 --pre-receive-hook $pkg
 163 END
 164     close $fh or die "$prerecv: $!";
 165     $ENV{'DGIT_RPR_WORK'}= $workrepo;
 166     $ENV{'DGIT_RPR_DEST'}= $destrepo;
 167 }
 168
 169 sub maybeinstallprospective () {
 170     return if $destrepo eq $realdestrepo;
 171
 172     my $child = open SR, "-|";
 173     defined $child or die $!;
 174     if (!$child) {
 175         chdir $destrepo or die $!;
 176         exec qw(git show-ref);
 177         die $!;
 178     }
 179     my %got = qw(tag 0 head 0);
 180     while (<SR>) {
 181         chomp or die;
 182         s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
 183         my $wh =
 184             m{^refs/tags/} ? 'tag' :
 185             m{^refs/dgit/} ? 'head' :
 186             die;
 187         die if $got{$wh}++;
 188     }
 189     die if grep { !$_ } values %got;
 190     $!=0; $?=0; close SR or die "$? $!";
 191
 192     rename $destrepo, $realdestrepo or die $!;
 193     remove "$destrepo.lock" or die $!;
 194 }
 195
 196 sub main__git_receive_pack () {
 197     makeworkingclone();
 198     setupstunthook();
 199     runcmd qw(git receive-pack), $destdir;
 200     maybeinstallprospective();
 201 }
 202
 203 #----- stunt post-receive hook -----
 204
 205 our ($tagname, $tagval, $suite, $oldcommit, $commit);
 206 our ($version, %tagh);
 207
 208 sub readupdates () {
 209     while (<STDIN>) {
 210         m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
 211         my ($old, $sha1, $refname) = ($1, $2, $3);
 212         if ($refname =~ m{^refs/tags/(?=debian/)}) {
 213             die if defined $tagname;
 214             $tagname = $'; #';
 215             $tagval = $sha1;
 216             reject "tag $tagname already exists -".
 217                 " not replacing previously-pushed version"
 218                 if $old =~ m/[^0]/;
 219         } elsif ($refname =~ m{^refs/dgit/}) {
 220             die if defined $suite;
 221             $suite = $'; #';
 222             $oldcommit = $old;
 223             $commit = $sha1;
 224         } else {
 225             die;
 226         }
 227     }
 228     STDIN->error and die $!;
 229
 230     die unless defined $refname;
 231     die unless defined $branchname;
 232 }
 233
 234 sub parsetag () {
 235     open PT, ">dgit-tmp/plaintext" or die $!;
 236     open DS, ">dgit-tmp/plaintext.asc" or die $!;
 237     open T, "-|", qw(git cat-file tag), $tagval or die $!;
 238     for (;;) {
 239         $!=0; $_=<T>; defined or die $!;
 240         print PT or die $!;
 241         if (m/^(\S+) (.*)/) {
 242             push @{ $tagh{$1} }, $2;
 243         } elsif (!m/\S/) {
 244             last;
 245         } else {
 246             die;
 247         }
 248     }
 249     $!=0; $_=<T>; defined or die $!;
 250     m/^($package_re) release (\S+) for (\S+) \[dgit\]$/ or die;
 251
 252     die unless $1 eq $pkg;
 253     $version = $2;
 254     die unless $3 eq $suite;
 255
 256     for (;;) {
 257         print PT or die $!;
 258         $!=0; $_=<T>; defined or die $!;
 259         last if m/^-----BEGIN PGP/;
 260     }
 261     for (;;) {
 262         print DS or die $!;
 263         $!=0; $_=<T>;
 264         last if !defined;
 265     }
 266     T->error and die $!;
 267     close PT or die $!;
 268     close DS or die $!;
 269 }
 270
 271 sub checksig_keyring ($) {
 272     my ($keyringfile) = @_;
 273     # returns primary-keyid if signed by a key in this keyring
 274     # or undef if not
 275     # or dies on other errors
 276
 277     my $ok = undef;
 278
 279     open P, "-|", (qw(gpgv --status-fd=1),
 280                    map { '--keyring', $_ }, @keyrings,
 281                    qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext))
 282         or die $!;
 283
 284     while (<P>) {
 285         next unless s/^\[GNUPG:\]: //;
 286         chomp or die;
 287         my @l = split / /, $_;
 288         if ($l[0] eq 'NO_PUBKEY') {
 289             last;
 290         } elsif ($l[0] eq 'VALIDSIG') {
 291             my $sigtype = $l[9];
 292             $sigtype eq '00' or reject "signature is not of type 00!";
 293             $ok = $l[10];
 294             die unless defined $ok;
 295             last;
 296         }
 297     }
 298     close P;
 299
 300     return $ok;
 301 }
 302
 303 sub dm_txt_check ($$) {
 304     my ($keyid, $dmtxtfn) = @_;
 305     open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
 306     while (<DT>) {
 307         m/^fingerprint:\s+$keyid$/oi
 308             ..0 or next;
 309         m/^\S/
 310             or reject "key $keyid missing Allow section in permissions!";
 311         # in right stanza...
 312         s/^allow:/ /i
 313             ..0 or next;
 314         s/^\s+//
 315             or reject "package $package not allowed for key $keyid";
 316         # in allow field...
 317         s/\([^()]+\)//;
 318         s/\,//;
 319         foreach my $p (split /\s+/) {
 320             return if $p eq $package; # yay!
 321         }
 322     }
 323     DT->error and die $!;
 324     close DT or die $!;
 325     reject "key $keyid not in permissions list although in keyring!";
 326 }
 327
 328 sub verifytag () {
 329     foreach my $kas (split /:/, $keyrings) {
 330         $kas =~ s/^([^,]+),// or die;
 331         my $keyid = checksig_keyring $1;
 332         if (defined $keyid) {
 333             if ($kas =~ m/^a$/) {
 334                 return; # yay
 335             } elsif ($kas =~ m/^m([^,]+)$/) {
 336                 dm_txt_check($keyid, $1);
 337                 return;
 338             } else {
 339                 die;
 340             }
 341         }
 342     }
 343     reject "key not found in keyrings";
 344 }
 345
 346 sub checksuite () {
 347     open SUITES, "<", $suitesfile or die $!;
 348     while (<SUITES>) {
 349         chomp;
 350         next unless m/\S/;
 351         next if m/^\#/;
 352         s/\s+$//;
 353         return if $_ eq $suite;
 354     }
 355     die $! if SUITES->error;
 356     reject "unknown suite";
 357 }
 358
 359 sub checks () {
 360     checksuite();
 361     tagh1('type') eq 'commit' or die;
 362     tagh1('object') eq $commit or die;
 363     tagh1('tag') eq $tagname or die;
 364
 365     my $v = $version;
 366     $v =~ y/~:/_%/;
 367     $tagname eq "debian/$v" or die;
 368
 369     # check that our ref is being fast-forwarded
 370     if ($oldcommit =~ m/[^0]/) {
 371         $?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
 372         chomp $mb;
 373         $mb eq $oldcommit or reject "not fast forward on dgit branch";
 374     }
 375 }
 376
 377 sub onwardpush () {
 378     $!=0;
 379     my $r = system (qw(git send-pack),
 380                     $destrepo,
 381                     "$commit:refs/dgit/$suite",
 382                     "$tagval:refs/tags/$tagname");
 383     !$r or die "onward push failed: $r $!";
 384 }
 385
 386 sub stunthook () {
 387     chdir $workrepo or die "chdir $workrepo: $!";
 388     mkdir "dgit-tmp" or $!==EEXIST or die $!;
 389     readupdates();
 390     parsetag();
 391     verifytag();
 392     checks();
 393     onwardpush();
 394 }
 395
 396 #----- arg parsing and main program -----
 397
 398 sub argval () {
 399     die unless @ARGV;
 400     my $v = shift @ARGV;
 401     die if $v =~ m/^-/;
 402     return $v;
 403 }
 404
 405 sub parseargsdispatch () {
 406     die unless @ARGV;
 407
 408     if ($ARGV[0] eq '--pre-receive-hook') {
 409         shift @ARGV;
 410         @ARGV == 1 or die;
 411         $pkg = shift @ARGV;
 412         defined($suitesfile = $ENV{'DGIT_RPR_SUITES'}) or die;
 413         defined($workrepo = $ENV{'DGIT_RPR_WORK'}) or die;
 414         defined($destrepo = $ENV{'DGIT_RPR_DEST'}) or die;
 415         defined($keyrings = $ENV{'DGIT_RPR_KEYRINGS'}) or die $!;
 416         open STDOUT, ">&STDERR" or die $!;
 417         stunthook();
 418         exit 0;
 419     }
 420
 421     $ENV{'DGIT_RPR_SUITES'} = argval();
 422     $ENV{'DGIT_RPR_KEYRINGS'} = argval();
 423     $dgitrepos = argval();
 424
 425     die unless @ARGV==1 && $ARGV[0] eq '--ssh';
 426
 427     my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
 428     $cmd =~ m{
 429         ^
 430         (?: \S* / )?
 431         ( [-0-9a-z]+ )
 432         \s+
 433         (?: \S* / )?
 434         ($package_re) \.git
 435         $
 436     }ox
 437     or reject "command string not understood";
 438     $method = $1;
 439     $pkg = $2;
 440     $realdestrepo = "$dgitrepos/$pkg.git";
 441
 442     my $funcn = $method;
 443     $funcn =~ y/-/_/;
 444     my $mainfunc = $main::{"main__$funcn"};
 445
 446     reject "unknown method" unless $mainfunc;
 447
 448     if (stat $realdestrepo) {
 449         $destrepo = $realdestrepo;
 450     } else {
 451         $! == ENOENT or die "stat dest repo $destrepo: $!";
 452         my $fixfunc = $main::{"fixmissing__$funcn"};
 453         &$fixfunc;
 454     }
 455
 456     &$mainfunc;
 457 }
 458
 459 sub unlockall () {
 460     while (my $fh = pop $lockfhs) { close $fh; }
 461 }
 462
 463 sub cleanup () {
 464     unlockall();
 465     chdir "$dgitrepos/_tmp" or die $!;
 466     foreach my $lock (<*.lock>) {
 467         my $tree = $lf;
 468         $tree =~ s/\.lock$//;
 469         next unless acquiretree($tree, 0);
 470         remove $lock or warn $!;
 471         unlockall();
 472     }
 473 }
 474
 475 parseargsdispatch();
 476 cleanup();