devscripts 2.17.6+deb9u2 / usr / bin / who-permits-upload

#!/usr/bin/perl

# who-permits-upload - Retrieve permissions granted to Debian Maintainers (DM)
# Copyright (C) 2012 Arno Töll <arno@debian.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.


use strict;
use Dpkg::Control;
use LWP::UserAgent;
use Encode::Locale;
use Encode;
use Getopt::Long;
use constant {TYPE_PACKAGE => "package", TYPE_UID => "uid", TYPE_SPONSOR => "sponsor"};
use constant {SPONSOR_FINGERPRINT => 0, SPONSOR_NAME => 1};
use List::Util qw(first);

our $DM_URL = "https://ftp-master.debian.org/dm.txt";
our $KEYRING = "/usr/share/keyrings/debian-keyring.gpg:/usr/share/keyrings/debian-maintainers.gpg";
our $TYPE = "package";
our $GPG = first { !system('sh', '-c', "command -v $_ >/dev/null 2>&1") } qw(gpg2 gpg);
our ($HELP, @ARGUMENTS, @DM_DATA, %GPG_CACHE);

binmode STDIN, ':encoding(console_in)';
binmode STDOUT, ':encoding(console_out)';
binmode STDERR, ':encoding(console_out)';

=encoding utf8

=head1 NAME

who-permits-upload - look-up Debian Maintainer access control lists

=head1 SYNOPSIS

B<who-permits-upload> [B<-h>] [B<-s> I<keyring>] [B<-d> I<dm_url>] [B<-s> I<search_type>] I<query> [I<query> ...]

=head1 DESCRIPTION

B<who-permits-upload> looks up the given Debian Maintainer (DM) upload permissions
from ftp-master.debian.org and parses them in a human readable way. The tool can
search by DM name, sponsor (the person who granted the permission) and by package.

=head1 OPTIONS

=over 4

=item B<--dmfile=>I<dm_url>, B<-d> I<dm_url>

Retrieve the DM permission file from the supplied URL. When this option is not
present, the default value I<https://ftp-master.debian.org/dm.txt> is used.

=item B<--help>, B<-h>

Display a usage summary and exit.

=item B<--keyring=>I<keyring>, B<-s> I<keyring>

Use the supplied GnuPG keyrings to look-up GPG fingerprints from the DM permission
file. When not present, the default Debian Developer and Maintainer keyrings are used
(I</usr/share/keyrings/debian-keyring.gpg> and
I</usr/share/keyrings/debian-maintainers.gpg>, installed by the I<debian-keyring>
package).

Separate keyrings with a colon ":".

=item B<--search=>I<search_type>, B<-s> I<search_type>

Modify the look-up behavior. This influences the
interpretation of the I<query> argument. Supported search types are:

=over 4

=item B<package>

Search for a source package name. This is also the default when B<--search> is omitted.
Since package names are unique, this will return given ACLs - if any - for a
single package.

=item B<uid>

Search for a Debian Maintainer. This should be (a fraction of) a name. It will
return all ACLs assigned to matching maintainers.

=item B<sponsor>

Search for a sponsor (i.e. a Debian Developer) who granted DM permissions. This
will return all ACLs given by the supplied developer.

Note that this is an expensive operation which may take some time.

=back

=item I<query>

A case sensitive argument to be looked up in the ACL permission file. The exact
interpretation of this argument is dependent by the B<--search> argument.

This argument can be repeated.

=back

=head1 EXIT VALUE

=over 4

=item 0Z<>

Success

=item 1Z<>

An error occurred

=item 2Z<>

The command line was not understood

=back

=head1 EXAMPLES

=over 4

=item who-permits-upload --search=sponsor arno@debian.org

Search for all DM upload permissions given by the UID "arno@debian.org". Note,
that only primary UIDs will match.

=item who-permits-upload -s=sponsor "Arno Töll"

Same as above, but use a full name instead.

=item who-permits-upload apache2

Look up who gave upload permissions for the apache2 source package.

=item who-permits-upload --search=uid "Paul Tagliamonte"

Look up all DM upload permissions given to "Paul Tagliamonte".

=back

=head1 AUTHOR

B<who-permits-upload> was written by Arno Töll <arno@debian.org> and is licensed
under the terms of the General Public License (GPL) version 2 or later.

=head1 SEE ALSO

B<gpg>(1), B<gpg2>(1), B<who-uploads>(1)

S<I<https://lists.debian.org/debian-devel-announce/2012/09/msg00008.html>>

=cut


GetOptions ("help|h" => \$HELP,
    "keyring|k=s" => \$KEYRING,
    "dmfile|d=s" => \$DM_URL,
    "search|s=s" => \$TYPE,
    );
# pop positionals
@ARGUMENTS = @ARGV;

$TYPE = lc($TYPE);
if ($TYPE eq 'package')
{
    $TYPE = TYPE_PACKAGE;
}
elsif ($TYPE eq 'uid')
{
    $TYPE = TYPE_UID;
}
elsif ($TYPE eq 'sponsor')
{
    $TYPE = TYPE_SPONSOR;
}
else
{
    usage();
}

if ($HELP)
{
    usage();
}

if (not @ARGUMENTS)
{
    usage();
}

sub usage
{
    print STDERR ("Usage: $0 [-h][-s KEYRING][-d DM_URL][-s SEARCH_TYPE] QUERY [QUERY ...]\n");
    print STDERR "Retrieve permissions granted to Debian Maintainers (DM)\n";
    print STDERR "\n";
    print STDERR "-h, --help\n";
    print STDERR "\t\t\tDisplay this usage summary and exit\n";
    print STDERR "-k, --keyring=KEYRING\n";
    print STDERR "\t\t\tUse the supplied keyring file(s) instead of the default\n";
    print STDERR "\t\t\tkeyring. Separate arguments by a colon (\":\")\n";
    print STDERR "-d, --dmfile=DM_URL\n";
    print STDERR "\t\t\tRetrieve DM permissions from the supplied URL.\n";
    print STDERR "\t\t\tDefault is https://ftp-master.debian.org/dm.txt\n";
    print STDERR "-s, --search=SEARCH_TYPE\n";
    print STDERR "\t\t\tSupplied QUERY arguments are interpreted as:\n";
    print STDERR "\t\t\tpackage name when SEARCH_TYPE is \"package\" (default)\n";
    print STDERR "\t\t\tDM user name id when SEARCH_TYPE is \"uid\"\n";
    print STDERR "\t\t\tsponsor user id when SEARCH_TYPE is \"sponsor\"\n";
    exit 2;
}

sub leave
{
    my $reason = shift;
    chomp $reason;
    print STDERR "$reason\n";
    exit 1;
}

sub lookup_fingerprint
{
    my $fingerprint = shift;
    my $uid = "";

    if (exists $GPG_CACHE{$fingerprint})
    {
        return $GPG_CACHE{$fingerprint};
    }

    my @gpg_arguments;
    foreach my $keyring (split(":", "$KEYRING"))
    {
        if (! -f $keyring)
        {
            leave("Keyring $keyring is not accessible");
        }
        push(@gpg_arguments, ("--keyring", $keyring));
    }
    push(@gpg_arguments, ("--no-options", "--no-auto-check-trustdb", "--no-default-keyring", "--list-key", "--with-colons", encode(locale => $fingerprint)));
    open(CMD, '-|', $GPG, @gpg_arguments) || leave "$GPG: $!\n";
    binmode CMD, ':utf8';
    while (my $l = <CMD>)
    {
        if ($l =~ /^pub/)
        {
            $uid = $l;
            # Consume the rest of the output to avoid a potential SIGPIPE when closing CMD
            my @junk = <CMD>;
            last;
        }
    }
    my @fields = split(":", $uid);
    $uid = $fields[9];
    close(CMD) || leave("gpg returned an error looking for $fingerprint: ". ($? >> 8));

    $GPG_CACHE{$fingerprint} = $uid;

    return $uid;
}

sub parse_data
{
    my $raw_data = shift;
    my $parser = Dpkg::Control->new(type => CTRL_UNKNOWN, allow_duplicate => 1);
    open(my $fh, '+<:utf8', \$raw_data) || leave('unable to read dm data: '.$!);
    my @dm_data = ();

    while ($parser->parse($fh))
    {
        foreach my $package (split(/,/, $parser->{Allow}))
        {
            if ($package =~ m/([a-z0-9\+\-\.]+)\s+\((\w+)\)/s)
            {
                my @package_row = ($1, $parser->{Fingerprint}, $parser->{Uid}, $2, SPONSOR_FINGERPRINT);
                push(@dm_data, \@package_row);
            }
        }
    }
    return @dm_data;
}


sub find_matching_row
{
    my $pattern = shift;
    my $type = shift;
    my @return_rows;
    foreach my $package (@DM_DATA)
    {
        # $package is an array ref in the format
        # (package, dm_fingerprint, dm_uid, sponsor_fingerprint callback)
        push(@return_rows, $package) if ($type eq TYPE_PACKAGE && $pattern eq $package->[0]);
        push(@return_rows, $package) if ($type eq TYPE_UID &&  $package->[2] =~ m/$pattern/);
        if ($type eq TYPE_SPONSOR)
        {
            # the sponsor function is a key id so far, mark we looked it up
            # already
            $package->[3] = lookup_fingerprint($package->[3]);
            $package->[4] = SPONSOR_NAME;
            if ($package->[3] =~ m/$pattern/)
            {
                push(@return_rows, $package);
            }
        }
    }
    return @return_rows;
}

my $http = LWP::UserAgent->new;
$http->timeout(10);
$http->env_proxy;

my $response = $http->get($DM_URL);
if ($response->is_success)
{
    @DM_DATA = parse_data($response->content);
}
else
{
    leave "Could not retrieve DM file: $DM_URL Server returned: " . $response->status_line;
}

foreach my $argument (@ARGUMENTS)
{
    $argument = decode(locale => $argument);
    my @rows = find_matching_row($argument, $TYPE);
    if (not @rows)
    {
        leave("No $TYPE matches $argument");
    }
    foreach my $row (@rows)
    {
        # $package is an array ref in the format
        # (package, dm_fingerprint, dm_uid, sponsor_fingerprint, sponsor_type_flag)
        my $sponsor = $row->[3];
        if ($row->[4] != SPONSOR_NAME)
        {
            $row->[3] = lookup_fingerprint($row->[3]);
        }
        printf("Package: %s DM: %s Sponsor: %s\n", $row->[0], $row->[2], $row->[3] );
    }
}