#!/usr/bin/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 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 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($);
sub dbg($);
sub version();

binmode STDOUT, ':utf8';
binmode STDERR, ':utf8';

my ($help, $verbose, $noclean, $version);

GetOptions(
	"help" => \$help,
	"verbose" => \$verbose,
	"noclean" => \$noclean,
	"version" => \$version
);

version() if ($version);
help(0) if ($help);

my $DEBUG = 0;
$DEBUG = 1 if ($verbose);
$noclean = 1 if ($noclean);

my $BASEURL = $ARGV[0] // '';
my $BASEDIR = $ARGV[1] // '';

help(0) unless ($BASEURL);
help(1) unless ($BASEDIR);

# check if there is trailing slash at the end of url and path
noslash($BASEURL);
noslash($BASEDIR);

syswrite STDOUT, sprintf("Cloning %s to %s\n", $BASEURL, $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\n");
	exit 1;
}

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) = @_;

		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});
}

if ($batchflag) {
	$done->recv;
}

syswrite STDOUT, "Cloning done.\n";
exit 0 if (defined($noclean));

syswrite STDOUT, sprintf("Cleaning old files in %s\n", $BASEDIR);

my $searchpath = $BASEDIR;
chop $searchpath;
getfilenames($searchpath);

foreach my $fileOnDisk (@FILES) {
	my $flag = 0;

	foreach my $fileInXML (@REPOFILES) {
		if ($fileInXML eq $fileOnDisk) {
			$flag = 1;
			last;
		}
	}

	if ($flag == 0) {
		unless (-d $fileOnDisk) {
			dbg("  - Unlinking $fileOnDisk");
			unlink $fileOnDisk;
		}
	}
}

syswrite STDOUT, "Cleaning done.\n";
exit 0;

sub help($) {
	my $rc = shift;
	my $help = <<'HELP';
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
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/

Other options:
--help    - show this message
--verbose - increases output verbosity
--version - show version number and quit
HELP

	syswrite STDOUT, $help;
	exit $rc;
}

sub download($$$) {
	my ($url, $file, $cb) = @_;
	open my $fh, "+>", $file or die "$file: $!";

	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;
		}

		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 $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");
				$batch--;
				return;
			} else {
				dbg("  + Queue download of $savepath - file exists but on-disk and in-repo sizes are mismatch - $filesize vs $size")
			}
		} else {
			dbg("  + Queue download of $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);
	$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;
	});

	undef $savepath;
	undef $url;
}

sub urlencode($) {
	my $url = shift;
	my $urlobj = url $url;
	$url = $urlobj->as_string;
	undef $urlobj;
	return $url;
}

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 {
			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($) {
	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";
	}
}

sub version() {
	syswrite STDOUT, "rrclone 1.2\n";
	exit 0;
}

# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
