App-KGB

 view release on metacpan or  search on metacpan

script/kgb-bot  view on Meta::CPAN

=item --simulate I<file>

Do not connect to IRC. Instead, output each notification line to the given
I<file>, like:

    #chan repo user branch revision module changed-paths
    #chan repo commit message line 1
    #chan repo commit message line 2

There are no colour codes in the output, unless B<--simulate-color> is also
given.

=item --simulate-color

Include color codes in the file used by B<--simulate>.

=item --debug

Log additional debugging information

=back

=cut

package KGB;

use strict;
use warnings;
use utf8;
use open ':encoding(utf8)';
use App::KGB::Painter;
use Net::IP;
use Time::Piece qw(localtime);

use Cwd;

our $config;
our ( $config_file, $config_dir, $foreground, $debug );
our %const = (
    SOAPsvc => "SOAPServer",
    BAsvc   => "BotAddressed",
    Connsvc => "Connecter",
    NSsvc   => "NickServID",
    NRsvc   => "NickReclaim",
    AJsvc   => "AutoJoin",
);
our %supported_protos = (
    "0" => 1,
    "1" => 1,
    "2" => 1,
    "3" => 1,
);
our $progname;
our $restart      = 0;
our $shuttingdown = 0;
our $painter;
our $painter_dummy = App::KGB::Painter->new( { simulate => 1 } );
my %stats;
my $run_time_since = time;

# for JSON::XS, used for debugging
sub Net::IP::TO_JSON {
    shift->short;
}

sub save_progname () {
    $progname = Cwd::realpath($0);
}

sub polygen_available () {
    unless ( eval { require IPC::Run } ) {
        KGB->debug("error loading IPC::Run\n");
        KGB->debug($@);
        return undef;
    }

    unless ( eval { require File::Which } ) {
        KGB->debug("error loading File::Which\n");
        KGB->debug($@);
        return undef;
    }

    my $oldpath = $ENV{PATH};
    $ENV{PATH}='/usr/bin/:/usr/games';
    my $polygen;
    unless ( $polygen = File::Which::which('polygen') ) {
        KGB->debug("missing polygen binary\n");
    }
    $ENV{PATH} = $oldpath;

    return $polygen;
}

sub merge_conf_hash($$);

sub merge_conf_hash($$) {
    my ( $dst, $src ) = @_;

    while ( my ($k, $v) = each %$src ) {
        if ( ref($v) ) {
            if ( exists $dst->{$k} ) {
                die
                    "Error merging key '$k': source is a reference, but destination is scalar\n"
                    unless ref( $dst->{$k} );
                ref( $dst->{$k} ) eq ref($v)
                    or die
                    "Error merging key '$k': reference type mismatch\n";
                if ( ref($v) eq 'ARRAY' ) {
                    push @{ $dst->{$k} }, @$v;
                }
                elsif ( ref($v) eq 'HASH' ) {
                    merge_conf_hash( $dst->{$k}, $v );
                }
                else {
                    die "Error merging key '$k': unknown reference type\n";
                }
            }
            else {
                $dst->{$k} = $v;
            }
        }

script/kgb-bot  view on Meta::CPAN

    my %chanidx;
    foreach ( @{ $conf->{channels} } ) {
        $_->{repositories} //= [];
        die "Missing channel name at channel\n" unless ( $_->{name} );
        die "Invalid network at channel " . $_->{name} . "\n"
            unless ( $_->{network} and $conf->{networks}{ $_->{network} } );
        $conf->{networks}{ $_->{network} }{channels}{$_->{name}} = $_->{secret};
        my $chanid = KGB->get_chanid( $_->{network}, $_->{name} );
        die "Invalid repos key at channel $chanid\n"
            unless $_->{broadcast}
            or ( ref $_->{repos} and ref $_->{repos} eq "ARRAY" );
        if ( $_->{broadcast} ) {
            push @{ $conf->{broadcast_channels} }, $chanid;
            KGB->out("Repository list ignored for broadcast channel $chanid\n")
                if @{ $_->{repositories} };
        }
        else {
            KGB->out("Channel $chanid doesn't listen on any repository\n")
                unless @{ $_->{repos} };
            foreach my $repo ( @{ $_->{repos} } ) {
                die "Invalid repository $repo at channel $chanid\n"
                    unless ( $conf->{repositories}{$repo} );
                push @{ $conf->{repositories}{$repo}{chanids} }, $chanid;
            }
        }
        $_->{chanid} = $chanid;
        $chanidx{$chanid} = $_;
    }
    $conf->{chanidx} = \%chanidx;

    $conf->{colors}             ||= {};
    $conf->{colors}{revision}   //= '';
    $conf->{colors}{path}       //= 'teal';
    $conf->{colors}{author}     //= 'purple';
    $conf->{colors}{branch}     //= 'brown';
    $conf->{colors}{module}     //= 'green';
    $conf->{colors}{web}        //= 'silver';
    $conf->{colors}{separator}  //= '';

    $conf->{colors}{addition}     //= 'green';
    $conf->{colors}{modification} //= 'teal';
    $conf->{colors}{deletion}     //= 'bold red';
    $conf->{colors}{replacement}  //= 'brown';

    $conf->{colors}{prop_change} //= 'underline';

    $conf->{colors}{success}     //= 'reverse green';
    $conf->{colors}{failure}     //= 'reverse red';

    $KGB::debug = $conf->{debug} if exists $conf->{debug};
    $conf->{pid_dir}
        = Cwd::realpath( $conf->{pid_dir} // '/var/run/kgb-bot' );

    if (    exists $conf->{webhook}
        and exists $conf->{webhook}{allowed_networks} )
    {
        $_ = Net::IP->new($_) for @{ $conf->{webhook}{allowed_networks} };
    }

    KGB->debug( JSON::XS->new->convert_blessed(1)->encode($conf) );
    return $conf;
}

sub load_conf($) {
    my $file = shift;
    my $conf = read_conf($file);

    # Save globals
    $config_file = Cwd::realpath($file);
    $config      = $conf;

    return $conf;
}

sub reload_conf() {
    my $new_conf = eval { KGB::read_conf($config_file) };
    if ($@) {
        KGB->out("Error in configuration file: $@");
        return -1;
    }
    if (   $new_conf->{soap}{service_name} ne $config->{soap}{service_name}
        or $new_conf->{soap}{server_port} ne $config->{soap}{server_port}
        or $new_conf->{soap}{server_addr} ne $config->{soap}{server_addr} )
    {
        KGB->out("Cannot reload configuration file, restarting\n");
        return -2;    # need restart
    }

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

    KGB->out("Configuration file reloaded\n");
    $config = $new_conf;
    return 0;
}

sub out {
    shift;
    print $KGB::out localtime->strftime('%Y.%m.%d %H:%M:%S').': ', @_, ( $_[-1] =~ /\n$/s ) ? () : "\n";
}

sub debug {
    return unless $KGB::debug;

    my $self = shift;

    my $first_line = shift;
    $first_line = (caller)[2] . ': ' . $first_line;

    $self->out( $first_line, @_ );
}

sub open_log {
    if ( my $f = $KGB::config->{log_file} ) {
        open( STDOUT, ">>", $f )
            or die "Error opening log $f: $!\n";
        open( STDERR, ">>", $f )
            or die "Error opening log $f: $!\n";
    }
    else {

script/kgb-bot  view on Meta::CPAN

        return undef;
    }

    KGB->count('notifications');

    my $alias = "irc_$net";
    $kernel->post( $alias => $method => $chan => $_ ) foreach (@$str);
    if ( $KGB::debug ) {
        KGB->out("$net/$chan > $_\n") foreach (@$str);
    }
}

sub reply {
    my ( $kernel, $net, $chan, $nick, $msg ) = @_;
    # put some hidden character to avoid addressing anyone
    my $safety = $KGB::painter->color_codes->{normal};
    return $chan
        ? $kernel->post( "irc_$net" => privmsg => $chan => "$safety$nick: $msg" )
        : $kernel->post( "irc_$net" => privmsg => $nick => "$safety$msg" );
}

sub irc_command {
    my ( $kernel, $heap, $command, $who, $chan, $net )
        = @_[ KERNEL, HEAP, ARG0 .. ARG3 ];

    my $nick = parse_user($who);

    return reply( $kernel, $net, $chan, $nick, "You are not my master" )
        unless grep { matches_mask( $_, $who ) } @{ $KGB::config->{admins} };

    if ( $command eq 'version' ) {
        return reply( $kernel, $net, $chan, $nick,
                  "Tried /CTCP "
                . $KGB::config->{networks}{$net}{nick}
                . " VERSION?" );
    }
    elsif ( $command eq 'stats' ) {
        my $stats = KGB->get_stats;
        my $run_time = human_duration( KGB->get_run_seconds );
        my $msg = "after $run_time: ";
        $msg .=
            %$stats
            ? join( ', ', map( "$_:$stats->{$_}", sort keys %$stats ) )
            : 'no stats yet';
        return reply( $kernel, $net, $chan, $nick, $msg);
    }
    elsif ( $command eq 'statsreset' ) {
        KGB->reset_stats;
        return reply( $kernel, $net, $chan, $nick, 'Done' );
    }
    else {
        return reply( $kernel, $net, $chan, $nick,
            "command '$command' is not known to me" );
    }
}

package KGB::JSON;

use strict;
use warnings;
use JSON::XS;
use POE;
use Digest::SHA qw(sha1_hex);

sub json_error {
    my ( $json, $resp, $error ) = @_;
    KGB->out($error);
    $resp->code(200);
    $resp->message('OK');
    $resp->content(
        encode_json(
            { id => $json->{id} // 0, error => $error, result => undef }
        )
    );
}

sub http_error {
    my ( $resp, $error, $code ) = @_;
    KGB->out($error);
    $resp->code($code // 400);
    $resp->message($error);
    $resp->content('');
}

sub json_request {
    my ( $req, $resp, $path ) = @_[ ARG0, ARG1, ARG2 ];

    my ($repo_id, $auth);
    unless (defined( $repo_id = $req->header('X-KGB-Project') )
        and defined( $auth = $req->header('X-KGB-Auth') ) )
    {
        http_error( $resp,
            'Invalid or missing X-KGB-Project or X-KGB-Auth headers' );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    unless ( exists $KGB::config->{repositories}{$repo_id} ) {
        http_error( $resp, "Unknown project ($repo_id)" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }
    my $check = sha1_hex( $KGB::config->{repositories}{$repo_id}{password},
        $repo_id, $req->content );

    unless ( $check eq $auth ) {
        http_error( $resp, "[$repo_id] Authentication failed", 401 );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    my $json;
    my $ok = eval { $json = decode_json( $req->content ); 1; };

    unless ($ok) {
        http_error( $resp, "[$repo_id] Error decoding JSON request" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    unless (exists $json->{method}