App-KGB
22 results

 view release on metacpan or  search on metacpan

script/kgb-bot  view on Meta::CPAN 

    push @info, colorize( module => $module ) if $module ne '';
    push @info, colorize( branch => $branch ) if $branch ne '';
    push @info, "$rev_prefix" . colorize( revision => $commit_id )
        if defined $commit_id;
    push @info, colorize( author => $author ) if $author ne '';
    push @info, colorize( path => "$common_dir/" ) if $common_dir ne '';

    if ( $changed_files > $MAGIC_MAX_FILES ) {
        my %dirs;
        for my $c (@$changes) {
            my $dir = dirname( $c->path );
            $dirs{$dir}++;
        }

        my $dirs = scalar( keys %dirs );

        my $path_string = join( ' ',
            ( $dirs > 1 )
            ? sprintf( "(%d files in %d dirs)", $changed_files, $dirs )
            : sprintf( "(%d files)",            $changed_files ) );

        push @info, colorize( path => $path_string );
    }
    else {
        push @info, join( ' ', map { colorize_change($_) } @$changes )
            if @$changes;
    }

    my @string = join( ' ', @info );

    my $web_string
        = defined( $data->{extra}{web_link} )
        ? colorize( web => $data->{extra}{web_link} )
        : undef;

    my $use_notices = $data->{extra}{use_irc_notices};

    # one-line notifications result in:
    #  user branch commit module changes log link
    # multi-line notifications look like:
    #  user branch commit module changes link
    #  log line 1
    #  log line 2 ...
    if ( 1 == @log and length($log[0]) <= 80 ) {
        $string[0] .= ' ' . colorize( separator => '*' ) . ' ' . $log[0];
    }
    else {
        push @string, @log;
    }

    $string[0] .= ' ' . colorize( separator => '*' ) . ' ' . $web_string
        if defined($web_string);

    @string = trim_lines(\@chanids, $repo_id, @string);

    foreach my $chanid ( @chanids ) {
        if ($KGB::simulate) {
            my $fh = IO::File->new(">> $KGB::simulate")
                or die "Error opening $KGB::simulate for writing: $!\n";
            $fh->autoflush(1);
            $fh->binmode(':utf8');
            for (@string) {
                $fh->print("$chanid $_\n");
            }
            $fh->close;
        }
        else {
            my ( $net, $chan ) = KGB->get_net_chan($chanid);
            $kernel->yield(
                irc_notify => $net, $chan, \@string,
                $use_notices ? 'notice' : 'privmsg'
            );
        }
    }
}

sub do_commit_v0 {
    my ( $kernel, $repo_id, $passwd, $rev, $paths, $log, $author )
        = @_;

    throw Error::Simple("Unknown repository '$repo_id'\n")
        unless $KGB::config->{repositories}{$repo_id};

    throw Error::Simple("Invalid password for repository $repo_id\n")
        if $KGB::config->{repositories}{$repo_id}{password}
        and $KGB::config->{repositories}{$repo_id}{password} ne $passwd;

    do_commit_msg(
        $kernel,
        $repo_id,
        {   rev_prefix => 'r',
            commit_id  => $rev,
            changes    => $paths,
            commit_log => $log,
            author     => $author
        }
    );
}

sub do_commit_v1 {
    my ($kernel, $repo_id, $checksum, $rev,
        $paths,  $log,      $author,  $branch,   $module
    ) = @_;

    # v1 is the same as v2, but has no rev_prefix parameter
    return do_commit_v2(
        $kernel, $repo_id, $checksum, 'r', $rev,
        $paths,  $log,      $author,  $branch,   $module
    );
}

sub do_commit_v2 {
    my ($kernel,     $repo_id, $checksum,
        $rev_prefix, $rev,      $paths,   $log,
        $author,     $branch,   $module,
    ) = @_;

    throw Error::Simple("Repository $repo_id is unknown\n")
        unless $KGB::config->{repositories}{$repo_id};

    # Protocol v2 always uses UTF-8

script/kgb-bot  view on Meta::CPAN 

}

sub do_json_commit_v4 {
    my ( $self, $kernel, $repo_id, $data ) = @_;

    KGB::SOAP::do_commit_msg( $kernel, $repo_id, $data );
}

sub do_json_relay_message {
    my ( $self, $kernel, $repo_id, $message, $opts ) = @_;

    $opts ||= {};

    defined $repo_id or die "Missing repo_id argument\n";
    exists $KGB::config->{repositories}{$repo_id} or die "Invalid repository '$repo_id'\n";
    my $repo = $KGB::config->{repositories}{$repo_id};
    my @chanids = @{ $repo->{chanids} };
    push @chanids, @{ $KGB::config->{broadcast_channels} }
        unless $repo->{private};

    die("Repository $repo_id has no associated channels.\n") unless @chanids;

    my @messages;

    defined($message) or die "No message parameter";
    if (ref($message) ) {
        ref($message) eq 'ARRAY'
            or die "Unsupported ref ("
            . ref($message)
            . ") for the message parameter";

        for (@$message) {
            defined($_) and not ref($_) or die "Invalid message";
            length($_) or die "Empty message";
        }

        KGB->debug(
            sprintf( "Received a batch of %d messages\n", scalar(@$message) )
        );
        @messages = @$message;
    }
    else {
        length($message) or die "Empty message";

        push @messages, $message;
    }

    die "Too much messages (rate limit overflow)"
        if $KGB::config->{queue_limit}
        and $KGB::IRC::irc_object
        and $KGB::config->{queue_limit}
        < ( $KGB::IRC::irc_object->send_queue + scalar(@messages) );

    foreach my $msg (@messages) {
        foreach my $chanid ( @chanids ) {
            for my $line ( split( /\n/, $msg ) ) {
                if ($KGB::simulate) {
                    my $fh = IO::File->new(">> $KGB::simulate")
                        or die "Error opening $KGB::simulate for writing: $!\n";
                    $fh->autoflush(1);
                    $fh->binmode(':utf8');
                    $fh->print("$chanid $line\n");
                    $fh->close;
                }
                else {
                    my ( $net, $chan ) = KGB->get_net_chan($chanid);
                    $kernel->yield(
                        irc_notify => $net, $chan, [$line],
                        $opts->{use_irc_notices} ? 'notice' : 'privmsg'
                    );
                }
            }
        }
    }

    return 'OK';
}

package KGB::WebHook;

use strict;
use warnings;
use File::Basename;
use HTTP::Status;
use JSON;
use App::KGB::Painter;
use List::MoreUtils qw(any);
use List::Util qw(max);
use Net::IP;
use POE;
use Text::Glob qw(match_glob);

sub colorize { KGB::SOAP::colorize( @_ ) };
sub colorize_change { KGB::SOAP::colorize_change( @_ ) };

sub webhook_error(\@$;$$) {
    my $env = shift;
    my $message = shift;
    my $code = shift // HTTP::Status::HTTP_BAD_REQUEST;
    my $content = shift // $message;

    KGB->debug("Webhook error: $message");
    my $response = $env->[ARG1];
    $response->code($code);
    $response->message($message);
    $response->content($content);
    return $env->[KERNEL]->post( $env->[SENDER], DONE => $response);
}

=head2 webhook_request I<request> I<response> I<dirmatch>

Handler for webhook HTTP request.

This handler only processes the HTTP part, parsing URI parameters and POST
contents.

The actual processing and IRC notification is done via an appropriate
C<gitlab_webhook_*> event, asynchronously.

=cut

script/kgb-bot  view on Meta::CPAN 

        unless ($ok) {
            KGB->out("Unable to load URL shortening service '$service': $@");
            return $url;
        }

        $shortener_loaded = $service;
    }

    my $short_url;
    my $ok = eval { $short_url = short_link($url); 1 };

    unless ($ok) {
        KGB->out(
            "Failure while calling URL shortening service '$service' for '$url': $@"
        );
        return monkey_shorten_git_hashes($url);
    }

    unless ( defined $short_url ) {
        KGB->out(
            "URL shortening service '$service' failed to shorten '$url'.");
        return monkey_shorten_git_hashes($url);
    }

    KGB->count('URLs_shortened');
    return $short_url;
}

sub trim_lines(\@$@) {
    my ( $chanids, $repoid, @strings ) = @_;
    # Standard says 512 (minus \r\n), anyway that's further trimmed when
    # resending to clients because of prefix.
    # Let's trim on 400, to be safe
    my $MAGIC_MAX_LINE = ( 400 - length("PRIVMSG ")
        - max( map( length($KGB::config->{chanidx}{$_}{name}), @$chanids ) ) );

    my @tmp;
    while ( $_ = shift @strings ) {
        if ( length($_) > $MAGIC_MAX_LINE ) {
            push @tmp, substr( $_, 0, $MAGIC_MAX_LINE );
            unshift @strings, substr( $_, $MAGIC_MAX_LINE );
        }
        else {
            push @tmp, $_;
        }
    }
    return @tmp;
}

sub webhook_to_irc {
    my ( $p ) = @_;

    my @chanids = @{ $p->{chanids} };
    my @strings = trim_lines(@chanids, $p->{repository}, @{ $p->{strings} });

    foreach my $chanid (@chanids) {
        if ( $KGB::simulate ) {
            my $fh = IO::File->new(">> $KGB::simulate")
                or die "Error opening $KGB::simulate for writing: $!\n";
            $fh->autoflush(1);
            $fh->binmode(':utf8');
            for (@strings) {
                $fh->print("$chanid $_\n");
            }
            $fh->close;
        }
        else {
            my ( $net, $chan ) = KGB->get_net_chan($chanid);
            my $method = $p->{opts}{use_irc_notices} ? 'notice' : 'privmsg';
            if ( not exists $KGB::joining_channels{$chanid} )
            {
                $p->{kernel}->yield(
                    irc_notify => $net, $chan, \@strings, $method
                );
            }
            else {
                KGB->out(
                    "Delaying a message to $chanid for after it is joined."
                );
                my $stash = { message => \@strings, method  => $method };
                push (@{ $KGB::joining_channels{$chanid}{pending_messages} },
                    $stash);
            }
        }
    }
}

=head2 gitlab_webhook_push

Handle a gitlab webhook call for the C<push> event (branch update).

Expects the body of the POST request (decoded, as a hash reference) in I<ARG0>
and all the request parameters in I<ARG1>.

The request is expected to conform to the GitLab webhook documentation at
L<https://salsa.debian.org/help/user/project/integrations/webhooks.md#push-events>.

The request parameters should look like the result of the CGI's param() method.

Supported parameters (?param=value&param=value2...)

=over

=item channel

The name of the channel to post notifications to. Leading hash sign is optional
and should be URL-encoded if present (%23).

=item network

The name of the IRC network, servicing the channel. Supported networks are
configured by the bot's admin.

=item private

A boolean flag, indicating that the notifications shouldn't also be posted to
the C<#commits> channel on Freenode.

=item use_color

A boolean flag enabling colors. Defaults to true.

script/kgb-bot  view on Meta::CPAN 

sub gitlab_webhook_build {
    my ( $kernel, $chanids, $body, $opts ) = @_[ KERNEL, ARG0 .. ARG2 ];

    my $module = $body->{project_name};

    KGB->debug("Handling webhook build event for project $module");

    local $KGB::painter = $KGB::painter_dummy
        if exists $opts->{use_color} and not $opts->{use_color};

    my $log = sprintf(
        'Build #%d (%s) stage: %s, status: %s',
        $body->{build_id}, $body->{build_name},
        $body->{build_stage}  // 'UNKNOWN',
        $body->{build_status} // 'UNKNOWN'
    );
    $log .= ". Duration: " . human_duration( $body->{build_duration} )
        if defined $body->{build_duration};

    my @info;

    push @info, colorize( module => $module ) if $module ne '';
    push @info, colorize( branch => 'builds' );
    push @info, colorize( author => $body->{user}{name} );
    push @info, colorize( revision => substr( $body->{sha}, 0, 7 ) )
        if $body->{object_attributes}{id};
    push @info, colorize( separator => '*' ) . ' ' . $log;

    my @string = join( ' ', @info );

    webhook_to_irc(
        {   kernel     => $kernel,
            chanids    => $chanids,
            strings    => \@string,
            repository => $body->{project}{namespace},
            opts       => $opts,
        }
    );
}

package main;

use strict;
use warnings;

use POE;
use POE::Component::Server::SOAP;
use POE::Component::IRC::State;
use POE::Component::IRC::Plugin::AutoJoin;
use POE::Component::IRC::Plugin::BotAddressed;
use POE::Component::IRC::Plugin::Connector;
use POE::Component::IRC::Plugin::NickReclaim;
use POE::Component::IRC::Plugin::NickServID;
use POE::Component::IRC::Plugin::CTCP;
use Getopt::Long;
use YAML ();
use Proc::PID::File;

KGB::save_progname();
$KGB::out = \*STDERR;
binmode( $KGB::out, ':utf8' );

my $conf_file  = '/etc/kgb-bot/kgb.conf';
my $conf_dir   = '/etc/kgb-bot/kgb.conf.d';
$KGB::foreground = 0;
$KGB::simulate = 0;
$KGB::simulate_color = 0;
$KGB::debug = 0;

Getopt::Long::Configure("bundling");
GetOptions(
    'c|config=s'   => \$conf_file,
    'cd|config-dir=s' => \$conf_dir,
    'f|foreground' => \$KGB::foreground,
    'simulate=s'    => \$KGB::simulate,
    'simulate-color!' => \$KGB::simulate_color,
    'debug!'        => \$KGB::debug,
) or die 'Invalid parameters';

@ARGV and die "No command line arguments supported\n";

KGB::load_conf($conf_file);

use Cwd;
$KGB::simulate = Cwd::realpath($KGB::simulate) if $KGB::simulate;

$KGB::painter
    = App::KGB::Painter->new( { item_colors => $KGB::config->{colors} } );

our $pid_keeper;

unless ($KGB::foreground) {
    pipe IN, OUT or die "pipe: $!\n";
    my $pid = fork();
    die "Can't fork: $!" unless ( defined $pid );
    if ($pid) {
        close OUT;
        my $r = join( "", <IN> );
        close IN or die $!;
        if ( $r =~ /^OK$/ ) {
            exit 0;
        }
        else {
            die $r;
        }

        die "Should not happen";
    }

    $poe_kernel->has_forked;

    close IN;
    eval {
        $pid_keeper = Proc::PID::File->new(
            verify => 1,
            dir    => $KGB::config->{pid_dir},
        );
        die "Already running\n" if $pid_keeper->alive;
        $pid_keeper->write;
        POSIX::setsid() or die "setsid: $!\n";
        umask(0022);



( run in 1.426 second using v1.01-cache-2.11-cpan-97f6503c9c8 )