Subversion Repositories

#! /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: