# buildd-uploader: upload finished packages for buildd
# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
# Copyright © 2009 Roger Leigh <rleigh@debian.org>
# Copyright © 2005 Ryan Murray <rmurray@debian.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see
# <http://www.gnu.org/licenses/>.
#
#######################################################################

package Buildd::Uploader;

use strict;
use warnings;

use Buildd qw(lock_file unlock_file unset_env exitstatus send_mail);
use Buildd::Base;
use Buildd::Conf qw();

BEGIN {
	use Exporter ();
	our (@ISA, @EXPORT);

	@ISA = qw(Exporter Buildd::Base);

	@EXPORT = qw();
}

sub new {
	my $class = shift;
	my $conf  = shift;

	my $self = $class->SUPER::new($conf);
	bless($self, $class);

	$self->set('Uploader Lock', undef);
	$self->set('Uploaded Pkgs', {});

	$self->open_log();

	return $self;
}

sub run {
	my $self = shift;

	unset_env();

	$self->set('Uploader Lock', lock_file("$main::HOME/buildd-uploader", 1));

	if (!$self->get('Uploader Lock')) {
		$self->log("exiting; another buildd-uploader is still running");
		return 1;
	}

	for my $queue_config (@{ $self->get_conf('UPLOAD_QUEUES') }) {
		$self->upload(
			$queue_config->get('DUPLOAD_LOCAL_QUEUE_DIR'),
			$queue_config->get('DUPLOAD_ARCHIVE_NAME'));
	}

	my $uploaded_pkgs = $self->get('Uploaded Pkgs');

	foreach my $archdist (keys %{$uploaded_pkgs}) {
		$self->log("Set to Uploaded($archdist):$uploaded_pkgs->{$archdist}");
	}

	return 0;
}

sub uploaded ($@) {
	my $self      = shift;
	my $pkg       = shift;
	my $arch_name = shift;
	my $dist_name = shift;

	my $msgs = "";

	my $dist_config
	  = $self->get_arch_dist_config_by_name($arch_name, $dist_name);
	my $db = $self->get_db_handle($dist_config);

	my $pipe = $db->pipe_query('--uploaded', $pkg);

	if ($pipe) {
		while (<$pipe>) {
			if (!/^(\S+): Propagating new state /) {
				$msgs .= $_;
			}
		}
		close($pipe);
		if ($msgs or $?) {
			$self->log($msgs) if $msgs;
			$self->log("wanna-build --uploaded failed with status ",
				exitstatus($?), "\n")
			  if $?;
		} else {
			my $archdist_name = "$arch_name/$dist_name";
			$self->get('Uploaded Pkgs')->{$archdist_name} .= " $pkg";
		}
	} else {
		$self->log("Can't spawn wanna-build --uploaded: $!\n");
	}
}

sub upload ($$) {
	my $self      = shift;
	my $udir      = shift;
	my $upload_to = shift;

	chdir("$main::HOME/$udir") || return;
	lock_file("$main::HOME/$udir");

	my ($f, $g, @before, @after);

	foreach $f (<*.changes>) {
		($g = $f) =~ s/\.changes$/\.upload/;
		push(@before, $f) if !-f $g;
	}

	unlock_file("$main::HOME/$udir");

	if (!@before) {
		$self->log("Nothing to do for $udir\n");
		return;
	}

	$self->log(scalar(@before), " jobs to upload in $udir: @before\n");

	foreach $f (@before) {
		($g = $f) =~ s/\.changes$/\.upload/;
		my $logref = $self->do_dupload($upload_to, $f);

		if (defined $logref and scalar(@$logref) > 0) {
			my $line;

			foreach $line (@$logref) {
				$self->log($line);
			}
		}

		if (-f $g) {
			if (!open(F, "<$f")) {
				$self->log("Cannot open $f: $!\n");
				next;
			}
			my $text;
			{ local ($/); undef $/; $text = <F>; }
			close(F);
			if ($text !~ /^Architecture:\s*(.*)\s*$/m) {
				$self->log("$f doesn't have a Architecture: field\n");
				next;
			}
			my @archs = split(/\s+/, $1);
			if ($text !~ /^Distribution:\s*(.*)\s*$/m) {
				$self->log("$f doesn't have a Distribution: field\n");
				next;
			}
			my @dists = split(/\s+/, $1);
			my ($version, $source, $pkg);
			if ($text =~ /^Version:\s*(\S+)\s*$/m) {
				$version = $1;
			}
			if ($text =~ /^Source:\s*(\S+)(?:\s+\(\S+\))?\s*$/m) {
				$source = $1;
			}
			if (defined($version) and defined($source)) {
				$pkg = "${source}_$version";
			} else {
				($pkg = $f) =~ s/_\S+\.changes$//;
			}
			$self->uploaded($pkg, @archs, @dists);
		} else {
			push(@after, $f);
		}
	}

	if (@after) {
		$self->log("The following jobs were not processed (successfully):\n"
			  . "@after\n");
	} else {
		$self->log("dupload successful.\n");
	}
	$self->write_stats("uploads", scalar(@before) - scalar(@after));
}

sub do_dupload ($@) {
	my $self      = shift;
	my $upload_to = shift;

	my @jobs = @_;
	my @log;
	local (*PIPE);
	my ($current_job, $current_file, @failed, $errs);

	if (!open(PIPE, "dupload -k --to $upload_to @jobs </dev/null 2>&1 |")) {
		return "Cannot spawn dupload: $!";
	}

	my $dup_log = "";
	while (<PIPE>) {
		$dup_log .= $_;
		chomp;
		if (/^\[ Preparing job \S+ from (\S+\.changes)$/) {
			$current_job = $1;
		} elsif (/^warning: MD5sum mismatch for (\S+), skipping/i) {
			my $f = $1;
			push(@log, "dupload error: md5sum mismatch for $f\n");
			$errs .= "md5sum mismatch on file $f ($current_job)\n";
			push(@failed, $current_job);
		} elsif (/^\[ Uploading job (\S+)$/) {
			$current_job = "$1.changes";
		} elsif (/dupload: error: Cannot upload (\S+)/i
			|| /^\s(\S+).*scp: (.*)$/) {
			my ($f, $e) = ($1, $2);
			push(@log, "dupload error: upload error for $f\n");
			push(@log, "($e)\n") if $e;
			$errs .= "upload error on file $f ($current_job)\n";
			push(@failed, $current_job);
		} elsif (/Timeout at [\S]+ line [\d]+$/) {
			$errs .= "upload timeout on file $current_job\n";
			push(@failed, $current_job);
		} elsif (/^\s(\S+)\s+[\d.]+ kB /) {
			$current_file = $1;
		}
	}
	close(PIPE);
	if ($?) {
		if (($? >> 8) == 141) {
			push(@log, "dupload error: SIGPIPE (broken connection)\n");
			$errs .= "upload error (broken connection) during "
			  . "file $current_file ($current_job)\n";
			push(@failed, $current_job);
		} else {
			push(@log, "dupload exit status " . exitstatus($?));
			$errs .= "dupload exit status " . exitstatus($?) . "\n";
			push(@failed, $current_job);
		}
	}

	foreach (@failed) {
		my $u = $_;
		$u =~ s/\.changes$/\.upload/;
		unlink($u);
		push(@log, "Removed $u due to upload errors.\n");
		$errs .= "Removed $u to reupload later.\n";
	}

	if ($errs) {
		$errs .= "\nComplete output from dupload:\n\n$dup_log";
		send_mail($self->get_conf('ADMIN_MAIL'), "dupload errors", $errs);
	}
	return \@log;
}

1;