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
  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
  36 our ($distro,$pkg, $d);
  37 our ($dgitlive,$repos,$suites,$diverts,$policyhook,$repo);
  38
  39 sub checkdivert ($) {
  40     my ($df) = @_;
  41     if (!open DIV, '<', $df) {
  42         $!==ENOENT or die $!;
  43         return undef;
  44     } else {
  45         while (<DIV>) {
  46             s/^\s+//; s/\s+$//;
  47             next unless m/\S/;
  48             next if m/^\#/;
  49             my $divert;
  50             if (s/\s+(\S+)$//) { $divert=$1; }
  51             s/[^-+._0-9a-zA-Z*]/\\$&/g;
  52             s/\*/.*/g;
  53             printf DEBUG 'DISPATCH DIVERT ^%s$ %s'."\n",
  54                 $_, ($divert // '(undef)');
  55             if ($pkg =~ m/^$_$/) { return $divert; }
  56         }
  57         DIV->error and die $!;
  58         close DIV;
  59         return undef;
  60     }
  61 }
  62
  63 sub finish () {
  64     close STDOUT or die $!;
  65     exit 0;
  66 }
  67
  68 sub prl ($) {
  69     print @_, "\n" or die $!;
  70 }
  71
  72 sub selectpackage ($$;$) {
  73     my $divertfn;
  74     ($distro,$pkg, $divertfn) = @_; # $distro,$pkg must have sane syntax
  75
  76     $d = "$dispatchdir/distro=$distro";
  77
  78     if (!stat $d) {
  79         die $! unless $!==ENOENT;
  80         die "unknown distro ($distro)\n";
  81     }
  82
  83     $dgitlive=    "$d/dgit-live";
  84     $repos=       "$d/repos";
  85     $suites=      "$d/suites";
  86     $policyhook=  "$d/policy-hook";
  87
  88     $authrune =~ s/\@/$d/g;
  89
  90     my $divert = checkdivert("$d/diverts");
  91     if (defined $divert) {
  92         $divertfn //= sub {
  93             die "diverted to $divert incompletely or too late!\n";
  94         };
  95         $divertfn->($divert);
  96         die;
  97     }
  98
  99     $repo = "$repos/$pkg.git";
 100
 101     print DEBUG "DISPATCH DISTRO $distro PKG $pkg\n";
 102 }
 103
 104 sub hasrepo () {
 105     if (stat $repo) {
 106         -d _ or die;
 107         return 1;
 108     } else {
 109         $!==ENOENT or die $!;
 110         return 0;
 111     }
 112 }
 113
 114 sub dispatch () {
 115     local ($_) = $ENV{'SSH_ORIGINAL_COMMAND'};
 116
 117     if (m#^: dgit ($lre) git-check ($lre) ;#) {
 118         selectpackage $1,$2, sub { prl "divert @_"; finish; };
 119         prl hasrepo;
 120         finish;
 121     } elsif (
 122         m#^${qre}git-([-a-z]+) ${qre}/dgit/($lre)/repos/($lre)\.git${qre}$#
 123     ) {
 124         my $cmd=$1;
 125         selectpackage $2,$3;
 126         if ($cmd eq 'receive-pack') {
 127             my $s = "$dgitlive/infra/dgit-repos-server";
 128             exec $s, $distro, $d, $authrune, qw(--ssh);
 129             die "exec $s: $!";
 130         } elsif ($cmd eq 'upload-pack') {
 131             $repo='$repos/_empty' unless hasrepo;
 132             exec qw(git upload-pack --strict --timeout=1000), $repo;
 133             die "exec git: $!";
 134         } else {
 135             die "unsupported git operation $cmd ($_)";
 136         }
 137     } else {
 138         die "unsupported operation ($_)";
 139     }
 140 }
 141
 142 dispatch;