infra/dgit-ssh-dispatch: New production infra script

[dgit.git] / infra / dgit-ssh-dispatch

diff --git a/infra/dgit-ssh-dispatch b/infra/dgit-ssh-dispatch
new file mode 100755 (executable)
index 0000000..bd8582a
--- /dev/null
+++ b/infra/dgit-ssh-dispatch
@@ -0,0 +1,138 @@
+#!/usr/bin/perl -w
+
+use strict;
+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 = '[0-9a-z][-+.0-9a-z]*';
+our $qre = '["'."']?";
+
+# $dispatchdir should contain
+#    dgit-live   a clone of dgit
+#    repos/
+#    suites
+#    diverts
+# 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.
+
+our ($distro,$pkg);
+our ($dgitlive,$repos,$suites,$diverts,$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
+
+    my $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";
+
+    $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 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') {
+           my $s = "$dgitlive/dgit-repos-server";
+           exec $s, $suites, $authrune, $repos, qw(--ssh);
+           die "exec $s: $!";
+       } elsif ($cmd eq 'upload-pack') {
+           $repo='$repos/_empty' unless hasrepo;
+           exec qw(git upload-pack --strict --timeout=1000), $repo;
+           die "exec git: $!";
+       } else {
+           die "unsupported git operation $cmd ($_)";
+       }
+    } else {
+       die "unsupported operation ($_)";
+    }
+}
+
+dispatch;