#!/usr/bin/perl

# Copyright © 2012, 2013 Jakub Wilk <jwilk@debian.org>
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the “Software”), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

use strict;
use warnings;

use v5.12; # for delete local

use Getopt::Long qw(:config);
use Errno;
use Fcntl qw(:flock);

BEGIN {
    $ENV{'DEBCONF_NOWARNINGS'} = 'yes';
}

my $pending_path = '/var/lib/adequate/pending';
my %pending = ();
my $pending_fh;

sub read_pending()
{
    die if defined $pending_fh;
    if (open($pending_fh, '+>>', $pending_path)) {
        flock $pending_fh, LOCK_EX;
        seek($pending_fh, 0, 0);
        for (<$pending_fh>) {
            chomp;
            $pending{$_} = 1;
        }
    } elsif ($!{ENOENT}) {
        return;
    } else {
        die "$pending_path: $!";
    }
}

sub write_pending()
{
    die unless defined $pending_fh;
    truncate($pending_fh, 0);
    seek($pending_fh, 0, 0);
    for (sort keys %pending) {
        print $pending_fh "$_\n";
    }
    close $pending_fh or die "$pending_path: $!";
    $pending_fh = undef;
}

sub do_apt_preinst()
{
    my $enabled = undef;
    while (<STDIN>) {
        given ($_) {
            when ("Adequate::Enabled=true\n") {
                $enabled = 1;
            }
            when ("Adequate::Enabled=false\n") {
                $enabled = 0;
            }
            when ("\n") {
                last;
            }
        }
    }
    if (not defined $enabled) {
        warning('apt hook is not enabled');
    }
    if (not $enabled) {
        return;
    }
    while (<STDIN>) {
        my ($package, $architecture) = m{^(\S+) \s+ \S+ \s+ \S+ \s+ \S+ \s+ /.+_([a-z0-9]+)[.]deb$}x or next;
        $package = "$package:$architecture" unless $architecture eq 'all';
        $pending{$package} = 1;
    }
    write_pending();
}

sub do_pending()
{
    process(keys %pending) if %pending;
    %pending = ();
    write_pending();
}

my $debconf = 0;
my @debconf_buffer = ();

sub process(@)
{
    my @packages = normalize_package_names(@_);
    error('no packages to check') if not @packages;
    my %file_map = get_file_map(@packages);
    check_broken_symlinks(%file_map);
    check_copyright(@packages);
    check_obsolete_conffiles(@packages);
    check_python_bytecompilation(%file_map);
    check_bin_sbin_libraries(%file_map);
    check_undefined_symbols(%file_map);
    if ($debconf and @debconf_buffer) {
        my $debconf_buffer = join("\n", @debconf_buffer);
        $debconf_buffer =~ s/\\/\\\\/g;
        $debconf_buffer =~ s/\n/\\n/g;
        my $t = 'adequate/error';
        Debconf::Client::ConfModule::version('2.0');
        Debconf::Client::ConfModule::capb('escape');
        Debconf::Client::ConfModule::fset($t, 'seen', 0);
        Debconf::Client::ConfModule::subst($t, 'tags', $debconf_buffer);
        Debconf::Client::ConfModule::input('high', $t);
        Debconf::Client::ConfModule::title('adequate found packaging bugs');
        Debconf::Client::ConfModule::go();
    }
}

sub tag($$@)
{
    my ($pkg, $tag, @extra) = @_;
    if ($debconf) {
        push @debconf_buffer, "$pkg: $tag @extra";
    } elsif (-t STDOUT) {
        print "$pkg: \e[31m$tag\e[0m @extra\n";
    } else {
        print "$pkg: $tag @extra\n";
    }
}

sub normalize_package_names(@)
{
    my @in_packages = @_;
    my @packages;
    open(my $fh, '-|',
        'dpkg-query', '-Wf', '${binary:Package} ${Package};${Status}\n',
        # try both ${binary:Package} and ${Package}; the former gives us
        # architecture information, but the later works with pre-multiarch dpkg
        '--', @in_packages
    ) or die "dpkg-query -W: $!";
    while (<$fh>) {
        my ($package, $status) = m/^\s*(\S+).*;.*\s(\S+)$/;
        if ($status eq 'installed') {
            push @packages, $package;
        } elsif (@in_packages) {
            warning("skipping $package because it's not installed");
        }
    }
    close($fh) or die "dpkg-query -W: " . ($! or 'failed');
    return @packages;
}

sub get_file_map(@)
{
    my %map = ();
    open(my $fh, '-|', 'dpkg', '-L', @_) or die "dpkg -L: $!";
    my $pkg = shift;
    $map{$pkg} = [];
    while (<$fh>) {
        if (/^$/) {
            $pkg = shift;
            $map{$pkg} = [];
            next;
        }
        m{^(/.+)$} or next;
        push($map{$pkg}, $1);
    }
    close($fh) or die "dpkg -L: " . ($! or 'failed');
    return %map;
}

sub check_broken_symlinks(%)
{
    my %map = @_;
    while (my ($pkg, $files) = each %map) {
        for my $file (@{$files}) {
            if (-l $file and not stat($file)) {
                my $target = readlink $file;
                if (defined $target) {
                    tag $pkg, 'broken-symlink', $file, '->', $target;
                } else {
                    tag $pkg, 'broken-symlink', $file, "($!)";
                }
            }
        }
    }
}

sub check_copyright(@)
{
    for (@_) {
        my $pkg = $_;
        $pkg =~ s/:.*//;
        my $file = "/usr/share/doc/$pkg/copyright";
        if (! -f $file) {
            tag $pkg, 'missing-copyright-file', $file;
        }
    }
}

sub check_obsolete_conffiles(@)
{
    my $pkg;
    open(my $fh, '-|', 'dpkg-query', '-Wf', '${binary:Package}\n${Conffiles}\n', @_) or die "dpkg-query -W: $!";
    while (<$fh>) {
        if (m/^(\S+)$/) {
            $pkg = $1;
        } elsif (m{^ (.*) [0-9a-f]+ obsolete$}) {
            my $file = $1;
            die unless defined $pkg;
            tag $pkg, 'obsolete-conffile', $file;
        }
    }
    close($fh) or die "dpkg-query -W: " . ($! or 'failed');
}

my $bytecompilation_not_needed_re = qr{
  etc/
| bin/
| sbin/
| usr/bin/
| usr/games/
| usr/lib/debug/bin/
| usr/lib/debug/sbin/
| usr/lib/debug/usr/bin/
| usr/lib/debug/usr/games/
| usr/lib/debug/usr/lib/pypy/
| usr/lib/debug/usr/sbin/
| usr/lib/pypy/
| usr/sbin/
| usr/share/doc/
| usr/share/jython/
}x;
# Please keep it in sync with lintian4python!

sub check_python_bytecompilation(%)
{
    my %map = @_;
    my @pythons = map { m/(python2[.]\d+)/ } glob('/usr/lib/python2.*/');
    my $pysupport_old = -d '/usr/lib/python-support/private/'; # python-support < 0.90
    my $pysupport_new = -d '/usr/share/python-support/private/'; # python-support >= 0.90
file:
    while (my ($pkg, $files) = each %map) {
        file:
        for (@{$files}) {
            my ($path, $dir, $base) = m{^((/.+/)([^/]+)[.]py)$} or next;
            next file if m{^/$bytecompilation_not_needed_re};
            if (m{^/usr/share/pyshared/(.+)} or m{^/usr/share/python-support/[^/]+/(?<!/private/)(.+)}) {
                my $subpath = $1;
                my $ok = 0;
                for my $python (@pythons) {
                    my $sitepkgs = ($python =~ m/^python2[.][0-5]$/) ? 'site-packages' : 'dist-packages';
                    next file if -f "/usr/lib/$python/$sitepkgs/${subpath}c";
                    next file if $pysupport_new and -f "/usr/lib/pymodules/$python/${subpath}c";
                    next file if $pysupport_old and -f "/var/lib/python-support/$python/${subpath}c";
                }
                tag $pkg, 'pyshared-file-not-bytecompiled', $path;
                next file;
            }
            if (-f $path) {
                next file if -f "${path}c";
                # Don't expect third-party Python 2.X modules to be
                # byte-compiled if the corresponding Python version is not
                # installed:
                next file if
                    $path =~ m{^(/usr/lib/python2[.]\d+)/(?:site|dist)-packages/}
                    and not -f "$1/os.py";
                # Check for PEP-3147 *.pyc repository directories:
                my $pycache = "$dir/__pycache__";
                if (opendir(my $fh, $pycache)) {
                    my @pyc = grep { /^\Q$base.\Ecpython-.+[.]pyc$/ and -f "$pycache/$_" } readdir($fh);
                    closedir($fh) or die "$pycache: $!";
                    next file if @pyc;
                } elsif (not $!{ENOENT}) {
                    die "$pycache: $!";
                }
                tag $pkg, 'py-file-not-bytecompiled', $path;
            }
        }
    }
}

sub check_bin_sbin_libraries(%)
{
    my %map = @_;
    my @ld_vars = grep { /^LD_/ } keys @ENV;
    delete local @ENV{@ld_vars};
    local $ENV{LC_ALL} = 'C';
    my %path2pkg = ();
    while (my ($pkg, $files) = each %map) {
        file:
        for my $path (@{$files}) {
            next file unless $path =~ m{^/s?bin/\S+$};
            next file if -l $path;
            next file unless -f $path;
            next file unless -r $path;
            $path2pkg{$path} = $pkg;
        }
    }
    my $path = undef;
    my $pkg = undef;
    given (scalar keys %path2pkg) {
        when (0) {
            # nothing to do
            return;
        }
        when (1) {
            # ldd won't print the path, so let's save it here
            ($path, $pkg) = each %path2pkg;
        }
    }
    open(my $ldd, '-|', 'ldd', sort keys %path2pkg) or die "ldd: $!";
    my $not_dynamic = 0;
    foreach (<$ldd>) {
        when (m/^(\S+):$/) {
            $path = $1;
            $pkg = $path2pkg{$path};
            die "unexpected output from ldd" unless defined $pkg;
        }
        when (m/^\s+not a dynamic executable$/) {
            $not_dynamic = 1;
        }
        when (m{=> (/usr/lib/\S+)}) {
            tag $pkg, 'bin-or-sbin-binary-requires-usr-lib-library', $path, '=>', $1;
        }
    }
    close($ldd) or $not_dynamic or die "ldd: " . ($! or 'failed');
}

sub check_undefined_symbols(%)
{
    return if $@;
    my %map = @_;
    my @ld_vars = grep { /^LD_/ } keys @ENV;
    delete local @ENV{@ld_vars};
    local $ENV{LC_ALL} = 'C';
    my %interesting_dirs = (
        '/bin' => 1,
        '/sbin' => 1,
        '/usr/bin' => 1,
        '/usr/games' => 1,
        '/usr/sbin' => 1,
    );
    open(my $ldconfig, '-|', '/sbin/ldconfig', '-p') or die "ldconfig -p: $!";
    foreach (<$ldconfig>) {
        when (m{\s[(]libc[^)]+[)]\s+=>\s+(\S+)[/][^/]+$}) {
            $interesting_dirs{$1} = 1;
        }
    }
    close($ldconfig) or die "ldconfig -p: " . ($! or 'failed');
    my %path2pkg = ();
    while (my ($pkg, $files) = each %map) {
        file:
        for my $path (@{$files}) {
            my ($dir) = $path =~ m{(.*)/[^/]+$};
            next file if $path =~ /\s/;
            next file if $path =~ m{^/lib\d*/.*(?<=/)ld(?:-.+)[.]so(?:$|[.])}; # dynamic linker
            next file unless defined $interesting_dirs{$dir};
            next file if -l $path;
            next file unless -f $path;
            next file unless -r $path;
            $path2pkg{$path} = $pkg;
        }
    }
    my $path = undef;
    my $pkg = undef;
    given (scalar keys %path2pkg) {
        when (0) {
            # nothing to do
            return;
        }
        when (1) {
            # ldd won't print the path, so let's save it here
            ($path, $pkg) = each %path2pkg;
        }
    }
    my $ldd_pid = open(my $ldd, '-|') // die "can't fork: $!";
    if ($ldd_pid) { # parent
        my $not_dynamic = 0;
        foreach (<$ldd>) {
            when (m/^(\S+):$/) {
                $path = $1;
                $pkg = $path2pkg{$path};
                die "unexpected output from ldd" unless defined $pkg;
            }
            when (m/^\s+not a dynamic executable$/) {
                $not_dynamic = 1;
            }
            when (m/^undefined symbol:\s+(\S+)\s+[(]\Q$path\E[)]$/) {
                my $symbol = $1;
                next if $path =~ m/python|py[23]/ and $symbol =~ /^_?Py/;
                next if $path =~ m/perl/ and $symbol =~ /^(?:Perl|PL)_/;
                tag $pkg, 'undefined-symbol', $path, '=>', $symbol;
            }
            when (m/^symbol (\S+), version (\S+) not defined in file (\S+) with link time reference\s+[(]\Q$path\E[)]/) {
                my $symbol = "$1\@$2";
                my $lib = $3;
                tag $pkg, 'undefined-symbol', $path, '=>', $symbol, "($lib)";
            }
        }
        wait or die "$ldd -r: $!";
        unless ($? == 0 or ($not_dynamic and $? == (1 << 8))) {
            die "ldd -r: failed";
        }
    } else { # child
        open(STDERR, ">&STDOUT") or die "can't redirect stderr: $!";
        exec('ldd', '-r', sort keys %path2pkg);
        die "can't exec ldd: $!";
    }
}

sub switch_uid_gid($$)
{
    my ($uid, $gid) = @_;
    return unless defined $uid and defined $gid;
    $! = 0;
    $( = $gid; die "setting real gid to $gid: $!" if $!;
    $) = "$gid $gid"; die "setting effective gid to $gid: $!" if $!;
    $< = $uid; die "setting real uid to $uid: $!" if $1;
    $> = $uid; die "setting effective uid to $uid: $!" if $!;
    die if $< != $uid;
    die if $> != $uid;
    die if $( ne "$gid $gid";
    die if $) ne "$gid $gid";
    delete $ENV{HOME};
}

sub display_help()
{
    print <<EOF ;
usage:

  adequate [options] <package-name>...
  adequate [options] --all
  adequate [options] --apt-preinst
  adequate [options] --pending
  adequate --help

options:

  --all                    check all installed packages
  --debconf                report issues via debconf
  --root <dir>             switch root directory
  --user <user>[:<group>]  switch user and group
  --apt-preinst            (used internally of the APT hook)
  --pending                (used internally of the APT hook)
  --help                   display this help and exit
EOF
    exit;
}

sub error($)
{
    say STDERR "adequate: error: @_";
    exit(1);
}

sub warning($)
{
    say STDERR "adequate: @_";
}

my @ARGV_copy = @ARGV;

sub enable_debconf()
{
    $debconf = 1;
    if (not exists $ENV{DEBIAN_HAS_FRONTEND}) {
        @ARGV = @ARGV_copy;
        # import will re-exec this program
    }
    require Debconf::Client::ConfModule;
    Debconf::Client::ConfModule::import();
}

umask 022;
my $opt_all = 0;
my $opt_debconf = 0;
my $opt_root = undef;
my $opt_user = undef;
my $opt_uid = undef;
my $opt_gid = undef;
my $opt_apt_preinst = 0;
my $opt_pending = 0;
my $rc = GetOptions(
    'all' => \$opt_all,
    'debconf' => \$opt_debconf,
    'root=s' => \$opt_root,
    'user=s' => \$opt_user,
    'apt-preinst' => \$opt_apt_preinst,
    'pending' => \$opt_pending,
    'help' => \&display_help,
);
if (not $rc) {
    exit(1);
}

enable_debconf() if $opt_debconf;

if (defined $opt_user) {
    my ($user, $group) = $opt_user =~ m/^([^\s:]++)(?::(\S+))?$/ or error('invalid user/group specification');
    if ($user =~ m/^\d+$/) {
        (undef, undef, $opt_uid, $opt_gid) = getpwuid($user) or error("$user: no such user");
    } else {
        (undef, undef, $opt_uid, $opt_gid) = getpwnam($user) or error("$user: no such user");
    }
    if (defined $group) {
        if ($group =~ m/^\d+$/) {
            (undef, undef, $opt_gid) = getgrgid($group) or error("$group: no such group");
        } else {
            (undef, undef, $opt_gid) = getgrnam($group) or error("$group: no such group");
        }
    }
}

if ($opt_apt_preinst) {
    error('--apt-preinst and --pending cannot be used together') if $opt_pending;
    error('--apt-preinst and --all cannot be used together') if $opt_all;
    error('--apt-preinst and --root cannot be used together') if defined $opt_root;
    error('too many arguments') if @ARGV;
    read_pending();
    switch_uid_gid($opt_uid, $opt_gid);
    do_apt_preinst();
} elsif ($opt_pending) {
    error('--pending and --all cannot be used together') if $opt_all;
    error('--pending and --root cannot be used together') if defined $opt_root;
    error('too many arguments') if (@ARGV);
    read_pending();
    switch_uid_gid($opt_uid, $opt_gid);
    do_pending();
} else {
    error('too many arguments') if ($opt_all and @ARGV);
    error('no packages to check') if (!$opt_all and !@ARGV);
    if (defined $opt_root) {
        chroot($opt_root) or die "chroot $opt_root: $!";
        chdir('/') or die "chdir /: $!";
    }
    switch_uid_gid($opt_uid, $opt_gid);
    process(@ARGV);
}
exit(0);

# vim:ts=4 sw=4 et
