infra/dgit-ssh-dispatch

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