App-KGB

 view release on metacpan or  search on metacpan

lib/App/KGB/Client.pm  view on Meta::CPAN

Timeout for server communication. Default is 15 seconds, as we want instant IRC
and commit response.

=item B<servers>

An array of servers, each an instance of L<App::KGB::Client::ServerRef> class.

When several servers are configured, the list is shuffled and then the servers
are tried one after another until a successful request is done, or the list is
exhausted, in which case an exception is thrown.

When shuffling, preference is added to the last server used by the client, or
by other clients (given C<status_dir> is configured).

=item B<batch_messages>

If true, the notifications are sent as a batch in one request to the server.
Useful with VCS that send many changes a time (e.g. Git).

Defaults to false, but will be changed later after some grace period for server

lib/App/KGB/Client/ServerRef.pm  view on Meta::CPAN

=back

=head1 METHODS

=over

=item B<send_changes> (I<message parameters>)

Transmits the change set and all data about it along with the necessary
authentication hash. If an error occurs, an exception is thrown.

Message parameters are passed as arguments in the following order:

=over

=item Client instance (L<App::KGB::Client>)

=item Protocol version (or 'auto')

=item Commit (an instance of L<App::KGB::Commit>)

script/kgb-bot  view on Meta::CPAN

        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

script/kgb-bot  view on Meta::CPAN

                $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,

script/kgb-bot  view on Meta::CPAN

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

script/kgb-bot  view on Meta::CPAN

            '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;

t/52-client-git.t  view on Meta::CPAN

diag `cat $hook_log` if $hook_log and -s $hook_log;

my $output = $test_bot->get_output;

undef($test_bot);   # make sure all output us there

eq_or_diff( [split(/\n/, $output)], [split(/\n/, TestBot->expected_output)] );

$c->_reset;
write_tmp("reflog", '');
throws_ok { $c->describe_commit } qr/Reflog was empty/, 'should die without reflog data';

done_testing();

t/58-client-git-unicode.t  view on Meta::CPAN

my $output = $test_bot->get_output;

undef($test_bot);   # make sure all output us there

eq_or_diff( [ split /\n/, $output ],
    [ split /\n/, TestBot->expected_output ] );

$c->_reset;
write_tmp("reflog", '');
throws_ok { $c->describe_commit } qr/Reflog was empty/, 'should die without reflog data';

done_testing();