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