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