view release on metacpan or  search on metacpan

script/kgb-bot  view on Meta::CPAN

    # we catch any exceptions, because we don't want reloading to be able
    # to kill the server
    unless ($KGB::foreground) {
        KGB->out("Error re-openning logs: $@\n")
            unless eval { KGB::open_log(); 1 };
    }

    # Reload successful
    $kernel->yield("_irc_reconnect");
    undef;
}

package KGB::SOAP;

use strict;
use warnings;

use POE;
use List::Util qw(max);
use Digest::SHA qw(sha1_hex);
use File::Basename;
use App::KGB::Change;
use Error ':try';

sub colorize {
    my( $category, $text ) = @_;

    return $text if $KGB::simulate and not $KGB::simulate_color;

    return $KGB::painter->colorize( $category => $text );
}

sub colorize_change {
    my $c = shift;

    return $KGB::painter->colorize_change($c);
}

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

    my $rev_prefix = $data->{rev_prefix} // '';
    my $commit_id = $data->{commit_id};
    my $changes = $data->{changes};
    my @log = split( /\n+/, $data->{commit_log} );
    my $author = $data->{author} // '';
    my $branch = $data->{branch} // '';
    my $module = $data->{module} // '';

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

    my $repo = $KGB::config->{repositories}{$repo_id};

    my @chanids = @{ $repo->{chanids} };
    push @chanids, @{ $KGB::config->{broadcast_channels} }
        unless $repo->{private};

    throw Error::Simple("Repository $repo_id has no associated channels.\n")
        unless (@chanids);

    my $path_string;
    my %dirs;
    my $changed_files   = scalar(@$changes);
    my $MAGIC_MAX_FILES = 4;

    $_ = App::KGB::Change->new($_)
        for grep { defined($_) and $_ ne '' } @$changes;  # convert to objects

    my $common_dir = App::KGB::Change->detect_common_dir($changes) // '';

    my @info;

    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
    utf8::decode($_)
        for ( $repo_id, $rev, @$paths, $log, $author, $branch, $module );
    my $message = join( "",
        $repo_id,
        $rev // (),
        @$paths,
        $log,
        ( defined($author) ? $author : () ),
        ( defined($branch) ? $branch : () ),
        ( defined($module) ? $module : () ),
        $KGB::config->{repositories}{$repo_id}{password} );
    utf8::encode($message);    # Convert to byte-sequence

    throw Error::Simple("Authentication failed for repository $repo_id\n")
        if $KGB::config->{repositories}{$repo_id}{password}
        and sha1_hex($message) ne $checksum;

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

sub do_commit_v3 {
    my ( $kernel, $repo_id, $serialized, $checksum ) = @_;

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

    my $pwd = $KGB::config->{repositories}{$repo_id}{password};
    throw Error::Simple("Authentication failed for repository $repo_id\n")
        if not defined($pwd)
        or sha1_hex( $repo_id, $serialized, $pwd ) ne $checksum;

    my $data;
    my $ok = eval { $data = Storable::thaw($serialized); 1 };

    throw Error::Simple("Invalid serialized data\n")
        unless $ok;

    do_commit_msg( $kernel, $repo_id, $data );
}

sub commit {
    my $kernel   = $_[KERNEL];
    my $response = $_[ARG0];
    my $params   = $response->soapbody();

    my $result;
    try {
        $result = do_commit( $kernel, $params );

        $response->content("OK");
        $kernel->post( SOAPServer => 'DONE', $response );
    }
    catch Error::Simple with {
        my $E = shift;
        KGB->out("$E");
        $kernel->post(
            SOAPServer => 'FAULT',
            $response, 'Client.Arguments',
            "$E",
        );
    }
    otherwise {
        my $E = shift;
        KGB->out("commit crashed: $E");
        $kernel->post(
            SOAPServer => 'FAULT',
            $response, 'Server.Code',
            'Internal Server Error'
        );
    };
}

sub do_commit {
    my ( $kernel, $params ) = @_;

    KGB->out( "commit: " . YAML::Dump($params) ) if $KGB::debug;

    throw Error::Simple("commit(params ...)\n")
        unless ref $params
        and ref $params eq "HASH"
        and $params->{Array}
        and ref $params->{Array}
        and ref $params->{Array} eq "ARRAY";

    my $proto_ver;
    if ( @{ $params->{Array} } == 6 ) {
        $proto_ver = 0;
    }
    else {
        $proto_ver = shift @{ $params->{Array} };
    }

    throw Error::Simple(
        sprintf(
            "Protocol version %s not welcomed\n", $proto_ver // '<undef>'
        )
        )
        unless defined($proto_ver)
        and $KGB::supported_protos{$proto_ver}
        and $proto_ver >= $KGB::config->{min_protocol_ver};

    throw Error::Simple("Rate limit enforced\n")
        if $KGB::config->{queue_limit}
        and $KGB::IRC::irc_object
        and $KGB::config->{queue_limit} < $KGB::IRC::irc_object->send_queue;

    if ( $proto_ver == 0 ) {
        return do_commit_v0( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 1 ) {
        return do_commit_v1( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 2 ) {
        return do_commit_v2( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 3 ) {
        return do_commit_v3( $kernel, @{ $params->{Array} } );
    }
    throw Error::Simple("Invalid protocol version ($proto_ver)\n");
}

package KGB::IRC;

use strict;
use warnings;

use App::KGB;
use Digest::MD5 qw(md5_hex);
use Monkey::Patch;
use POE;
use POE::Component::IRC::Common qw( parse_user matches_mask );
use POE::Component::IRC::Constants qw( MSG_PRI MSG_TEXT PRI_HIGH );
use Schedule::RateLimiter;
use Storable qw(dclone);

our %current = ();
our $irc_object;
our $autoresponse_limitter
    = Schedule::RateLimiter->new( iterations => 5, seconds => 30,
    block => 0 );

# Monkey patch to avoid delaying high priority commands when flood protection
# is enabled.
sub _sl_delayed {
    my $orig_func = shift;
    my $self = $_[OBJECT];
    return if !defined $self->{socket};

    while (@{ $self->{send_queue} } &&
        $self->{send_queue}[0][MSG_PRI] <= PRI_HIGH)
    {
        my $arg = (shift @{$self->{send_queue}})->[MSG_TEXT];
        warn ">>> $arg\n" if $self->{debug};
        $self->send_event(irc_raw_out => $arg) if $self->{raw};
        $self->{socket}->put($arg);
    }
    return $orig_func->(@_);
}
my $patch = Monkey::Patch::patch_package('POE::Component::IRC', 'sl_delayed',
    \&_sl_delayed);

# Handles the connection, disconnection and real-time configuration changes WRT
# IRC servers and channels
sub _irc_reconnect {
    my ( $kernel, $session ) = @_[ KERNEL, SESSION ];
    my ( @to_start, @to_stop, @to_restart );

    KGB->debug("_irc_reconnect called, re-sync network configuration.");
    foreach my $net ( keys %current ) {
        next unless ( defined( $current{$net} ) );
        my ( $new, $old )
            = ( $KGB::config->{networks}{$net}, $current{$net} );
        if ( !$new ) {
            push @to_stop, $net;
        }
        elsif ($new->{nick} ne $old->{nick}
            or $new->{ircname}  ne $old->{ircname}
            or $new->{username} ne $old->{username}
            or ( $new->{password} || "" ) ne ( $old->{password} || "" )