infra/dgit-ssh-dispatch

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 use Debian::Dgit;
   6 setup_sigwarn();
   7
   8 use POSIX;
   9
  10 open DEBUG, '>/dev/null' or die $!;
  11 if (@ARGV && $ARGV[0] eq '-D') {
  12     shift @ARGV;
  13     open DEBUG, '>&STDERR' or die $!;
  14 }
  15
  16 die unless @ARGV>=1 && @ARGV<=2 && $ARGV[0] !~ m/^-/;
  17 our ($dispatchdir,$authrune) = @ARGV;
  18
  19 $authrune //= join ':',
  20     '@/keyrings/debian-keyring.gpg,a',
  21     '@/keyrings/debian-maintainers.gpg,m@/dm.txt';
  22
  23 our $lre = $package_re;
  24 our $qre = '["'."']?";
  25
  26 # $dispatchdir/distro=DISTRO should contain
  27 #    dgit-live          a clone of dgit (only if not using installed vsns)
  28 #    diverts
  29 #    repos/             }  by virtue of
  30 #    suites             }    dgit-repos-server's defaults relating to
  31 #    policy-hook        }    dispatch-dir
  32 # plus files required by the authrune (by default, keyrings/ and dm.txt)
  33 #
  34 # diverts should be list of
  35 #  <pat> [<divert-to>]
  36 # where <pat> is a package name pattern which may contain * or literals.
  37 # <divert-to> is for `git config dgit-distro.DISTRO.diverts.<divert-to>'
  38
  39 our ($distro,$pkg, $d);
  40 our ($dgitlive,$repos,$suites,$diverts,$policyhook,$repo);
  41
  42 sub checkdivert ($) {
  43     my ($df) = @_;
  44     if (!open DIV, '<', $df) {
  45         $!==ENOENT or die $!;
  46         return undef;
  47     } else {
  48         while (<DIV>) {
  49             s/^\s+//; s/\s+$//;
  50             next unless m/\S/;
  51             next if m/^\#/;
  52             my $divert;
  53             if (s/\s+(\S+)$//) { $divert=$1; }
  54             s/[^-+._0-9a-zA-Z*]/\\$&/g;
  55             s/\*/.*/g;
  56             printf DEBUG 'DISPATCH DIVERT ^%s$ %s'."\n",
  57                 $_, ($divert // '(undef)');
  58             if ($pkg =~ m/^$_$/) { return $divert; }
  59         }
  60         DIV->error and die $!;
  61         close DIV;
  62         return undef;
  63     }
  64 }
  65
  66 sub finish () {
  67     close STDOUT or die $!;
  68     exit 0;
  69 }
  70
  71 sub prl ($) {
  72     print @_, "\n" or die $!;
  73 }
  74
  75 sub selectpackage ($$;$) {
  76     my $divertfn;
  77     ($distro,$pkg, $divertfn) = @_; # $distro,$pkg must have sane syntax
  78
  79     $d = "$dispatchdir/distro=$distro";
  80
  81     if (!stat $d) {
  82         die $! unless $!==ENOENT;
  83         die "unknown distro ($distro)\n";
  84     }
  85
  86     $dgitlive=    "$d/dgit-live";
  87     $repos=       "$d/repos";
  88     $suites=      "$d/suites";
  89     $policyhook=  "$d/policy-hook";
  90
  91     $authrune =~ s/\@/$d/g;
  92
  93     my $divert = checkdivert("$d/diverts");
  94     if (defined $divert) {
  95         $divertfn //= sub {
  96             die "diverted to $divert incompletely or too late!\n";
  97         };
  98         $divertfn->($divert);
  99         die;
 100     }
 101
 102     $repo = "$repos/$pkg.git";
 103
 104     print DEBUG "DISPATCH DISTRO $distro PKG $pkg\n";
 105 }
 106
 107 sub hasrepo () {
 108     if (stat $repo) {
 109         -d _ or die;
 110         return 1;
 111     } else {
 112         $!==ENOENT or die $!;
 113         return 0;
 114     }
 115 }
 116
 117 sub serve_up ($) {
 118     my ($repo) = @_;
 119     exec qw(git upload-pack --strict --timeout=1000), $repo;
 120     die "exec git: $!";
 121 }
 122
 123 sub dispatch () {
 124     local ($_) = $ENV{'SSH_ORIGINAL_COMMAND'} // '';
 125
 126     if (m#^: dgit ($lre) git-check ($lre) ;#) {
 127         selectpackage $1,$2, sub { prl "divert @_"; finish; };
 128         prl hasrepo;
 129         finish;
 130     } elsif (
 131         m#^${qre}git-([-a-z]+) ${qre}/dgit/($lre)/repos/($lre)\.git${qre}$#
 132         ) {
 133         my $cmd=$1;
 134         selectpackage $2,$3;
 135         if ($cmd eq 'receive-pack') {
 136             $ENV{'PERLLIB'} //= '';
 137             $ENV{'PERLLIB'} =~ s#^(?=.)#:#;
 138             $ENV{'PERLLIB'} =~ s#^# $ENV{DGIT_TEST_INTREE} // $dgitlive #e;
 139             my $s = "$dgitlive/infra/dgit-repos-server";
 140             $s = "dgit-repos-server" if !stat_exists $s;
 141             exec $s, $distro, $d, $authrune, qw(--ssh);
 142             die "exec $s: $!";
 143         } elsif ($cmd eq 'upload-pack') {
 144             $repo='$repos/_empty' unless hasrepo;
 145             serve_up $repo;
 146         } else {
 147             die "unsupported git operation $cmd ($_)";
 148         }
 149     } elsif (
 150  m#^${qre}git-upload-pack ${qre}/dgit/($lre)/(?:repos/)?_dgit-repos-server\.git${qre}$#
 151         ) {
 152         my $distro= $1;
 153         # if running installed packages, source code should come
 154         # some other way
 155         serve_up("$dispatchdir/distro=$1/dgit-live/.git");
 156     } elsif (m#^${qre}git-upload-pack\s#) {
 157         die "unknown repo to serve ($_).  use dgit, or for server source ".
 158             "git clone here:/dgit/DISTRO/repos/_dgit-repos-server.git";
 159     } else {
 160         die "unsupported operation ($_)";
 161     }
 162 }
 163
 164 dispatch;