#!/usr/bin/perl

use autodie;
use Carp;
use CPAN::Meta;
use Cwd qw(getcwd);
use MIME::Lite;
use File::Basename;
use File::HomeDir;
use File::Slurp qw(read_file write_file);
use File::Spec;
use Getopt::Long;
use Term::ReadLine;
use Time::Piece qw(localtime);
use Text::Wrap qw(wrap);
use Proc::InvokeEditor;

use warnings;
use strict;

=head1 NAME

dpt-forward - Forward a bug or a patch upstream

=head1 SYNOPSIS

 dpt forward [option...] path/to/some.patch [bug-number]
 dpt forward [option...] bug-number [path/to/some.patch]

=head1 OPTIONS

=over

=item B<--dist> I<name>

=item B<-d> I<name>

Distribution name. Determined from F<META>, the C<Homepage> field in
F<debian/control> file or the C<Source> field in F<debian/copyright>, in that
order.

=item B<--force>

Normally <dpt-forward> checks if the bug/patch is already forwarded upstream
and aborts if so. With this option, the check is still done, but execution is
not aborted and only a warning is issued.

=item B<--meta> I<file>

Specifies the location of the F<META> file. Defaults to F<META.json> or
F<META.yml> in the current directory, whichever is found first.

=item B<--mode> bug|patch

=item B<-m> bug|patch

Mode of operation. Should rarely be needed.

Determines the meaning of the arguments. I<bug> means that the first argument
is a bug number, and the second argument is a patch file name. I<patch> means
the opposite.

Determined from the first non-option argument and whether it looks like a bug
number or a patch file name.

=item B<--offline-test>

All operations that require network are replaced with stubs, allowing for
off-line testing.

=item B<--ticket> I<number>

If present, the information is submitted to the ticket as an additional
comment.

If missing, a new ticket is created.

=item B<--tracker> I<name>

=item B<-t> I<name>

Tracker used by the distribution. B<dpt forward> currently supports B<cpan>
(L<http://rt.cpan.org>) and B<github>. The default is determined from the C<<
resources->bugtracker->web >> field of F<META>. If that field is not present,
B<cpan> is used.

=item B<--tracker-url> I<url>

=item B<-u> I<url>

Tracker URL to submit the information to. Taken from the C<<
resources->bugtracker->web >> field of F<META>. Defaults to C<<
https://rt.cpan.org/Public/Dist/Display.html?Name=I<dist-name> >> for B<cpan> and
is mandatory for B<github>.

=back

=cut

$| = 1;

my $opt_dist;
my $opt_force;
my $opt_tracker;
my $opt_tracker_url;
my $opt_mode;
my $opt_offline_test;
my $opt_meta_file;
my $opt_ticket;

GetOptions(
    'd|dist=s'        => \$opt_dist,
    'force!'          => \$opt_force,
    't|tracker=s'     => \$opt_tracker,
    'u|tracker-url=s' => \$opt_tracker_url,
    'm|mode=s'        => \$opt_mode,
    'offline-test!'   => \$opt_offline_test,
    'meta=s'          => \$opt_meta_file,
    'ticket=s'        => \$opt_ticket,
) or exit 1;

die
    "Expecting one or two arguments, representing patch file name or bug number.\n"
    unless @ARGV == 1 or @ARGV == 2;

my $arg1 = shift @ARGV;

$opt_meta_file //= 'META.json' if -e 'META.json';
$opt_meta_file //= 'META.yml' if -e 'META.yml';

my $meta;
$meta = CPAN::Meta->load_file($opt_meta_file) if $opt_meta_file;

$opt_dist ||= $meta->name if $meta;
$opt_dist ||= detect_dist();

die "Unable to determine distribution name.\n"
    . "Please use the --dist option.\n"
    unless $opt_dist;

$opt_tracker_url ||= $meta->resources->{bugtracker}{web}
    if $meta
    and $meta->resources
    and $meta->resources->{bugtracker};

unless ($opt_tracker_url) {
    warn "Bug tracker not found in META.\n";

    $opt_tracker_url
        = "https://rt.cpan.org/Public/Dist/Display.html?Name=$opt_dist";

    warn "Falling back to $opt_tracker_url\n";
}

$opt_tracker ||= detect_tracker();

$opt_mode ||= 'patch'
    if $arg1 =~ '\.(?:patch|diff)$' or $arg1 =~ m{debian/patches/};

$opt_mode ||= 'bug' if $arg1 =~ /^#?\d+$/;

die "'$arg1' is not recognized as neither bug nor patch file name.\n"
    . "Please use the --mode option.\n"
    unless $opt_mode;

my $scissors_line = ( "------8<-----" x 5 ) . "\n";

my ( $patch, $bug );
my ( %patch_info, %bug_info );

if ( $opt_mode eq 'patch') {
    $patch = $arg1;
    $bug = shift @ARGV;
}
elsif ( $opt_mode eq 'bug' ) {
    $bug = $arg1;
    $patch = shift @ARGV;
}
else {
    die "Unknown mode of operation '$opt_mode'\n";
}

if ($patch) {
    open( my $in, "<", $patch );
    my $line_no = 1;
    while ( $line_no <= 10 ) {
        my $line = <$in>;
        chomp($line);

        last if $line =~ /^(?:diff|index|---|\+\+\+)/s;

        if (    $line !~ /^Forwarded: not yet/i
            and $line !~ /^Forwarded: no$/i
            and $line =~ /^(?:Forwarded|Bug): (\S+)/i )
        {
            if ($opt_force) {
                warn "Patch already forwarded to $1\n";
                warn "Continuing anyway because of --force.\n";
            }
            else {
                die "Patch already forwarded to $1\n";
            }
        }

        $patch_info{Subject} = $1
            if $line =~ /^(?:Subject|Description):\s+(.+)/;
        $patch_info{From} = $1
            if $line =~ /^(?:From|Author):\s+(.+)/;
        $line_no++;
    }

    unless ( $patch_info{Subject} ) {
        # default subject is the patch name
        my $fn = ( File::Spec->splitpath($patch) )[-1];
        $fn =~ s/\.(?:patch|diff)$//;    # strip extension
        $fn =~ s/^\d+[-_]?//;            # strip leading number
        $patch_info{Subject} = $fn;
    }
}

retrieve_bug_info() if $bug;

sub retrieve_bug_info {
    $bug_info{url} = "https://bugs.debian.org/$bug";

    if ($opt_offline_test) {
        $bug_info{Subject} = 'Test bug subject';
        $bug_info{msg}     = "Test bug message\n";

        return;
    }

    # See http://wiki.debian.org/DebbugsSoapInterface
    require SOAP::Lite;
    my $soap = SOAP::Lite->uri('Debbugs/SOAP')
        ->proxy('http://bugs.debian.org/cgi-bin/soap.cgi');

    my $info = $soap->get_status($bug)->result()->{$bug};

    die "Err: Bug #$bug already closed\n" if $info->{done};
    if ( $info->{forwarded} ) {
        if ($opt_force) {
            warn "Wrn: Bug #$bug already forwarded to $info->{forwarded}\n";
        }
        else {
            die "Err: Bug #$bug already forwarded to $info->{forwarded}\n";
        }
    }

    $bug_info{Subject} = $info->{subject};

    # try to get the body of the first message
    # get_bug_log() fails with a SOAP error for some bugs. cf. #635018
    my $ok = eval {
        my $log = $soap->get_bug_log($bug)->result();
        $bug_info{msg} = $log->[0]->{body};
        $bug_info{msg} .= "\n" unless $bug_info{msg} =~ /\n$/;
        1;
    };

    unless ($ok) {
        my $err = $@;

        warn "W: Failed to retrieve content of bug #$bug:\n";
        warn "W: $err";
    }
}

sub get_subject {
    my $default = ( $bug ? $bug_info{Subject} : $patch_info{Subject} ) // '';
    $default = "[PATCH] $default"
        if $patch and $default !~ /\[PATCH\]/;

    my $term = Term::ReadLine->new('forward');

    return $term->readline( 'Subject:', $default );
}

sub detect_dist {
    open my $dctrl, '<', 'debian/control';

    while ( my $line = <$dctrl> ) {
        if ( $line =~ /^Homepage/ ) {
            if ( $line
                =~ m{(?:http://search\.cpan\.org/dist|https://metacpan\.org/release)/(.*?)/?$}
                )
            {
                return $1;
            }
        }
    }

    close $dctrl;

    open my $dcopyright, '<', 'debian/copyright';

    while ( my $line = <$dcopyright> ) {
        if ( $line =~ /^Source/ ) {
            if ( $line
                =~ m{(?:http://search\.cpan\.org/dist|https://metacpan\.org/release)/(.*?)/?$}
                )
            {
                return $1;
            }
        }
    }

    close $dcopyright
        or warn "Cannot close debian/copyright from reading: $!";

    return;
}

my $name = $ENV{'DEBFULLNAME'};
my $email
    = $ENV{'DEBEMAIL'}
    || $ENV{'EMAIL'}
    || die "Err: Set a valid email address";

if ( !$name ) {
    $name = ( getpwuid($<) )[6];
    $name =~ s/,.*//;
}

# RT config
my $rt_server = 'https://rt.cpan.org';
my %rt_login;

sub read_pause_credentials {
    open my $pauserc, '<',
        File::Spec->catfile( File::HomeDir->my_home, '.pause' );

    while (<$pauserc>) {
        chomp;
        next unless $_ and $_ !~ /^\s*#/;

        my ( $k, $v ) = /^\s*(\w+)\s+(.+)$/;
        $rt_login{$k} = $v;
    }

    close $pauserc;

    die 'Err: Provide valid PAUSE credentials'
        if not $rt_login{'user'}
        or not $rt_login{'password'};
}

sub prepare_body {
    my $body;

    $Text::Wrap::columns = 70;
    $Text::Wrap::huge    = 'overflow';

    if ($bug) {
        $body = "We have the following bug reported to the Debian package "
            . "of $opt_dist ($bug_info{url}):" . "\n";
        $body .= "\nIt doesn't seem to be a bug in the packaging, "
            . "so you may want to take a look. Thanks!\n";
        $body = wrap( '', '', $body );

        $body .= "\n" . $scissors_line;
        $body .= "\n\`\`\`" if $opt_tracker eq 'github';
        $body .= "\n" . $bug_info{msg};
        $body .= "\n\`\`\`" if $opt_tracker eq 'github';
        $body .= "\n" . $scissors_line . "\n";

        if ($patch) {
            # bug + patch
            $body
                .= wrap( '', '', "The Debian package of $opt_dist has the following "
                . "patch applied to fix the bug.\n" );
        }
    }
    elsif ($patch) {
        # patch but no bug

        my $pre = ( $opt_tracker eq 'github' ) ? '    ' : '';

        $body
            = "In Debian we are currently applying the following "
            . "patch to $opt_dist.\n"
            . "We thought you might be interested in it too.";
        $body = wrap( '', '', $body );
        $body .= "\n\n";

        open my $patch_fh, '<', $patch;

        while ( my $line = <$patch_fh> ) {
            chomp($line);
            last if $line eq '---';
            last if $line =~ /^--- /;
            last if $line =~ /^diff\h--git\ha\//;
            last if $line =~ /^index\h[0-9a-f]+\.\.[0-9a-f]+\h\d*\h/;
            next if $line =~ /^Forwarded:/;
            $body .= $pre . $line . "\n";
        }
    }
    else {
        die "No patch nor bug!? (a.k.a. should not happen)";
    }

    if ($patch) {
        require Dpkg::Control::Info;
        my $c = Dpkg::Control::Info->new();
        my $vcs_browser = $c->get_source->{'Vcs-Browser'};
        if ( $vcs_browser and $vcs_browser =~ /cgit/ ) {
            $body .= wrap( '', '', "\nThe patch is tracked in our Git repository at "
                  . "$vcs_browser/plain/$patch\n" );
        }
        elsif ( $vcs_browser and $vcs_browser =~ /gitweb/ ) {
            $body .= wrap( '', '', "\nThe patch is tracked in our Git repository at "
                  . "$vcs_browser;a=blob;f=$patch;hb=HEAD\n" );
        }
    }

    $body .= "\nThanks for considering,\n";
    $body .= wrap( '  ', '  ', "$name,\nDebian Perl Group\n" );

    return edit_message($body);
}

sub submit_cpan_rt {
    # prepare subject
    my $subject = get_subject();

    # There are two ways for submitting RT tickets: email and REST
    # The email way is to send the mail, then use RT::Client::REST to find the
    # newly created ticket. Below is the other approach, in which the ticket is
    # created via the REST API and the patch is added as an attachment in a
    # comment. Ticket creation doesn't support attachments directly.

    # Prepare body
    my $body = prepare_body();

    my $ticket_url;

    if ($opt_offline_test) {
        $ticket_url = "https://rt.cpan.org/Ticket/Display.html?id=DUMMY";
    }
    else {
        read_pause_credentials();

        require RT::Client::REST;
        my $rt = RT::Client::REST->new( server => $rt_server );
        my $ok = eval {
            $rt->login(
                username => $rt_login{user},
                password => $rt_login{password}
            );
            1;
        };
        unless ($ok) {
            warn "Unable to login to RT: $@";
            return;
        }

        my $ticket;
        require RT::Client::REST::Ticket;

        if ( $opt_ticket ) {
            $ticket = RT::Client::REST::Ticket->new(
                rt => $rt,
                id => $opt_ticket,
                queue => $opt_dist,
            );
            $ticket->retrieve();
            $ticket->add_cc($rt_login{user} . '@cpan.org');

            $ticket->correspond(
                message => $body,
                $patch ? ( attachments => [$patch] ) : (),
            );
        }
        else {
            $ticket = RT::Client::REST::Ticket->new(
                rt      => $rt,
                queue   => $opt_dist,
                subject => $subject,
                requestor => [ $rt_login{user} . '@cpan.org' ],
            );

            $ticket->store( text => $body );

            $ticket->correspond(
                message     => "Here's the patch.",
                attachments => [$patch],
            ) if $patch;
        }

        $ticket_url = "https://rt.cpan.org/Ticket/Display.html?id=" . $ticket->id;
    }

    mark_patch_as_forwarded($ticket_url) if $patch;

    mark_bug_as_forwarded($ticket_url) if $bug;
}

sub submit_github {

    eval { require Net::GitHub; }
        or die "Net::GitHub not available.\n"
        . "Please install libnet-github-perl and try again.";

    die "github requires DPT_GITHUB_OAUTH setting.\n"
        . "See dpt-config(5) and dpt-github-oauth.\n"
        unless $ENV{DPT_GITHUB_OAUTH};

    die "Unable to determine github issue tracker URL.\n"
        unless $opt_tracker_url;

    my ( $gh_user, $gh_repo, $gh_opts )
        = $opt_tracker_url
        =~ m{^https?://github.com/([^/]+)/([^/]+)/issues(?:/?|\?(.*))$};
    my $gh_labels = '';
    $gh_labels = $1 if $gh_opts and $gh_opts =~ m{labels=([^;&]+)};

    die "Unable to determine github user and repository\n"
        . "from $opt_tracker_url"
        unless $gh_user and $gh_repo;

    # prepare subject
    my $subject = get_subject();

    my $body = prepare_body();

    my $issue_url;

    if ( $opt_offline_test ) {
        $issue_url = "https://github.com/$gh_user/$gh_repo/issues/DUMMY";
        goto ISSUE_CREATED;
    }

    # now create the issue
    my $gh = Net::GitHub->new(    # Net::GitHub::V3
        access_token => $ENV{DPT_GITHUB_OAUTH},
    );

    $gh->set_default_user_repo( $gh_user, $gh_repo );

    my $issue;
    if ($opt_ticket) {
        $issue = $gh->issue->issue($opt_ticket);
        $gh->issue->create_comment( $opt_ticket, { body => $body } );
    }
    else {
        $issue = $gh->issue->create_issue(
            {   title  => $subject,
                body   => $body,
                labels => [ split( /,/, $gh_labels ) ],
            }
        );
    }

    $issue_url = $issue->{html_url};

ISSUE_CREATED:
    mark_patch_as_forwarded($issue_url) if $patch;
    mark_bug_as_forwarded($issue_url)   if $bug;
}

sub edit_message {
    my $body = shift or confess;

    $body
        = "# Feel free to edit the message contents to your liking.\n"
        . "# Fiddling with the patch itself is probably a bad idea.\n"
        . "# Heading lines starting with '#' are ignored\n"
        . "# Empty message aborts the process\n"
        . "#\n"
        . "# You may want to check if a similar ticket already exists at\n"
        . "#  $opt_tracker_url\n\n"
        . $body;

    $body = Proc::InvokeEditor->edit($body);

    $body =~ s/^#[^\n]*\n//mg while $body =~ /^#/;

    die "Empty message. Terminating.\n" unless $body;

    return $body;
}

sub mark_patch_as_forwarded {
    my $url = shift;

    my @lines = read_file($patch);

    my @result;
    my $forwarded = "Forwarded: $url\n";
    my $bug = "Bug: $url\n";
    my ( $forwarded_set, $bug_set );

    while ( @lines ) {
        my $line = shift @lines;

        if ( $line =~ /^Forwarded:/ ) {
            # probably 'Forwarded: no' or similar, see the check for existing
            # forwarding at the top
            push @result, $forwarded;
            $forwarded_set++;
            next;
        }

        if ( $line =~ /^Bug:/ ) {
            $bug_set++;
        }

        if ( $line =~ /^---/ or $line =~ /^\n/ ) {
            push @result, $forwarded unless $forwarded_set++;
            push @result, $bug unless $bug_set++;

            push @result, $line, @lines;
            last;
        }

        push @result, $line;
    }

    if ( not $forwarded_set or not $bug_set ) {
        warn "Patch formatting not recognized.";
        warn "Please make sure that the following headers are present:\n";
        warn " Forwarded: $url\n";
        warn " Bug: $url\n";
    }
    else {
        write_file( $patch, @result );

        print "Patch marked as forwarded to\n";
        print " $url\n";

        # TODO
        # `bts forwarded $bug $url` ? if the patch has ^Bug-Debian:
    }
}

sub mark_bug_as_forwarded {
    my $url = shift;

    my @cmd = ( 'bts', 'forward', $bug, $url );

    print 'Running ' . join( ' ', @cmd ) . ' ...';

    if ($opt_offline_test) {
        print " (not really) ";
    }
    else {
        system(@cmd) == 0
            or die " failed: $?\n";
    }

    print " done.\n";
}

sub detect_tracker {
    # discover the appropriate tracker

    return 'cpan' if $opt_tracker_url and $opt_tracker_url =~ /rt\.cpan\.org/;
    return 'github' if $opt_tracker_url and $opt_tracker_url =~ /github/;

    die "Unable to determine bug tracker from URL '$opt_tracker_url'.\n";
}

if ( $opt_tracker eq 'cpan' ) {
    submit_cpan_rt();
}
elsif ( $opt_tracker eq 'github' ) {
    submit_github();
}
else {
    die "Unsupported tracker: '$opt_tracker'\n";
}

=head1 AUTHOR

=over

=item Alessandro Ghedini <ghedo@debian.org>.

=item Damyan Ivanov <dmn@debian.org>.

=back

=head1 LICENSE AND COPYRIGHT

=over

=item Copyright 2014 Damyan Ivanov.

=item Copyright 2011 Alessandro Ghedini.

=back

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut
