rrclone/rrclone-mt

#!/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__