view release on metacpan or  search on metacpan

hooks/proxy  view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;

my $who = ($ENV{REMOTE_USER} || die "Auth required\n")."\@$ENV{REMOTE_ADDR}";
my $how = shift =~ /^([\w\-]+)$/ ? $1 : die localtime().": [$who] git-server: Proxy invocation malfunction.\n";
my $base = delete $ENV{GIT_DIR} or die "$0: Unimplemented invocation.\n";
my %proxy = do { my $i=0; map { ("there".($i++?"-$i":"") => $_) } split /\n/, scalar `git config --get-all proxy.url` } or exit 0;
my $working = "$base.workingdir";

$ENV{GIT_SSH_COMMAND} = (`git config core.sshCommand 2>/dev/null` =~ /^(.+)/ ? $1 : "ssh")." -A -o SendEnv=XMODIFIERS";
$ENV{XMODIFIERS} ||= "";
($ENV{DEBUG} and !warn localtime().": [$who] git-server: DEBUG: [$base] Skipping proxy checks during $how\n") or exit 0 if $ENV{XMODIFIERS} =~ /^skip_proxy=(.*)/m and $1;
$ENV{XMODIFIERS} =~ s/^skip_proxy=.*//gm; # Clear any (false) setting
$ENV{XMODIFIERS} = "skip_proxy=1\n$ENV{XMODIFIERS}";
while ($ENV{XMODIFIERS} =~ s/\n\n/\n/g) {}
$ENV{XMODIFIERS} =~ s/\n+$//;
$ENV{USER} ||= [getpwuid $<]->[0];
$ENV{HOME} ||= [getpwuid $<]->[7];
while (my ($remote,$proxy) = each %proxy) {
    # Ensure no cheater local repo urls.
    # XXX: Should HTTP URLs be converted to SSH URLs on the fly to be "helpful" for known URLs, such as github.com?
    next if $proxy =~ m{^(\w+://|[-.@\w]+:)}; # If it has a colon, it's probably a safe enough "remote" git URL
    my $server = $ENV{SERVER_ADDR} or die "Auth required for proxy.url $proxy\n";
    $proxy =~ s{^~(/?)}{$ENV{HOME}$1};
    $proxy =~ s{^\Q$ENV{HOME}\E(/?)}{};
    $proxy ||= "/";
    $proxy = "$ENV{USER}\@$server:$proxy";
    $proxy{$remote} = $proxy;
}
my $WHY_FAILED = {};
sub remote_refs {
    my $remote = shift;
    return "" if $WHY_FAILED->{$remote};
    require File::Temp;
    my $tmp = File::Temp->new;
    warn localtime().": [$who] git-server: DEBUG: [$base] Comparing refs for ".($proxy{$remote} || $base)." ...\n" if $ENV{DEBUG};
    my @list = `git ls-remote $remote 2>$tmp`;
    if (my $why = $?) {
        $WHY_FAILED->{$remote} = "FAILED [$why] VIEWING REMOTE ".($proxy{$remote} || $base)."\n";
        seek($tmp, 0, 0);
        $WHY_FAILED->{$remote} .= join "", map { "! $_" } <$tmp>;
        $WHY_FAILED->{$remote} =~ s/\s*$//;
        $? = $why;
    }
    else {
        $WHY_FAILED->{$remote} = "";
    }
    # Clean up refs list ignoring "HEAD" and ignore everything that isn't a regular branch or tag, such as /pull/ requests.
    @list = sort { my ($a_ref,$b_ref) = "$a$b" =~ /\s(refs.*)\n.*?\s(refs.*)/; $a_ref cmp $b_ref or $a cmp $b } grep { m{\srefs/(?:heads|tags)/(?!HEAD)} } @list;
    return join "", @list;
}

my $refs = {};
if (!-d $working) {
    # If /pre/ couldn't create this directory, then /post/ definitely shouldn't bother trying:
    exit 0 if $how =~ /post/;

    # Initial setup
    warn localtime().": [$who] git-server: Initial proxy setup ...\n";
    system qw(git clone -o here), $base, $working;
    chdir $working or die localtime().": [$who] git-server: Failed local working directory for proxy!\n";
    while (my ($remote,$proxy) = each %proxy) {
        0 == system qw(git remote add), $remote, $proxy or system "rm","-rf",$working or die localtime().": [$who] git-server: Failed to remote add $proxy\n";
        # Make sure known_hosts contains remote server pub keys for SSH style repos
        my $remotehost = "";
        if ($proxy =~ m{^ssh://(?:|[^/:]+\@)\[([a-z0-9\-\.\:]+)\]:(\d+)/}i or
            $proxy =~ m{^ssh://(?:|[^/:]+\@)\[?([a-z0-9\-\.]+)\]?:\[?(\d+)\]?/}i or
            $proxy =~ m{^ssh://(?:|[^/:]+\@)\[?([a-z0-9\-\.\:]+)\]?/}i or
            $proxy =~ m{^(?:|[^/:]+\@)\[([a-z0-9\-\.]+):(\d+)\]:}i or
            $proxy =~ m{^(?:|[^/:]+\@)\[([a-z0-9\-\.\:]+)\]():}i or
            $proxy =~ m{^(?:|[^/:]+\@)([a-z0-9\-\.]+)():}i) {
            $remotehost = $1;
            my $remoteport = $2 || 22;
            warn localtime().": [$who] git-server: DEBUG: Detected remote proxy SSH server [$remotehost] port [$remoteport]\n" if $ENV{DEBUG};
            my $try = `ssh -o BatchMode=yes -o StrictHostKeyChecking=no -T -p $remoteport $remotehost hostname 2>&1`;
        }
        if ($refs->{$remote} = remote_refs $remote and 0 == system "git fetch $remote") {
            warn localtime().": [$who] git-server: Successful access to remote proxy: $proxy\n" if $ENV{DEBUG};