infra/dgit-ssh-dispatch

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