#!/usr/bin/perl -w

use strict;
use JSON::XS;

use Getopt::Std;
use Pod::Usage qw( pod2usage );

my %opts;

getopts('d:aA:nbhmI', \%opts) || pod2usage(2);

my $showall = exists $opts{a};
my $arch = $opts{A} || 'amd64';
my $dist = $opts{d} || 'unstable';
my $keepcache = exists $opts{n};
my $showbugs = exists $opts{b};
my $showid = exists $opts{I};
pod2usage(1) if $opts{h};
pod2usage(-exitval => 0, -verbose => 2) if $opts{m};

use AptPkg::Config '$_config';
use AptPkg::System '$_system';
use AptPkg::Source;
use SOAP::Lite;
use Term::ANSIColor;
use File::Spec;

my $srccache;
my $versioning;

# initialise the global config object with the default values and
    # setup the $_system object
    $_config->init;
    $_system = $_config->system;
    $versioning = $_system->versioning;

    # suppress cache building messages
    $_config->{quiet} = 2;

    # set up the cache
    $srccache = AptPkg::Source->new;

my $cachedir = $ENV{XDG_CACHE_HOME} || $ENV{HOME} . '/.cache';
my $packagesfile = File::Spec->catfile($cachedir, "ci.debian.net-packages-$dist-$arch.json");
unlink $packagesfile unless $keepcache;
system("wget -q https://ci.debian.net/data/status/$dist/${arch}/packages.json -O $packagesfile")
    if ! -f $packagesfile;

open(IN, "<$packagesfile") or die("open $packagesfile: $!");

local $/;

for my $j (@{decode_json(<IN>)}) {
    my $p = $j->{package};
    if ($j->{status} eq "fail") {
        next if $p !~ /perl/ and !$showall;
        my @slist = $srccache->find($p) or warn("can't find $p in apt source cache"), next;
        my $s = src_latest(@slist);
        next if $s->{Maintainer} !~ /pkg-perl/ and $p ne 'perl';
        if (!$showall) {
            next if $s->{Version} ne $j->{version};
        }
        my $prefix = substr($p, 0, ($p =~ /^lib/ ? 4 : 1));
        my @rcbugs = map {"https://bugs.debian.org/$_"} src_rcbugs($p) if $showbugs;
        my $run_id = $j->{run_id};
        printf "%s_%s %s %s %s %s\n", $p, $j->{version},
            "https://ci.debian.net/packages/$prefix/$p/$dist/${arch}/",
            ($showid ? $run_id : ''),
            (@rcbugs ? colored('RC: ', 'magenta') . join(" ", @rcbugs) : ""),
            ($j->{previous_status} eq "fail" ? "" : colored("# NEW", 'red'));
    }
}

close IN;

sub src_latest {
    return (sort src_byversion @_)[-1];
}

sub src_byversion {
    return $versioning->compare($a->{Version}, $b->{Version});
}

sub src_rcbugs {
    my $pkg  = shift;
    my $soap = SOAP::Lite->uri('Debbugs/SOAP')
        ->proxy('https://bugs.debian.org/cgi-bin/soap.cgi');
    my $bugs
        = $soap->get_status( $soap->get_bugs( src => $pkg )->result() )->result;
    return unless $bugs;

    my @rcbugs;
    foreach my $b ( sort keys %$bugs ) {
        next unless my $status = $bugs->{$b};
        next
            if $status->{done}
            or $status->{archived}
            or ( grep { !/(serious|grave|critical)/ } $status->{severity} );
        push @rcbugs, $status->{bug_num};
    }
    return @rcbugs;
}


=head1 NAME

dpt-ci-failures - query ci.debian.net for autopkgtest failures

=head1 SYNOPSIS

B<dpt ci-failures> I<[-d E<lt>distributionE<gt>]> I<[-A E<lt>architectureE<gt>]> I<[-anbhmI]>

=head1 OPTIONS

=over

=item B<-d E<lt>distributionE<gt>>

Defaults to I<unstable>.

=item B<-A E<lt>architectureE<gt>>

Defaults to I<amd64>.

=item B<-a>

Show more ("all") results (slow). By default only packages matching /perl/
and the latest versions are shown.

=item B<-b>

Additionally show RC bugs for the found packages.

=item B<-I>

Additionally show the run id for the last run (suitable for retrying a test
via the ci.debian.net API.)

=item B<-n>

Keep old cache file instead of downloading the current file from ci.debian.net.

=item B<-h>

Show this help.

=item B<-m>

Show full manpage.

=back

=head1 CONFIGURATION

None.

=head1 FILES

A file called F<ci.debian.net-packages-$dist-$arch.json> is stored in
F<$XDG_CACHE_HOME> or F<$HOME/.cache>.

=head1 COPYRIGHT AND LICENSE

    Copyright 2017-2018, Niko Tyni <ntyni@debian.org>
              2017-2019, gregor herrmann <gregoa@debian.org>

    This program is free software. You may distribute it under the same
    terms as Perl.
