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