#!/usr/bin/perl

use autodie;
use Carp;
use CPAN::Meta;
use Cwd qw(getcwd);
use File::HomeDir;
use File::Slurp qw(read_file write_file);
use File::Spec;
use Getopt::Long;
use Time::Piece qw(localtime);
use YAML::XS qw(LoadFile);
use Debian::PkgPerl::Bug;
use Debian::PkgPerl::Patch;
use Debian::PkgPerl::Message;
use Debian::PkgPerl::GitHub;

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<Name> field in
F<debian/upstream/metadata>, 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 B<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> or the C<Bug-Database>
field in F<debian/upstream/metadata>. Defaults to C<<
https://rt.cpan.org/Public/Dist/Display.html?Name=I<dist-name> >> for B<cpan> and
is mandatory for B<github>.

=item B<--use-mail>

Send bug and patch submissions by e-mail instead of creating an issue
or pull request via API. As the resulting ticket URL is not known to
B<dpt forward>, it cannot mark patch and bug as forwarded.

=item B<--mailto> I<address>

This option sets the e-mail address to forward to. The default
is determined from the C<< resources->bugtracker->mailto >>
field of F<META> or CPAN RT bug address if that field is not present.

=item B<--fallback>

Enable fallback to forwarding patches as bug reports when pull requests
fail for any reason. Defaults to false.

=back

=head1 FILES

=over

=item ~/.pause

Your pause credentials. At least B<user> and B<password> are needed in order
to create tickets on rt.cpan.org via REST API. B<dpt forward> will fall back
to email (slower, won't mark patches and bugs forwarded) otherwise.

=back

=head1 ENVIRONMENT

=over

=item DPT_GITHUB_OAUTH

In order to perform github operations, DPT_GITHUB_OAUTH must be set.
See L<dpt-github-oauth(1)> on how to obtain an access token for your
github account, and L<dpt-config(5)> on storing settings permanently
in dpt.conf.

=item DPT_GITHUB_ORGNAME

Producing merge requests on github as a result of forwarding a patch
requires that you belong to an organization that will own the cloned
repositories from upstream. Therefore you'll need that some
organization administrator invites you; for instance by using
L<dpt-invite-github(1)>.

For more details about tuning merge requests through environment
variables and their defaults, please see L<Debian::PkgPerl::GitHub(1)>.

=back

=head1 SEE ALSO

L<Forwarding tutorial|https://perl-team.pages.debian.net/forward.html>

=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;
my $opt_use_mail;
my $opt_mailto;
my $opt_fallback;

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,
    'use-mail!'       => \$opt_use_mail,
    'mailto=s'        => \$opt_mailto,
    'fallback!'       => \$opt_fallback,
) 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;

my $upstream_metadata;
$upstream_metadata = LoadFile('debian/upstream/metadata')
    if -e 'debian/upstream/metadata';

$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 ||= detect_tracker_url();

if ( $meta and $meta->resources and $meta->resources->{bugtracker} ) {
    $opt_mailto      ||= $meta->resources->{bugtracker}{mailto};
    $opt_mailto =~ s/ at /@/ if $opt_mailto;
}

$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 ( $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) {
    my $patch_info = Debian::PkgPerl::Patch->new(
        patch => $patch,
        force => $opt_force,
    );
    %patch_info = $patch_info->retrieve_patch_info();
}

my $bug_info = Debian::PkgPerl::Bug->new(
    bug     => $bug,
    offline => $opt_offline_test,
    force   => $opt_force,
);
%bug_info = $bug_info->retrieve_bug_info() if $bug;

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

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

my $message = Debian::PkgPerl::Message->new(
    bug     => $bug,
    patch   => $patch,
    info    => $bug ? \%bug_info : \%patch_info,
    tracker => $opt_tracker,
    url     => $opt_tracker_url,
    dist    => $opt_dist,
    name    => $name,
    email   => $email,
    mailto  => $opt_mailto,
);

sub detect_dist {
    return $upstream_metadata->{Name}
        if $upstream_metadata
        and exists $upstream_metadata->{Name};

    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;

    return;
}

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

sub read_pause_credentials {
    my $pausefile = File::Spec->catfile( File::HomeDir->my_home, '.pause' );
    unless ( -r $pausefile ) {
        warn "Could not open ~/.pause, supply credentials to use REST interface\n";
        return 0;
    }

    open my $pauserc, '<', $pausefile;

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

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

    close $pauserc;

    if (not $rt_login{'user'} or not $rt_login{'password'}) {
        warn "Err: Provide valid PAUSE credentials\n";
        return 0;
    }

    return 'pause credentials ok';
}

sub submit_cpan_rt {
    # prepare subject
    my $subject = $message->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 = $message->prepare_body();

    my $ticket_url;

    if ($opt_offline_test) {
        $ticket_url = "https://rt.cpan.org/Ticket/Display.html?id=DUMMY";
    }
    else {
        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 is the current version of 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 {
    my $gh = Debian::PkgPerl::GitHub->new(
        ticket   => $opt_ticket,
        message  => $message,
        fallback => $opt_fallback,
    );

    my $issue_url = $opt_offline_test ? $gh->test() : $gh->forward();

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

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.\n";
        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_url {
    $opt_tracker_url ||= $meta->resources->{bugtracker}{web}
        if $meta
        and $meta->resources
        and $meta->resources->{bugtracker};

    $opt_tracker_url ||= $upstream_metadata->{'Bug-Database'}
        if $upstream_metadata
        and exists $upstream_metadata->{'Bug-Database'};

    unless ($opt_tracker_url) {
        warn "Bug tracker web 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";
    }

    return $opt_tracker_url;
}

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_use_mail) {
    $message->send_by_mail();
}
elsif ( $opt_tracker eq 'cpan' ) {
    if ( read_pause_credentials() ) {
        submit_cpan_rt();
    } else {
        warn "Falling back to email\n";
        $message->send_by_mail();
    }
}
elsif ( $opt_tracker eq 'github' ) {
    submit_github();
}
else {
    die "Unsupported tracker: '$opt_tracker'\n";
}

=head1 LICENSE AND COPYRIGHT

=over

=item Copyright 2016 Alex Muntada.

=item Copyright 2014 Salvatore Bonaccorso.

=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