view release on metacpan or  search on metacpan

script/kgb-bot  view on Meta::CPAN

                    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

my @array_webhook_params =
    qw( channel pipeline_only_status always_squash_branch only_branch
        only_tag always_squash_outside_dir );
my %array_webhook_params = map( ( $_ => 1 ), @array_webhook_params );

sub webhook_request {
    my ( $kernel, $request, $response, $dirmatch ) = @_[ KERNEL, ARG0 .. ARG2 ];

    unless ( $KGB::config->{webhook}{enabled} ) {
        return webhook_error(@_, 'WebHook support not enabled',
            HTTP::Status::HTTP_PRECONDITION_FAILED);
    }

    my $client_ip = $response->connection->remote_ip;
    # fix ipv4-as-ipv6 represenation
    $client_ip =~ s/^::ffff:(\d+\.\d+\.\d+\.\d+)$/$1/;
    $client_ip = Net::IP->new($client_ip);

    my $allowed = 0;

    my $allowed_nets = $KGB::config->{webhook}{allowed_networks};
    if ($allowed_nets) {
        for my $net (@$allowed_nets) {
            next unless $net->version == $client_ip->version;

            $allowed = 1, last
                if $net->overlaps($client_ip) != $Net::IP::IP_NO_OVERLAP;
        }
    }

    unless ($allowed) {
        return webhook_error(@_, 'Client IP ' . $client_ip->ip . ' is not whitelisted',
            HTTP::Status::HTTP_FORBIDDEN);
    }

    KGB->debug( "got a webhook request from " . $client_ip->ip );

    unless( $request->method eq 'POST' ) {
        return webhook_error(@_, 'Request method must be "POST"');
    }

    KGB->debug('DEBUG: method check passed');

    my $json;
    my $ok = eval {
        $json = JSON::from_json( $request->content, { utf8 => 1 } );
        1;
    };

    unless ($ok) {
        return webhook_error(@_, 'Error decoding JSON body', undef, $@);
    }

    KGB->debug('Body decoded');

    unless (
            $json