#!/usr/bin/perl

use CPAN::Meta;
use Cwd qw(getcwd);
use MIME::Lite;
use File::Basename;
use File::Slurp qw(read_file write_file);
use Getopt::Long;
use Term::ReadLine;
use Proc::InvokeEditor;

use warnings;
use strict;

=head1 NAME

forward-patch - Forward a patch to CPAN's request tracker

=head1 SYNOPSIS

 forward-patch [option...] PATCH [DISTRIBUTION]

 Examples:
   $ forward-patch some-patch.patch Some-Dist # explicitly set dist name
   $ forward-patch some-patch.patch           # make f-p read dist name from debian/control

=head1 CONFIGURATION

If the distribution name is not set from the command-line B<forward-patch>
will also look at the C<Homepage> field in the C<debian/control> file or the
C<Source> filed in C<debian/copyright> and extracts the name from there.

B<forward-patch> will use by default the C<DEBFULLNAME> and C<DEBEMAIL>
environment variables to retrieve information about the ticket author. If not set,
L<getpwuid> and the C<EMAIL> environment variable will be used.

=head1 OPTIONS

=over

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

Instructs B<forward-patch> to use the specified issue tracker.

Supported values for I<tracker-name> are:

=over

=item B<github>

Uses GitHub API to submit the patch as an issue. Requires proper
C<< resources->repository >> in F<META>.

=item B<cpan>

Submits the patch to L<http://rt.cpan.org>.

=back

The default is determined by the C<resources.bugs> and C<resources.repository>
values in F<META>.

=back

=cut

my $opt_tracker;

GetOptions( 'tracker=s' => \$opt_tracker ) or exit 1;

my $patch = $ARGV[0];

die 'Err: Provide a valid patch file' if !$patch;

my $meta;
$meta = CPAN::Meta->load_file('META.json') if -e 'META.json';
$meta //= CPAN::Meta->load_file('META.yml') if -e 'META.jml';

sub get_subject {
    my $term = Term::ReadLine->new('forward-patch');

    my $subject .= basename($patch);
    $subject =~ s/(\_|\-)/\ /g;
    $subject =~ s/(\.patch|\.diff)//;

    return $term->readline( 'Subject:', "[PATCH] $subject" );
}

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

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

sub submit_cpan_rt {
    my $dist = shift;

    $dist ||= $meta->name if $meta;

    if ( !$dist ) {
        open my $dctrl, '<', 'debian/control'
            or die "Err: Can't open debian/control for reading: $!";

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

        close $dctrl or warn "Cannot close debian/control from reading: $!";
    }

    if ( !$dist ) {
        open my $dcopyright, '<', 'debian/copyright'
            or die "Err: Can't open debian/copyright for reading: $!";

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

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

    die 'Err: Provide valid distribution name' if !$dist;

    # prepare subject
    my $subject = get_subject();

    # RT::Client::REST does not support attachments, we need to use the email interface
    # prepare body
    my $body
        = "In Debian we are currently applying the attached patch to $dist.\n";
    $body .= "We thought you might be interested in it, too.\n\n";

    open my $patch_fh, '<', $patch
        or die "Err: Can't open $patch for reading: $!";

    while ( my $line = <$patch_fh> ) {
        last if ( $line =~ /^--- / );
        next if ( $line =~ /^Forwarded:/ );
        $body .= $line;
    }

    close $patch_fh or warn "Cannot close $patch from reading: $!";

    $body .= "\nThanks in advance,\n";
    $body .= "$name, Debian Perl Group\n";

    $body = edit_message($body);

    # now on to the email
    my $from = "$name <$email>";
    my $to   = 'bug-' . lc($dist) . '@rt.cpan.org';

    my $msg = MIME::Lite->new(
        From    => $from,
        To      => $to,
        Subject => $subject,
        Type    => 'multipart/mixed'
    ) or die "Error creating multipart container: $!\n";

    # edit body for ticket
    my $text = Proc::InvokeEditor->edit($body);

    $msg->attach(
        Type => 'TEXT',
        Data => $text
    ) or die "Error adding the text message part: $!\n";

    # add the patch as attachment
    $msg->attach(
        Type        => 'TEXT',
        Path        => $patch,
        Filename    => basename($patch),
        Disposition => 'attachment'
    ) or die "Error adding attachment: $!\n";

    # the email is not currently sent
    MIME::Lite->send( 'sendmail', '/usr/sbin/sendmail -t' )
        ;    # change mailer to your needs
    $msg->send;

    # TODO
    # find bug on https://rt.cpan.org/Public/Dist/Display.html?Name=$dist
    # or via RT::Client::REST and add the URL to the Forwarded header in the patch

    my $rturl = "https://rt.cpan.org/Public/Dist/Display.html?Name=$dist";
    print "Find your ticket on\n"
        . "$rturl\n"
        . "and add the ticket URL to $patch\n\n"
        . "Trying to open the URL with sensible-browser now.\n";
    system( 'sensible-browser', "$rturl" );
}

sub submit_github {

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

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

    my $url;
    $url = $meta->resources->{bugtracker}{web} if $meta->resources->{bugtracker};
    die "Unable to determine github issue tracker URL.\n" unless $url;

    my ( $gh_user, $gh_repo, $gh_opts )
        = $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 reposotory\n" . "from $url"
        unless $gh_user and $gh_repo;

    my $dist = $meta->name;

    # prepare subject
    my $subject = get_subject();

    # prepare body
    my $body
        = "In Debian we are currently applying the following patch to $dist.\n";
    $body .= "We thought you might be interested in it too.\n\n";

    # relative patch name
    my $rpn = Cwd::abs_path($patch);
    $rpn =~ s{(?:^|.+/)debian/patches/}{};

    my $package = basename(getcwd());

    my $alioth = 'https://anonscm.debian.org/cgit/pkg-perl/packages';

    $body .= "The patch is located at $alioth/$package.git/plain/debian/patches/$rpn\n\n";

    open my $patch_fh, '<', $patch
        or die "Err: Can't open $patch for reading: $!";

    while ( my $line = <$patch_fh> ) {
        last if $line =~ /^--- /;
        next if $line =~ /^Forwarded:/;
        $line =~ s/^Description:\s*//;
        $line =~ s/^ //;    # continuation lines
        $body .= '    ' . $line;    # indented
    }

    close $patch_fh or warn "Cannot close $patch from reading: $!";

    $body .= "\nThanks in advance,\n";
    $body .= "  $name, Debian Perl Group\n";

    $body = edit_message($body);

    # 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 $i = $gh->issue->create_issue(
        {   title => $subject,
            body  => $body,
            labels => [ split(/,/, $gh_labels) ],
        }
    );

    mark_patch_as_forwarded( $i->{html_url} );
}

sub edit_message {
    my $body = shift;

    $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"
        . $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);
    if ( $lines[0] =~ /^Description:/ ) {
        my @result;
        while ( @lines and $lines[0] =~ /^(?:\h|[a-z][a-z-]*:)/i ) {
            push @result, shift @lines;
        }

        push @result, "Forwarded: $url\n";

        push @result, @lines;

        write_file( $patch, @result );

        print "Patch marked as forwarded to\n";
        print "  $url\n";
    }
    else {
        warn "Patch formatting not recognized.";
        warn "Please add suitable marking that the patch was forwarded to\n";
        warn "  $url\n";
    }
}

sub detect_tracker {
    # discover the appropriate tracker

    unless ( $meta ) {
        warn "No META file found. Falling back to rt.cpan.org\n";
        return 'cpan';
    }

    my $url;
    $url = $meta->resources->{bugtracker}{web}
        if $meta->resources
        and $meta->resources->{bugtracker};

    # bad idea, as the issue tracker may be disabled
    #$url = $meta->resources->{repository}{web}
    #    if not $url
    #    and $meta->resources
    #    and $meta->resources->{repository};

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

    warn "Unable to determine bug tracker from META.\n";
    warn "Falling back to rt.cpan.org.\n";
    return 'cpan';
}

$opt_tracker ||= detect_tracker();

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

=head1 AUTHOR

Alessandro Ghedini <ghedo@debian.org>

=head1 LICENSE AND COPYRIGHT

Copyright 2011 Alessandro Ghedini.
Copyright 2014 Damyan Ivanov.
Copyright 2014 Salvatore Bonaccorso.

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
