304 lines
12 KiB
Perl
304 lines
12 KiB
Perl
#!/usr/bin/perl
|
||
# HTTP-апплет для проксирования запросов к Subversion-репозиториям
|
||
# с проверкой свойств по регулярному выражению или просто на существование
|
||
# (файлы, для которых проверка не удаётся, представляются как несуществующие)
|
||
|
||
# Для использования создайте файл svn.cgi со следующим содержимым:
|
||
#
|
||
# use URI::Escape;
|
||
# use SVNPropCheck;
|
||
# my $obj = SVNPropCheck->instance("instance name", { Хеш конфигурации });
|
||
# $obj->handler(uri_unescape($ENV{QUERY_STRING}));
|
||
#
|
||
# И обращайтесь к нему в духе /svn.cgi?<svn path>
|
||
|
||
package SVNPropCheck;
|
||
|
||
use strict;
|
||
use POSIX qw(strftime);
|
||
use Encode qw(from_to);
|
||
use File::Path 2.06 qw(make_path);
|
||
use IO::SendFile qw(sendfile);
|
||
use LWP::MediaTypes;
|
||
|
||
use SVN::Core;
|
||
use SVN::Client;
|
||
use SVN::Ra;
|
||
|
||
my $instances = {};
|
||
|
||
# кэш объектов SVN::Ra
|
||
my $RAS = {};
|
||
|
||
# Получение именованного экземпляра SVNPropCheck. Именованного - чтобы в одном
|
||
# Perl-интерпретаторе могло жить несколько SVNPropCheck'ов.
|
||
#
|
||
# use SVNPropCheck;
|
||
# my $obj = SVNPropCheck->instance("instance name", { Хеш параметров });
|
||
#
|
||
# Параметры конфигурации:
|
||
# 1. repos_url - URL к репозиторию Subversion, из которого будут браться файлы.
|
||
# В случае, если параметр не указан или имеет ложное значение, но задан
|
||
# параметр repos_parent, первый компонент всех дочерних URI берётся в качестве
|
||
# имени репозитория и приписывается к repos_parent.
|
||
# Пример: "https://svn.office.custis.ru/3rdparty/"
|
||
# 2. repos_parent - родительский URL, приписывая имя конкретного репозитория к
|
||
# которому, можно получать URL отдельных репозиториев.
|
||
# Пример: "https://svn.office.custis.ru/"
|
||
# 3. repos_username - имя пользователя Subversion (нужен доступ только на чтение)
|
||
# 4. repos_password - пароль пользователя Subversion (нужен доступ только на чтение)
|
||
# 5. check_prop_name - название свойства, значение которого делает файлы доступными
|
||
# Пример: "wiki:visible"
|
||
# 6. check_prop_re - регулярное выражение для проверки значения свойства.
|
||
# В случае, если параметр не указан или имеет значение undef, указанное
|
||
# свойство просто должно быть задано.
|
||
# 7. cache_path - директория локального кэша файлов.
|
||
# 8. enc_from_to - массив из двух названий кодировок. Первая из них - входная
|
||
# кодировка обрабатываемых адресов, вторая - кодировка, в которой имена файлов
|
||
# должны передаваться библиотекам Subversion для доступа. Параметр необязательный,
|
||
# и если он не указан, перекодировка не осуществляется.
|
||
# Пример: [ "cp1251", "utf8" ]
|
||
# 9. access_log - если true, то логгировать все запросы на STDERR
|
||
# 10. mime_types - путь к файлу /etc/mime.types или подобному
|
||
sub instance
|
||
{
|
||
my $class = shift;
|
||
$class = ref($class) || $class;
|
||
my ($instance_name, $params) = @_;
|
||
if ($instances->{$instance_name})
|
||
{
|
||
return $instances->{$instance_name};
|
||
}
|
||
my $ra;
|
||
unless ($params->{cache_path} &&
|
||
$params->{repos_username} && exists $params->{repos_password})
|
||
{
|
||
# ругаемся
|
||
warn __PACKAGE__.": parameters cache_path, repos_username, repos_password are mandatory";
|
||
return undef;
|
||
}
|
||
$params->{cache_path} =~ s!/+$!!so;
|
||
my $auth_providers = [
|
||
SVN::Client::get_ssl_server_trust_prompt_provider(sub {
|
||
$_[0]->accepted_failures(
|
||
$SVN::Auth::SSL::NOTYETVALID |
|
||
$SVN::Auth::SSL::EXPIRED |
|
||
$SVN::Auth::SSL::CNMISMATCH |
|
||
$SVN::Auth::SSL::UNKNOWNCA |
|
||
$SVN::Auth::SSL::OTHER
|
||
);
|
||
}),
|
||
SVN::Client::get_simple_provider(),
|
||
SVN::Client::get_simple_prompt_provider(sub {
|
||
$_[0]->username($params->{repos_username});
|
||
$_[0]->password($params->{repos_password});
|
||
}, 3),
|
||
];
|
||
if ($params->{repos_url})
|
||
{
|
||
# открываем репозиторий
|
||
$ra = SVN::Ra->new(
|
||
url => $params->{repos_url},
|
||
auth => $auth_providers,
|
||
);
|
||
}
|
||
if (!$ra && !$params->{repos_parent})
|
||
{
|
||
# ругаемся
|
||
warn __PACKAGE__.": need one of correct repos_url or repos_parent";
|
||
return undef;
|
||
}
|
||
# создаём объект себя
|
||
my $self = bless {
|
||
params => $params,
|
||
ra => $ra,
|
||
auth_prov => $auth_providers,
|
||
}, $class;
|
||
if (!%$instances)
|
||
{
|
||
# на первый раз инициализируем LWP::MediaTypes
|
||
# он всё равно глобальный, так что смысла
|
||
# всасывать типы из разных файлов нет
|
||
LWP::MediaTypes::read_media_types($params->{mime_types} || '/etc/mime.types');
|
||
}
|
||
$instances->{$instance_name} = $self;
|
||
return $self;
|
||
}
|
||
|
||
# Отправить сообщение об ошибке
|
||
sub print_error
|
||
{
|
||
my ($errmsg, $diemsg) = @_;
|
||
$diemsg ||= '';
|
||
$diemsg =~ s/ at \S+ line \d+.*$//so;
|
||
$errmsg =~ s/\.*$/./so;
|
||
$errmsg .= ":\n$diemsg" if $diemsg;
|
||
print STDERR (strftime("[%Y-%m-%d %H:%M:%S] ", localtime) . __PACKAGE__ . $errmsg . "\n");
|
||
$errmsg =~ s/\n/<br \/>/gso;
|
||
my $p = __PACKAGE__;
|
||
$errmsg = "<html><head><title>$p: Error</title></head><body><h1>Error</h1><p>$errmsg</p><hr /><p>$p/0.5</p></body></html>";
|
||
print $ENV{SERVER_PROTOCOL}." 200 OK\x0d\x0a".
|
||
"Server: ".$ENV{SERVER_SOFTWARE}."\x0d\x0a".
|
||
"Content-Type: text/html; charset=utf-8\x0d\x0a".
|
||
"\x0d\x0a".
|
||
$errmsg;
|
||
}
|
||
|
||
# Обработчик запроса. Выводит на STDOUT HTTP-ответ (то же, что режим CGI non-parsed headers).
|
||
#
|
||
# Вызывать после получения объекта с параметром, равным пути к требуемому SVN файлу
|
||
sub handler
|
||
{
|
||
my $self = shift;
|
||
my ($uri) = @_;
|
||
my $LP = strftime("[%Y-%m-%d %H:%M:%S] ", localtime) . __PACKAGE__;
|
||
# превращаем URL в относительный и получаем свойства файла
|
||
$uri =~ s!^/+!!so;
|
||
my $ra = $self->{ra};
|
||
my $rname = '';
|
||
unless ($ra)
|
||
{
|
||
# необходимо открыть репозиторий Subversion
|
||
$uri =~ s!^([^/]+)/*!!so;
|
||
unless ($rname = $1)
|
||
{
|
||
# пустой урл
|
||
return print_error("Requested URL does not contain repository name");
|
||
}
|
||
my $K = $self->{params}->{repos_username} . '@' . $self->{params}->{repos_parent} . $rname;
|
||
$ra = $RAS->{$K};
|
||
unless ($ra)
|
||
{
|
||
# открываем репозиторий
|
||
eval { $ra = SVN::Ra->new(
|
||
url => $self->{params}->{repos_parent} . $rname,
|
||
auth => $self->{auth_prov},
|
||
) };
|
||
unless ($ra)
|
||
{
|
||
# репозиторий не открывается
|
||
return print_error("Failed to open Subversion repository '$rname'", $@);
|
||
}
|
||
$RAS->{$K} = $ra;
|
||
}
|
||
}
|
||
if ($self->{params}->{enc_from_to})
|
||
{
|
||
# перекодируем имя файла
|
||
from_to($uri, $self->{params}->{enc_from_to}->[0], $self->{params}->{enc_from_to}->[1]);
|
||
}
|
||
my ($revnum, $props);
|
||
if ($uri !~ /\/$/so)
|
||
{
|
||
eval
|
||
{
|
||
($revnum, $props) = $ra->get_file($uri, $SVN::Core::INVALID_REVNUM, undef);
|
||
};
|
||
}
|
||
# проверяем, есть ли файл
|
||
if (!$props)
|
||
{
|
||
if ($@ && $@ =~ /405\s+Method\s+Not\s+Allowed/so)
|
||
{
|
||
return print_error("Unknown repository '$rname'", $@);
|
||
}
|
||
else
|
||
{
|
||
return print_error("File '$uri' not found in Subversion repository '$rname'", $@);
|
||
}
|
||
}
|
||
# кэшируем файл, если нужно
|
||
my $path = $self->{params}->{cache_path} . '/' . $rname . $uri;
|
||
my $dir = $path;
|
||
$dir =~ s!/+[^/]*$!!so;
|
||
unless (-d $dir || make_path($dir))
|
||
{
|
||
return print_error("Failed to create cache path '$dir'");
|
||
}
|
||
my ($uptodate, $mime_type, $fd, $cached_rev);
|
||
if (-f $path && open $fd, "<$path.rev")
|
||
{
|
||
$cached_rev = <$fd>;
|
||
$mime_type = <$fd>;
|
||
chomp $mime_type;
|
||
close $fd;
|
||
$cached_rev =~ s/^\s*//so;
|
||
$cached_rev =~ s/\s*$//so;
|
||
if ($props->{'svn:entry:committed-rev'} <= $cached_rev && $mime_type)
|
||
{
|
||
# закэшировано актуальное
|
||
if ($self->{params}->{access_log})
|
||
{
|
||
# логгируем запрос
|
||
print STDERR "$LP: file $rname$uri is up to date, latest ".$props->{'svn:entry:committed-rev'}.", cached $cached_rev\n";
|
||
}
|
||
$uptodate = 1;
|
||
}
|
||
}
|
||
if (!$uptodate)
|
||
{
|
||
# проверка значения свойства - только при обновлении
|
||
if ($self->{params}->{check_prop_name})
|
||
{
|
||
my ($n, $re) = ($self->{params}->{check_prop_name}, $self->{params}->{check_prop_re});
|
||
my $ok = defined $re && $props->{$n} =~ /$re/ || !defined $re && exists $props->{$n};
|
||
if ($self->{params}->{check_prop_inherit})
|
||
{
|
||
# тупое наследование - интересно, будут ли тормоза?
|
||
my $diruri = $uri;
|
||
my $props;
|
||
while (!$ok && $diruri =~ s!/+[^/]*$!!iso)
|
||
{
|
||
$props = {};
|
||
eval { (undef, undef, $props) = $ra->get_dir($diruri, $SVN::Core::INVALID_REVNUM) };
|
||
$ok = defined $re && $props->{$n} =~ /$re/ || !defined $re && $props->{$n};
|
||
}
|
||
}
|
||
if (!$ok)
|
||
{
|
||
return print_error("Access to '$uri' from Subversion repository '$rname' is forbidden");
|
||
}
|
||
}
|
||
# угадать MIME-тип
|
||
$mime_type = $props->{'svn:mime-type'};
|
||
if (!$mime_type || $mime_type eq 'application/octet-stream')
|
||
{
|
||
$mime_type = LWP::MediaTypes::guess_media_type($path);
|
||
}
|
||
# записываем содержимое файла
|
||
eval
|
||
{
|
||
die "Could not open $path: $!" unless open $fd, ">$path";
|
||
($revnum, $props) = $ra->get_file($uri, $revnum, $fd);
|
||
close $fd;
|
||
die "Could not open $path.rev: $!" unless open $fd, ">$path.rev";
|
||
print $fd $props->{'svn:entry:committed-rev'}, "\n", $mime_type, "\n";
|
||
close $fd;
|
||
};
|
||
if ($@)
|
||
{
|
||
return print_error("Failed to checkout '$uri' @ rev.$revnum from Subversion repository '$rname' into local file '$path': $@");
|
||
}
|
||
# логгируем запрос
|
||
if ($self->{params}->{access_log})
|
||
{
|
||
print STDERR $cached_rev
|
||
? "$LP: file $rname$uri, updated to latest $revnum = ".$props->{'svn:entry:committed-rev'}." from cached $cached_rev\n"
|
||
: "$LP: file $rname$uri, checked out $revnum\n";
|
||
}
|
||
}
|
||
if (!open $fd, '<', $path)
|
||
{
|
||
return print_error("Cannot read $path");
|
||
}
|
||
print $ENV{SERVER_PROTOCOL}." 200 OK\x0d\x0a".
|
||
"Server: ".$ENV{SERVER_SOFTWARE}."\x0d\x0a".
|
||
"Content-Type: $mime_type\x0d\x0a".
|
||
"Content-Length: ".(-s $path)."\x0d\x0a".
|
||
"\x0d\x0a";
|
||
sendfile(fileno(STDOUT), fileno($fd), 0, -s $path);
|
||
}
|
||
|
||
1;
|
||
__END__
|