chiark / gitweb /
dgit-repos-policy-debian: WIP bugfixes
[dgit.git] / 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;