eleksir/rrclone
1
Fork 0
Code Activity

Initial commit

Browse Source
This commit is contained in:
eleksir
2019-01-05 02:53:27 +03:00
commit 22e92ee731
5 changed files with 840 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
LICENSE Normal file
View File

@@ -0,0 +1,22 @@
Copyright 2010 Sergei Fedosov <eleksir@gmail.com>
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

71
README.md Normal file
View File

@@ -0,0 +1,71 @@
# RPM Repositories Cloning tool
1 to 1 rpm cloning tool
## Getting Started
rrclone http://source/repo/ /absolute/path/to/destination/folder/
### Prerequisites
Linux or FreeBSD with recent perl (at least 5.20, on previous versions i didn't
test it). There is no external packages required in order to run this program.
The only thing that required is Perl. But many linux distributions have
ill-minded practice to rip Perl into many sub-packages, in this case you have
to install some perl packages.
for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl,
libio-compress-perl, liburi-perl
in case of Slackware Linux everything is already shipped with single Perl
package.
```
apt install libjson-pp-perl, libfile-spec-perl, libxml-parser-perl,
libio-compress-perl, liburi-perl
```
### Installing
There are no additional effort required for one-shot sync.
But if you planning to keep repository in sync with upstream, you should add
cron job, that can be run without any additional privileges, i.e. web server
user is enough for that.
to add cronjob invoke
```
su -s /bin/bash apache
crontab -e
```
```
30 4 * * 0 /path/to/rrclone http://repository/url/ /absolute/path/to/copy/
```
This will run job weekly, at Sunday 4:30.
## Deployment
Obviously, before deploy this script on some production environment you should
package it properly :)
## Contributing
If you want contribute ideas or code - please feel free to contact me via
email eleksir at exs-elm.ru
## Authors
* **Eleksir** - *Initial work* - [exs' corner](https://exs-elm.ru/hg/rrclone)
## License
This project is licensed under the BSD License - see the [LICENSE](LICENSE) file for details
## Acknowledgments
* Hat tip to anyone whose code was used
* Inspiration
* you

19
TODO Normal file
View File

@@ -0,0 +1,19 @@
Технический долг и планируемые доработки.
* внедрить GetOpt, чтобы корректно парсить аргументы ком.строки стандартными средствами. Для этого нужно будет использовать внешние по отношению к Perl модули, GetOpt и GetOpt::Long
* XML::Simple умеет работать не только с деревом, но и с потоком xml, в случае с потоком должно потребляться меньше памяти, но работать с ним сложнее
* добавить возможность работы с sqlite-метаданными и перейти на этот метод по-умолчанию
* добавить пример spec-файла
* добавить пример debian package
* добавить slackbuild
* добавить ebuild
* добавить примеры crontab
* добавить man page
* добавить методики работы с https://packagecloud.io/ и сервисами подобными им (без автоиндекса)
Факультативное задание :)
* добавить возможность клонирования deb-репозиториев
* добавить возможность клонирования ещё каких-нибудь репозиториев, навроде apt-rpm
* добавить возможность исключения пакетов по регулярке (по подстроке, хотябы)
* добавить возможность перегенерации метаданных, по фэн-шую (описать этот фэн-шуй в документации)

325
rrclone Normal file
View File

@@ -0,0 +1,325 @@
#!/usr/bin/perl
#
# simple RPM Repository cloning script
# looks like some toxic ditribution polices for ill-driven distros like debian|ubuntu or less shitty like centos
# make maintainers split std. perl (and python too) distribution to many-many packages, even meta packages like
# perl-modules for ubuntu contain not full set of default perl source distribution' modules, so you have to install
# some packages in order to work with this script
#
# for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl, libio-compress-perl, liburi-perl
# for slackware - everything is bundled with builtin perl :)
use strict;
use warnings "all";
use Fcntl;
use File::Basename;
use File::Path qw(make_path);
use File::Spec;
use XML::Parser;
use IO::Zlib;
use URI::URL;
#use Data::Dumper;
sub dlfunc(@);
sub urlencode($);
sub getmetadata();
sub help($);
sub path_normalize_by_string_manipulation($);
sub getfilenames($);
sub noslash($);
help(0) unless (defined $ARGV[0]);
help(1) unless (defined $ARGV[1]);
help(0) if ($ARGV[0] eq '--help');
help(0) if ($ARGV[0] eq '-h');
my $noclean = 0;
if (defined($ARGV[0]) and $ARGV[0] eq '--noclean') {
$noclean = 1;
}
my $BASEURL = $ARGV[0];
my $BASEDIR = $ARGV[1];
if ($noclean == 1) {
help(1) unless (defined $ARGV[2]);
$BASEURL = $ARGV[1];
$BASEDIR = $ARGV[2];
}
noslash($BASEURL);
noslash($BASEDIR);
my @REPOFILES;
my @FILES;
my $primaryxmlgz = getmetadata();
my $fh = new IO::Zlib;
my $xmldata = '';
if ($fh->open($BASEDIR . $primaryxmlgz, "rb")) {
while (<$fh>) {
$xmldata .= $_;
}
$fh->close;
} else {
syswrite STDERR, sprintf("An error has occured while reading %s.", $BASEDIR . 'repodata/primary.xml.gz');
exit 1;
}
my $p1 = new XML::Parser(Style => 'Tree');
my $ref = $p1->parse($xmldata);
undef $xmldata;
my @array = @{ $ref->[1] };
for (my $i = 0; $i < @array; $i++) {
if (defined($array[$i]) and ($array[$i] eq 'package')) {
$i++;
my @array2 = @{ $array[$i] };
my $size = -1;
my $link;
for (my $j = 0; $j < @array2; $j++) {
if (defined($array2[$j]) and ($array2[$j] eq 'size')) {
$j++;
$size = $array2[$j][0]{'package'};
}
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
$j++;
$link = $array2[$j][0]{'href'};
# syswrite STDOUT, "+ " . $array2[$j][0]{'href'} . "\n";
}
}
dlfunc($link, $size);
undef $size;
undef $link;
@array2 = -1;
}
}
exit 0 if ($noclean == 1);
my $searchpath = $BASEDIR;
chop $searchpath;
getfilenames($searchpath);
my @filesToDelete;
foreach my $fileOnDisk (@FILES) {
my $flag = 0;
foreach my $fileInXML (@REPOFILES) {
if ($fileInXML eq $fileOnDisk) {
$flag = 1;
last;
}
}
if ($flag == 0) {
push @filesToDelete, $fileOnDisk;
}
}
foreach my $file (@filesToDelete) {
unless (-d $file) {
unlink $file;
}
}
exit 0;
sub help($) {
my $rc = shift;
my $help = <<'HELP';
Usage: cr.pl [--noclean] source destination
Where
--noclean is optional argument, if it specified, no cleanup operation will
be performed after rpm downloading complete.
Source must be http(s) url which trimmed at repodata folder. If full url is
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/repodata/repomd.xml
source must be given as:
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/
Destination is the folder where all files and metadata will be downloaded, if
folder does not exist it will be created. Must contain trailng slash char.
For example:
/var/www/htdocs/repo/
HELP
syswrite STDOUT, $help;
exit $rc;
}
sub dlfunc(@) {
my $url = shift; # short (relative) URL without BASE part
my $size = shift;
my $wgetpath;
my $savepath = path_normalize_by_string_manipulation ($BASEDIR . $url);
if (substr($savepath, 0, length($BASEDIR)) ne $BASEDIR) {
syswrite STDERR, sprintf("Skipping package %s, because it out of destdir %s, looks like quirky metadata.\n", $savepath, $BASEDIR);
return;
}
push @REPOFILES, $savepath;
# do not re-download already downloaded rpm packages
unless ($size == -1) {
if (-f $savepath) {
my $filesize = (stat($savepath))[7];
if ($size == $filesize) {
return;
}
}
}
my $basedir; (undef, $basedir) = fileparse($savepath);
unless (-d $basedir) {
my $ret = make_path ($basedir);
if ($ret < 1) {
syswrite STDERR, sprintf("Unable to create directory %s .\n", $basedir);
exit 1;
}
}
if (-f "/bin/wget") {
$wgetpath = '/bin/wget';
} elsif (-f "/usr/bin/wget") {
$wgetpath = '/usr/bin/wget';
} elsif (-f "/usr/local/bin/wget") {
$wgetpath = '/usr/local/bin/wget';
} else {
syswrite STDERR, "Please install wget. (Unable to find it in std locations)\n";
exit 1;
}
$url = $BASEURL . $url;
$url = urlencode($url);
system($wgetpath, '--no-check-certificate', '-q', '-T', '20', '-O', $savepath, '-o', '/dev/null', $url);
undef $savepath;
undef $url;
}
sub urlencode($) {
my $url = shift;
my $urlobj = url $url;
$url = $urlobj->as_string;
undef $urlobj;
return $url;
}
sub getmetadata() {
dlfunc('repodata/repomd.xml', -1);
my $p1 = new XML::Parser(Style => 'Tree');
my $ref = $p1->parsefile($BASEDIR . 'repodata/repomd.xml');
#print Dumper $ref->[1][8][12][0]{'href'};
# must be 'data'-------^
# must be 'location'------^
my @array = @{ $ref->[1] };
my $primaryxmlgz;
for (my $i = 0; $i < @array; $i++) {
if (defined($array[$i]) and ($array[$i] eq 'data')){
$i++;
my @array2 = @{ $array[$i] };
for (my $j = 0; $j < @array2; $j++) {
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
$j++;
dlfunc($array2[$j][0]{'href'}, -1);
if ($array2[$j][0]{'href'} =~ /primary\.xml\.gz$/) {
$primaryxmlgz = $array2[$j][0]{'href'};
}
}
}
@array2 = -1;
}
}
return $primaryxmlgz;
}
sub path_normalize_by_string_manipulation ($) {
my $path = shift;
# canonpath does string manipulation, but does not remove "..".
my $ret = File::Spec->canonpath($path);
# Let's remove ".." by using a regex.
while ($ret =~ s{
(^|/) # Either the beginning of the string, or a slash, save as $1
( # Followed by one of these:
[^/]| # * Any one character (except slash, obviously)
[^./][^/]| # * Two characters where
[^/][^./]| # they are not ".."
[^/][^/][^/]+ # * Three or more characters
) # Followed by:
/\.\./ # "/", followed by "../"
}{$1}x
) {
# Repeat this substitution until not possible anymore.
}
# Re-adding the trailing slash, if needed.
if ($path =~ m!/$! && $ret !~ m!/$!) {
$ret .= '/';
}
return $ret;
}
sub getfilenames($) {
my $path = shift;
opendir (DIR, $path) or return "";
my @localfiles;
@localfiles =
map { $path . '/' . $_ }
grep { !/^\.{1,2}$/ }
readdir (DIR);
@FILES = (@FILES, @localfiles);
foreach (@localfiles) {
next if(-l $_);
if( -d $_){
getfilenames($_);
}
}
}
sub noslash($) {
my $str = shift;
return if ($str =~ /\/$/);
syswrite STDERR, "Source and destination must have trailing slashes!\n";
exit 1;
}
__END__

403
rrclone-mt Normal file
View File

@@ -0,0 +1,403 @@
#!/usr/bin/perl
# simple RPM Repository cloning script
# looks like some toxic ditribution polices for ill-driven distros like debian|ubuntu or less shitty like centos
# make maintainers split std. perl (and python too) distribution to many-many packages, even meta packages like
# perl-modules for ubuntu contain not full set of default perl source distribution' modules, so you have to install
# some packages in order to work with this script
#
# for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl, libio-compress-perl, liburi-perl
# for slackware - everything is bundled with builtin perl :)
# TODO: use another model of xml processing to use less memory
use strict;
use warnings "all";
use Fcntl;
use threads;
use threads::shared;
use File::Basename;
use File::Path qw(make_path);
use File::Spec;
use XML::Parser;
use IO::Zlib;
use URI::URL;
use Data::Dumper;
use HTTP::Tiny;
use IO::Socket::SSL; # implicit requirement in order to HTTP::Tiny work with https
sub mythread();
sub dlfunc(@);
sub urlencode($);
sub getmetadata();
sub help($);
sub path_normalize_by_string_manipulation($);
sub getfilenames($);
sub noslash($);
sub dbg($);
help(0) unless (defined $ARGV[0]);
help(1) unless (defined $ARGV[1]);
help(0) if ($ARGV[0] eq '--help');
help(0) if ($ARGV[0] eq '-h');
my $noclean = 0;
my $DEBUG = 0;
if (defined($ARGV[0]) and $ARGV[0] eq '--noclean') {
$noclean = 1;
}
my $BASEURL = $ARGV[0];
my $BASEDIR = $ARGV[1];
if ($noclean == 1) {
help(1) unless (defined $ARGV[2]);
$BASEURL = $ARGV[1];
$BASEDIR = $ARGV[2];
}
noslash($BASEURL);
noslash($BASEDIR);
syswrite STDOUT, sprintf("Cloning %s to %s\n", $BASEURL, $BASEDIR);
my @REPOFILES :shared;
my @FILES;
my @LINKS :shared;
my @SIZES :shared;
my $MUTEX :shared = 0; # while $MUTEX = 1, noone picks links
my $primaryxmlgz = getmetadata();
my $fh = new IO::Zlib;
my $xmldata = '';
if ($fh->open($BASEDIR . $primaryxmlgz, "rb")) {
while (<$fh>) {
$xmldata .= $_;
}
$fh->close;
} else {
syswrite STDERR, sprintf("An error has occured while reading %s.", $BASEDIR . 'repodata/primary.xml.gz');
exit 1;
}
my $p1 = new XML::Parser(Style => 'Tree');
my $ref = $p1->parse($xmldata);
undef $xmldata;
my @array = @{ $ref->[1] };
for (my $i = 0; $i < @array; $i++) {
if (defined($array[$i]) and ($array[$i] eq 'package')) {
$i++;
my @array2 = @{ $array[$i] };
my $size = -1;
my $link;
for (my $j = 0; $j < @array2; $j++) {
if (defined($array2[$j]) and ($array2[$j] eq 'size')) {
$j++;
$size = $array2[$j][0]{'package'};
}
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
$j++;
$link = $array2[$j][0]{'href'};
}
}
push @LINKS, $link;
push @SIZES, $size;
undef $size;
undef $link;
@array2 = -1;
}
}
@array = -1;
undef $p1;
for (my $i = 1; $i < 4; $i++) {
threads->create('mythread');
}
my $tcount = 0;
do {
$tcount = threads->list();
foreach my $thread (threads->list(threads::joinable)) {
$thread->join();
}
# list of threads can be polled once per second, it delays consecutive polls by one second
sleep(3);
} while ($tcount > 0);
undef $tcount;
syswrite STDOUT, "Cloning done.\n";
exit 0 if ($noclean == 1);
syswrite STDOUT, sprintf("Cleaning old files in %s\n", $BASEDIR);
my $searchpath = $BASEDIR;
chop $searchpath;
getfilenames($searchpath);
my @filesToDelete;
foreach my $fileOnDisk (@FILES) {
my $flag = 0;
foreach my $fileInXML (@REPOFILES) {
if ($fileInXML eq $fileOnDisk) {
$flag = 1;
last;
}
}
if ($flag == 0) {
push @filesToDelete, $fileOnDisk;
}
}
while (@filesToDelete > 0) {
my $file = pop(@filesToDelete);
unless (-d $file) {
dbg(" - Unlinking $file");
unlink $file;
}
}
syswrite STDOUT, "Cleaning done.\n";
exit 0;
sub help($) {
my $rc = shift;
my $help = <<'HELP';
Usage: cr.pl [--noclean] http://source/url/ /destination/dir/
Where
--noclean is optional argument, if it specified, no cleanup operation will
be performed after rpm downloading complete.
Source must be http(s) url which trimmed at repodata folder. If full url is
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/repodata/repomd.xml
source must be given as:
http://mirror.yandex.ru/centos/7.4.1708/os/x86_64/
Destination is the folder where all files and metadata will be downloaded, if
folder does not exist it will be created. Must contain trailng slash char.
For example:
/var/www/htdocs/repo/
HELP
syswrite STDOUT, $help;
exit $rc;
}
sub mythread() {
while ( 1 ) {
my $size;
my $link;
if ($MUTEX == 0) {
$MUTEX = 1;
$size = pop(@SIZES);
$link = pop(@LINKS);
$MUTEX = 0;
} else {
# pop from 2 arrays takes very small amount of time,
# in practice we do not need this micro-sleep
# select(undef, undef, undef, 0.05);
next;
}
if (@LINKS > 0) {
if ((defined($size)) and (defined($link))) {
dlfunc($link, $size);
}
} else {
# handle last package in list
if ((defined($size)) and (defined($link))) {
dlfunc($link, $size);
} else {
last;
}
}
}
}
sub dlfunc(@) {
my $url = shift; # short (relative) URL without BASE part
my $size = shift;
my $wgetpath;
my $savepath = path_normalize_by_string_manipulation ($BASEDIR . $url);
if (substr($savepath, 0, length($BASEDIR)) ne $BASEDIR) {
syswrite STDERR, sprintf("Skipping package %s, because it out of destdir %s, looks like quirky metadata.\n", $savepath, $BASEDIR);
return;
}
push @REPOFILES, $savepath;
# do not re-download already downloaded rpm packages
unless ($size == -1) {
if (-f $savepath) {
my $filesize = (stat($savepath))[7];
if ($size == $filesize) {
dbg(" * Skip $savepath file already exists and on-disk and in-repo sizes are match.");
return;
} else {
dbg(" + Downloading $savepath file exists but on-disk and in-repo sizes are mismatch. $filesize vs $size.")
}
} else {
dbg(" + Downloading $savepath");
}
}
my $basedir; (undef, $basedir) = fileparse($savepath);
unless (-d $basedir) {
my $ret = make_path ($basedir);
if ($ret < 1) {
syswrite STDERR, sprintf("Unable to create directory %s .\n", $basedir);
exit 1;
}
}
$url = $BASEURL . $url;
$url = urlencode($url);
my $http = HTTP::Tiny->new();
$http->mirror($url, $savepath);
undef $http;
undef $savepath;
undef $url;
}
sub urlencode($) {
my $url = shift;
my $urlobj = url $url;
$url = $urlobj->as_string;
undef $urlobj;
return $url;
}
sub getmetadata() {
dlfunc('repodata/repomd.xml', -1);
my $p1 = new XML::Parser(Style => 'Tree');
my $ref = $p1->parsefile($BASEDIR . 'repodata/repomd.xml');
#print Dumper $ref->[1][8][12][0]{'href'};
# must be 'data'-------^
# must be 'location'------^
my @array = @{ $ref->[1] };
my $primaryxmlgz;
for (my $i = 0; $i < @array; $i++) {
if (defined($array[$i]) and ($array[$i] eq 'data')){
$i++;
my @array2 = @{ $array[$i] };
for (my $j = 0; $j < @array2; $j++) {
if (defined($array2[$j]) and ($array2[$j] eq 'location')) {
$j++;
dlfunc($array2[$j][0]{'href'}, -1);
if ($array2[$j][0]{'href'} =~ /primary\.xml\.gz$/) {
$primaryxmlgz = $array2[$j][0]{'href'};
}
}
}
@array2 = -1;
}
}
@array = -1;
return $primaryxmlgz;
}
sub path_normalize_by_string_manipulation ($) {
my $path = shift;
# canonpath does string manipulation, but does not remove "..".
my $ret = File::Spec->canonpath($path);
# Let's remove ".." by using a regex.
while ($ret =~ s{
(^|/) # Either the beginning of the string, or a slash, save as $1
( # Followed by one of these:
[^/]| # * Any one character (except slash, obviously)
[^./][^/]| # * Two characters where
[^/][^./]| # they are not ".."
[^/][^/][^/]+ # * Three or more characters
) # Followed by:
/\.\./ # "/", followed by "../"
}{$1}x
) {
# Repeat this substitution until not possible anymore.
}
# Re-adding the trailing slash, if needed.
if ($path =~ m!/$! && $ret !~ m!/$!) {
$ret .= '/';
}
return $ret;
}
sub getfilenames($) {
my $path = shift;
opendir (DIR, $path) or return "";
my @localfiles =
map { $path . '/' . $_ }
grep { !/^\.{1,2}$/ }
readdir (DIR);
@FILES = (@FILES, @localfiles);
foreach (@localfiles) {
next if(-l $_);
if(-d $_){
getfilenames($_);
}
}
}
sub noslash($) {
my $str = shift;
return if ($str =~ /\/$/);
syswrite STDERR, "Source and destination must have trailing slashes!\n";
exit 1;
}
sub dbg($) {
my $msg = shift;
if ($DEBUG) {
syswrite STDOUT, "$msg\n";
}
}
__END__