chiark / gitweb /
dgit-repos-server: Defend against bad commits (from eg #849041).
[dgit.git] / infra / dgit-ssh-dispatch
1 #!/usr/bin/perl -w
2 # wrapper to dispatch git ssh service requests
3 #
4 # Copyright (C) 2015-2016  Ian Jackson
5 #
6 #    This program is free software; you can redistribute it and/or modify
7 #    it under the terms of the GNU General Public License as published by
8 #    the Free Software Foundation; either version 3 of the License, or
9 #    (at your option) any later version.
10 #
11 #    This program is distributed in the hope that it will be useful,
12 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
13 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 #    GNU General Public License for more details.
15 #
16 #    You should have received a copy of the GNU General Public License
17 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
18
19 use strict;
20
21 use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
22 use Debian::Dgit;
23 setup_sigwarn();
24
25 use POSIX;
26
27 open DEBUG, '>/dev/null' or die $!;
28 if (@ARGV && $ARGV[0] eq '-D') {
29     shift @ARGV;
30     open DEBUG, '>&STDERR' or die $!;
31 }
32
33 die unless @ARGV>=1 && @ARGV<=2 && $ARGV[0] !~ m/^-/;
34 our ($dispatchdir,$authrune) = @ARGV;
35
36 $authrune //= join ':',
37     '@/keyrings/debian-keyring.gpg,a',
38     '@/keyrings/debian-maintainers.gpg,m@/dm.txt';
39
40 our $lre = $package_re;
41 our $qre = '["'."']?";
42
43 # $dispatchdir/distro=DISTRO should contain
44 #    dgit-live          a clone of dgit (only if not using installed vsns)
45 #    diverts
46 #    repos/             }  by virtue of
47 #    suites             }    dgit-repos-server's defaults relating to
48 #    policy-hook        }    dispatch-dir
49 # plus files required by the authrune (by default, keyrings/ and dm.txt)
50 #
51 # diverts should be list of
52 #  <pat> [<divert-to>]
53 # where <pat> is a package name pattern which may contain * or literals.
54 # <divert-to> is for `git config dgit-distro.DISTRO.diverts.<divert-to>'
55
56 our ($distro,$pkg, $d);
57 our ($dgitlive,$repos,$suites,$diverts,$policyhook,$repo);
58
59 sub checkdivert ($) {
60     my ($df) = @_;
61     if (!open DIV, '<', $df) {
62         $!==ENOENT or die $!;
63         return undef;
64     } else {
65         while (<DIV>) {
66             s/^\s+//; s/\s+$//;
67             next unless m/\S/;
68             next if m/^\#/;
69             my $divert;
70             if (s/\s+(\S+)$//) { $divert=$1; }
71             s/[^-+._0-9a-zA-Z*]/\\$&/g;
72             s/\*/.*/g;
73             printf DEBUG 'DISPATCH DIVERT ^%s$ %s'."\n",
74                 $_, ($divert // '(undef)');
75             if ($pkg =~ m/^$_$/) { return $divert; }
76         }
77         DIV->error and die $!;
78         close DIV;
79         return undef;
80     }
81 }
82         
83 sub finish () {
84     close STDOUT or die $!;
85     exit 0;
86 }
87
88 sub prl ($) {
89     print @_, "\n" or die $!;
90 }
91         
92 sub selectpackage ($$;$) {
93     my $divertfn;
94     ($distro,$pkg, $divertfn) = @_; # $distro,$pkg must have sane syntax
95
96     $d = "$dispatchdir/distro=$distro";
97
98     if (!stat $d) {
99         die $! unless $!==ENOENT;
100         die "unknown distro ($distro)\n";
101     }
102
103     $dgitlive=    "$d/dgit-live";
104     $repos=       "$d/repos";
105     $suites=      "$d/suites";
106     $policyhook=  "$d/policy-hook";
107
108     $authrune =~ s/\@/$d/g;
109
110     my $divert = checkdivert("$d/diverts");
111     if (defined $divert) {
112         $divertfn //= sub {
113             die "diverted to $divert incompletely or too late!\n";
114         };
115         $divertfn->($divert);
116         die;
117     }
118
119     $repo = "$repos/$pkg.git";
120
121     print DEBUG "DISPATCH DISTRO $distro PKG $pkg\n";
122 }
123
124 sub hasrepo () {
125     if (stat $repo) {
126         -d _ or die;
127         return 1;
128     } else {
129         $!==ENOENT or die $!;
130         return 0;
131     }
132 }
133
134 sub serve_up ($) {
135     my ($repo) = @_;
136     exec qw(git upload-pack --strict --timeout=1000), $repo;
137     die "exec git: $!";
138 }
139
140 sub dispatch () {
141     local ($_) = $ENV{'SSH_ORIGINAL_COMMAND'} // '';
142
143     if (m#^: dgit ($lre) git-check ($lre) ;#) {
144         selectpackage $1,$2, sub { prl "divert @_"; finish; };
145         prl hasrepo;
146         finish;
147     } elsif (
148         m#^${qre}git-([-a-z]+) ${qre}/dgit/($lre)/repos/($lre)\.git${qre}$#
149         ) {
150         my $cmd=$1;
151         selectpackage $2,$3;
152         if ($cmd eq 'receive-pack') {
153             $ENV{'PERLLIB'} //= '';
154             $ENV{'PERLLIB'} =~ s#^(?=.)#:#;
155             $ENV{'PERLLIB'} =~ s#^# $ENV{DGIT_TEST_INTREE} // $dgitlive #e;
156             my $s = "$dgitlive/infra/dgit-repos-server";
157             $s = "dgit-repos-server" if !stat_exists $s;
158             exec $s, $distro, $d, $authrune, qw(--ssh);
159             die "exec $s: $!";
160         } elsif ($cmd eq 'upload-pack') {
161             $repo='$repos/_empty' unless hasrepo;
162             serve_up $repo;
163         } else {
164             die "unsupported git operation $cmd ($_)";
165         }
166     } elsif (
167  m#^${qre}git-upload-pack ${qre}/dgit/($lre)/(?:repos/)?_dgit-repos-server\.git${qre}$#
168         ) {
169         my $distro= $1;
170         # if running installed packages, source code should come
171         # some other way
172         serve_up("$dispatchdir/distro=$1/dgit-live/.git");
173     } elsif (m#^${qre}git-upload-pack\s#) {
174         die "unknown repo to serve ($_).  use dgit, or for server source ".
175             "git clone here:/dgit/DISTRO/repos/_dgit-repos-server.git";
176     } else {
177         die "unsupported operation ($_)";
178     }
179 }
180
181 dispatch;