Rev 6 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
#! /usr/bin/perl -w
#####
#
# Copyright 2003-2004 Joel Baker. All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# 3. Neither the name of the Author nor the names of any contributors
# may be used to endorse or promote products derived from this software
# without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
# $Id: debpool 54 2005-02-21 21:48:29Z joel $
#
#####
# Put our private support module area into the search path
use lib '/usr/share/debpool/perl5';
# We always want to be careful about things...
use strict;
use warnings;
use POSIX; # This gets us strftime.
# First things first - figure out how we need to be configured.
use Getopt::Long qw(:config pass_through);
use DebPool::Config qw(:functions :vars);
my($help);
GetOptions('help!' => \$help);
if (defined($help)) {
#23456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789 |
print "Usage: debpool [Options]
Pool-based Debian package archive manager
--config=configfile May be issued multiple times; each time it is used, it will
add the named config file to the list which DebPool will
load (later config files override earlier ones, in case of
any conflicts).
--daemon Run debpool as a daemon.
--debug Run debpool in debug mode. Identical to daemon mode but
remains in foreground.
--help Displays this help text.
--dumpdb Dumps the debpool database.
--log_file=filename Send logging output to the specified filename.
--rebuild-files Forces all of the distribution files (Packages and Sources)
to be rebuilt.
--rebuild-dbs Forces all of the metadata files to be rebuilt from scratch.
WARNING: This feature is not yet implemented
--rebuild-all Turn on all other rebuild options (currently --rebuild-files
and --rebuild-dbs).
WARNING: This feature depends on rebuild-dbs, which is not
yet implemented; only the --rebuild-files section will be
triggered.
";
exit(0);
}
# First, grab --config and --nodefault options if they exist. We
# don't want these in the %Options hash, and they affect what we do when
# loading it.
my(@config_files);
my($default);
GetOptions('config=s' => \@config_files, 'default!' => \$default);
# Call Load_Default_Configs if we're loading default values, or
# Load_Minimal_Configs if we're not (we still need the OptionDefs hash to
# be populated).
if (!defined($default) || $default) {
Load_Default_Configs();
} else {
Load_Minimal_Configs();
}
# Load any config files we were given.
my($config);
foreach $config (@config_files) {
Load_File_Configs($config);
}
# And finally, pull in any other command line options.
GetOptions(\%Options, values(%OptionDefs));
# Run the cleanup stuff on %Options.
Clean_Options();
# Okay. We're more or less ready to go. First, load some modules that we
# know we'll be calling.
use DebPool::Dirs qw(:functions :vars); # Directory management
use DebPool::DB qw(:functions :vars); # Various databases
use DebPool::GnuPG qw(:functions :vars); # GnuPG interaction routines
use DebPool::Gzip qw(:functions :vars); # Gzip interaction routines
use DebPool::Logging qw(:functions :facility :level); # Logging routines
use DebPool::Packages qw(:functions :vars); # Distribution databases
use DebPool::Signal qw(:functions :vars); # Handle signals
# Before we do anything else, let's find out if we need to act as a daemon,
# and if so, whether we can manage to pull it off.
if ($Options{'daemon'}) {
Log_Message("Trying to enter daemon mode.", LOG_GENERAL, LOG_DEBUG);
require Proc::Daemon;
Proc::Daemon::Init();
Log_Message("Now running as a daemon.", LOG_GENERAL, LOG_DEBUG);
}
# Create the directory tree. This is clean even it it already exists,
# so we can do it every time we start up. I believe the fancy word is
# 'idempotent'. We do this before grabbing a lockfile because it should
# never screw anything up, even if run multiple times at once, and our
# lockfile may be (probably is, in fact) in one of these places.
if (!Create_Tree()) {
my($msg) = "Couldn't create directory tree: $DebPool::Dirs::Error";
Log_Message($msg, LOG_GENERAL, LOG_FATAL);
die "$msg\n";
}
# Obtain a lockfile. We should never run more than one occurance; it's too
# likely that we'd step on our own toes.
if (!sysopen(LOCK_FILE, $Options{'lock_file'}, O_WRONLY|O_CREAT|O_EXCL, 0644)) {
my($msg) = "Couldn't obtain lockfile '$Options{'lock_file'}'; ";
if (open(LOCK_FILE, '<', $Options{'lock_file'}) &&
(my($pid) = <LOCK_FILE>)) {
chomp($pid);
$msg .= "(PID $pid)\n";
} else {
$msg .= "(unable to read PID)\n";
}
die $msg;
} else { # Do something useful - like put our PID into the file.
print LOCK_FILE "$$\n";
close(LOCK_FILE);
}
# Start the main loop. We use a do/until loop so that we always fire off at
# least once.
MAIN_LOOP: do {
Log_Message("Starting processing run", LOG_GENERAL, LOG_DEBUG);
# First off, open up our databases. We do this each time through the loop,
# so that they get flushed periodically if we're in daemon mode.
Open_Databases();
# This keeps track of what distributions need to have their Packages and
# Sources files rebuilt. We force it to be 'everything' if the user has
# requested a rebuild (normally from the command line).
my(%rebuild) = ();
if ($Options{'rebuild-files'}) {
my($dist);
foreach $dist (@{$Options{'realdists'}}) {
$rebuild{$dist} = 1;
}
}
# Check for any changes files in the incoming directory.
my(@changefiles) = Scan_Changes($Options{'incoming_dir'});
# Go through each of the changes files we found, and process it. This is the
# heart of things.
my($changefile);
foreach $changefile (@changefiles) {
Log_Message("Processing changefile '$changefile'", LOG_GENERAL, LOG_INFO);
# .dsc = .changes, minus the part after the last _, plus .dsc
my(@parts) = split(/_/, $changefile);
pop(@parts);
my($dscfile) = join('_', @parts) . '.dsc';
my($changes_data) = Parse_Changes("$Options{'incoming_dir'}/$changefile");
if (!defined($changes_data)) {
Log_Message("Failure parsing changes file '$changefile': " .
$DebPool::Packages::Error, LOG_GENERAL, LOG_ERROR);
next;
}
my($with_source) = undef; # Upload with or without source?
my($temp);
for $temp (@{$changes_data->{'Architecture'}}) {
if ('source' eq $temp) {
$with_source = 1;
}
}
my($has_orig) = undef; # Has an orig tarball?
my($filehr);
foreach $filehr (@{$changes_data->{'Files'}}) {
if ($filehr->{'Filename'} =~ /orig\.tar\.gz/) {
$has_orig = 1;
}
}
my($dsc_data) = Parse_DSC("$Options{'incoming_dir'}/$dscfile");
if ($with_source && !defined($dsc_data)) {
Log_Message("Failure parsing dsc file '$dscfile': " .
$DebPool::Packages::Error, LOG_GENERAL, LOG_ERROR);
next;
}
my($package) = $changes_data->{'Source'};
my($version) = $changes_data->{'Version'};
if ($Options{'require_sigs_meta'}) {
# First, check the changefile signature
if (!Check_Signature("$Options{'incoming_dir'}/$changefile")) {
Reject_Package($changefile, $changes_data);
Log_Message("GPG signature failure in changes file '$changefile'",
LOG_REJECT, LOG_ERROR);
next;
} else {
Log_Message("Successful changes signature: '$changefile'",
LOG_GPG, LOG_DEBUG);
}
# Now check the dscfile signature
if ($with_source && !Check_Signature("$Options{'incoming_dir'}/$dscfile")) {
Reject_Package($changefile, $changes_data);
Log_Message("GPG signature failure in dsc file '$dscfile'",
LOG_REJECT, LOG_ERROR);
next;
} else {
Log_Message("Successful dsc signature: '$dscfile'",
LOG_GPG, LOG_DEBUG);
}
}
# Verify MD5 checksums on all files.
my($valid) = 1;
foreach $filehr (@{$changes_data->{'Files'}}) {
if (!(Verify_MD5("$Options{'incoming_dir'}/$filehr->{'Filename'}",
$filehr->{'MD5Sum'}))) {
$valid = undef;
}
}
if (!$valid) {
Reject_Package($changefile, $changes_data);
my($msg) = "MD5 checksum failure in changes file '$changefile'";
Log_Message($msg, LOG_REJECT, LOG_ERROR);
next;
}
$valid = 1;
my($rejected) = undef;
if ($with_source) {
foreach $filehr (@{$dsc_data->{'Files'}}) {
# A bit of a special case here; if the Changes file lists an
# orig tarball, we must *not* have one for that version in the
# pool. If it doesn't, then we *must* have one. In either case,
# as long as it's in the right place we use that file for the
# MD5Sum check when the file is listed in the DSC.
my($file) = $filehr->{'Filename'};
if ($file =~ /orig\.tar\.gz/) {
my($section) = Guess_Section($changes_data);
my($pkg_pooldir) = join('/',
($Options{'pool_dir'}, PoolDir($package, $section),
$package));
if ($has_orig) { # Orig tarball uploaded
if (-e "$pkg_pooldir/$file") {
Reject_Package($changefile, $changes_data);
my($msg) = "Duplicate orig tarball '$file'";
Log_Message($msg, LOG_REJECT, LOG_ERROR);
$rejected = 1;
last; # Don't check other files, we just rejected
} elsif (!(-e "$Options{'incoming_dir'}/$file")) {
Reject_Package($changefile, $changes_data);
my($msg) = "Missing orig tarball '$file'";
Log_Message($msg, LOG_REJECT, LOG_ERROR);
$rejected = 1;
last; # Don't check other files, we just rejected
} else {
$file = "$Options{'incoming_dir'}/$file";
}
} else { # Orig tarball in pool - we hope
if (!(-e "$pkg_pooldir/$file")) {
Reject_Package($changefile, $changes_data);
my($msg) = "Missing orig tarball '$file'";
Log_Message($msg, LOG_REJECT, LOG_ERROR);
$rejected = 1;
last; # Don't check other files, we just rejected
} else {
$file = "$pkg_pooldir/$file";
}
}
} else { # Not an orig tarball - must be in upload
$file = "$Options{'incoming_dir'}/$file";
}
# Whatever it is, it must also pass the MD5 checksum test.
if (!(Verify_MD5($file, $filehr->{'MD5Sum'}))) {
$valid = undef;
last; # Don't check other files, we already failed
}
}
}
next if ($rejected); # Reject message already logged, go to next package.
if (!$valid) {
Reject_Package($changefile, $changes_data);
my($msg) = "MD5 checksum failure in dsc file '$dscfile'";
Log_Message($msg, LOG_REJECT, LOG_ERROR);
next;
}
# Go through each distribution in the changes file, and decide whether
# the package is valid for that distribution.
my($distribution, $realdist);
my(@valid_dists);
foreach $distribution (@{$changes_data->{'Distribution'}}) {
$realdist = $distribution;
if (defined($Options{'virtual_dists'}->{$realdist})) {
$realdist = $Options{'virtual_dists'}->{$realdist};
}
if (defined($Options{'dists'}->{$realdist})) {
$realdist = $Options{'dists'}->{$realdist};
}
if (!defined($realdist)) {
Log_Message("Distribution $distribution does not exist",
LOG_INSTALL, LOG_ERROR);
next;
}
my($allow) = Allow_Version($package, $version, $realdist);
if (!defined($allow)) {
Log_Message("Version check for $version failed: " .
$DebPool::Packages::Error, LOG_INSTALL, LOG_ERROR);
next;
}
if (!$allow) {
Log_Message("Cannot install version $version of $package to " .
"$realdist", LOG_INSTALL, LOG_WARNING);
next;
}
# It's valid. Put it in the list.
push(@valid_dists, $realdist);
}
if (-1 == $#valid_dists) {
Reject_Package($changefile, $changes_data);
Log_Message("No valid distributions for version $version of $package",
LOG_REJECT, LOG_ERROR);
next;
}
# Install the package
if (Install_Package($changefile, $changes_data, $dscfile, $dsc_data, \@valid_dists)) {
my($dist);
foreach $dist (@valid_dists) {
$rebuild{$dist} = 1;
}
my($msg) = "Installed $package ($version) to ";
$msg .= "distribution(s): " . join(', ', @valid_dists);
Log_Message($msg, LOG_INSTALL, LOG_INFO);
} else {
# Something is very, very wrong.
Log_Message("Couldn't install package '$package': " .
$DebPool::Packages::Error, LOG_INSTALL, LOG_FATAL);
Close_Databases();
unlink($Options{'lock_file'}); # Release our lock
die "Couldn't install package '$package'\n";
}
# And, now that that's done, audit the package area in the pool to get
# rid of crufty, obsolete versions.
Audit_Package($package, $changes_data);
}
# Regenerate {Packages,Sources}{,.gz} for distributions which need it. Also
# rebuild Release files that need it, if we're doing them.
my($dist, $section);
foreach $dist (keys(%rebuild)) {
my(@rel_filelist) = ();
foreach $section (@{$Options{'sections'}}) {
my(@archs) = @{$Options{'archs'}};
@archs = grep(!/^all$/, @archs); # We don't build binary-all files.
my($arch);
ARCH_LOOP:
foreach $arch (@{$Options{'archs'}}) {
# We cheat, and use @triple for dist/section/arch inputs.
# Perl lets us get away with this. I'd care, except that Perl
# prototyping isn't, so it's useless to not do this.
my(@triple) = ($dist, $section, $arch);
# Generate a Packages/Sources file.
my($file) = Generate_List(@triple);
if (!defined($file)) {
my($msg) = "Couldn't create list for $dist/$section/${arch}: ";
$msg .= $DebPool::Packages::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
next;
}
# If we're compressing distribution files, do that here.
my($gzfile);
if ($Options{'compress_dists'}) {
$gzfile = Gzip_File($file);
if (!defined($gzfile)) {
my($msg) = "Couldn't create compressed file: ";
$msg .= $DebPool::Gzip::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
unlink($file);
next;
}
}
# If we're doing Release files, now is the time for triples.
my($relfile);
my($sigfile);
if ($Options{'do_release'}) {
require DebPool::Release;
# Release versions are YYYY.MM.DD.HH.MM.SS (GMT) by default.
my($release_version) = strftime('%Y.%m.%d.%H.%M.%S', gmtime());
$relfile = DebPool::Release::Generate_Release_Triple(
@triple, $release_version);
if (!defined($relfile)) {
my($msg) = "Couldn't create Release file: ";
$msg .= $DebPool::Release::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
unlink($file);
if (defined($gzfile)) {
unlink($gzfile);
}
next;
}
if ($Options{'sign_release'}) {
$sigfile = Sign_Release($relfile);
if (!defined($sigfile)) {
my($msg) = "Couldn't create Release signature file: ";
$msg .= $DebPool::GnuPG::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
unlink($file);
if (defined($gzfile)) {
unlink($gzfile);
}
if (defined($relfile)) {
unlink($relfile);
}
next;
}
}
}
# Install {Packages,Sources}{,.gz}
if (!Install_List(@triple, $file, $gzfile)) {
my($msg) = "Couldn't install distribution files for ";
$msg .= "$dist/$section/${arch}: " . $DebPool::Packages::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
if (-e $file) {
unlink($file);
}
if (defined($gzfile) && -e $gzfile) {
unlink($gzfile);
}
if (defined($relfile) && -e $relfile) {
unlink($relfile);
}
if (defined($sigfile) && -e $sigfile) {
unlink($sigfile);
}
next;
}
# Install Release{,.gpg}
if (defined($relfile) &&
!DebPool::Release::Install_Release(@triple, $relfile, $sigfile)) {
my($msg) = "Couldn't install release files for ";
$msg .= "$dist/$section/${arch}: " . $DebPool::Release::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
if (-e $relfile) {
unlink($relfile);
}
if (defined($sigfile) && -e $sigfile) {
unlink($sigfile);
}
next;
}
my($pushfile) = Archfile(@triple, 0);
$pushfile =~ s/${dist}\///;
push(@rel_filelist, $pushfile);
if (defined($gzfile)) {
push(@rel_filelist, $pushfile . '.gz');
}
if (defined($relfile)) {
$pushfile = Archfile(@triple, 1);
$pushfile =~ s/${dist}\///;
$pushfile .= '/Release';
push(@rel_filelist, $pushfile);
if (defined($sigfile)) {
push(@rel_filelist, $pushfile . '.gpg');
}
}
}
}
# If we're doing Release files, now is the time for the general dist one.
my($relfile);
my($sigfile);
if ($Options{'do_release'}) {
require DebPool::Release;
# Release versions are YYYY.MM.DD.HH.MM.SS (GMT) by default.
my($release_version) = strftime('%Y.%m.%d.%H.%M.%S', gmtime());
$relfile = DebPool::Release::Generate_Release_Dist(
$dist, $release_version, @rel_filelist);
if (!defined($relfile)) {
my($msg) = "Couldn't create Release file: ";
$msg .= $DebPool::Release::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
} else {
if ($Options{'sign_release'}) {
$sigfile = Sign_Release($relfile);
if (!defined($sigfile)) {
my($msg) = "Couldn't create Release signature file: ";
$msg .= $DebPool::GnuPG::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
unlink($relfile);
$relfile = undef;
}
}
}
}
# Install Release{,.gpg}
if (defined($relfile) &&
!DebPool::Release::Install_Release($dist, undef, undef,
$relfile, $sigfile)) {
my($msg) = "Couldn't install release files for ";
$msg .= "${dist}: " . $DebPool::Release::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
if (-e $relfile) {
unlink($relfile);
}
if (defined($sigfile) && -e $sigfile) {
unlink($sigfile);
}
}
}
# Close out the databases, ensuring that they're flushed to disk. We'll
# just reopen them in a moment, if we're in daemon mode; it's still good to
# write them out.
Close_Databases();
# This will short-circuit if we catch a signal while sleeping.
if ($Options{'daemon'}) {
Log_Message("Waiting on changes to incoming dir.", LOG_GENERAL, LOG_DEBUG);
if (!Monitor_Incoming()) {
my($msg) = "Error in Monitor_Incoming: " . $DebPool::Dirs::Error;
Log_Message($msg, LOG_GENERAL, LOG_ERROR);
}
}
# End of MAIN_LOOP; we loop back until either we're not in daemon mode
# (that is, we've been told to single-pass), or until we catch a signal.
} until ((!$Options{'daemon'}) || $Signal_Caught);
# Release our lock
unlink($Options{'lock_file'});
Log_Message("Exiting.", LOG_GENERAL, LOG_DEBUG);
exit(0);
__END__
# vim:set tabstop=4 expandtab: