scripts/git-cache-proxy

   1 #!/usr/bin/perl -w
   2 #
   3 # git caching proxy
   4 #
   5 # usage: run it on some port, and then clone or fetch
   6 #  "git://<realhost>:<realport>/<real-git-url>[ <options>]"
   7 # where <real-git-url> is http://<host>/... or git://<host>/...
   8 # and <options> is zero or more (whitespace-separated) of
   9 #    [<some-option>]      will be ignored if not recognised
  10 #    {<some-option>}      error if not recognised
  11 # options currently known:
  12 #    fetch=must           fail if the fetch/clone from upstream fails
  13 #    fetch=no             just use what is in the cache
  14 #    fetch=try            use what is in the cache if the fetch/clone fails
  15 #    timeout=<seconds>    length of time to allow for fetch/clone
  16
  17 use strict;
  18 use warnings;
  19
  20 use POSIX;
  21 use Socket;
  22 use Sys::Syslog;
  23 use Fcntl qw(:flock SEEK_SET);
  24
  25 our $us = 'git-cache-proxy';
  26 our $log; # filehandle (ref), or "1" meaning syslog
  27
  28 BEGIN {
  29     open STDERR, ">/dev/null" or exit 255;
  30     open TEMPERR, "+>", undef or exit 255;
  31     open STDERR, ">&TEMPERR" or exit 255;
  32
  33     sub ntoa {
  34         my $sockaddr = shift;
  35         return ('(local)') unless defined $sockaddr;
  36         my ($port,$addr) = sockaddr_in $sockaddr;
  37         $addr = inet_ntoa $addr;
  38         return ("[$addr]:$port",$addr,$port);
  39     }
  40
  41     our ($client,$client_addr,$client_port) = ntoa getpeername STDIN;
  42     our ($server,$server_addr,$server_port) = ntoa getsockname STDIN;
  43
  44     sub ensurelog () {
  45         return if $log;
  46         openlog $us, qw(pid), 'daemon';
  47         $log = 1;
  48     }
  49
  50     sub logm ($$) {
  51         my ($pri, $msg) = @_;
  52         ensurelog();
  53         my $mainmsg = sprintf "%s-%s: %s", $server, $client, $msg;
  54         if (ref $log) {
  55             my $wholemsg = sprintf("%s [%d] %s: %s\n",
  56                                    strftime("%Y-%m-%d %H:%M:%S Z", gmtime),
  57                                    $$,
  58                                    $pri,
  59                                    $mainmsg);
  60             print $log $wholemsg;
  61         } else {
  62             syslog $pri, $mainmsg;
  63         }
  64     }
  65
  66     END {
  67         if ($?) { logm 'crit', "crashing ($?)"; }
  68         seek TEMPERR, 0, SEEK_SET;
  69         while (<TEMPERR>) {
  70             chomp;
  71             logm 'crit', $_;
  72         }
  73         exit $?;
  74     }
  75 }
  76
  77 our $fetchtimeout = 1800;
  78 our $maxfetchtimeout = 3600;
  79
  80 sub fail ($) {
  81     my ($msg) = @_;
  82     logm 'err', $msg;
  83     exit 0;
  84 }
  85
  86 sub gitfail ($) {
  87     my ($msg) = @_;
  88     close LOCK;
  89     alarm 60;
  90     logm 'notice', $msg;
  91     my $gitmsg = "ERR $us: $msg";
  92     $gitmsg = substr($gitmsg,0,65535); # just in case
  93     printf "%04x%s", length($gitmsg)+4, $gitmsg;
  94     flush STDOUT;
  95     exit 0;
  96 }
  97
  98 our $cachedir = '/var/cache/git-cache-proxy';
  99
 100 for (;;) {
 101     last unless @ARGV;
 102     last unless $ARGV[0] =~ m/^-/;
 103     $_ = shift @ARGV;
 104     for (;;) {
 105         last unless m/^-./;
 106         if (s/^-L(.*)$//) {
 107             my $logfile = $_;
 108             open STDERR, ">>", $logfile or fail "open $logfile: $!";
 109             $log = \*STDERR;
 110         } elsif (s/^-d(.*)$//) {
 111             $cachedir = $1;
 112         } elsif (s/^--(maxfetchtimeout|fetchtimeout)=(\d+)$//) {
 113             ${ $::{$1} } = $2;
 114         } else {
 115             fail "bad usage: unknown option `$_'";
 116         }
 117     }
 118 }
 119
 120 !@ARGV or fail "bad usage: no non-option arguments permitted";
 121
 122 chdir $cachedir or fail "chdir $cachedir: $!";
 123
 124 our ($service,$specpath,$spechost);
 125
 126 $SIG{ALRM} = sub { fail "timeout" };
 127 alarm 30;
 128
 129 sub xread {
 130     my $length = shift;
 131     my $buffer = "";
 132     while ($length > length $buffer) {
 133         my $ret = sysread STDIN, $buffer, $length, length $buffer;
 134         fail "Expected $length bytes, got ".length $buffer
 135                             if defined $ret and $ret == 0;
 136         fail "read: $!" if not defined $ret and $! != EINTR and $! != EAGAIN;
 137     }
 138     return $buffer;
 139 }
 140 my $hex_len = xread 4;
 141 fail "Bad hex in packet length" unless $hex_len =~ m|^[0-9a-fA-F]{4}$|;
 142 my $line = xread -4 + hex $hex_len;
 143 unless (($service,$specpath,$spechost) = $line =~
 144         m|^(git-[a-z-]+) /*([!-~ ]+)\0host=([!-~]+)\0$|) {
 145     $line =~ s|[^ -~]+| |g;
 146     gitfail "unknown/unsupported instruction `$line'"
 147 }
 148
 149 alarm 0;
 150
 151 $service eq 'git-upload-pack'
 152     or gitfail "unknown/unsupported service `$service'";
 153
 154 my $fetch = 2; # 0:don't; 1:try; 2:force
 155 my $url = $specpath;
 156
 157 while ($url =~ s#\s+(\[)([^][{}]+)\]$## ||
 158        $url =~ s#\s+(\{)([^][{}]+)\}$##) {
 159     $_ = $2;
 160     my $must = $1 eq '{';
 161     if (m/^fetch=try$/) {
 162         $fetch = 1;
 163     } elsif (m/^fetch=no$/) {
 164         $fetch = 0;
 165     } elsif (m/^fetch=must$/) {
 166         $fetch = 2; # the default
 167     } elsif (m/^timeout=(\d+)$/) {
 168         $fetchtimeout = $1 <= $maxfetchtimeout ? $1 : $maxfetchtimeout;
 169     } elsif ($must) {
 170         gitfail "unknown/unsupported option `$_'";
 171     }
 172 }
 173
 174 $url =~ m{^(?:https?|git)://[-.0-9a-z]+/}
 175     or gitfail "unknown/unsupported url scheme or format `$url'";
 176
 177 our $subdir = $url;
 178 $subdir =~ s|\\|\\\\|g;
 179 $subdir =~ s|,|\\,|g;
 180 $subdir =~ s|/|,|g;
 181
 182 logm 'info', "$specpath locking";
 183
 184 my $tmpd= "$subdir\\.tmp";
 185 my $gitd= "$subdir\\.git";
 186 my $lock = "$subdir\\.lock";
 187
 188 for (;;) {
 189     open LOCK, "+>", $lock or fail "open/create $lock: $!";
 190     flock LOCK, LOCK_EX or fail "lock exclusive $lock: $!";
 191
 192     my $exists = stat $gitd;
 193     $exists or $!==ENOENT or fail "stat $gitd: $!";
 194
 195     our $fetchfail = '';
 196
 197     if ($fetch) {
 198
 199         our @cmd;
 200
 201         if (!$exists) {
 202             system qw(rm -rf --), $tmpd;
 203             @cmd = (qw(git clone -q --mirror), $url, $tmpd);
 204             logm 'info', "$specpath cloning @cmd";
 205         } else {
 206             @cmd = (qw(git remote update --prune));
 207             logm 'info', "$specpath fetching @cmd";
 208         }
 209         my $cmd = "@cmd[0..1]";
 210
 211         my $child = open FETCHERR, "-|";
 212         defined $child or fail "fork: $!";
 213         if (!$child) {
 214             if ($exists) {
 215                 chdir $gitd or fail "chdir $gitd: $!";
 216             }
 217             setpgrp or fail "setpgrp: $!";
 218             open STDERR, ">&STDOUT" or fail "redirect stderr: $!";
 219             exec @cmd or fail "exec $cmd[0]: $!";
 220         }
 221
 222         my $fetcherr = '';
 223         my $timedout = 0;
 224         {
 225             local $SIG{ALRM} = sub {
 226                 logm 'info', "$specpath fetch/clone timeout";
 227                 $timedout=1; kill 9, -$child;
 228             };
 229 logm 'info', "timeout=$fetchtimeout";
 230             alarm($fetchtimeout);
 231             $!=0; { local $/=undef; $fetcherr = <FETCHERR>; }
 232             !FETCHERR->error or fail "read pipe from fetch/clone: $!";
 233             alarm(10);
 234         }
 235
 236         kill -9, $child or fail "kill fetch/clone: $!";
 237         $!=0; $?=0; if (!close FETCHERR) {
 238             fail "reap fetch/clone: $!" if $!;
 239             my $fetchfail =
 240                 !($? & 255) ? "$cmd died with error exit code ".($? >> 8) :
 241                 $? != 9 ? "$cmd died due to fatal signa, status $?" :
 242                 $timedout ? "$cmd timed out (${fetchtimeout}s)" :
 243                 "$cmd died due to unexpected SIGKILL";
 244             if (length $fetcherr) {
 245                 $fetchfail .= "\n$fetcherr";
 246                 $fetchfail =~ s/\n$//;
 247                 $fetchfail =~ s{\n}{ // }g;
 248             }
 249             if ($fetch >= 2) {
 250                 gitfail $fetchfail;
 251             } else {
 252                 logm 'info', "$specpath fetch/clone failed: $fetchfail";
 253             }
 254         }
 255
 256         if (!$exists) {
 257             rename $tmpd, $gitd or fail "rename fresh $tmpd to $gitd: $!";
 258             $exists = 1;
 259         }
 260     } else {
 261         $fetchfail = 'not attempted';
 262     }
 263
 264     if (!$exists) {
 265         gitfail "no cached data, and not cloned: $fetchfail";
 266     }
 267
 268     logm 'info', "$specpath sharing";
 269     flock LOCK, LOCK_UN or fail "unlock $lock: $!";
 270     flock LOCK, LOCK_SH or fail "lock shared $lock: $!";
 271     # actually, just relocking as shared would have the same semantics
 272     # but it's best to be explicit
 273
 274     if (chdir $gitd) {
 275         last;
 276     }
 277     $!==ENOENT or fail "chdir $gitd: $!";
 278
 279     # Well, err, someone must have taken the lock in between
 280     # and garbage collected it.  How annoying.
 281 }
 282
 283 logm 'info', "$specpath servicing";
 284 exec qw(git-upload-pack --strict --timeout=1000 .)
 285     or fail "exec git-upload-pack: $!";