#! /usr/bin/perl -w
#
# debaux-publish - Debian package publishing script
#
# Copyright 2000,2001,2002,2006 Stefan Hornburg (Racke) <racke@linuxia.de>
#
# 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, write to the Free
# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA.

# MODULE SETUP
# ============

use strict;
use AppConfig qw(:argcount);
use Data::Dumper;
$Data::Dumper::Terse = 1;
use File::Basename;
use Getopt::Long;
use Net::SSH qw(sshopen2);

use DebAux::Util;

# VARIABLES
# =========

my $infref;
# package info by file name, binary package name, source package name
my (%upmap, %pkgmap, %srcmap);
my @secdirs;
# remote location information
my %rmtloc;
# used distributions and architectures
my $debarch;
my %distmap;
my %distarches;
# settings specific for a site
my %sitedefs;

# COMMANDLINE PARAMETERS
# ======================

my %opts = ('dry-run' => 0);
my $whandler = $SIG{__WARN__};
$SIG{__WARN__} = sub {print STDERR "$0: @_";};
unless (GetOptions (\%opts, 'distribution|d=s', 'dry-run|n', 'site=s')) {
    exit 1;
}
$SIG{__WARN__} = $whandler;

# PARSE CONFIGURATION FILE
# ========================

my $cfgfile = $ENV{'HOME'} . '/.debpublishrc';
my $config = new AppConfig ({GLOBAL => {ARGCOUNT => ARGCOUNT_ONE},
							 ERROR => sub {conferror($cfgfile,@_)}});
$config -> define ('host', {ARGCOUNT => ARGCOUNT_HASH});
$config -> define ('remote_host');
$config -> define ('remote_dir', {ARGCOUNT => ARGCOUNT_HASH});
$config -> define ('remote_user');
$config -> define ('user', {ARGCOUNT => ARGCOUNT_HASH});
$config -> define ('override');
$config -> define ('distconf');
$config -> define ('dist_remote_dir');

open (CONF, $cfgfile)
	|| die "$0: Couldn't open configuration file $cfgfile: $!\n";
$config -> file (\*CONF);
close (CONF);

# sanity checks
if ($opts{'site'}) {
	# if a site is given, we need its name and the remote directory
	my $href = $config->get('remote_dir');
	unless (exists $href->{$opts{'site'}}) {
		die "$0: remote directory for site \"$opts{'site'}\" not defined\n";
	}
	$sitedefs{'remote_dir'} = $href->{$opts{'site'}};
	$href = $config->get('host');
	unless (exists $href->{$opts{'site'}}) {
		die "$0: remote host for site \"$opts{'site'}\" not defined\n";
	}
	$sitedefs{'host'} = $href->{$opts{'site'}};
	$href = $config->get('user');
	$sitedefs{'user'} = $href->{$opts{'site'}};
}

# determine architecture
$debarch = DebAux::Util::architecture();

my $debfile;

for (@ARGV) {
	if (/\.deb$/) {
		# Debian package file
		$debfile = $_;
		$infref = get_debinfo ($_);
		if (exists $pkgmap{$infref->{'package'}}) {
			if (compare_versions('>', $infref->{'version'},
								 $pkgmap{$infref->{'package'}}->{'version'})) {
				# remove entrie for older package
				delete $upmap{$pkgmap{$infref->{'package'}}->{'deb'}};
			} else {
				next;
			}
		}
#		push (@secdirs, $infref->{'section'});
		$upmap{$debfile} = {arch => $infref->{'arch'},
							dir => $infref->{'section'},
							deb => $debfile,
							dsc => dsc_filename ($infref),
							name => $infref->{'package'},
							priority => $infref->{'priority'},
							source => $infref->{'source'},
							version => $infref->{'version'},
						   };
		$pkgmap{$infref->{'package'}} = $upmap{$debfile};
	} else {
		die "$0: What is $_ ?\n";
	}
}

unless (keys %upmap) {
	die "$0: Nothing found to publish\n";
}

for (keys %upmap) {
	# complete entries for valid packages
	push(@{$srcmap{$upmap{$_}->{'source'}}->{'bin'}}, $upmap{$_}->{'name'});
	$srcmap{$upmap{$_}->{'source'}}->{'localdir'} = dirname($_);
	$srcmap{$upmap{$_}->{'source'}}->{'version'} = $upmap{$_}->{'version'};
	$srcmap{$upmap{$_}->{'source'}}->{'dir'} = $upmap{$_}->{'dir'};
}

my $distconfig;
my %distrmtdirs;
my $rmtdir;

# read distribution configuration file
my $distrcfile;
my %vars;

if ($opts{'distribution'}) {
	for (keys %upmap) {
		$vars{$upmap{$_}->{source}} = [$opts{'distribution'}];
		$vars{$upmap{$_}->{name}} = [$opts{'distribution'}];
	} 
} else {
	$distrcfile = $config->get('distconf');

	unless ($distrcfile) {
		die "$0: please specify distribution configuration file or use the distribution commandline option\n";
	}
	
	$distconfig	= new AppConfig ({GLOBAL => {ARGCOUNT => ARGCOUNT_LIST},
								  CREATE => 1,
								  ERROR => sub {conferror($distrcfile,@_)}});
	
	open (CONF, $distrcfile)
		|| die "$0: Couldn't open configuration file $distrcfile: $!\n";
	$distconfig -> file (\*CONF);
	close (CONF);
	%vars = $distconfig -> varlist ('.');
}

my $dscfile;

if ($opts{site}) {
	$rmtdir = $sitedefs{'remote_dir'};
} else {
	$rmtdir = $config -> get ('dist_remote_dir');
}

foreach my $src (keys %vars) {
	if (exists $srcmap{$src}) {
		# read corresponding .dsc file
		$dscfile = $srcmap{$src}->{localdir} . '/' . $src . '_' . cut_epoch($srcmap{$src}->{version}) . '.dsc';
		open (DSC, $dscfile)
			|| die ("$0: Couldn't open $dscfile\n");
		my ($afterfiles, @frags, @srcfiles);
		while (<DSC>) {
			if ($afterfiles) {
				last unless /\S/;
				s/^\s+//;
				@frags = split (/\s+/);
				push (@srcfiles, $frags[2]);
			} elsif (index ($_, 'Files:') == 0) {
				$afterfiles = 1;
			}
		}
		close (DSC);
		push (@srcfiles, $src . '_'
			  . cut_epoch ($srcmap{$src}->{version}) . '.dsc');
		for my $dist (@{$vars{$src}}) {
			next if $dist eq '1';
			my (@distfrags, $cmpop, $cmpversion, $sysret);
			@distfrags = split (/\s+/, $dist);
			if (@distfrags == 3) {
				($dist, $cmpop, $cmpversion) = @distfrags;
				my $cmpret = compare_versions($cmpop, $srcmap{$src}->{version},$cmpversion);
				next if $cmpret == 0; # skip this entry
			}
			
			$distmap{$dist} = 1;
			
			# add source files
			for my $srcfile (@srcfiles) {
				push (@{$rmtloc{$srcmap{$src}->{localdir} . '/' . $srcfile}},
					  join ('/',
							"dists/$dist/main/source",
							$srcmap{$src}->{dir}, $srcfile));
			}
			
			# loop over all corresponding binary packages
			for my $pkg (@{$srcmap{$src}->{'bin'}}) {
				push (@{$pkgmap{$pkg}->{dists}}, $dist);
				my $arch = $pkgmap{$pkg}->{arch};
				if ($arch eq 'all') {
					$arch = $debarch;
				}
				unless (grep {$_ eq $pkgmap{$pkg}->{arch}} @{$distarches{$dist}}) {
					push (@{$distarches{$dist}}, $arch);
				}
				push (@{$rmtloc{$pkgmap{$pkg}->{deb}}},
					  join ('/',
							"dists/$dist/main/binary-" . $pkgmap{$pkg}->{arch},
							$pkgmap{$pkg}->{dir},
							basename($pkgmap{$pkg}->{deb})));
				if ($pkgmap{$pkg}->{arch} eq 'all') {
					push (@{$rmtloc{$pkgmap{$pkg}->{deb}}},
						  join ('/',
								"dists/$dist/main/binary-$debarch",
								$pkgmap{$pkg}->{dir},
								basename($pkgmap{$pkg}->{deb})));
				}
			}
		}
	}
}

for (keys %rmtloc) {
	for my $loc (@{$rmtloc{$_}}) {
		$distrmtdirs{$rmtdir . '/' . dirname($loc)} = 1;
	}
}

sub conferror {
	my $file = shift;
	die "$0: $file: @_\n";
}

# CREATE REMOTE DIRECTORIES
# =========================

$rmtdir ||= '';

if ($rmtdir !~ m%^/\S+%) {
	die "$0: suspicious remote directory \"$rmtdir\"\n";
}

my $seclist = join (',', map{"'$_'"} (@secdirs, "$rmtdir/indices",
									  sort(keys(%distrmtdirs))));
my $script = <<'EOF';
use strict;
use File::Path;

my $dryrun = '@dryrun@';

if ($dryrun) {
    print "Creating directories @secdirs@\n";
} else {
    mkpath([@secdirs@], 1, 0755);
}

EOF

my $host = $config->get('remote_host');
my $user = $config->get('remote_user');

if ($opts{'site'}) {
	$host = $sitedefs{'host'};
	$user = $sitedefs{'user'};
}

remote_perl ($script, {secdirs => $seclist,
					   dryrun => $opts{'dry-run'}},
			 $host, $user);

# UPLOAD FILES
# ============

$script = << 'EOF';
use strict;
my $locs = @locs@;
my $dryrun = '@dryrun@';

chdir('@remotedir@') || die "Couldn't enter remote directory @remotedir@: $!\n";
for (@$locs) {
	if (-f $_ || -l $_) {
        if ($dryrun) {
            print "Unlinking $_\n";
        } else {
		    unlink($_) || die "Couldn't delete $_: $!\n";
        }
	}

    if ($dryrun) {
        print "Creating symbolic link from $_ to ../../../../../@original@\n";
    } else {
	    symlink('../../../../../@original@', $_) || die "Couldn't create symbolic link @original@ => $_: $!\n";
    }
}
EOF

my $sysret;

for (sort (keys %rmtloc)) {
	my @locs = @{$rmtloc{$_}};
	my $firstloc = shift(@locs);
	
	# copy first location
	if ($opts{'dry-run'}) {
		print "Running rsync $_ $user\@$host:$rmtdir/$firstloc\n";
	} else {
		$sysret = system ("rsync $_ $user\@$host:$rmtdir/$firstloc");
		if ($sysret) {
			die "Rsync failed with exit state ", $sysret >> 8, "\n";
		}
	}

	# symlink other locations
	remote_perl ($script,
				 {original => $firstloc,
				  locs => Dumper(\@locs),
				  remotedir => $rmtdir,
				  dryrun => $opts{'dry-run'}},
				  $host,
				  $user
				 );
}

# DELETE OLD PACKAGES, MANGLE OVERRIDE FILE, UPDATE PACKAGES FILE
# ===============================================================

my $ovfile = $config->get('override');

$script = << 'EOF';
use strict;
use File::Basename;
use File::Find;

# FUNCTION: cut_epoch
sub cut_epoch {
	my ($version) = @_;
	$version =~ s/^\d+://;
	$version;
}

my (@ovlines, $package, $state, $section);
my $pkgmap = @pkgdata@;
my $srcmap = @srcdata@;
my $dist = '@dist@';
my $archs = @archs@;
my $dryrun = '@dryrun@';

sub debcleaner {
    my ($package, $file, $var, $value);

	# remove broken symlinks
	if (-l $_ && ! -f readlink($_)) {
		if ($dryrun) {
			print "Deleting broken symlink $_\n";
		} else {
			print "Deleting broken symlink $_\n";
			unlink ($_) || die "$0: Couldn't delete symlink $_: $!\n";
		}
		return;
	}
	
    # consider only valid files
	return unless (-f $_ || -l $_);
#    return unless /\.deb$/;

    $file = $_;

	if (/\.deb$/) {
	    open (DPKGINF, "dpkg-deb --info $_ |");
		while (<DPKGINF>) {
			s/\s+$//;
			($var, $value) = split (/:\s*/);
			if ($var =~ /^ Package/) {
				$package = $value;
				last;
			}
		}
		close (DPKGINF) || die "$0: Bad exit state from dpkg-deb\n";

		# see if package corresponds to one of the published
		if (exists $$pkgmap{$package}) {
			if ($file ne basename($$pkgmap{$package}->{deb})) {
				# inappropriate package => need to delete it
				print "Delete $file\n";
				unless ($dryrun) {
					unlink ($file) || die "$0: Couldn't delete file $file: $!\n";
				}
			}
		}
	} elsif (/^(.*?)_(.*?)\.diff\.gz$/) {
		if (exists $$srcmap{$1}) {
			if ($file ne $1 . '_' . cut_epoch($$srcmap{$1}->{version}) . '.diff.gz') {
				print "Delete $file\n";
				unless ($dryrun) {
					unlink ($file) || die "$0: Couldn't delete file $file: $!\n";
				}
			}
		}
	} elsif (/^(.*?)_(.*?)\.dsc$/) {
		if (exists $$srcmap{$1}) {
			if ($file ne $1 . '_' . cut_epoch($$srcmap{$1}->{version}) . '.dsc') {
				print "Delete $file\n";
				unless ($dryrun) {
					unlink ($file) || die "$0: Couldn't delete file $file: $!\n";
				}
			}
		}
	} elsif (/^(.*?)_(.*?)\.orig\.tar\.gz$/) {
		if (exists $$srcmap{$1}) {
			my ($origversion) = split (/-/, cut_epoch($$srcmap{$1}->{version}));
			
			if ($file ne $1 . '_' . $origversion . '.orig.tar.gz') {
				print "Delete $file\n";
				unless ($dryrun) {
					unlink ($file) || die "$0: Couldn't delete file $file: $!\n";
				}
			}
		}
	}
}

find (\&debcleaner, '@rootdir@/main');

unless ($dryrun) {
unless (-f '@override@') {
	open (OVERRIDE, '>@override@');
	close (OVERRIDE);
}

open (OVERRIDE, '+<@override@')
	|| die ("$0: Couldn't open override file @override@: $!\n");
while (<OVERRIDE>) {
    chomp;
    next unless /\S/;
	my $distflag = 1;
	($package, $state, $section) = split;
	# is this a package just uploaded ?
	if (exists $$pkgmap{$package}) {
		if ($dist) {
			$distflag = grep {$_ eq $dist} @{$$pkgmap{$package}->{dists}};
			next unless $distflag;
		}
        push (@ovlines, join (' ', $package, $$pkgmap{$package}->{priority},
                              $$pkgmap{$package}->{dir}));
        delete $$pkgmap{$package};
    } else {
        push (@ovlines, $_);
    }
}
for (sort (keys %$pkgmap)) {
    push (@ovlines, join (' ', $_, $$pkgmap{$_}->{priority},
                          $$pkgmap{$_}->{dir}));
}
unless (truncate (OVERRIDE, 0)) {
    die ("$0: Couldn't truncate @override@: $!\n");
}
seek (OVERRIDE, 0, 0); 
print OVERRIDE join ("\n", @ovlines, ''); 
close(OVERRIDE);
for (@$archs) {
	chdir ("@rootdir@") || die "$0: Couldn't enter directory @rootdir@: $!\n";
	system ("dpkg-scanpackages main/binary-$_ '@override@' dists/$dist/ | gzip -c > main/binary-$_/Packages.gz");
}
chdir ("@rootdir@") || die "$0: Couldn't enter directory @rootdir@: $!\n";
system ("dpkg-scansources main/source '@override@' dists/$dist/ | gzip -c > main/source/Sources.gz");
}
EOF
	
#remote_perl ($script,
#			 {override => $config->get('override'),
#              pkgdata => Dumper(\%pkgmap),
#              rootdir => $config->get('remote_dir')},
#			 $config->get('remote_host'),
#			 $config->get('remote_user')
#			 );

for (sort (keys %distmap)) {
	print "Preparing distribution $_\n";
	remote_perl ($script,
				 {archs => Dumper($distarches{$_}),
				  dist => $_,
				  override => "$rmtdir/indices/override.$_",
				  pkgdata => Dumper(\%pkgmap),
				  rootdir => "$rmtdir/dists/$_",
				  srcdata => Dumper(\%srcmap),
				  dryrun => $opts{'dry-run'}},
				 $host,
				 $user
				);
}

# -----------------------------------------------
# FUNCTION: compare_versions OP VERSION1 VERSION2
#
# Compares versions VERSION1 and VERSION2 with
# operator OP. Returns the result.
# -----------------------------------------------

sub compare_versions {
	my ($op, $version1, $version2) = @_;
	my $sysret;
	
	$sysret = system ("dpkg --compare-versions '$version1' '$op' '$version2'");
	$sysret /= 256;
	
	if ($sysret != 0 && $sysret != 1) {
		die "$0: dpkg --compare-versions '$version1' '$op' '$version2' failed\n";
	}
	return ! $sysret;
}

# ----------------------------------------------------------
# FUNCTION: get_debinfo FILE
#
# Retrieves information about the Debian package and returns
# a hash reference with the following pieces of information:
#
# arch      architecture where the package belongs to
# package   package name
# priority  package priority
# section   category where the package belongs to
# source    source package name
# ----------------------------------------------------------

sub get_debinfo {
	my ($file) = @_;
	my (%infmap, $var, $value, $param);
	
	open (DPKGINF, "dpkg-deb --info $file |");
	while (<DPKGINF>) {
		s/\s+$//;
		($var, $value) = split (/:\s*/, $_, 2);
		if ($var =~ /^ Section/) {
			if ($value eq 'non-US/main') {
				$infmap{'section'} = 'non-us';
			} else {
				$infmap{'section'} = $value;
			}
		} elsif ($var =~ /^ Architecture/) {
			$infmap{'arch'} = $value;
		} elsif ($var =~ /^ Package/) {
			$infmap{'package'} = $value;
		} elsif ($var =~ /^ Priority/) {
			$infmap{'priority'} = $value;
		} elsif ($var =~ /^ Source/) {
			($value, $param) = split (/\s/, $value);
			$infmap{'source'} = $value;
			if (defined $param && $param =~ /\((.*?)\)/) {
				$infmap{'version'} = $1;
			}
		} elsif ($var =~ /^ Version/) {
			$infmap{'version'} = $value;
		}
	}
	close (DPKGINF) || die "$0: Bad exit state from dpkg-deb\n";

	# source package has the same name as the base package
	# if source not explicitly mentioned by dpkg-deb
	unless (exists $infmap{'source'}) {
		$infmap{'source'} = $infmap{'package'};
	}
	
	\%infmap;
}

# -------------------------------------------------
# FUNCTION: dsc_filename DEBINFREF
#
# Returns the name of the description file
# derived from the information stored in DEBINFREF.
# -------------------------------------------------

sub dsc_filename {
	my ($debinfref) = @_;

	$debinfref->{'package'} . '_' . $debinfref->{'version'} . '.dsc';
}

# --------------------------------------------------------
# FUNCTION: pooldir NAME
#
# Returns the name of the pool directory for package NAME.
# --------------------------------------------------------

sub pooldir {
	my ($name) = @_;

	join('/', substr($name,0,1), $name);
}

# FUNCTION: cut_epoch
sub cut_epoch {
	my ($version) = @_;
	$version =~ s/^\d+://;
	$version;
}

# FUNCTION: remote_perl SCRIPT REPLACEMENTS HOST USER

sub remote_perl {
	my ($script, $repref, $host, $user) = @_;
	my $reg;
	
	for (keys %$repref) {
		$reg = qr/\@$_\@/;
		$script =~ s/$reg/$$repref{$_}/eg;
	}

	sshopen2("$user\@$host", *READER, *WRITER, "/usr/bin/perl -");
	print WRITER $script;
	close WRITER;
	while (<READER>) {
		print;
	}
	close READER;
}

# DOCUMENTATION
# =============

=head1 NAME

debaux-publish - Debian package publishing script

=head1 SYNOPSIS

debaux-publish [OPTIONS] DEBFILES

=head1 VERSION

0.1.4

=head1 DESCRIPTION

debaux-publish is a helper script for publishing Debian packages.

=head1 OPTIONS

=over 4

=item C<-d NAME, --distribution NAME>

Forces debaux-publish to publish the package(s) to this distribution.

=item C<-n, --dry-run>

Don't actually publish anything.

=item C<--site=NAME>

Publish Debian packages on site NAME.

=back

=head1 SEE ALSO

dpkg(8), dpkg-scanpackages(8)

=head1 AUTHOR

Stefan Hornburg (Racke) <racke@linuxia.de>.

=head1 LICENSE

debaux-publish comes with ABSOLUTELY NO WARRANTY. This is free software, and
you are welcome to redistribute and modify it under the terms of the
GNU General Public License.

=head1 COPYRIGHT

Copyright 2000,2001,2002 Stefan Hornburg (Racke) <racke@linuxia.de>.

=cut
