From 5675486db21689ba3802e2b6ee68cbaef9effacd Mon Sep 17 00:00:00 2001
From: eleksir <eleksir@exs-elm.ru>
Date: Sun, 12 Jan 2020 23:58:02 +0300
Subject: [PATCH] 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   |   1 +
 README.md    |  85 ++++++++++++++++++--------
 TODO         |   2 -
 bootstrap.sh |   5 ++
 cpanfile     |   6 ++
 rrclone      | 168 +++++++++++++++++++++++++++++++++++++--------------
 6 files changed, 196 insertions(+), 71 deletions(-)
 create mode 100644 .gitignore
 create mode 100755 bootstrap.sh
 create mode 100644 cpanfile

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..643a2d9
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+vendor_perl/**
\ No newline at end of file
diff --git a/README.md b/README.md
index e1a042e..5dbd319 100644
--- a/README.md
+++ b/README.md
@@ -4,52 +4,87 @@
 
 ## 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
 ```
 
-A correct path to repository. You need 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.
+#### 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.
 
-### 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
+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/
 ```
 
@@ -58,7 +93,9 @@ This will run job weekly, at Sunday 4:30.
 ## Deployment
 
 Obviously, before deploy this script on some production environment you should
-package it properly :) 
+package it properly :)
+
+And as a good practice do not run it as root user.
 
 ## Contributing
 
@@ -67,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
 
diff --git a/TODO b/TODO
index 2970b7a..a828b61 100644
--- a/TODO
+++ b/TODO
@@ -2,7 +2,6 @@
 
 * добавить возможность работы с sqlite-метаданными и перейти на этот метод по-умолчанию
 * сделать fatpack скрипта
-* запользовать AnyEvent::HTTP для скачивания пакетов
 * задействовать проверку по sha256 хэшу как скачиваемых пакетов так и тех, которые уже были скачаны
 * уточнить список возможных хэшей
 * добавить пример spec-файла
@@ -15,4 +14,3 @@
 * добавить возможность клонирования ещё каких-нибудь репозиториев, навроде apt-rpm
 * добавить возможность исключения пакетов по регулярке (по подстроке, хотябы)
 * добавить возможность перегенерации метаданных, по фэн-шую (описать этот фэн-шуй в документации)
-
diff --git a/bootstrap.sh b/bootstrap.sh
new file mode 100755
index 0000000..92f3eca
--- /dev/null
+++ b/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:
diff --git a/cpanfile b/cpanfile
new file mode 100644
index 0000000..5246e10
--- /dev/null
+++ b/cpanfile
@@ -0,0 +1,6 @@
+requires 'local::lib';
+requires 'IO::Socket::SSL';
+requires 'AnyEvent::HTTP';
+requires 'XML::Parser';
+requires 'IO::Zlib';
+requires 'URI::URL';
diff --git a/rrclone b/rrclone
index d48c25d..6388daf 100644
--- a/rrclone
+++ b/rrclone
@@ -3,25 +3,31 @@
 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;
 
-sub mythread();
+# 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 dlfunc(@);
 sub urlencode($);
 sub getmetadata();
 sub help($);
+sub download($$$); # borrowed directly from AnyEvent::HTTP docs
 sub path_normalize_by_string_manipulation ($);
 sub getfilenames($);
 sub noslash($);
@@ -58,11 +64,8 @@ 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;
@@ -82,7 +85,7 @@ if ($fh->open($BASEDIR . $primaryxmlgz, "rb")) {
 my $package;
 my $location;
 my $size;
-my %list :shared;
+my %list;
 my $p = XML::Parser->new( Style => 'Stream' );
 $p->setHandlers (
 	Start   => sub {
@@ -111,24 +114,17 @@ $p->parse($xmldata);
 undef $xmldata;
 undef $p;
 
-for (my $i = 1; $i < 4; $i++) {
-	threads->create('mythread');
+$done = AnyEvent->condvar;
+$batch = scalar(keys(%list));
+
+for my $url (keys(%list)) {
+	dlfunc($url, $list{$url});
 }
 
-my $tcount = 0;
+if ($batchflag) {
+	$done->recv;
+}
 
-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(1);
-} while ($tcount > 0);
-
-undef $tcount;
 syswrite STDOUT, "Cloning done.\n";
 exit 0 if (defined($noclean));
 
@@ -167,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
@@ -188,27 +188,77 @@ 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 ( 1 ) { # to properly remove lock
-			lock %list;
-			my @l = keys(%list);
-			last if (@l == 0);
-			$link = $l[0];
-			$size = delete($list{$link});
+	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;
 		}
 
-		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 {
+			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);
 
 	if (substr($savepath, 0, length($BASEDIR)) ne $BASEDIR) {
@@ -220,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");
 		}
 
 	}
@@ -249,10 +299,21 @@ sub dlfunc(@) {
 
 	$url = $BASEURL . $url;
 	$url = urlencode($url);
+	$batchflag = 1 if ($batchflag == 0);
+
+	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;
+	});
 
-	my $http = HTTP::Tiny->new();
-	$http->mirror($url, $savepath);
-	undef $http;
 	undef $savepath;
 	undef $url;
 }
@@ -267,7 +328,14 @@ sub urlencode($) {
 
 sub getmetadata() {
 	my @metafiles;
+	$batch = 1;
 	dlfunc('repodata/repomd.xml', -1);
+
+	if ($batchflag) {
+		$done->recv;
+		$batchflag = 0;
+	}
+
 	my $p = XML::Parser->new( Style => 'Stream' );
 	$p->setHandlers (
 		Start   => sub {
@@ -285,10 +353,20 @@ sub getmetadata() {
 
 	$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$/);
 	}