chiark / gitweb /
git-cache-proxy: Do not spuriously timeout on too many simultaneous invocations
[chiark-utils.git] / scripts / git-cache-proxy
1 #!/usr/bin/perl -w
2 #
3 # git caching proxy
4
5 # Suitable only for exposing to semi-trusted clients: clients are not
6 # supposed to be able to take over the server.  However, clients can
7 # probably deny service to each other because the current
8 # implementation is not very good at handling various out-of-course
9 # situations (notably, clients which are too slow).
10
11 # usage: run it on some port, and then clone or fetch
12 #  "git://<realhost>:<realport>/<real-git-url>[ <options>]"
13 # where <real-git-url> is http://<host>/... or git://<host>/...
14 # and <options> is zero or more (whitespace-separated) of
15 #    [<some-option>]      will be ignored if not recognised
16 #    {<some-option>}      error if not recognised
17 # options currently known:
18 #    fetch=must           fail if the fetch/clone from upstream fails
19 #    fetch=no             just use what is in the cache
20 #    fetch=try            use what is in the cache if the fetch/clone fails
21 #    timeout=<seconds>    length of time to allow for fetch/clone
22
23 # example inetd.conf line:
24 #  9419 stream tcp nowait git-cache /usr/bin/git-cache-proxy git-cache-proxy
25 # you'll need to 
26 #  adduser git-cache
27 #  mkdir /var/cache/git-cache-proxy
28 #  chown git-cache /var/cache/git-cache-proxy
29
30 # git-cache-proxy
31 # Copyright 2010 Tony Finch
32 # Copyright 2013,2014 Ian Jackson
33
34 # git-cache-proxy is free software; you can redistribute it and/or
35 # modify them under the terms of the GNU General Public License as
36 # published by the Free Software Foundation; either version 3, or (at
37 # your option) any later version.
38 #
39 # git-cache-proxy is distributed in the hope that it will be useful,
40 # but WITHOUT ANY WARRANTY; without even the implied warranty of
41 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
42 # General Public License for more details.
43
44 # You should have received a copy of the GNU General Public License along
45 # with this program; if not, consult the Free Software Foundation's
46 # website at www.fsf.org, or the GNU Project website at www.gnu.org.
47
48 # (Some code taken from userv-utils's git-daemon.in and git-service.in
49 # which were written by Tony Finch <dot@dotat.at> and subsequently
50 # heavily modified by Ian Jackson <ijackson@chiark.greenend.org.uk>
51 # and were released under CC0 1.0.  The whole program is now GPLv3+.)
52
53 use strict;
54 use warnings;
55
56 use POSIX;
57 use Socket;
58 use Sys::Syslog;
59 use Fcntl qw(:flock SEEK_SET);
60 use File::Path qw(remove_tree);
61
62 our $us = 'git-cache-proxy';
63
64 our $debug = 0;
65 our $housekeepingeverydays = 1;
66 our $treeexpiredays = 21;
67 our $fetchtimeout = 1800;
68 our $maxfetchtimeout = 3600;
69 our $cachedir = '/var/cache/git-cache-proxy';
70 our $housekeepingonly = 0;
71
72 #---------- error handling and logging ----------
73
74 # This is a bit fiddly, because we want to catch errors sent to stderr
75 # and dump them to syslog if we can, but only if we are running as an
76 # inetd service.
77
78 our $log; # filehandle (ref), or "1" meaning syslog
79
80 sub ntoa {
81     my $sockaddr = shift;
82     return ('(local)') unless defined $sockaddr;
83     my ($port,$addr) = sockaddr_in $sockaddr;
84     $addr = inet_ntoa $addr;
85     return ("[$addr]:$port",$addr,$port);
86 }
87
88 our ($client) = ntoa getpeername STDIN;
89 our ($server) = ntoa getsockname STDIN;
90
91 sub ensurelog () {
92     return if $log;
93     openlog $us, qw(pid), 'daemon';
94     $log = 1;
95 }
96
97 sub logm ($$) {
98     my ($pri, $msg) = @_;
99     return if $pri eq 'debug' && !$debug;
100     if ($client eq '(local)') {
101         print STDERR "$us: $pri: $msg\n" or die $!;
102         return;
103     }
104     ensurelog();
105     my $mainmsg = sprintf "%s-%s: %s", $server, $client, $msg;
106     if (ref $log) {
107         my $wholemsg = sprintf("%s [%d] %s: %s\n",
108                                strftime("%Y-%m-%d %H:%M:%S Z", gmtime),
109                                $$,
110                                $pri eq 'err' ? 'error' : $pri,
111                                $mainmsg);
112         print $log $wholemsg;
113     } else {
114         syslog $pri, "%s", "$pri $mainmsg";
115     }
116 }
117
118 if ($client ne '(local)') {
119     open STDERR, ">/dev/null" or exit 255;
120     open TEMPERR, "+>", undef or exit 255;
121     open STDERR, ">&TEMPERR" or exit 255;
122 }
123
124 END {
125     if ($client ne '(local)') {
126         if ($?) { logm 'crit', "crashing ($?)"; }
127         seek TEMPERR, 0, SEEK_SET;
128         while (<TEMPERR>) {
129             chomp;
130             logm 'crit', $_;
131         }
132     }
133     exit $?;
134 }
135
136 sub fail ($) {
137     my ($msg) = @_;
138     logm 'err', $msg;
139     exit 0;
140 }
141
142 sub gitfail ($) {
143     my ($msg) = @_;
144     close LOCK;
145     alarm 60;
146     logm 'notice', $msg;
147     my $gitmsg = "ERR $us: $msg";
148     $gitmsg = substr($gitmsg,0,65535); # just in case
149     printf "%04x%s", length($gitmsg)+4, $gitmsg;
150     flush STDOUT;
151     exit 0;
152 }
153
154 #---------- argument parsing ----------
155
156 for (;;) {
157     last unless @ARGV;
158     last unless $ARGV[0] =~ m/^-/;
159     $_ = shift @ARGV;
160     for (;;) {
161         last unless m/^-./;
162         if (s/^-H/-/) {
163             $housekeepingonly++;
164         } elsif (s/^-D/-/) {
165             $debug++;
166         } elsif (s/^-L(.*)$//) {
167             my $logfile = $_;
168             open STDERR, ">>", $logfile or fail "open $logfile: $!";
169             $log = \*STDERR;
170         } elsif (s/^-d(.*)$//) {
171             $cachedir = $1;
172         } elsif (s/^--( max-fetch-timeout
173                       | fetch-timeout
174                       | tree-expire-days
175                       | housekeeping-interval-days
176                       )=(\d+)$//x) {
177             my $vn = $1;
178             $vn =~ y/-//d;
179             die $vn unless defined ${ $::{$vn} };
180             ${ $::{$vn} } = $2;
181         } else {
182             fail "bad usage: unknown option `$_'";
183         }
184     }
185 }
186
187 !@ARGV or fail "bad usage: no non-option arguments permitted";
188
189 #---------- utility functions ----------
190
191 sub lockfile ($$$) {
192     my ($fh, $fn, $flockmode) = @_;
193     my $what = $fn.(($flockmode & ~LOCK_NB) == LOCK_SH ? " (shared)" : "");
194     for (;;) {
195         close $fh;
196         open $fh, '+>', $fn or fail "open/create $fn for lock: $!";
197         logm 'debug', "lock $what: acquiring";
198         if (!flock $fh, $flockmode) {
199             if ($flockmode & LOCK_NB && $! == EWOULDBLOCK) {
200                 return 0; # ok then
201             }
202             fail "lock $what: $!";
203         }
204         stat $fh or fail "stat opened $fn: $!";
205         my $fh_ino = ((stat _)[1]);
206         if (!stat $fn) {
207             $! == ENOENT or fail "stat $fn: $!";
208             next;
209         }
210         my $fn_ino = ((stat _)[1]);
211         if ($fn_ino == $fh_ino) {
212             logm 'debug', "lock $what: acquired";
213             return 1;
214         }
215         logm 'debug', "lock $what: deleted, need to loop again";
216         # oh dear
217     }
218 }
219
220 sub xread {
221     my $length = shift;
222     my $buffer = "";
223     while ($length > length $buffer) {
224         my $ret = sysread STDIN, $buffer, $length, length $buffer;
225         fail "expected $length bytes, got ".length $buffer
226                             if defined $ret and $ret == 0;
227         fail "read: $!" if not defined $ret and $! != EINTR and $! != EAGAIN;
228     }
229     return $buffer;
230 }
231
232 #---------- main program ----------
233
234 chdir $cachedir or fail "chdir $cachedir: $!";
235
236 our ($service,$specpath,$spechost,$subdir);
237 our ($tmpd,$gitd,$lock);
238 our ($fetch,$url);
239
240 sub servinfo ($) {
241     my ($msg) = @_;
242     logm 'info', "service `$specpath': $msg";
243 }
244
245 sub readcommand () {
246     $SIG{ALRM} = sub { fail "timeout" };
247     alarm 30;
248
249     my $hex_len = xread 4;
250     fail "Bad hex in packet length" unless $hex_len =~ m|^[0-9a-fA-F]{4}$|;
251     my $line = xread -4 + hex $hex_len;
252     unless (($service,$specpath,$spechost) = $line =~
253             m|^(git-[a-z-]+) /*([!-~ ]+)\0host=([!-~]+)\0$|) {
254         $line =~ s|[^ -~]+| |g;
255         gitfail "unknown/unsupported instruction `$line'"
256     }
257
258     alarm 0;
259
260     $service eq 'git-upload-pack'
261         or gitfail "unknown/unsupported service `$service'";
262
263     $fetch = 2; # 0:don't; 1:try; 2:force
264     $url = $specpath;
265
266     while ($url =~ s#\s+(\[)([^][{}]+)\]$## ||
267            $url =~ s#\s+(\{)([^][{}]+)\}$##) {
268         $_ = $2;
269         my $must = $1 eq '{';
270         if (m/^fetch=try$/) {
271             $fetch = 1;
272         } elsif (m/^fetch=no$/) {
273             $fetch = 0;
274         } elsif (m/^fetch=must$/) {
275             $fetch = 2; # the default
276         } elsif (m/^timeout=(\d+)$/ && $1 >= 1) {
277             $fetchtimeout = $1 <= $maxfetchtimeout ? $1 : $maxfetchtimeout;
278         } elsif ($must) {
279             gitfail "unknown/unsupported option `$_'";
280         }
281     }
282
283     $url =~ m{^(?:https?|git)://[-.0-9a-z]+/}
284         or gitfail "unknown/unsupported url scheme or format `$url'";
285
286     $subdir = $url;
287     $subdir =~ s|\\|\\\\|g;
288     $subdir =~ s|,|\\,|g;
289     $subdir =~ s|/|,|g;
290
291     $tmpd= "$subdir\\.tmp";
292     $gitd= "$subdir\\.git";
293     $lock = "$subdir\\.lock";
294
295     servinfo "locking";
296 }
297
298 sub clonefetch () {
299     lockfile \*LOCK, $lock, LOCK_EX;
300
301     my $exists = lstat $gitd;
302     $exists or $!==ENOENT or fail "lstat $gitd: $!";
303
304     our $fetchfail = '';
305
306     if ($fetch) {
307
308         our @cmd;
309
310         if (!$exists) {
311             system qw(rm -rf --), $tmpd;
312             @cmd = (qw(git clone -q --mirror), $url, $tmpd);
313             servinfo "cloning";
314         } else {
315             @cmd = (qw(git remote update --prune));
316             servinfo "fetching";
317         }
318         my $cmd = "@cmd[0..1]";
319
320         my $child = open FETCHERR, "-|";
321         defined $child or fail "fork: $!";
322         if (!$child) {
323             if ($exists) {
324                 chdir $gitd or fail "chdir $gitd: $!";
325             }
326             setpgrp or fail "setpgrp: $!";
327             open STDERR, ">&STDOUT" or fail "redirect stderr: $!";
328             exec @cmd or fail "exec $cmd[0]: $!";
329         }
330
331         my $fetcherr = '';
332         my $timedout = 0;
333         {
334             local $SIG{ALRM} = sub {
335                 servinfo "fetch/clone timeout";
336                 $timedout=1; kill 9, -$child;
337             };
338             alarm($fetchtimeout);
339             $!=0; { local $/=undef; $fetcherr = <FETCHERR>; }
340             !FETCHERR->error or fail "read pipe from fetch/clone: $!";
341             alarm(10);
342         }
343
344         kill -9, $child or fail "kill fetch/clone: $!";
345         $!=0; $?=0; if (!close FETCHERR) {
346             fail "reap fetch/clone: $!" if $!;
347             my $fetchfail =
348                 !($? & 255) ? "$cmd died with error exit code ".($? >> 8) :
349                 $? != 9 ? "$cmd died due to fatal signa, status $?" :
350                 $timedout ? "$cmd timed out (${fetchtimeout}s)" :
351                 "$cmd died due to unexpected SIGKILL";
352             if (length $fetcherr) {
353                 $fetchfail .= "\n$fetcherr";
354                 $fetchfail =~ s/\n$//;
355                 $fetchfail =~ s{\n}{ // }g;
356             }
357             if ($fetch >= 2) {
358                 gitfail $fetchfail;
359             } else {
360                 servinfo "fetch/clone failed: $fetchfail";
361             }
362         }
363         alarm 0;
364
365         if (!$exists) {
366             rename $tmpd, $gitd or fail "rename fresh $tmpd to $gitd: $!";
367             $exists = 1;
368         }
369     } else {
370         $fetchfail = 'not attempted';
371     }
372
373     if (!$exists) {
374         gitfail "no cached data, and not cloned: $fetchfail";
375     }
376
377     servinfo "sharing";
378     lockfile \*LOCK, $lock, LOCK_SH; # NB releases and relocks
379
380     if (stat $gitd) {
381         return 1;
382     }
383     $!==ENOENT or fail "stat $gitd: $!";
384
385     # Well, err, someone must have taken the lock in between
386     # and garbage collected it.  How annoying.
387     return 0;
388 }
389
390 sub hkfail ($) { my ($msg) = @_; fail "housekeeping: $msg"; }
391
392 sub housekeeping () {
393     logm 'info', "housekeeping started";
394     foreach $lock (<[a-z]*\\.lock>) {
395         my $subdir = $lock;  $subdir =~ s/\\.lock$//;
396         if (!lstat $lock) {
397             $! == ENOENT or hkfail "$lock: lstat: $!";
398             next;
399         }
400         if (-M _ <= $treeexpiredays) {
401             logm 'debug', "housekeeping: subdirs $subdir: touched recently";
402             next;
403         }
404         if (!lockfile \*LOCK, $lock, LOCK_EX|LOCK_NB) {
405             logm 'info', "housekeeping: subdirs $subdir: lock busy, skipping";
406             next;
407         }
408         logm 'info', "housekeeping: subdirs $subdir: cleaning";
409         eval {
410             foreach my $suffix (qw(tmp git)) {
411                 my $dir = "${subdir}\\.$suffix";
412                 my $tdir = "${subdir}\\.tmp";
413                 if ($dir ne $tdir) {
414                     if (!rename $dir,$tdir) {
415                         next if $! == ENOENT;
416                         die "$dir: cannot rename to $tdir: $!\n";
417                     }
418                 }
419                 system qw(rm -rf --), $tdir;
420                 if (stat $tdir) {
421                     die "$dir: problem deleting file(s), rm exited $?\n";
422                 } elsif ($! != ENOENT) {
423                     die "$tdir: cannot stat after deletion: $!\n";
424                 }
425             }
426         };
427         if (length $@) {
428             chomp $@;
429             logm 'warning', "housekeeping: $subdir: cleanup prevented: $@";
430         } else {
431             unlink $lock or hkfail "remove $lock: $!";
432         }
433     }
434     open HS, ">", "Housekeeping.stamp" or hkfail "touch Housekeeping.stamp: $!";
435     close HS or hkfail "close Housekeeping.stamp: $!";
436     logm 'info', "housekeeping finished";
437 }
438
439 sub housekeepingcheck ($$) {
440     my ($dofork, $force) = @_;
441     if (!$force) {
442         if (!lockfile \*HLOCK, "Housekeeping.lock", LOCK_EX|LOCK_NB) {
443             logm 'debug', "housekeeping lock taken, not running";
444             close HLOCK;
445             return 0;
446         }
447     }
448     if ($force) {
449         logm 'info', "housekeeping forced";
450     } elsif (!lstat "Housekeeping.stamp") {
451         $! == ENOENT or fail "lstat Housekeeping.stamp: $!";
452         logm 'info', "housekeeping not done yet, will run";
453     } elsif (-M _ <= $housekeepingeverydays) {
454         logm 'debug', "housekeeping done recently";
455         close HLOCK;
456         return 0;
457     }
458     if ($dofork) {
459         my $child = fork;
460         defined $child or fail "fork: $!";
461         if (!$child) {
462             open STDERR, "|logger -p daemon.warning -t '$us(housekeeping)'"
463                 or die "fork: logger $!";
464             housekeeping();
465             exit 0;
466         }
467     } else {
468         housekeeping();
469     }
470     close HLOCK;
471     return 1;
472 }
473
474 sub runcommand () {
475     servinfo "serving";
476
477     chdir $gitd or fail "chdir $gitd: $!";
478
479     exec qw(git-upload-pack --strict --timeout=1000 .)
480         or fail "exec git-upload-pack: $!";
481 }
482
483 sub daemonservice () {
484     readcommand();
485     while (!clonefetch()) { }
486     housekeepingcheck(1,0);
487     runcommand();
488 }
489
490 if ($housekeepingonly) {
491     housekeepingcheck(0, $housekeepingonly>=2);
492 } else {
493     daemonservice();
494 }