infra/dgit-ssh-dispatch

   1 #!/usr/bin/perl -w
   2 # wrapper to dispatch git ssh service requests
   3 #
   4 # Copyright (C) 2015-2016  Ian Jackson
   5 #
   6 #    This program is free software; you can redistribute it and/or modify
   7 #    it under the terms of the GNU General Public License as published by
   8 #    the Free Software Foundation; either version 3 of the License, or
   9 #    (at your option) any later version.
  10 #
  11 #    This program is distributed in the hope that it will be useful,
  12 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 #    GNU General Public License for more details.
  15 #
  16 #    You should have received a copy of the GNU General Public License
  17 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 use strict;
  20
  21 use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
  22 use Debian::Dgit;
  23 setup_sigwarn();
  24
  25 use POSIX;
  26
  27 open DEBUG, '>/dev/null' or die $!;
  28 if (@ARGV && $ARGV[0] eq '-D') {
  29     shift @ARGV;
  30     open DEBUG, '>&STDERR' or die $!;
  31 }
  32
  33 die unless @ARGV>=1 && @ARGV<=2 && $ARGV[0] !~ m/^-/;
  34 our ($dispatchdir,$authrune) = @ARGV;
  35
  36 $authrune //= join ':',
  37     '@/keyrings/debian-keyring.gpg,a',
  38     '@/keyrings/debian-maintainers.gpg,m@/dm.txt';
  39
  40 our $lre = $package_re;
  41 our $qre = '["'."']?";
  42
  43 # $dispatchdir/distro=DISTRO should contain
  44 #    dgit-live          a clone of dgit (only if not using installed vsns)
  45 #    diverts
  46 #    repos/             }  by virtue of
  47 #    suites             }    dgit-repos-server's defaults relating to
  48 #    policy-hook        }    dispatch-dir
  49 # plus files required by the authrune (by default, keyrings/ and dm.txt)
  50 #
  51 # diverts should be list of
  52 #  <pat> [<divert-to>]
  53 # where <pat> is a package name pattern which may contain * or literals.
  54 # <divert-to> is for `git config dgit-distro.DISTRO.diverts.<divert-to>'
  55
  56 our ($distro,$pkg, $d);
  57 our ($dgitlive,$repos,$suites,$diverts,$policyhook,$repo);
  58
  59 sub checkdivert ($) {
  60     my ($df) = @_;
  61     if (!open DIV, '<', $df) {
  62         $!==ENOENT or die $!;
  63         return undef;
  64     } else {
  65         while (<DIV>) {
  66             s/^\s+//; s/\s+$//;
  67             next unless m/\S/;
  68             next if m/^\#/;
  69             my $divert;
  70             if (s/\s+(\S+)$//) { $divert=$1; }
  71             s/[^-+._0-9a-zA-Z*]/\\$&/g;
  72             s/\*/.*/g;
  73             printf DEBUG 'DISPATCH DIVERT ^%s$ %s'."\n",
  74                 $_, ($divert // '(undef)');
  75             if ($pkg =~ m/^$_$/) { return $divert; }
  76         }
  77         DIV->error and die $!;
  78         close DIV;
  79         return undef;
  80     }
  81 }
  82
  83 sub finish () {
  84     close STDOUT or die $!;
  85     exit 0;
  86 }
  87
  88 sub prl ($) {
  89     print @_, "\n" or die $!;
  90 }
  91
  92 sub selectpackage ($$;$) {
  93     my $divertfn;
  94     ($distro,$pkg, $divertfn) = @_; # $distro,$pkg must have sane syntax
  95
  96     $d = "$dispatchdir/distro=$distro";
  97
  98     if (!stat $d) {
  99         die $! unless $!==ENOENT;
 100         die "unknown distro ($distro)\n";
 101     }
 102
 103     $dgitlive=    "$d/dgit-live";
 104     $repos=       "$d/repos";
 105     $suites=      "$d/suites";
 106     $policyhook=  "$d/policy-hook";
 107
 108     $authrune =~ s/\@/$d/g;
 109
 110     my $divert = checkdivert("$d/diverts");
 111     if (defined $divert) {
 112         $divertfn //= sub {
 113             die "diverted to $divert incompletely or too late!\n";
 114         };
 115         $divertfn->($divert);
 116         die;
 117     }
 118
 119     $repo = "$repos/$pkg.git";
 120
 121     print DEBUG "DISPATCH DISTRO $distro PKG $pkg\n";
 122 }
 123
 124 sub hasrepo () {
 125     if (stat $repo) {
 126         -d _ or die;
 127         return 1;
 128     } else {
 129         $!==ENOENT or die $!;
 130         return 0;
 131     }
 132 }
 133
 134 sub serve_up ($) {
 135     my ($repo) = @_;
 136     exec qw(git upload-pack --strict --timeout=1000), $repo;
 137     die "exec git: $!";
 138 }
 139
 140 sub dispatch () {
 141     local ($_) = $ENV{'SSH_ORIGINAL_COMMAND'} // '';
 142
 143     if (m#^: dgit ($lre) git-check ($lre) ;#) {
 144         selectpackage $1,$2, sub { prl "divert @_"; finish; };
 145         prl hasrepo;
 146         finish;
 147     } elsif (
 148         m#^${qre}git-([-a-z]+) ${qre}/dgit/($lre)/repos/($lre)\.git${qre}$#
 149         ) {
 150         my $cmd=$1;
 151         selectpackage $2,$3;
 152         if ($cmd eq 'receive-pack') {
 153             $ENV{'PERLLIB'} //= '';
 154             $ENV{'PERLLIB'} =~ s#^(?=.)#:#;
 155             $ENV{'PERLLIB'} =~ s#^# $ENV{DGIT_TEST_INTREE} // $dgitlive #e;
 156             my $s = "$dgitlive/infra/dgit-repos-server";
 157             $s = "dgit-repos-server" if !stat_exists $s;
 158             exec $s, $distro, $d, $authrune, qw(--ssh);
 159             die "exec $s: $!";
 160         } elsif ($cmd eq 'upload-pack') {
 161             $repo='$repos/_empty' unless hasrepo;
 162             serve_up $repo;
 163         } else {
 164             die "unsupported git operation $cmd ($_)";
 165         }
 166     } elsif (
 167  m#^${qre}git-upload-pack ${qre}/dgit/($lre)/(?:repos/)?_dgit-repos-server\.git${qre}$#
 168         ) {
 169         my $distro= $1;
 170         # if running installed packages, source code should come
 171         # some other way
 172         serve_up("$dispatchdir/distro=$1/dgit-live/.git");
 173     } elsif (m#^${qre}git-upload-pack\s#) {
 174         die "unknown repo to serve ($_).  use dgit, or for server source ".
 175             "git clone here:/dgit/DISTRO/repos/_dgit-repos-server.git";
 176     } else {
 177         die "unsupported operation ($_)";
 178     }
 179 }
 180
 181 dispatch;