diff -r 71503088f51b -r f880f219c566 openpkg/lint-rpm.pl --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/openpkg/lint-rpm.pl Tue Jul 31 12:23:42 2012 +0200 @@ -0,0 +1,447 @@ +## +## lint-rpm.pl -- OpenPKG *.rpm File Checker +## Copyright (c) 2000-2012 OpenPKG GmbH +## +## This software is property of the OpenPKG GmbH, DE MUC HRB 160208. +## All rights reserved. Licenses which grant limited permission to use, +## copy, modify and distribute this software are available from the +## OpenPKG GmbH. +## +## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED 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 AUTHORS AND COPYRIGHT HOLDERS AND THEIR +## 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. +## + +# Perl run-time requirement +require 5; +BEGIN { + eval "use Getopt::Long; use IO;"; + if ($@) { + print STDERR + "lint-rpm: ERROR: This command requires a full-size Perl installation!\n" . + "lint-rpm: HINT: Install OpenPKG \"perl\" package to use this command.\n"; + exit(1); + } +} + +# OpenPKG instance prefix +my $my_prefix = $ENV{'OPENPKG_PREFIX'}; +delete $ENV{'OPENPKG_PREFIX'}; + +# program information +my $progname = "lint-rpm"; +my $progvers = "1.0.0"; + +# parameters (defaults) +my $version = 0; +my $verbose = 0; +my $help = 0; +my $check = 'all'; +my $tmpdir = ($ENV{TMPDIR} || $ENV{TEMPDIR} || "/tmp") . "/$progname"; +my $rpm = "$my_prefix/bin/openpkg rpm"; +my $rpm2cpio = "$my_prefix/bin/openpkg rpm2cpio"; + +# exception handling support +$SIG{__DIE__} = sub { + my ($err) = @_; + $err =~ s|\s+at\s+.*||s if (not $verbose); + print STDERR "$progname:ERROR: $err ". ($! ? "($!)" : "") . "\n"; + exit(1); +}; + +# command line parsing +Getopt::Long::Configure("bundling"); +my $result = GetOptions( + 'V|version' => \$version, + 'v|verbose' => \$verbose, + 'h|help' => \$help, + 'c|check=s' => \$check, + 't|tmpdir=s' => \$tmpdir, + 'r|rpm=s' => \$rpm, +) || die "option parsing failed"; +if ($help) { + print "Usage: $progname [options] [RPMFILE ...]\n" . + "Available options:\n" . + " -v,--verbose enable verbose run-time mode\n" . + " -h,--help print out this usage page\n" . + " -c,--check=CHECKS select checks to perform (default='all')\n" . + " -r,--rpm=FILE filesystem path to RPM program\n" . + " -t,--tmpdir=PATH filesystem path to temporary directory\n" . + " -V,--version print program version\n"; + exit(0); +} +if ($version) { + print "OpenPKG $progname $progvers\n"; + exit(0); +} + +# verbose message printing +sub msg_verbose { + my ($msg) = @_; + print STDERR "$msg\n" if ($verbose); +} + +# warning message printing +sub msg_warning { + my ($msg) = @_; + print STDERR "$progname:WARNING: $msg\n"; +} + +# error message printing +sub msg_error { + my ($msg) = @_; + print STDERR "$progname:ERROR: $msg\n"; +} + +# determine check list +my @check_list = (qw( + layout + attrib + content +)); +my @checks = (); +if ($check eq 'all') { + @checks = @check_list; +} +else { + foreach my $c (split(/,/, $check)) { + if (not grep(/^$c$/, @check_list)) { + die "invalid check \"$c\""; + } + push(@checks, $c); + } +} + +# global return code +$main::GRC = 0; + +# environment preparation +system("rm -rf $tmpdir"); +system("mkdir -p $tmpdir"); + +# iterate over all .rpm files +foreach my $filename (@ARGV) { + die "unable to open file \"$filename\" for reading" + if (not -f $filename); + my $info = &rpm_info($filename, \@checks); + foreach my $check (@checks) { + eval "\&check_$check(\$filename, \$info);"; + } + &rpm_info_cleanup($filename, \@checks, $info); +} + +# environment cleanup +system("rm -rf $tmpdir"); + +# die gracefully +exit($main::GRC); + +## _________________________________________________________________ +## +## COMMON SUBROUTINES +## _________________________________________________________________ +## + +sub lint_message { + my ($type, $file, $msg) = @_; + $file =~ s|^.+?/([^/]+)$|$1|s; + printf(STDERR "%s:%s: %s: %s\n", $progname, $type, $file, $msg); +} + +sub lint_warning { + my ($file, $msg) = @_; + &lint_message("WARNING", $file, $msg); + $main::GRC = 1 if ($main::GRC < 1); +} + +sub lint_error { + my ($file, $msg) = @_; + &lint_message("ERROR", $file, $msg); + $main::GRC = 2 if ($main::GRC < 2); +} + +## _________________________________________________________________ +## +## RPM INFORMATION GATHERING +## _________________________________________________________________ +## + +sub rpm_info { + my ($filename, $checks) = @_; + my $info = {}; + + # query package name + &msg_verbose("++ querying RPM package name"); + $info->{name} = `$rpm -qp --qf '%{NAME}' $filename`; + + # query prefix + &msg_verbose("++ querying RPM package installation prefix"); + $info->{prefix} = `$rpm -qp --qf '%{PREFIXES}' $filename`; + + # query file listing + &msg_verbose("++ querying RPM package file listing"); + my @list = `$rpm -qplv $filename`; + my @config = `$rpm -qplc $filename`; + + # process file listing + $info->{ls} = {}; + foreach my $entry (@list) { + if ($entry =~ m|^\(contains no files\)\s*$|s) { + next; + } + elsif ($entry =~ m|^(\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\d+)\s+(.{12})\s+(.+)\s*$|s) { + my ($perm, $links, $owner, $group, $size, $mtime, $path) = ($1, $2, $3, $4, $5, $6, $7); + my $symlink = ""; + if ($path =~ m|^(\S+)\s+->\s+(\S+)$|) { + ($path, $symlink) = ($1, $2); + } + $path =~ s|\s+$||s; + my $config = 0; + if (grep(m|^$path$|, @config)) { + $config = 1; + } + $info->{ls}->{$path} = { + 'perm' => $perm, + 'links' => $links, + 'owner' => $owner, + 'group' => $group, + 'size' => $size, + 'time' => $mtime, + 'path' => $path, + 'symlink' => $symlink, + 'config' => $config, + }; + } + else { + &lint_error($filename, "invalid file listing entry: \"$entry\""); + } + } + + # unpacking files + if (grep(/^content$/, @{$checks})) { + &msg_verbose("++ unpacking RPM package files"); + $info->{root} = "$tmpdir/root"; + system("mkdir -p ".$info->{root}); + system("$rpm2cpio $filename | (cd ".$info->{root}." && cpio -idmu 2>/dev/null)"); + } + + return $info; +} + +sub rpm_info_cleanup { + my ($filename, $checks, $info) = @_; + + if (grep(/^content$/, @{$checks})) { + system("rm -rf ".$info->{root}) if ($info->{root} =~ m/^\/.+/ and -d $info->{root}); + } +} + +## _________________________________________________________________ +## +## CHECK "layout": file path layout +## _________________________________________________________________ +## + +sub check_layout { + my ($rpm, $info) = @_; + + # no need to check 'openpkg' package because it + # has a hard-coded file list! + return if ($rpm =~ m|^(.+?/)?openpkg-\d[^/]+$|); + + # check prefix + if ($info->{prefix} !~ m|^/.+$|) { + &lint_error($rpm, "invalid installation prefix ".$info->{prefix}. + " (expected to match \"^/.+\$\")"); + return; + } + + # check top-level path (all-in-one) + my @topdirs = (qw( + bin cgi etc include info lib libexec + local man pub sbin share usr var + )); + my $topdirs = "{".join(",", @topdirs)."}"; + if (not keys(%{$info->{ls}})) { + &lint_error($rpm, "invalid empty package (expected at least one file)"); + return; + } + foreach my $path (keys(%{$info->{ls}})) { + my $ok = 0; + foreach my $topdir (@topdirs) { + my $prefix = quotemeta($info->{prefix} . "/" . $topdir); + if ($path =~ m/^$prefix$/ && $rpm !~ m|^openpkg-\d+|) { + &lint_error($rpm, "top-level directory \"$topdir\" provided" . + " (expected none except for 'openpkg' package)"); + } + if ($path =~ m/^$prefix/) { + $ok = 1; + last; + } + } + if (not $ok) { + &lint_error($rpm, "invalid top-level directory in path \"$path\"". + " (expected one of $topdirs)"); + } + } + + # check for second-level path (all-in-one) + my @topdirs_subdir_no = (qw(bin cgi info sbin)); + my @topdirs_subdir_yes = (qw(etc libexec share var)); + foreach my $path (keys(%{$info->{ls}})) { + foreach my $topdir (@topdirs_subdir_yes) { + my $prefix = quotemeta($info->{prefix} . "/" . $topdir); + if ($path =~ m/^$prefix\/[^\/]+$/) { + if ($info->{ls}->{$path}->{perm} !~ m|^d|) { + &lint_error($rpm, "invalid positioned file \"$path\" under topdir \"$topdir\" (expected directory)"); + } + } + } + foreach my $topdir (@topdirs_subdir_no) { + my $prefix = quotemeta($info->{prefix} . "/" . $topdir); + if ($path =~ m/^$prefix\/[^\/]+$/) { + if ($info->{ls}->{$path}->{perm} =~ m|^d|) { + &lint_error($rpm, "invalid positioned directory \"$path\" under topdir \"$topdir\" (expected file)"); + } + } + } + } + + # check "bin" and "sbin" directories + foreach my $path (keys(%{$info->{ls}})) { + foreach my $topdir (qw(bin sbin)) { + my $prefix = quotemeta($info->{prefix} . "/" . $topdir); + if ($path =~ m/^$prefix\/(.+)$/) { + my $file = $1; + if ($file =~ m|^[^/]+\.[^/.]+$|) { + &lint_warning($rpm, "strange executable filename \"$path\" containing an extension (expected no extension)"); + } + my $perm = $info->{ls}->{$path}->{'perm'}; + if ($perm =~ m|^-| && $perm !~ m|^-[-r][-w][sx][-r][-w][-sx][-r][-w][-tx]$|) { + &lint_error($rpm, "non-executable file \"$path\" (with permissions \"$perm\" under topdir \"$topdir\" (expected to be executable)"); + } + } + } + } + + # check for symbolic link targets (outside absolute, dangling) + foreach my $path (keys(%{$info->{ls}})) { + my $symlink = $info->{ls}->{$path}->{'symlink'}; + if ($symlink ne '') { + # check for outside absolute target + my $prefix = quotemeta($info->{prefix}); + if ($symlink =~ m|^/.*| and $symlink !~ m|^$prefix|s) { + &lint_warning($rpm, "symbolic link \"$path\" points to absolute path \"$symlink\" outside prefix \"$info->{prefix}\" (expected it to be under prefix only)"); + } + # check for dangling target + my $resolved = &resolve($info, $path); + sub resolve { + my ($info, $path) = @_; + if (not defined($info->{ls}->{$path})) { + return $path; + } + my $symlink = $info->{ls}->{$path}->{'symlink'}; + if ($symlink eq '') { + return $path; + } + else { + my $resolved; + if ($symlink =~ m|^/|) { + $resolved = $symlink; + } + else { + $resolved = $path; + $resolved =~ s|/[^/]+$||s; + $resolved .= "/" . $symlink; + $resolved =~ s|/{2,}|/|sg; + $resolved =~ s|/\.(?=/)||sg; + $resolved =~ s|/\.$||sg; + 1 while ($resolved =~ s|/[^/]+/\.\./|/|s); + $resolved =~ s|/[^/]+/\.\.$||s; + $resolved =~ s|(.)/$|$1|s; + } + return &resolve($info, $resolved); + } + } + if (not defined($info->{ls}->{$resolved})) { + &lint_error($rpm, "symbolic link \"$path\" points to not existing target path \"$resolved\" (expected existing target path)"); + } + } + } +} + +## _________________________________________________________________ +## +## CHECK "attrib": file attributes +## _________________________________________________________________ +## + +sub check_attrib { + my ($rpm, $info) = @_; + + # check for empty files + foreach my $path (keys(%{$info->{ls}})) { + if ( $info->{ls}->{$path}->{'size'} == 0 + and $info->{ls}->{$path}->{'perm'} !~ m|^d| + and $path !~ m/^.*\/lib\/perl\/.+\.bs$/ + and $rpm !~ m/\bopenpkg-[0-9]+/) { + &lint_warning($rpm, "empty file \"$path\" found (expected no empty files)"); + } + } + + # check for %config flagged files + my $prefix = quotemeta($info->{'prefix'}); + my $name = quotemeta($info->{'name'}); + foreach my $path (keys(%{$info->{ls}})) { + my $config = $info->{ls}->{$path}->{'config'}; + my $path = $info->{ls}->{$path}->{'path'}; + if ($rpm !~ m/\bopenpkg-[0-9]+/ and $config and $path !~ m/^$prefix\/etc\/($name\d*|fsl)\/.+/) { + &lint_warning($rpm, "non-config file \"$path\" flagged as \%config (expected only \"$prefix/etc/$name/*\" files to be \%config files)"); + } + if ($config and $path =~ m/^$prefix\/s?bin\/[^\/]+$/) { + &lint_error($rpm, "executable file \"$path\" flagged as \%config"); + } + if ($config and $path =~ m/^$prefix\/etc\/rc\.d\/rc\.$name$/) { + &lint_error($rpm, "run-command file \"$path\" flagged as \%config"); + } + } + + # check for permissions + foreach my $path (keys(%{$info->{ls}})) { + my $perm = $info->{ls}->{$path}->{'perm'}; + if ($path =~ m/^$prefix\/(bin|sbin)\/[^\/]+$/) { + if ($perm !~ m|^[^d]..[xs]..[xs]..[xt]$|) { + &lint_warning($rpm, "executable file \"$path\" has permissions \"$perm\" only (expected it to be executable by everyone)"); + } + } + } + + # TODO: user/group? +} + +## _________________________________________________________________ +## +## CHECK "content": file content +## _________________________________________________________________ +## + +sub check_content { + my ($rpm, $info) = @_; + + # TODO: stripped (file) + # TODO: syslibs (ldd) + # TODO: hard-coded paths pointing outside instance + # TODO: sanity check for shebang-lines + # TODO: contained temporary path + # TODO: bad-files: .po +} +