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