OpenPKG Specs: openpkg/lint-rpm.pl@c10fb90893b9 (annotated)

openpkg/lint-rpm.pl@c10fb90893b9 (annotated)

openpkg/lint-rpm.pl

Thu, 04 Oct 2012 20:30:05 +0200

author: Michael Schloh von Bennewitz <michael@schloh.com>
date: Thu, 04 Oct 2012 20:30:05 +0200
changeset 715: c10fb90893b9
permissions: -rw-r--r--

Correct out of date build configuration, porting to Solaris 11 network
link infrastructure and new libpcap logic. This additionally allows for
device drivers in subdirectories of /dev. Correct packaged nmap
personalities and signatures to work out of the box. Finally, hack
arpd logic to properly close sockets and quit on TERM by repeating
signaling in the run command script. Sadly, all this fails to correct
the run time behaviour of honeyd which fails to bind to the IP layer.

 ##
 ##  lint-rpm.pl -- OpenPKG *.rpm File Checker
 ##  Copyright (c) 2000-2012 OpenPKG GmbH <http://openpkg.com/>
 ##
 ##  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;
 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
 }

OpenPKG Specs / annotate

openpkg/lint-rpm.pl@c10fb90893b9 (annotated)

openpkg/lint-rpm.pl