scripts/git-cache-proxy

   1 #!/usr/bin/perl
   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>
   7 # where <real-git-url> is http://<host>/... or git://<host>/...
   8
   9 use strict;
  10 use warnings;
  11
  12 use POSIX;
  13 use Socket;
  14 use Sys::Syslog;
  15
  16 our $us = 'git-cache-proxy';
  17 our $log; # filehandle (ref), or "1" meaning syslog
  18 our $fetchtimeout = 1800;
  19 our $maxfetchtimeout = 3600;
  20
  21 sub ntoa {
  22     my $sockaddr = shift;
  23     return ('(local)') unless defined $sockaddr;
  24     my ($port,$addr) = sockaddr_in $sockaddr;
  25     $addr = inet_ntoa $addr;
  26     return ("[$addr]:$port",$addr,$port);
  27 }
  28
  29 our ($client,$client_addr,$client_port) = ntoa getpeername STDIN;
  30 our ($server,$server_addr,$server_port) = ntoa getsockname STDIN;
  31
  32 sub ensurelog () {
  33     return if $log;
  34     openlog $us, qw(pid), 'daemon';
  35     $log = 1;
  36 }
  37
  38 sub log ($) {
  39     my ($pri, $msg) = @_;
  40     ensurelog();
  41     my $mainmsg = sprintf "%s-%s: %s", $server, $client, $msg;
  42     if (ref $log) {
  43         my $wholemsg = sprintf("%s [%d] %s: %s\n",
  44                                strftime("%Y-%m-%d %H:%M:%S Z", gmtime),
  45                                $$,
  46                                $pri,
  47                                $mainmsg);
  48         print $log $wholemsg;
  49     } else {
  50         syslog $pri, $mainmsg;
  51     }
  52 }
  53
  54 sub fail ($) {
  55     my ($msg) = @_;
  56     log 'error', $msg;
  57     exit 1;
  58 }
  59
  60 sub gitfail ($) {
  61     my ($msg) = @_;
  62     log 'warning', $msg;
  63     my $gitmsg = "ERR $us: $msg";
  64     $gitmsg = substr($gitmsg,0,65535); # just in case
  65     printf "%04x%s", length($gitmsg)+4, $gitmsg;
  66     flush STDOUT;
  67     exit 1;
  68 }
  69
  70 our $cachedir = '/var/cache/git-cache-proxy';
  71
  72 for (;;) {
  73     last unless @ARGV;
  74     last unless $ARGV[0] =~ m/^-/;
  75     $_ = shift @ARGV;
  76     for (;;) {
  77         last unless m/^-./;
  78         if (s/^-L(.*)$//) {
  79             my $logfile = $_;
  80             open STDERR, ">>", $logfile or fail "open $logfile: $!";
  81             $log = \*STDERR;
  82         } elsif (s/^-d(.*)$//) {
  83             $cachedir = $1;
  84         } elsif (s/^--(maxfetchtimeout|fetchtimeout)=(\d+)$//) {
  85             ${ $::{$1} } = $2;
  86         } else {
  87             fail "bad usage: unknown option `$_'";
  88         }
  89     }
  90 }
  91
  92 !@ARGV or fail "bad usage: no non-option arguments permitted";
  93
  94 chdir $cachedir or fail "chdir $cachedir: $!";
  95
  96 our ($service,$specpath,$spechost);
  97
  98 $SIG{ALRM} = sub { fail "timeout" };
  99 alarm 30;
 100
 101 sub xread {
 102     my $length = shift;
 103     my $buffer = "";
 104     while ($length > length $buffer) {
 105         my $ret = sysread STDIN, $buffer, $length, length $buffer;
 106         fail "Expected $length bytes, got ".length $buffer
 107                             if defined $ret and $ret == 0;
 108         fail "read: $!" if not defined $ret and $! != EINTR and $! != EAGAIN;
 109     }
 110     return $buffer;
 111 }
 112 my $hex_len = xread 4;
 113 fail "Bad hex in packet length" unless $hex_len =~ m|^[0-9a-fA-F]{4}$|;
 114 my $line = xread -4 + hex $hex_len;
 115 unless (($service,$specpath,$spechost) = $line =~
 116         m|^(git-[a-z-]+) /*([!-~]+)\0host=([!-~]+)\0$|) {
 117     $line =~ s|[^ -~]+| |g;
 118     fail "Could not parse \"$line\""
 119 }
 120
 121 alarm 0;
 122
 123 $service eq 'git-upload-pack'
 124     or gitfail "unknown/unsupported service `$service'";
 125
 126 my $fetch = 2; # 0:don't; 1:try; 2:force
 127 my $url = $specpath;
 128
 129 while ($url =~ s#^(\[)([^][{}])+\]## ||
 130        $url =~ s#^(\{)([^][{}])+\}##) {
 131     $_ = $2;
 132     my $must = $1 eq '{';
 133     if (m/^relaxed$/) {
 134         $fetch = 1;
 135     } elsif (m/^nofetch$/) {
 136         $fetch = 0;
 137     } elsif (m/^timeout=(\d+)$/) {
 138         $fetchtimeout = $1 <= $maxfetchtimeout ? $1 : $maxfetchtimeout;
 139     } elsif ($must) {
 140         gitfail "unknown/unsupported option `$_'";
 141     }
 142 }
 143
 144 $url =~ m{^(?:https?|git)://[-.0-9a-z]+/}
 145     or gitfail "unknown/unsupported url scheme or format `$url'";
 146
 147 our $subdir = $url;
 148 $subdir =~ s|\\|\\\\|g;
 149 $subdir =~ s|,|\\,|g;
 150 $subdir =~ s|/|,|g;
 151
 152 log 'info', "$specpath locking";
 153
 154 my $tmpd= "$subdir\\.tmp";
 155 my $gitd= "$subdir\\.git";
 156 my $lock = "$subdir\\.lock";
 157
 158 open LOCK, "+>", $lock or fail "open/create $lock: $!";
 159 flock LOCK, LOCK_EX or fail "lock $lock: $!";
 160
 161 $exists = stat $gitd;
 162 $exists or $!==ENOENT or FAIL "stat $gitd: $!";
 163
 164 if ($fetch) {
 165
 166     our @cmd;
 167
 168     if (!$exists) {
 169         system qw(rm -rf --), $tmpd;
 170         @cmd = qw(git clone -q --mirror), $url;
 171         log 'info', "$specpath cloning";
 172     } else {
 173         @cmd = qw(git remote update --prune), $url;
 174         log 'info', "$specpath fetching";
 175     }
 176
 177     my $child = open P, "-|";
 178     defined $child or fail "fork: $!";
 179     if (!$child) {
 180         if ($exists) {
 181             chdir $gitd or fail "chdir $gitd: $!";
 182         }
 183         setpgrp or fail "setpgrp: $!";
 184         open STDERR, ">&STDOUT" or fail "redirect stderr: $!";
 185         exec @cmd or fail "exec $cmd[0]: $!";
 186     }
 187
 188     local $SIG{ALARM} = sub {
 189         kill 9, -$child;
 190
 191         } or log 'crit',
 192     };
 193
 194     alarm($fetchtimeout);
 195
 196
 197 printf STDERR "%s [$$] %s %s\n",
 198     strftime("%Y-%m-%d %H:%M:%S %Z", localtime), $server, $client;
 199
 200
 201
 202
 203
 204 $service eq '
 205
 206 @@READ_URLMAP@@
 207
 208 fail "No global mapping for $uri" unless defined $serve_user;
 209
 210 my ($hn,$ha,$at,$naddrs,@addrs) = gethostbyname $spechost;
 211 fail "hostname/address mismatch ($spechost $server_addr)" unless grep {
 212     $server_addr eq inet_ntoa $_
 213     } @addrs;
 214
 215 our @opts;
 216
 217 push @opts, "-D$_=${$::{$_}}"
 218     for qw(service specpath spechost
 219            client client_addr client_port
 220            server server_addr server_port);
 221
 222 fail "no user $serve_user" unless getpwnam($serve_user);
 223
 224 syslog 'notice', "$client $service $uri $serve_user";
 225
 226 my @cmd = ('userv', '-t300', @opts, $serve_user, $service);
 227 no warnings; # suppress errors to stderr
 228 exec @cmd or fail "exec userv: $!";
 229
 230 # end