Move from HTTP::Tiny and threads to AnyEvent:HTTP

* Use AnyEvent::HTTP instead of HTTP::Tiny to decrease resource usage
* Remove threads and threads::shared
* Update --help
* Update README.md
* Update TODO
* Add .gitignore
* Add cpanfile with list of required files
* Add bootstrap.sh to easily prepare run environment

.gitignore

@@ -0,0 +1 @@
+vendor_perl/**

.hgtags

@@ -1 +0,0 @@
-7220aac9615b3ef8f1b26df11d8c5a0c5310dcc0 v1.0

README.md

@@ -1,46 +1,90 @@
 # RPM Repositories Cloning tool
 
-1 to 1 rpm cloning tool
+1 to 1 rpm repository cloning tool
 
 ## Getting Started
 
+```bash
 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.
+test it). Perl modules required: AnyEvent, AnyEvent::HTTP, JSON::PP,
+XML::Parser, URI::URL
 
-for ubuntu: libjson-pp-perl, libfile-spec-perl, libxml-parser-perl,
-libio-compress-perl, liburi-perl
+#### For ubuntu it is enough to perform
 
-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
+```bash
+sudo apt install libjson-pp-perl libfile-spec-perl libxml-parser-perl \
+liburi-perl libanyevent-http-perl
 ```
 
-### Installing
+#### For centos 7+ it is enough to perform
+
+```bash
+yum install perl-AnyEvent-HTTP perl-JSON-PP perl-XML-Parser perl-URI \
+perl-IO-Zlib
+```
+
+#### Cpanminus way
+
+There is a way to install all modules locally either to application dir or to
+user profile. All you need in this case is cpanminus. Some **perl-App-cpanm**
+or cpm or carton or so. In most bad case you can wget it from cpanminus
+[github](https://github.com/miyagawa/cpanminus/raw/devel/App-cpanminus/cpanm)
+directly.
+
+Also you'll need analogue of centos **@development** metapackage (package group
+Development Tools) or Ubuntu **build-essential** metapackage to build perl'
+binary modules.
+
+To prepare environment you need to run **./bootstrap.sh** in rrclone directory.
+**Never run it as root**, or packages will be installed directly in system.
+
+In case of package, providing perl' **local::lib** found in system dependencies
+will be installed in script directory in **vendor_perl** catalogue, else it will
+go to **~./perl5**.
+
+To run script properly you should setup environment variables pointing to these
+vendored modules.
+
+```bash
+export PERL5LIB="/path/to/rrclone/dir/vendor_perl/lib/perl5"
+```
+
+and in case if perl' local::lib is not found in system:
+
+```bash
+export PERL5LIB="$HOME/.perl5/lib/perl5"
+```
+
+### Using rrclone
 
 There are no additional effort required for one-shot sync.
 
+You need correct path to repository. A string after "baseurl=" in repo-file
+(one that located in **/etc/yum.repos.d**, for example), it must end with
+**trailng slash**. If it does not, just add it.
+
+To check that url is correct you can try to download part of repository xml
+metadata. Put your string into browser address bar and add
+"repodata/repomd.xml" (no quotes) and if you see xml text then - vua-la! -
+your string is correct.
+
 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
+To add cronjob invoke
 
-```
+```bash
 su -s /bin/bash apache
 crontab -e
 ```
 
-```
+```text
 30 4 * * 0 /path/to/rrclone http://repository/url/ /absolute/path/to/copy/
 ```
 
@@ -51,6 +95,8 @@ This will run job weekly, at Sunday 4:30.
 Obviously, before deploy this script on some production environment you should
 package it properly :)
 
+And as a good practice do not run it as root user.
+
 ## Contributing
 
 If you want contribute ideas or code - please feel free to contact me via
@@ -58,7 +104,7 @@ email eleksir at exs-elm.ru
 
 ## Authors
 
-* **Eleksir** - *Initial work* - [exs' corner](https://exs-elm.ru/hg/rrclone)
+* **Eleksir** - *Initial work* - [exs' bitbucket](https://bitbucket.org/eleksir/rrclone/src/master/)
 
 ## License
 

TODO

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

bootstrap.sh

@@ -0,0 +1,5 @@
+#!/bin/bash
+
+cpanm -L vendor_perl --force --installdeps .
+
+# vim: set ft=sh noet ai ts=4 sw=4 sts=4:

cpanfile

@@ -0,0 +1,6 @@
+requires 'local::lib';
+requires 'IO::Socket::SSL';
+requires 'AnyEvent::HTTP';
+requires 'XML::Parser';
+requires 'IO::Zlib';
+requires 'URI::URL';

docs/rrclone.1

@@ -0,0 +1,41 @@
+.TH "RRCLONE" "1" "5 December 2019"
+.SH "NAME"
+rrclone \- RPM Repository Cloning tool
+.SH "SYNOPSIS"
+.B rrclone
+[\fI\,OPTION\/\fR]...
+SOURCE
+DESTINATION
+.SH "DESCRIPTION"
+.PP
+Copies all packages and metadata from remote repository to local folder.
+To guess package list it parses metadata. For now only XML metadata is supported.
+.SH "OPTIONS"
+.TP
+\fB\-\-help\fR
+show brief help message
+.TP
+\fB\-\-version\fR
+show version
+.TP
+\fB\-\-verbose\fR
+more verbose output
+.TP
+\fB\-\-noclean\fR
+do not clean packages that are missing in metadata
+.TP
+\fBSOURCE\fR
+is http(s) url that does not include repodata part.
+For example if full (index) metadata path is http://server/repo/Packages/repodata/repomd.xml
+then SOURCE will be http://server/repo/Packages/ with trailing slash.
+.TP
+\fBDESTINATION\fR
+full path to local directory, for example /var/www/repository/ with triling slash.
+.SH "AUTHOR"
+.TP
+Sergei Fedosoff <eleksir@gmail.com> aka eleksir <eleksir@exs-elm.ru>
+.SH "COPYRIGHT"
+Copyright © 2018 Sergei Fedosoff. License 2 clause BSD:
+https://directory.fsf.org/wiki?title=License:FreeBSD
+.SH "SEE ALSO"
+.B rpm (1).

docs/rrclone.crontab

@@ -0,0 +1,2 @@
+# run every sunday at 4.30 in the night
+30 4 * * 0 http://server/repo/packages/ /var/www/repo 1>/dev/null

rrclone

@@ -1,33 +1,42 @@
 #!/usr/bin/perl
-# simple RPM Repository cloning script
-
+#
 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
+use AnyEvent::Loop;
+use AnyEvent::HTTP;
+use IO::Socket::SSL; # implicit requirement in order work with https
 use Getopt::Long;
+use utf8;
+
+# global vars
+my $done = AnyEvent->condvar;
+$AnyEvent::HTTP::MAX_PER_HOST = 4;
+$AnyEvent::HTTP::TIMEOUT = 10;
+my $batch = 0;
+my $batchflag = 0;
+my $savepath = '/dev/null';
 
-sub mythread();
 sub dlfunc(@);
 sub urlencode($);
 sub getmetadata();
 sub help($);
-sub path_normalize_by_string_manipulation($);
+sub download($$$); # borrowed directly from AnyEvent::HTTP docs
+sub path_normalize_by_string_manipulation ($);
 sub getfilenames($);
 sub noslash($);
 sub dbg($);
 sub version();
 
+binmode STDOUT, ':utf8';
+binmode STDERR, ':utf8';
+
 my ($help, $verbose, $noclean, $version);
 
 GetOptions(
@@ -55,95 +64,75 @@ noslash($BASEURL);
 noslash($BASEDIR);
 
 syswrite STDOUT, sprintf("Cloning %s to %s\n", $BASEURL, $BASEDIR);
-
-my @REPOFILES :shared;
+my @REPOFILES;
 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');
+	syswrite STDERR, sprintf("An error has occured while reading %s.", $BASEDIR . "repodata/primary.xml.gz\n");
 	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'};
-			}
+my $package;
+my $location;
+my $size;
+my %list;
+my $p = XML::Parser->new( Style => 'Stream' );
+$p->setHandlers (
+	Start   => sub {
+		my($parseinst, $element, %attributes) = @_;
+		$package = 1 if ($element eq 'package');
+		$location = $attributes{href} if ($element eq 'location');
+		$size = $attributes{package} if ($element eq 'size');
 
+		if ($package and defined($size) and $location) {
+			$list{$location} = $size;
 		}
+	},
+	Char    => sub {},
+	End     => sub {
+		my($parseinst, $element, %attributes) = @_;
 
-		push @LINKS, $link;
-		push @SIZES, $size;
-
-		undef $size;
-		undef $link;
-		@array2 = -1;
+		if ($element eq 'package') {
+			$package = undef;
+			$location = undef;
+			$size = undef;
+		}
 	}
+);
+
+$p->parse($xmldata);
+undef $xmldata;
+undef $p;
+
+$done = AnyEvent->condvar;
+$batch = scalar(keys(%list));
+
+for my $url (keys(%list)) {
+	dlfunc($url, $list{$url});
 }
 
-@array = -1;
-undef $p1;
-
-for (my $i = 1; $i < 4; $i++) {
-	threads->create('mythread');
+if ($batchflag) {
+	$done->recv;
 }
 
-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);
+exit 0 if (defined($noclean));
 
 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;
@@ -156,17 +145,10 @@ foreach my $fileOnDisk (@FILES) {
 	}
 
 	if ($flag == 0) {
-		push @filesToDelete, $fileOnDisk;
-	}
-}
-
-
-while (@filesToDelete > 0) {
-	my $file = pop(@filesToDelete);
-
-	unless (-d $file) {
-		dbg("  - Unlinking $file");
-		unlink $file;
+		unless (-d $fileOnDisk) {
+			dbg("  - Unlinking $fileOnDisk");
+			unlink $fileOnDisk;
+		}
 	}
 }
 
@@ -181,6 +163,10 @@ Usage: rrclone.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.
+Note: because of new metadata arrives from repository old packages become
+"dead", so you cannot simply "yum downgrade" unless old packages are saved
+in yum cache. In order to make old packages "live" if --noclean given you
+should run createrepo or createrepo_c command to re-generate metadata.
 
 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
@@ -202,43 +188,78 @@ HELP
 	exit $rc;
 }
 
-sub mythread() {
-	while ( 1 ) {
-		my $size;
-		my $link;
+sub download($$$) {
+	my ($url, $file, $cb) = @_;
+	open my $fh, "+>", $file or die "$file: $!";
 
-		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;
+	my %hdr;
+	my $ofs = 0;
+
+	if (stat $fh and -s _) {
+		$ofs = -s _;
+		warn "-s is ", $ofs;
+		$hdr{"if-unmodified-since"} = AnyEvent::HTTP::format_date +(stat _)[9];
+		$hdr{"range"} = "bytes=$ofs-";
+	}
+
+	http_get $url,
+	headers   => \%hdr,
+	on_header => sub {
+		my ($hdr) = @_;
+
+		if ($hdr->{Status} == 200 && $ofs) {
+			# resume failed
+			truncate $fh, $ofs = 0;
 		}
 
-		if (@LINKS > 0) {
-			if ((defined($size)) and (defined($link))) {
-				dlfunc($link, $size);
-			}
+		sysseek $fh, $ofs, 0;
+
+		1
+	},
+	on_body   => sub {
+		my ($data, $hdr) = @_;
+
+		if ($hdr->{Status} =~ /^2/) {
+			length $data == syswrite $fh, $data
+				or return; # abort on write errors
+		}
+
+		1
+	},
+	sub {
+		my (undef, $hdr) = @_;
+		my $status = $hdr->{Status};
+
+		if (my $time = AnyEvent::HTTP::parse_date $hdr->{"last-modified"}) {
+			utime $time, $time, $fh;
+		}
+
+		if ($status == 200 || $status == 206 || $status == 416) {
+			# download ok || resume ok || file already fully downloaded
+			$cb->(1, $hdr);
+
+		} elsif ($status == 412) {
+			# file has changed while resuming, delete and retry
+			unlink $file;
+			$cb->(0, $hdr);
+
+		} elsif ($status == 500 or $status == 503 or $status =~ /^59/) {
+			# retry later
+			syswrite STDERR, "Unable to download $url. Server returns 5xx http status code.\n";
+			$cb->(0, $hdr);
+
 		} else {
-# handle last package in list
-			if ((defined($size)) and (defined($link))) {
-				dlfunc($link, $size);
-			} else {
-				last;
-			}
+			syswrite STDERR, "Unable to download $url.\n";
+			$cb->(undef, $hdr);
 		}
 	}
+	;
 }
 
 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);
+	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);
@@ -249,18 +270,18 @@ sub dlfunc(@) {
 
 	# 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.");
+				dbg("  * Skip $savepath - file already exists and on-disk and in-repo sizes are match");
+				$batch--;
 				return;
 			} else {
-				dbg("  + Downloading $savepath file exists but on-disk and in-repo sizes are mismatch. $filesize vs $size.")
+				dbg("  + Queue download of $savepath - file exists but on-disk and in-repo sizes are mismatch - $filesize vs $size")
 			}
 		} else {
-			dbg("  + Downloading $savepath");
+			dbg("  + Queue download of $savepath");
 		}
 
 	}
@@ -278,10 +299,20 @@ sub dlfunc(@) {
 
 	$url = $BASEURL . $url;
 	$url = urlencode($url);
+	$batchflag = 1 if ($batchflag == 0);
 
-	my $http = HTTP::Tiny->new();
-	$http->mirror($url, $savepath);
-	undef $http;
+	download ($url, $savepath, sub {
+		if ($_[0]) {
+			#syswrite STDERR, "$url downloaded.\n";
+		} elsif (defined $_[0]) {
+			#syswrite STDERR, "Unable to download $url.\n";
+		} else {
+			#syswrite STDERR, "Unable to download $url. Server returns 5xx http status code.\n";
+		}
+
+		$batch--;
+		$done->send if $batch == 0;
+	});
 
 	undef $savepath;
 	undef $url;
@@ -296,46 +327,54 @@ sub urlencode($) {
 }
 
 sub getmetadata() {
+	my @metafiles;
+	$batch = 1;
 	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;
-		}
-
+	if ($batchflag) {
+		$done->recv;
+		$batchflag = 0;
 	}
 
-	@array = -1;
-	return $primaryxmlgz;
+	my $p = XML::Parser->new( Style => 'Stream' );
+	$p->setHandlers (
+		Start   => sub {
+			my($parseinst, $element, %attributes) = @_;
+
+			foreach (keys(%attributes)) {
+				if ($_ eq 'href') {
+					push @metafiles, $attributes{$_};
+				}
+			}
+		},
+		Char    => sub {},
+		End     => sub {}
+	);
+
+	$p->parsefile($BASEDIR . 'repodata/repomd.xml');
+
+	$done = AnyEvent->condvar;
+	$batch = scalar(@metafiles);
+
+	die "Incorrect metadata in repository\n" if ($batch < 1);
+
+	foreach (@metafiles) {
+		dlfunc($_, -1);
+	}
+
+	if ($batchflag) {
+		$done->recv;
+		$batchflag = 0;
+	}
+
+	foreach (@metafiles) {
+		return $_ if ($_ =~ /primary\.xml\.gz$/);
+	}
+
+	die "No primary.xml metadata found.\n";
 }
 
-sub path_normalize_by_string_manipulation ($) {
+sub path_normalize_by_string_manipulation($) {
 	my $path = shift;
 
 	# canonpath does string manipulation, but does not remove "..".
@@ -369,15 +408,16 @@ sub getfilenames($) {
 
 	opendir (DIR, $path) or return "";
 	my @localfiles =
-	map { $path . '/' . $_ }
-	grep { !/^\.{1,2}$/ }
-	readdir (DIR);
+		map { $path . '/' . $_ }
+		grep { !/^\.{1,2}$/ }
+		readdir (DIR);
+
 	@FILES = (@FILES, @localfiles);
 
 	foreach (@localfiles) {
-		next if(-l $_);
+		next if (-l $_);
 
-		if(-d $_){
+		if (-d $_) {
 			getfilenames($_);
 		}
 	}
@@ -399,7 +439,8 @@ sub dbg($) {
 }
 
 sub version() {
-	syswrite STDOUT, "rrclone 1.1\n";
+	syswrite STDOUT, "rrclone 1.2\n";
 	exit 0;
 }
-__END__
+
+# vim: set ft=perl noet ai ts=4 sw=4 sts=4: