pkg-perl-tools 0.42 / usr / share / perl5 / Debian / PkgPerl / GitHub.pm

package Debian::PkgPerl::GitHub;

use strict;
use warnings;


=head1 NAME

Debian::PkgPerl::GitHub - Help forwarding a bug or a patch to GitHub

=head1 SYNOPSIS

    use Debian::PkgPerl::Bug;
    use Debian::PkgPerl::Patch;
    use Debian::PkgPerl::Message;
    use Debian::PkgPerl::GitHub;
    
    my %params = (
        url     => 'https://github.com/foo/bar/issues',
        tracker => 'github',
        dist    => 'Foo-Bar',
        name    => 'My Name',
        email   => 'my.name@example.com',
        mailto  => 'your.name@example.com',
    );
    
    my %bug_info = Debian::PkgPerl::Bug
        ->new( bug => 123 )
        ->retrieve_bug_info();
    my $bug_msg = Debian::PkgPerl::Message->new(
        %params,
        info => \%bug_info,
    );
    print Debian::PkgPerl::GitHub->new(
        message => $bug_msg,
        ticket  => 456,
    )->forward();
    
    my %patch_info = Debian::PkgPerl::Patch
        ->new( patch => 'foo-bar.patch' )
        ->retrieve_patch_info();
    my $patch_msg = Debian::PkgPerl::Message->new(
        %params,
        info => \%patch_info,
    );
    print Debian::PkgPerl::GitHub->new(
        message  => $patch_msg,
        fallback => 0,
    )->forward();

=head1 DESCRIPTION

This module exports several helpers that that provide support for
forwarding patches to GitHub as pull requests.

=head1 METHODS

=cut


use File::Temp qw(tempdir);
use Git::Repository;
use Cwd 'realpath';


=head2 new(%params)

=head3 Parameters:

=over

=item * message

Message to be forwarded to an upstream project.

=item * ticket

Existing issue number to forward the bug to.

=item * fallback

Enables fallback to forwarding a patch as an issue if pull-request
fails for any reason. Default is false.

=back

=head3 Environment:

=over

=item * DPT_GITHUB_OAUTH

GitHub personal API token. No default.

=item * DPT_GITHUB_ORGNAME

Organization used to fork upstreams. Defaults to I<pkg-perl-tools>.

=item * DPT_GITHUB_BRANCH

Branch name for pull requests. Defaults to C<pkg-perl-$^T>.

=back

=cut

sub new {
    my $class = shift;
    my %params = @_;

    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 $params{message} and $params{message}->get_url();

    my ( $owner, $repo, $opts )
        = $params{message}->get_url()
        =~ m{^https?://github.com/([^/]+)/([^/]+)/issues(?:/?|\?(.*))$};

    my @labels;
    @labels = split /,/, $1 if $opts and $opts =~ m{labels=([^;&]+)};

    die "Unable to determine github user and repository\n"
        . "from " . $params{message}->get_url()
        unless $owner and $repo;

    my $github = Net::GitHub::V3->new(
        access_token => $ENV{DPT_GITHUB_OAUTH},
    );

    my %obj = (
        %params,
        github  => $github,
        owner   => $owner,
        repo    => $repo,
        labels  => \@labels,
        orgname => $ENV{'DPT_GITHUB_ORGNAME'} || 'pkg-perl-tools',
        branch  => $ENV{'DPT_GITHUB_BRANCH' } || "pkg-perl-$^T",
    );

    return bless \%obj, $class;
}

=head2 fork_exists()

Checks if any member in the GitHub organization has already forked a repository.

=head3 Returns:

Boolean value.

=cut

sub fork_exists {
    my $self = shift;

    my $gh   = $self->{github};
    my $user = $self->{orgname};
    my $repo = $self->{repo};

    return !!eval{ $gh->repos->get($user, $repo) };
}

=head2 create_fork()

Creates a repository fork by an organization.

=head3 Returns:

The new forked repository.

=cut

sub create_fork {
    my $self = shift;

    my $gh = $self->{github};
    my $owner = $self->{owner};
    my $repo  = $self->{repo};
    my $orgname = $self->{orgname};

    $gh->repos->set_default_user_repo($owner, $repo);
    return $gh->repos->create_fork($orgname);
}

=head2 clone_branch_patch_push()

Clones a repository in a temporary directory, creates a new branch,
applies the patch, commits the change, pushes it and removes the
temporary working copy.

=head3 Returns:

Nothing.

=cut

sub clone_branch_patch_push {
    my $self = shift;
    my %params = @_;

    my $orgname = $self->{orgname};
    my $user    = $self->{owner};
    my $repo    = $self->{repo};
    my $branch  = $self->{branch};
    my $comment = $self->{message}->get_subject();
    my $patch   = $self->{message}->get_patch();

    # Clone
    my $workdir = tempdir( CLEANUP => 1 );
    Git::Repository->run(
        clone => "git\@github.com:$orgname/$repo.git",
        $workdir,
        { quiet => 1 },
    );
    my $r = Git::Repository->new(
        work_tree => $workdir,
        { quiet => 1 },
    );

    # Sync
    $r->run( qw( remote add upstream ) => "https://github.com/$user/$repo.git" );
    $r->run( pull => '--ff-only', qw( upstream master ) );
    $r->run( push => qw( origin master ) );

    # Branch
    $r->run( checkout => '-b', $branch );

    # Patch
    $r->run( apply => '-p1', realpath($patch), { quiet => 0, fatal => "!0" } );

    # Push
    $r->run( add => '.' );
    $r->run( commit => '-m', $comment );
    $r->run( push => 'origin', $branch );

    return;
}

=head2 create_pull_request()

=head3 Returns:

Pull request URL on success, nothing otherwise.

=cut

sub create_pull_request {
    my $self = shift;

    my $gh   = $self->{github};
    my $user = $self->{owner};
    my $repo = $self->{repo};

    $gh->pull_request->set_default_user_repo($user, $repo);

    my $pull = $gh->pull_request->create_pull({
        title  => $self->{message}->get_subject(),
        body   => $self->{message}->prepare_body(),
        head   => join(":", $self->{orgname}, $self->{branch}),
        base   => 'master',
        labels => $self->{labels},
    });
    return $pull && $pull->{html_url};
}

=head2 forward_patch_as_pull_request()

=cut

sub forward_patch_as_pull_request {
    my $self = shift;

    my $gh = $self->{github};
    my $orgname = $self->{orgname};
    die "Cannot find your GitHub user in $orgname organization"
        unless $gh->user->show($orgname)->{login} eq $orgname;

    $self->create_fork() unless $self->fork_exists();
    $self->clone_branch_patch_push();
    my $issue_url = $self->create_pull_request();
    return $issue_url;
}

=head2 forward_patch_as_ticket()

Fallback to forwarding a patch as a bug.

=head3 Returns:

Issue URL on success, nothing otherwise.

=cut

sub forward_patch_as_ticket {
    my $self = shift;

    # Do nothing unless fallback is enabled.
    return unless $self->{fallback};

    my $gh      = $self->{github};
    my $owner   = $self->{owner};
    my $repo    = $self->{repo};
    my $ticket  = $self->{ticket};
    my $title   = $self->{message}->get_subject();
    my $comment = $self->{message}->prepare_body();

    $gh->set_default_user_repo( $owner, $repo );
    my $issue;
    if ($ticket) {
        $issue = $gh->issue->issue($ticket);
        $gh->issue->create_comment( $ticket, { body => $comment } );
    }
    else {
        $issue = $gh->issue->create_issue({
            title  => $title,
            body   => $comment,
            labels => $self->{labels},
        });
    }

    return $issue && $issue->{html_url};
}

=head2 forward_bug_as_issue()

=cut

sub forward_bug_as_issue {
    my $self = shift;

    my $gh      = $self->{github};
    my $user    = $self->{owner};
    my $repo    = $self->{repo};
    my $ticket  = $self->{ticket};
    my $title   = $self->{message}->get_subject();
    my $comment = $self->{message}->prepare_body();

    $gh->set_default_user_repo( $user, $repo );

    my $issue;
    if ($ticket) {
        $issue = $gh->issue->issue($ticket);
        $gh->issue->create_comment( $ticket, { body => $comment } );
    }
    else {
        $issue = $gh->issue->create_issue({
            title  => $title,
            body   => $comment,
            labels => $self->{labels},
        });
    }

    return $issue->{html_url};
}

=head2 forward()

Forward an issue as a pull request or bug.

=cut

sub forward {
    my $self = shift;

    my $issue_url;
    $issue_url = $self->forward_bug_as_issue()
        unless $self->{message}->get_patch();

    $issue_url = eval { $self->forward_patch_as_pull_request() }
        unless defined $issue_url;

    warn "WARNING! Pull request failed...\n$@" if $@;

    $issue_url = $self->forward_patch_as_ticket()
        unless defined $issue_url;

    return $issue_url;
}

=head2 test()

Support for off-line testing.

=cut

sub test {
    my $self = shift;

    my $gh_user = $self->{owner};
    my $gh_repo = $self->{repo};

    return "https://github.com/$gh_user/$gh_repo/issues/DUMMY";
}

=head1 LICENSE AND COPYRIGHT

=over

=item Copyright 2016 Alex Muntada.

=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

1;