password results from the CPAN

password

App-KGB

view release on metacpan or search on metacpan

    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;

script/kgb-bot view on Meta::CPAN

    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} || "" )
            or ( $new->{nickserv_password} || "" ) ne
            ( $old->{nickserv_password} || "" )
            or $new->{server} ne $old->{server}
            or $new->{port}   ne $old->{port}
            or ( $new->{use_ssl} // '' ) ne ( $old->{use_ssl} // '' )
    )
        {
            push @to_restart, $net;
        }
        else {
            # TODO: this doesn't account for secret changes
            # perhaps it needs to part and re-join a channel when
            # its secret is changed?
            my ( %newchan, %oldchan, %allchan );
            %newchan = %{ $new->{channels} };
            %oldchan = %{ $old->{channels} };
            %allchan = ( %newchan, %oldchan );
            foreach my $chan ( sort keys %allchan ) {
                if ( exists $newchan{$chan} and not exists $oldchan{$chan} ) {
                    KGB->out("Joining $chan...\n");
                    $kernel->post( "irc_$net" => join => $chan => $newchan{$chan} );
                }
                elsif ( not exists $newchan{$chan} and exists $oldchan{$chan} ) {
                    KGB->out("Parting $chan...\n");
                    $kernel->post( "irc_$net" => part => $chan );
                }
            }
            $current{$net} = dclone($new);
        }
    }
    foreach ( keys %{ $KGB::config->{networks} } ) {
        if ( !$current{$_} ) {
            push @to_start, $_;
        }
    }
    foreach my $net (@to_start) {
        my $opts = $KGB::config->{networks}{$net};
        $current{$net} = dclone($opts);

        my $irc = POE::Component::IRC::State->spawn(
            Alias      => "irc_$net",
            WhoJoiners => 0,
        );

        # No need to register, as it's done automatically now. If you register
        # twice, POE never exits
    }
    foreach ( @to_stop, @to_restart ) {
        KGB->out("Disconnecting from $_\n");
        $kernel->post( "irc_$_" => "shutdown" );
        delete $current{$_};
    }
    if (@to_restart) {
        $kernel->delay( "_irc_reconnect", 3 );
    }
}

sub irc_registered {
    my ( $kernel, $heap, $sender ) = @_[ KERNEL, HEAP, SENDER ];
    $irc_object = $_[ARG0];

    my $alias = $irc_object->session_alias();
    $alias =~ s/^irc_//;
    my $opts = $KGB::config->{networks}{$alias};

    $irc_object->plugin_add( $KGB::const{AJsvc},
        POE::Component::IRC::Plugin::AutoJoin->new(
            Channels => $opts->{channels},
            NickServ_delay => 60,
        )
    ) if ( $opts->{channels} );

    $irc_object->plugin_add( $KGB::const{NSsvc},
        POE::Component::IRC::Plugin::NickServID->new(
            Password => $opts->{nickserv_password},
        )
    ) if ( $opts->{nickserv_password} );

    $irc_object->plugin_add( $KGB::const{NRsvc},
        POE::Component::IRC::Plugin::NickReclaim->new() );

    $irc_object->plugin_add( $KGB::const{Connsvc},
        POE::Component::IRC::Plugin::Connector->new() );

    $irc_object->plugin_add( $KGB::const{BAsvc},
        POE::Component::IRC::Plugin::BotAddressed->new() );

    $irc_object->plugin_add(
        'CTCP' => POE::Component::IRC::Plugin::CTCP->new(
            version    => "KGB v$App::KGB::VERSION",
            userinfo   => "KGB v$App::KGB::VERSION",
            clientinfo => "VERSION USERINFO CLIENTINFO SOURCE",
            source     => "https://salsa.debian.org/kgb-team/kgb",
        )
    );

    $kernel->post(
        $sender => connect => {
            Server   => $opts->{server},
            Port     => $opts->{port},
            Nick     => $opts->{nick},
            Ircname  => $opts->{ircname},
            Username => $opts->{username},
            Password => $opts->{password},
            Flood    => $opts->{flood},
            UseSSL   => $opts->{use_ssl},
        }
    );
    undef;
}

sub _default {
    return 0 unless $KGB::debug;
    my ( $event, $args ) = @_[ ARG0 .. $#_ ];
    my $out = "$event ";
    foreach (@$args) {
        if ( ref($_) eq 'ARRAY' ) {
            $out .= "[" . join( ", ", @$_ ) . "] ";
        }
        elsif ( ref($_) eq 'HASH' ) {
            $out .= "{" . join( ", ", %$_ ) . "} ";
        }
        elsif ( defined $_ ) {
            $out .= "'$_' ";
        }
        else {
            $out .= "undef ";
        }
    }
    KGB->debug("$out\n");
    return 0;
}

sub irc_public {
    my ( $kernel, $heap, $who, $where, $what )
        = @_[ KERNEL, HEAP, ARG0, ARG1, ARG2 ];
    my $nick = parse_user($who);
    my $chan = $where->[0];

    $kernel->yield( irc_new_hash => $chan => $what );

    KGB->debug( $chan . ':<' . $nick . '> ' . $what . "\n" );
    undef;
}

sub get_net {
    my $obj = shift;

    ( my $net = $obj->get_heap()->session_alias() ) =~ s/^irc_//;

    return $net;
}

sub add_channel ($$$) {
    my ( $kernel, $network, $channel ) = @_;
    my $chanid = KGB->get_chanid($network, $channel);

    die "Unknown network \"$network\"."
        unless (exists $KGB::config->{networks}{$network});
    return if (exists $KGB::config->{chanidx}{$chanid});

    # secret-less
    $KGB::config->{networks}{$network}{channels}{$channel} = '';
    $KGB::config->{chanidx}{$chanid} = {

script/kgb-bot view on Meta::CPAN

            ? 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}
        and defined $json->{method}
        and not ref( $json->{method} )
        and length $json->{method} )
    {
        json_error( $json, $resp, "[$repo_id] Request has no valid \"method\" member" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }
    unless (exists $json->{params}
        and defined $json->{params}
        and ref( $json->{params} )
        and ref( $json->{params} ) eq 'ARRAY'
        and length $json->{params} )
    {
        json_error( $json, $resp, "[$repo_id] Request has no valid \"params\" member" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }
    unless (exists $json->{id}
        and defined $json->{id}
        and not ref( $json->{id} )
        and length $json->{id} )
    {
        json_error( $json, $resp, "[$repo_id] Request has no valid \"id\" member" );
        $_[KERNEL]->post( $_[SENDER], DONE => $resp );
        return;
    }

    my $json_result;
    $ok = eval {
        $json_result = encode_json(
            {   id     => $json->{id} // 0,
                result => __PACKAGE__->handle_json_request( $_[KERNEL], $repo_id, $json ),
                error  => undef
            }
        );
        1;
    };
    my $error = $@;

    unless ($ok) {
        KGB->out($error);

( run in 0.508 second using v1.01-cache-2.11-cpan-2398b32b56e )