dgit-repos-server

   1 #!/usr/bin/perl -w
   2 # dgit-repos-server
   3 #
   4 # usages:
   5 #  .../dgit-repos-server SUITES KEYRING-AUTH-SPEC DGIT-REPOS-DIR --ssh
   6 # internal usage:
   7 #  .../dgit-repos-server --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 $package;
  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 sub runcmd {
 141     $!=0; $?=0;
 142     my $r = system @_;
 143     die "@_ $? $!" if $r;
 144 }
 145
 146 #----- git-receive-pack -----
 147
 148 sub fixmissing__git_receive_pack () {
 149     $destrepo = "$dgitrepos/_tmp/${package}_prospective";
 150     acquiretree($destrepo, 1);
 151     my $r = system qw(cp -a --), "$dgitrepos/_template", "$destrepo";
 152     !$r or die "create new repo failed failed: $r $!";
 153 }
 154
 155 sub makeworkingclone () {
 156     $workrepo = "$dgitrepos/_tmp/${package}_incoming$$";
 157     acquiretree($workrepo, 1);
 158     runcmd qw(git clone -l -q --mirror), $destrepo, $workrepo;
 159 }
 160
 161 sub setupstunthook () {
 162     my $prerecv = "$workrepo/hooks/pre-receive";
 163     my $fh = new IO::File $prerecv, O_WRONLY|O_CREAT|O_TRUNC, 0777
 164         or die "$prerecv: $!";
 165     print $fh <<END or die "$prerecv: $!";
 166 #!/bin/sh
 167 set -e
 168 exec $0 --pre-receive-hook $package
 169 END
 170     close $fh or die "$prerecv: $!";
 171     $ENV{'DGIT_RPR_WORK'}= $workrepo;
 172     $ENV{'DGIT_RPR_DEST'}= $destrepo;
 173 }
 174
 175 sub maybeinstallprospective () {
 176     return if $destrepo eq $realdestrepo;
 177
 178     my $child = open SR, "-|";
 179     defined $child or die $!;
 180     if (!$child) {
 181         chdir $destrepo or die $!;
 182         exec qw(git show-ref);
 183         die $!;
 184     }
 185     my %got = qw(tag 0 head 0);
 186     while (<SR>) {
 187         chomp or die;
 188         s/^\S*[1-9a-f]\S* (\S+)$/$1/ or die;
 189         my $wh =
 190             m{^refs/tags/} ? 'tag' :
 191             m{^refs/dgit/} ? 'head' :
 192             die;
 193         die if $got{$wh}++;
 194     }
 195     die if grep { !$_ } values %got;
 196     $!=0; $?=0; close SR or die "$? $!";
 197
 198     rename $destrepo, $realdestrepo or die $!;
 199     remove "$destrepo.lock" or die $!;
 200 }
 201
 202 sub main__git_receive_pack () {
 203     makeworkingclone();
 204     setupstunthook();
 205     runcmd qw(git receive-pack), $destrepo;
 206     maybeinstallprospective();
 207 }
 208
 209 #----- stunt post-receive hook -----
 210
 211 our ($tagname, $tagval, $suite, $oldcommit, $commit);
 212 our ($version, %tagh);
 213
 214 sub readupdates () {
 215     while (<STDIN>) {
 216         m/^(\S+) (\S+) (\S+)$/ or die "$_ ?";
 217         my ($old, $sha1, $refname) = ($1, $2, $3);
 218         if ($refname =~ m{^refs/tags/(?=debian/)}) {
 219             die if defined $tagname;
 220             $tagname = $'; #';
 221             $tagval = $sha1;
 222             reject "tag $tagname already exists -".
 223                 " not replacing previously-pushed version"
 224                 if $old =~ m/[^0]/;
 225         } elsif ($refname =~ m{^refs/dgit/}) {
 226             die if defined $suite;
 227             $suite = $'; #';
 228             $oldcommit = $old;
 229             $commit = $sha1;
 230         } else {
 231             die;
 232         }
 233     }
 234     STDIN->error and die $!;
 235
 236     die unless defined $tagname;
 237     die unless defined $suite;
 238 }
 239
 240 sub parsetag () {
 241     open PT, ">dgit-tmp/plaintext" or die $!;
 242     open DS, ">dgit-tmp/plaintext.asc" or die $!;
 243     open T, "-|", qw(git cat-file tag), $tagval or die $!;
 244     for (;;) {
 245         $!=0; $_=<T>; defined or die $!;
 246         print PT or die $!;
 247         if (m/^(\S+) (.*)/) {
 248             push @{ $tagh{$1} }, $2;
 249         } elsif (!m/\S/) {
 250             last;
 251         } else {
 252             die;
 253         }
 254     }
 255     $!=0; $_=<T>; defined or die $!;
 256     m/^($package_re) release (\S+) for (\S+) \[dgit\]$/ or die;
 257
 258     die unless $1 eq $package;
 259     $version = $2;
 260     die unless $3 eq $suite;
 261
 262     for (;;) {
 263         print PT or die $!;
 264         $!=0; $_=<T>; defined or die $!;
 265         last if m/^-----BEGIN PGP/;
 266     }
 267     for (;;) {
 268         print DS or die $!;
 269         $!=0; $_=<T>;
 270         last if !defined;
 271     }
 272     T->error and die $!;
 273     close PT or die $!;
 274     close DS or die $!;
 275 }
 276
 277 sub checksig_keyring ($) {
 278     my ($keyringfile) = @_;
 279     # returns primary-keyid if signed by a key in this keyring
 280     # or undef if not
 281     # or dies on other errors
 282
 283     my $ok = undef;
 284
 285     open P, "-|", (qw(gpgv --status-fd=1 --keyring),
 286                    $keyringfile,
 287                    qw(dgit-tmp/plaintext.asc dgit-tmp/plaintext))
 288         or die $!;
 289
 290     while (<P>) {
 291         next unless s/^\[GNUPG:\]: //;
 292         chomp or die;
 293         my @l = split / /, $_;
 294         if ($l[0] eq 'NO_PUBKEY') {
 295             last;
 296         } elsif ($l[0] eq 'VALIDSIG') {
 297             my $sigtype = $l[9];
 298             $sigtype eq '00' or reject "signature is not of type 00!";
 299             $ok = $l[10];
 300             die unless defined $ok;
 301             last;
 302         }
 303     }
 304     close P;
 305
 306     return $ok;
 307 }
 308
 309 sub dm_txt_check ($$) {
 310     my ($keyid, $dmtxtfn) = @_;
 311     open DT, '<', $dmtxtfn or die "$dmtxtfn $!";
 312     while (<DT>) {
 313         m/^fingerprint:\s+$keyid$/oi
 314             ..0 or next;
 315         m/^\S/
 316             or reject "key $keyid missing Allow section in permissions!";
 317         # in right stanza...
 318         s/^allow:/ /i
 319             ..0 or next;
 320         s/^\s+//
 321             or reject "package $package not allowed for key $keyid";
 322         # in allow field...
 323         s/\([^()]+\)//;
 324         s/\,//;
 325         foreach my $p (split /\s+/) {
 326             return if $p eq $package; # yay!
 327         }
 328     }
 329     DT->error and die $!;
 330     close DT or die $!;
 331     reject "key $keyid not in permissions list although in keyring!";
 332 }
 333
 334 sub verifytag () {
 335     foreach my $kas (split /:/, $keyrings) {
 336         $kas =~ s/^([^,]+),// or die;
 337         my $keyid = checksig_keyring $1;
 338         if (defined $keyid) {
 339             if ($kas =~ m/^a$/) {
 340                 return; # yay
 341             } elsif ($kas =~ m/^m([^,]+)$/) {
 342                 dm_txt_check($keyid, $1);
 343                 return;
 344             } else {
 345                 die;
 346             }
 347         }
 348     }
 349     reject "key not found in keyrings";
 350 }
 351
 352 sub checksuite () {
 353     open SUITES, "<", $suitesfile or die $!;
 354     while (<SUITES>) {
 355         chomp;
 356         next unless m/\S/;
 357         next if m/^\#/;
 358         s/\s+$//;
 359         return if $_ eq $suite;
 360     }
 361     die $! if SUITES->error;
 362     reject "unknown suite";
 363 }
 364
 365 sub checks () {
 366     checksuite();
 367     tagh1('type') eq 'commit' or die;
 368     tagh1('object') eq $commit or die;
 369     tagh1('tag') eq $tagname or die;
 370
 371     my $v = $version;
 372     $v =~ y/~:/_%/;
 373     $tagname eq "debian/$v" or die;
 374
 375     # check that our ref is being fast-forwarded
 376     if ($oldcommit =~ m/[^0]/) {
 377         $?=0; $!=0; my $mb = `git merge-base $commit $oldcommit`;
 378         chomp $mb;
 379         $mb eq $oldcommit or reject "not fast forward on dgit branch";
 380     }
 381 }
 382
 383 sub onwardpush () {
 384     $!=0;
 385     my $r = system (qw(git send-pack),
 386                     $destrepo,
 387                     "$commit:refs/dgit/$suite",
 388                     "$tagval:refs/tags/$tagname");
 389     !$r or die "onward push failed: $r $!";
 390 }
 391
 392 sub stunthook () {
 393     chdir $workrepo or die "chdir $workrepo: $!";
 394     mkdir "dgit-tmp" or $!==EEXIST or die $!;
 395     readupdates();
 396     parsetag();
 397     verifytag();
 398     checks();
 399     onwardpush();
 400 }
 401
 402 #----- git-upload-pack -----
 403
 404 sub fixmissing__git_upload_pack () {
 405     $destrepo = "$dgitrepos/_empty";
 406 }
 407
 408 sub main__git_upload_pack () {
 409     runcmd qw(git upload-pack), $destrepo;
 410 }
 411
 412 #----- arg parsing and main program -----
 413
 414 sub argval () {
 415     die unless @ARGV;
 416     my $v = shift @ARGV;
 417     die if $v =~ m/^-/;
 418     return $v;
 419 }
 420
 421 sub parseargsdispatch () {
 422     die unless @ARGV;
 423
 424     if ($ARGV[0] eq '--pre-receive-hook') {
 425         shift @ARGV;
 426         @ARGV == 1 or die;
 427         $package = shift @ARGV;
 428         defined($suitesfile = $ENV{'DGIT_RPR_SUITES'}) or die;
 429         defined($workrepo = $ENV{'DGIT_RPR_WORK'}) or die;
 430         defined($destrepo = $ENV{'DGIT_RPR_DEST'}) or die;
 431         defined($keyrings = $ENV{'DGIT_RPR_KEYRINGS'}) or die $!;
 432         open STDOUT, ">&STDERR" or die $!;
 433         stunthook();
 434         exit 0;
 435     }
 436
 437     $ENV{'DGIT_RPR_SUITES'} = argval();
 438     $ENV{'DGIT_RPR_KEYRINGS'} = argval();
 439     $dgitrepos = argval();
 440
 441     die unless @ARGV==1 && $ARGV[0] eq '--ssh';
 442
 443     my $cmd = $ENV{'SSH_ORIGINAL_COMMAND'};
 444     $cmd =~ m{
 445         ^
 446         (?: \S* / )?
 447         ( [-0-9a-z]+ )
 448         \s+
 449         (?: \S* / )?
 450         ($package_re) \.git
 451         $
 452     }ox
 453     or reject "command string not understood";
 454     my $method = $1;
 455     $package = $2;
 456     $realdestrepo = "$dgitrepos/$package.git";
 457
 458     my $funcn = $method;
 459     $funcn =~ y/-/_/;
 460     my $mainfunc = $main::{"main__$funcn"};
 461
 462     reject "unknown method" unless $mainfunc;
 463
 464     if (stat $realdestrepo) {
 465         $destrepo = $realdestrepo;
 466     } else {
 467         $! == ENOENT or die "stat dest repo $destrepo: $!";
 468         my $fixfunc = $main::{"fixmissing__$funcn"};
 469         &$fixfunc;
 470     }
 471
 472     &$mainfunc;
 473 }
 474
 475 sub unlockall () {
 476     while (my $fh = pop @lockfhs) { close $fh; }
 477 }
 478
 479 sub cleanup () {
 480     unlockall();
 481     chdir "$dgitrepos/_tmp" or die $!;
 482     foreach my $lf (<*.lock>) {
 483         my $tree = $lf;
 484         $tree =~ s/\.lock$//;
 485         next unless acquiretree($tree, 0);
 486         remove $lf or warn $!;
 487         unlockall();
 488     }
 489 }
 490
 491 parseargsdispatch();
 492 cleanup();