#!/usr/bin/perl
# TODO: implement fool proof paths check (add trailing backslash if it absent on url and path)
#
# 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 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 Data::Dumper;

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 = 1;

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 $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] };
my @threads;
my $tcount = 0;

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

		}

		threads->create('dlfunc', $link, $size);

		do {
			my $flag = 0;
			$tcount = threads->list();

			foreach my $thread (threads->list(threads::joinable)) {
				$thread->join();
				$flag = 1;
			}

			select(undef, undef, undef, 0.25) unless ($flag == 1);

		} while ($tcount > 3);

		undef $size;
		undef $link;
		@array2 = -1;
	}
}

do {
	$tcount = threads->list();

	foreach my $thread (threads->list(threads::joinable)) {
		$thread->join();
	}

	select(undef, undef, undef, 0.25);
} while ($tcount > 0);

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


foreach my $file (@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 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;
		}

	}

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

sub dbg($) {
	my $msg = shift;

	if ($DEBUG) {
		syswrite STDOUT, "$msg\n";
	}
}

__END__