Fetching contributors…
Cannot retrieve contributors at this time
executable file 758 lines (627 sloc) 18.5 KB
#!/usr/bin/perl -w
use strict;
use Scriptalicious;
#use YAML qw(LoadFile DumpFile Dump);
use Storable qw(nstore retrieve);
use File::Find qw(find);
use Set::Object 1.15, qw(set);
use List::Util qw(max);
use Digest::SHA1;
use Digest::MD5;
use Date::Manip qw(UnixDate);
use IO::Handle;
use IO::Plumbing;
use YAML::Syck qw(Dump);
use Cwd;
use Fcntl qw(:mode);
my @z = qw(gz bz2);
my %z_progs = (gz => [qw(gzip -9)],
bz2 => [qw(bzip2)] );
# hmm. This should really be configable. FIXME.
my %suites = (qw(woody oldstable
sarge stable
sid unstable
));
my $force_regen;
my $force_rescan;
my $path;
# these are actually per-repository, but nobody uses them anyway.
# perhaps what we could do is actually read them in from the old
# versions on-disk, so that changes persist.
my $def_origin = "ars-unconfigured";
my $def_label = "Unconfigured ARS";
my $def_desc = "An unconfigured apt-repository-simple";
my $origin;
my $label;
my $desc;
my $no_sign;
my $clean_old;
my $times_not_versions;
my $signing_key;
my $keyring;
my $no_gpg_agent;
my $perms;
my @gpg_options;
getopt getconf( "force-regen|f" => \$force_regen,
"force-rescan|F" => \$force_rescan,
"path|p=s" => \$path,
"origin|o=s" => \$origin,
"label|l=s" => \$label,
"desc|D=s" => \$desc,
"clean|c" => \$clean_old,
"newer|n" => \$times_not_versions,
"perms=s" => \$perms,
"shared" => sub { $perms = "2775" },
"no-sign|S" => \$no_sign,
"signing-key|k=s" => \$signing_key,
"keyring|K=s" => \$keyring,
"gpg-option|g=s\@" => \@gpg_options,
"no-agent" => \$no_gpg_agent,
);
if ($perms) {
oct($perms) or barf "bad octal value: $perms";
$perms = oct($perms);
}
if ( $path ) {
chdir($path) or barf "failed to change to $path; $!";
}
$path = cwd;
unless ( $no_gpg_agent or $ENV{GPG_AGENT_INFO} ) {
# try to find a running agent
for my $path ( </tmp/gpg-*/S.*> ) {
if ( -S $path ) {
my $pid=`fuser $path 2>/dev/null`;
chomp($pid);
if ( $pid ) {
whisper "using GPG agent PID $pid";
$ENV{GPG_AGENT_INFO}="$path:$pid:1";
last;
}
}
}
if ( !$ENV{GPG_AGENT_INFO} ) {
say "Starting the GPG agent";
my @vars = `gpg-agent -s --daemon 2>/dev/null`;
if ( $? ) {
moan "no GPG agent found - disabling GPG agent";
$no_gpg_agent = 1;
} else {
for ( @vars ) {
chomp;
my ($var, $val) = split "=", $_, 2;
$ENV{$var} = $val;
}
}
}
}
(my $sec_keyring = $keyring)
=~ s{(p)ubring}{secring};
undef($sec_keyring) unless $1;
push @gpg_options,
( ($no_gpg_agent? () : ("--use-agent")),
($signing_key ? ("--default-key", $signing_key) : ()),
($keyring ? ("--keyring", $keyring) : ()),
($sec_keyring ? ("--secret-keyring", $sec_keyring) : ()),
);
my @dirs = <pool/*>;
my @indep_dirs;
my %dists;
my %dist_dirs;
my $superceded = set();
my $all_arches = set();
for my $dir (@dirs) {
next unless -d $dir;
say "processing $dir";
my ($pool) = ($dir =~ m{.*/(.*)});
if (my ($dist, $arch) = ($pool =~ m{(.*)-(.*)})) {
if ($arch eq "all") {
push @{ $dists{$dist}||=[] }, $dir
} else {
push @{ $dist_dirs{$dist}{$arch} ||= [] }, $dir;
$all_arches->insert($arch);
}
} elsif ( $pool =~ m{^(all|indep|any)$} ) {
push @indep_dirs, $dir;
} else {
whisper "ignoring directory $dir";
next;
}
my $statefile = "$dir/packages.pm3";
my %pkgs;
my $dirty = 0;
if ( -e $statefile) {
%pkgs = %{ retrieve $statefile };
while (my ($k, $v) = each %pkgs) {
# spot a renamed pool and fix the data up.
my ($old_pool) = $v->{filename} =~ m{^pool/([^/]*)};
if ( $old_pool ne $pool ) {
#whisper "detected pool change in $v->{filename}";
$v->{filename} =~
s{^pool/\Q$old_pool\E}{pool/$pool};
$dirty = 1;
}
unless ( -e $v->{filename} ) {
delete $pkgs{$k};
$dirty = 1;
}
}
}
find(sub {
return if m{^(\.\.?|.*\.(yml|pm3|changes|tar.gz|dsc|diff.gz|groups))$};
(my $rel_filename = $File::Find::name) =~ s{^\./*}{};
if ( -f ) {
my ($pkg, $vers, $arch) = m{(.*)_(.*)_(.*).deb}
or do {
moan "file $rel_filename doesn't match debian form!";
return;
};
if ($pkgs{$pkg}) {
# ignore epoch for now
if ( $rel_filename eq $pkgs{$pkg}{filename} ) {
# force a rescan if the timestamp changes
if ( (stat _)[9] != $pkgs{$pkg}{mtime} ) {
#whisper "rescanning $pkg (mtime changed)";
delete $pkgs{$pkg};
}
}
elsif ( ( $times_not_versions
? ( $pkgs{$pkg}{mtime} < ((stat _)[9]) )
: ( debvers_cmp($pkgs{$pkg}{version}, $vers) < 0
or ( $pkgs{$pkg}{version} eq $vers
and $pkgs{$pkg}{mtime} != ((stat _)[9]))
) )
or ( ! -e "$path/$pkgs{$pkg}{filename}" )
) {
whisper "superceding $pkgs{$pkg}{filename} with $vers";
$superceded->insert($pkgs{$pkg}{filename});
delete $pkgs{$pkg};
} else {
whisper "$rel_filename is already superceded by "
."$pkgs{$pkg}{filename}";
$superceded->insert($rel_filename);
}
}
if (!$pkgs{$pkg} or $force_rescan) {
$dirty++;
mutter "adding $pkg from $rel_filename";
my $md5sum = `md5sum $_`;
($md5sum) = ($md5sum =~ m{^(\w+)});
my $filename = $_;
my @groups;
#stat $rel_filename;
my $mtime = ((stat _)[9]);
my $size = ((stat _)[7]);
if ( -f "$filename.groups" ) {
@groups = map { chomp; $_ } `cat $filename.groups`;
if ( !@groups ) {
unlink "$filename.groups";
}
}
$pkgs{$pkg} =
{
filename => $rel_filename,
version => $vers,
mtime => $mtime,
size => $size,
md5sum => $md5sum,
info => grok_dpkg_info($filename),
md5sums => get_md5sums($filename),
groups => set(@groups),
};
}
};
}, $dir);
if ($dirty) {
nstore reverse($statefile, \%pkgs)
}
mutter("$dir: $dirty package(s) updated");
}
for my $dist ( (set(keys %dists) + set(keys %dist_dirs))->members ) {
my $release = eval { retrieve 'dists/$dist/Release.pm3' } || [];
my $dirty;
my %done_contents;
my %sums;
my $files = set();
my $every_group = set();
unless ( grep !/^(sources|all)/, keys %{ $dist_dirs{$dist} } ) {
my @arches = $all_arches->members;
if ( ! @arches ) {
chomp(my $DEB_HOST_ARCH =
`(dpkg --print-architecture || uname -m) 2>/dev/null`);
@arches = $DEB_HOST_ARCH;
}
moan "dist '$dist' missing arch-specific dirs; using: @arches";
$dist_dirs{$dist}{$_}=[] for @arches;
$all_arches->insert(@arches);
}
for my $arch ( $all_arches->members ) {
# FIXME - write proper Sources files
next if $arch eq 'sources';
my @files = grep { -e }
map { "$_/packages.pm3" }
@{ $dist_dirs{$dist}{$arch}||[] },
@{ $dists{$dist} },
@indep_dirs;
mutter("preparing Contents files for $dist-$arch");
my @dirs = map { retrieve $_ } @files;
my %pkgs;
( -d "dists" ) || _mkdir("dists", $perms);
( -d "dists/$dist" ) || _mkdir("dists/$dist", $perms);
open CONTENTS, "| gzip > dists/$dist/Contents-$arch.gz";
print CONTENTS "Install the apt-file package to automatically search this file.
FILE LOCATION\n";
for my $dir (@dirs) {
while (my ($pkg, $info) = each %$dir) {
if ($pkgs{$pkg}) {
moan "package $pkg appears more than once in dirs for $dist-$arch";
} else {
$pkgs{$pkg} = $info;
my $md5sums = $info->{md5sums};
my @groups = ($info->{groups}||set())->members;
my ($primary_group) = ( (sort @groups), "all");
for (my $i = 0; $i < $#$md5sums; $i+=2) {
print CONTENTS $md5sums->[$i], " ", "$primary_group/$pkg", "\n";
}
}
}
}
close CONTENTS;
my $all_groups = set(map { ($_->{groups}||set())->members
} values %pkgs );
$every_group += $all_groups;
for my $group ( "all", $all_groups->members ) {
my $dir = "dists/$dist/$group/binary-$arch";
( -e $dir ) || _mkdir($dir, $perms);
open RELEASE, ">$dir/Release.new"
or barf "open($dir/Release.new) failed; $!";
my ($conf_origin, $conf_label) = @{{
map { chomp; split ": ", $_, 2 }
grep { m{^\w+: } }
`cat $dir/Release`
}}{qw(Origin Label)}
if ( -e "$dir/Release" );
my $release_data = join "", map { $_, "\n" }
"Archive: $dist",
"Component: $group",
"Origin: ${\( $origin || $conf_origin || $def_origin )}",
"Label: ${\( $label || $conf_label || $def_label )}",
"Architecture: $arch";
print RELEASE $release_data;
close RELEASE;
{
my $md5 = Digest::MD5->new();
my $sha1 = Digest::SHA1->new();
$md5->add($release_data);
$sha1->add($release_data);
my $length = length $release_data;
push @$release,
(
(join(":","MD5Sum",$md5->hexdigest,
$length,"$dir/Release"). "\n"),
(join(":","SHA1",$sha1->hexdigest,
$length,"$dir/Release"). "\n")
);
}
my $Packages = "$dir/Packages";
my $max = (max map { ((stat $_)[9]) } @files) ;
if ( ($max||0) < ((stat $Packages)[9]||0) and !$force_regen ) {
mutter "no new packages in $dist-$arch ($group)";
# we still need to get the sums...
for my $file ( $Packages, "$Packages.gz", "$Packages.bz2" ) {
next unless -f $file;
mutter "getting checksums for $file";
local($/)=\((stat _)[11]||4096);
open FILE, "<$file" or die $!;
binmode FILE;
my $md5 = Digest::MD5->new();
my $sha1 = Digest::SHA1->new();
my $length = 0;
while ( <FILE> ) {
$md5->add($_);
$sha1->add($_);
$length += length;
}
close FILE;
push @$release,
(
(join(":","MD5Sum",$md5->hexdigest,
$length,"$file"). "\n"),
(join(":","SHA1",$sha1->hexdigest,
$length,"$file"). "\n")
);
}
next;
}
# this fragment will write out a packages file to STDOUT
my $print_packages = new IO::Plumbing
code => sub {
for my $pkg (sort keys %pkgs) {
next unless $group eq "all" or
($pkgs{$pkg}{groups} and
$pkgs{$pkg}{groups}->includes($group));
print map {
$_
} ($n++ ? "\n" : ""), display($pkgs{$pkg});
}
};
# checksum each compression format separately
my %hashers;
for my $ext ( "", map { ".$_" } @z ) {
$hashers{$ext} =
new IO::Plumbing
code => sub {
my $md5 = Digest::MD5->new();
my $sha1 = Digest::SHA1->new();
while (<STDIN>) {
$length += length $_;
$md5->add($_);
$sha1->add($_);
print $_;
}
print(join(":","MD5Sum",$md5->hexdigest,
$length,"$Packages.$ext"), "\n",
join(":","SHA1",$sha1->hexdigest,
$length,"$Packages.$ext"), "\n");
};
}
# make the compressor plumbs
my %compressors;
for ( @z ) {
$compressors{$_} = plumb $z_progs{$_};
}
# this sort of thing should get built into IO::Plumbing
my $tee = new IO::Plumbing
code => sub {
my @hoses = map { hose(output => $compressors{$_}) }
@z, $hashers{""};
while ( <STDIN> ) {
for my $hose ( @hoses ) {
print { $hose->out_fh } $_;
}
}
};
# so, now...
# for getting back MD5 and SHA1 sums
my $bucket = bucket($release);
$print_packages->output($tee);
for ( "", @z ) {
$hashers{$_}->output($bucket)
}
$print_packages->execute;
my $errors;
for my $plumb ( $print_packages, values %hashers,
values %compressors, $bucket
) {
if ( !$plumb->ok ) {
moan "$plumb exploded; ".$plumb->error;
$errors++;
}
}
barf "pipeline exploded, aborting" if $errors;
# just like that! :)
}
mutter "preparing Release file for $dist";
nstore $release, "dists/$dist/Release.pm3";
}
my ($conf_origin, $conf_label, $conf_desc) = @{{
map { chomp; split ": ", $_, 2 }
grep { m{^\w+: } }
`cat dists/$dist/Release`
}}{qw(Origin Label Description)}
if ( -e "dists/$dist/Release" );
open RELEASE, ">dists/$dist/Release.new" or barf "open(>dists/$dist/Release.new) failed; $!";
print RELEASE "Origin: ${\( $origin || $conf_origin || $def_origin )}
Label: ${\( $label || $conf_label || $def_label )}
Suite: ${\( $suites{$dist} || $dist )}
Codename: $dist
Date: ".UnixDate("now", "%g")."
Architectures: ".join(" ",( grep { $_ ne "sources" }
keys %{ $dist_dirs{$dist} } ))."
Components: all @{[ sort $every_group->members ]}
Description: ${\( $desc || $conf_desc || $def_desc )}
";
for my $line (@$release) {
my ($type, $digest, $length, $filename) = split ":", $line;
chomp($filename);
$sums{$type}{$filename} = [ $digest, $length ];
$files->insert($filename)
if ( -e "$filename.new" );
}
for my $type (qw(MD5Sum SHA1)) {
print RELEASE "$type:\n";
for my $filename (sort keys %{ $sums{$type} }) {
my ($digest, $length) = @{ $sums{$type}{$filename} };
$filename =~ s{dists/$dist/}{};
printf RELEASE " %s %16d %s\n", $digest, $length, $filename;
}
}
close RELEASE;
say "wrote dists/$dist/Release";
unless ( $no_sign ) {
unlink("dists/$dist/Release.new.asc");
run(-in => \*STDIN, -out => \*STDOUT,
"gpg", @gpg_options, "-b", "-a", "dists/$dist/Release.new");
if ( ! -s "dists/$dist/Release.new.asc" ) {
moan("gpg sign failed; rc=$?");
} else {
rename("dists/$dist/Release.new.asc", "dists/$dist/Release.gpg.new");
$files->insert("dists/$dist/Release.gpg");
}
}
for my $file ($files->members, "dists/$dist/Release") {
rename("$file.new", $file) or barf("rename($file.new, $file) failed; $!");
}
}
if ( $clean_old and $superceded->size ) {
say "deleting superceded files:";
for ( sort @$superceded ) {
print " $_\n";
}
unlink(@$superceded);
}
exit 0;
sub display {
my $info = shift;
my $dpkg_info = $info->{info};
my @rv;
for (my $i = 0; ($i * 2)+2 < @$dpkg_info; $i++) {
push @rv, $dpkg_info->[($i*2)], ": ", $dpkg_info->[($i*2)+1], "\n";
}
push @rv, "Filename: ", $info->{filename}, "\n";
push @rv, "Size: ", $info->{size}, "\n";
push @rv, "MD5sum: ", $info->{md5sum}, "\n";
push @rv, $dpkg_info->[$#$dpkg_info-1], ": ",
$dpkg_info->[$#$dpkg_info],"\n";
if ( grep { !defined } @rv ) {
moan "display for $info->{filename} returns: ";
say Dump \@rv;
say "info is:";
say Dump $info;
}
return @rv;
}
sub grok_dpkg_info {
my $filename = shift;
my $data = capture(qw(dpkg -I), $filename);
scalar($data =~ m{\A.*^ Package: (\S+)\n}msg);
my @data = ( "Package" => $1 );
while ($data =~ m{\G (\S+): ((?-s:.*(\n .*)*))\n}sg) {
my ($what, $value) = ($1, $2);
$value =~ s{^ }{}mg;
chomp($value);
push @data, $what => $value;
}
return \@data;
}
sub get_md5sums {
my $filename = shift;
my ($err, @data) = capture_err(qw(dpkg -I), $filename, "md5sums");
return undef if $err;
my @sums = map { chomp; m/(\S+)\s*(.*)/ && ($2 => $1) } @data;
return \@sums;
}
sub split_debver {
return (my ($epoch, $version, $pkg_version) = ($_[0] =~ m{^(?:(\d+):)?(\d+.*?)(?:-(\d[^\-]*))?$}));
}
sub cmp_vers {
my $A = shift;
$A = "" if !defined $A;
my $B = shift;
$B = "" if !defined $B;
my @p_a = split /\./, $A;
my @p_b = split /\./, $B;
my $rv;
while (@p_a or @p_b) {
my $a = shift @p_a;
my $b = shift @p_b;
if (defined $a and !defined $b) {
return 1;
}
elsif (defined $b and !defined $a) {
return -1;
}
elsif ( $a > $b ) {
return 1;
}
elsif ( $b > $a ) {
return -1;
}
}
return 0;
}
sub debvers_cmp {
my ($a_ep, $a_v, $a_post) = split_debver(shift);
my ($b_ep, $b_v, $b_post) = split_debver(shift);
cmp_vers($a_ep, $b_ep)
or
cmp_vers($a_v, $b_v)
or
cmp_vers($a_post, $b_post)
}
sub _mkdir {
my $dir = shift;
my $perms = shift;
my ($dn) = ($dir =~ m{(.*)/[^/]*/?$});
if ( $dn and ! -d $dn ) {
_mkdir($dn, $perms);
}
if ( ! -d $dir ) {
mkdir($dir) or barf "mkdir($dir) failed; $!";
stat $dir;
}
if ($perms) {
my $mode = (stat _)[2];
if ($mode & 07777 != $perms ) {
chmod($perms, $dir) or barf "chmod($perms, $dir) failed; $!";
}
}
}
__END__
=head1 NAME
ars-update - update Packages files in simple apt repositories
=head1 SYNOPSIS
ars-update [options]
=head1 DESCRIPTION
This script scans a pool of directories (in F<pool/>), which are
assumed to be in the form I<dist>-I<arch> (where I<arch> may be
C<all>, or a real arch like C<i386> or C<amd64>).
This script works a bit like C<dpkg-scanpackages>, its principle
difference being that it caches information between runs. This makes
it orders of magnitude faster for many common cases.
=head1 COMMAND LINE OPTIONS
=over
=item B<-f, --force-regen>
Force all Packages lists to be regenerated, not just the ones that
changed.
=item B<-F, --force-rescan>
Force all packages to be checksummed and scanned, not just the ones
whose filestamps changed.
=item B<-p, --path=PATH>
Specify a directory other than the working directory that the APT
repository is rooted.
=item B<-o, --origin=ORIGIN>
Specify the APT Origin. Used to pin packages with
/etc/apt/preferences, etc.
=item B<-l, --label=LABEL>
Specify the APT Label. Similar use to Origin.
=item B<-D, --desc="Description">
An optional description of the archive.
=item B<-S, --no-sign>
Don't try to generate F<.asc> files for the F<Packages> and F<Release>
files. These files allow packages to be installed without warning the
user about them being unsigned - but only if the user also has the key
used for signing in their APT keyring. See L<apt-key>.
=item B<-k, --signing-key=ID>
Specify the PGP key used for signing.
=item B<-K, --keyring=FILE>
Specify the keyring in which to find the private PGP key used for
signing.
=item B<-g, --gpg-option=X>
Aux. method for feeding gpg commandline options
=item B<--no-agent>
Suppress the C<--use-agent> option to GPG.
=item B<-c, --clean>
Delete all packages which have newer packages in the same pool dir.
=item B<-n, --newer>
When deciding if a package is older or newer than another one with the
same name, use the timestamp, not the version number.
=item B<-h, --help>
Display a program usage screen and exit.
=item B<-V, --version>
Display program version and exit.
=item B<-v, --verbose>
Verbose command execution, displaying things like the
commands run, their output, etc.
=item B<-q, --quiet>
Suppress all normal program output; only display errors and
warnings.
=item B<-d, --debug>
Display output to help someone debug this script, not the
process going on.
=back
=head1 SEE ALSO
L<dpkg-scanpackages>, L<dpkg-deb>, L<apt>
=head1 AUTHOR
Sam Vilain, <samv@cpan.org>
Sponsored by Catalyst IT Ltd, L<http://www.catalyst.net.nz/>
=cut