diff options
Diffstat (limited to 'infra/dgit-ssh-dispatch')
| -rwxr-xr-x | infra/dgit-ssh-dispatch | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/infra/dgit-ssh-dispatch b/infra/dgit-ssh-dispatch new file mode 100755 index 0000000..c5861d2 --- /dev/null +++ b/infra/dgit-ssh-dispatch @@ -0,0 +1,181 @@ +#!/usr/bin/perl -w +# wrapper to dispatch git ssh service requests +# +# Copyright (C) 2015-2016 Ian Jackson +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <http://www.gnu.org/licenses/>. + +use strict; + +use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC! +use Debian::Dgit; +setup_sigwarn(); + +use POSIX; + +open DEBUG, '>/dev/null' or die $!; +if (@ARGV && $ARGV[0] eq '-D') { + shift @ARGV; + open DEBUG, '>&STDERR' or die $!; +} + +die unless @ARGV>=1 && @ARGV<=2 && $ARGV[0] !~ m/^-/; +our ($dispatchdir,$authrune) = @ARGV; + +$authrune //= join ':', + '@/keyrings/debian-keyring.gpg,a', + '@/keyrings/debian-maintainers.gpg,m@/dm.txt'; + +our $lre = $package_re; +our $qre = '["'."']?"; + +# $dispatchdir/distro=DISTRO should contain +# dgit-live a clone of dgit (only if not using installed vsns) +# diverts +# repos/ } by virtue of +# suites } dgit-repos-server's defaults relating to +# policy-hook } dispatch-dir +# plus files required by the authrune (by default, keyrings/ and dm.txt) +# +# diverts should be list of +# <pat> [<divert-to>] +# where <pat> is a package name pattern which may contain * or literals. +# <divert-to> is for `git config dgit-distro.DISTRO.diverts.<divert-to>' + +our ($distro,$pkg, $d); +our ($dgitlive,$repos,$suites,$diverts,$policyhook,$repo); + +sub checkdivert ($) { + my ($df) = @_; + if (!open DIV, '<', $df) { + $!==ENOENT or die $!; + return undef; + } else { + while (<DIV>) { + s/^\s+//; s/\s+$//; + next unless m/\S/; + next if m/^\#/; + my $divert; + if (s/\s+(\S+)$//) { $divert=$1; } + s/[^-+._0-9a-zA-Z*]/\\$&/g; + s/\*/.*/g; + printf DEBUG 'DISPATCH DIVERT ^%s$ %s'."\n", + $_, ($divert // '(undef)'); + if ($pkg =~ m/^$_$/) { return $divert; } + } + DIV->error and die $!; + close DIV; + return undef; + } +} + +sub finish () { + close STDOUT or die $!; + exit 0; +} + +sub prl ($) { + print @_, "\n" or die $!; +} + +sub selectpackage ($$;$) { + my $divertfn; + ($distro,$pkg, $divertfn) = @_; # $distro,$pkg must have sane syntax + + $d = "$dispatchdir/distro=$distro"; + + if (!stat $d) { + die $! unless $!==ENOENT; + die "unknown distro ($distro)\n"; + } + + $dgitlive= "$d/dgit-live"; + $repos= "$d/repos"; + $suites= "$d/suites"; + $policyhook= "$d/policy-hook"; + + $authrune =~ s/\@/$d/g; + + my $divert = checkdivert("$d/diverts"); + if (defined $divert) { + $divertfn //= sub { + die "diverted to $divert incompletely or too late!\n"; + }; + $divertfn->($divert); + die; + } + + $repo = "$repos/$pkg.git"; + + print DEBUG "DISPATCH DISTRO $distro PKG $pkg\n"; +} + +sub hasrepo () { + if (stat $repo) { + -d _ or die; + return 1; + } else { + $!==ENOENT or die $!; + return 0; + } +} + +sub serve_up ($) { + my ($repo) = @_; + exec qw(git upload-pack --strict --timeout=1000), $repo; + die "exec git: $!"; +} + +sub dispatch () { + local ($_) = $ENV{'SSH_ORIGINAL_COMMAND'} // ''; + + if (m#^: dgit ($lre) git-check ($lre) ;#) { + selectpackage $1,$2, sub { prl "divert @_"; finish; }; + prl hasrepo; + finish; + } elsif ( + m#^${qre}git-([-a-z]+) ${qre}/dgit/($lre)/repos/($lre)\.git${qre}$# + ) { + my $cmd=$1; + selectpackage $2,$3; + if ($cmd eq 'receive-pack') { + $ENV{'PERLLIB'} //= ''; + $ENV{'PERLLIB'} =~ s#^(?=.)#:#; + $ENV{'PERLLIB'} =~ s#^# $ENV{DGIT_TEST_INTREE} // $dgitlive #e; + my $s = "$dgitlive/infra/dgit-repos-server"; + $s = "dgit-repos-server" if !stat_exists $s; + exec $s, $distro, $d, $authrune, qw(--ssh); + die "exec $s: $!"; + } elsif ($cmd eq 'upload-pack') { + $repo='$repos/_empty' unless hasrepo; + serve_up $repo; + } else { + die "unsupported git operation $cmd ($_)"; + } + } elsif ( + m#^${qre}git-upload-pack ${qre}/dgit/($lre)/(?:repos/)?_dgit-repos-server\.git${qre}$# + ) { + my $distro= $1; + # if running installed packages, source code should come + # some other way + serve_up("$dispatchdir/distro=$1/dgit-live/.git"); + } elsif (m#^${qre}git-upload-pack\s#) { + die "unknown repo to serve ($_). use dgit, or for server source ". + "git clone here:/dgit/DISTRO/repos/_dgit-repos-server.git"; + } else { + die "unsupported operation ($_)"; + } +} + +dispatch; |